#! /usr/local/bin/perl -w

use strict;
use Carp;

my $master_template = do { local $/; <DATA> };

my @pod_files = glob 't_source/*.pod6';

print "Building ", scalar(@pod_files), " tests\n";

POD_FILE:
for my $pod_file (@pod_files) {
    my $rep_file  = substr($pod_file,0,-5) . '.rep';
    my $test_file = substr($pod_file,0,-5) . '.t';
    $test_file =~ s{t_source/}{t/}xms;

    open my $pod_fh, '<', $pod_file
        or carp "Can't open Perldoc source file '$pod_file'"
        and next POD_FILE;

    open my $rep_fh, '<', $rep_file
        or carp "Can't open representation source file '$rep_file'"
        and next POD_FILE;

    open my $test_fh, '>', $test_file
        or carp "Can't create test file '$test_file'"
        and next POD_FILE;

    print "Creating $test_file\n";
    print {$test_fh} fill_template($pod_fh, $rep_fh);
}

sub fill_template {
    my ($pod_fh, $rep_fh) = @_;

    my %data;

    local $/;
    $data{'<POD>'} = <$pod_fh>;
    $data{'<REP>'} = <$rep_fh>;

    my $template = $master_template;

    $template =~ s{( <POD> | <REP> )}{$data{$1}}gxms;

    return $template;
}

__DATA__
# Testing this Pod specification...
my $perldoc_data = <<'END_PERLDOC';
<POD>
END_PERLDOC

# Expect it to parse to this ADT...
my $expected_structure = eval <<'END_EXPECTED';
<REP>
END_EXPECTED

# Remove filenames from error messages (since two sources differ)...
for my $msg ( @{ $expected_structure->{warnings} },
              @{ $expected_structure->{errors} }
) {
    $msg =~ s{at \S+ line}{at line};
}

use Perl6::Perldoc::Parser;
use Test::More 'no_plan';

# Open input filehandle on Pod daa and parse it...
open my $fh, '<', \$perldoc_data
    or die "Could not open file on test data";
my $representation = Perl6::Perldoc::Parser->parse($fh ,{all_pod=>1});

# Walk resulting representation and expectation tree in parallel, comparing...
compare(
    '  ',                     # Indent
    'return value',           # Description
    {%{$representation}},     # What we got
    {%{$expected_structure}}  # What we expected
);


use Scalar::Util qw< reftype blessed >;

# Only consider valid accessor methods...
my %is_valid_scalar_method;
my %is_valid_list_method;
BEGIN {
   @is_valid_scalar_method{ qw< typename style number target > } = ();
   @is_valid_list_method{   qw< content rows cells >           } = ();
}

# Walk two trees, comparing nodes as we go...
sub compare {
    my ($indent, $desc, $rep, $expected) = @_;

    # Verify data at current node is of correct class...
    my ($rep_class, $expected_class)
        = map {ref($_) || q{STRING}} $rep, $expected;

    is $rep_class, $expected_class => "$indent$desc is $expected_class";

    # Recurse down trees according to type of node expected...
    $indent .= q{  };
    my $expected_type = reftype($expected) || q{STRING};

    # If current node an object -> match keys as method calls...
    if (blessed $expected) {
        for my $attr ( keys %{ $expected } ) {
            # Expected subnode must be retrieved via known accessor...
            my $is_scalar = exists $is_valid_scalar_method{$attr};
            my $is_list   = exists $is_valid_list_method{$attr};
            if (!$is_scalar && !$is_list) {
                fail "Internal error: unknown method $attr() "
                   . "expected for $rep_class node";
            }

            # Known accessor must be available...
            elsif (! $rep->can($attr) ) {
                fail "Can't call $attr() on $rep_class node";
            }

            # If accessor returns a list, recursively compare the lists...
            elsif ($is_list) {
                compare($indent,$attr, [$rep->$attr], $expected->{$attr});
            }

            # If accessor returns a scalar, string-compare the values...
            else {
                compare($indent,$attr, scalar($rep->$attr), $expected->{$attr});
            }
        }
    }
    
    # If current node a hash -> match keys as hash entries...
    elsif ($expected_type eq 'HASH') {
        for my $attr ( keys %{ $expected } ) {
            compare($indent, $attr, $rep->{$attr}, $expected->{$attr});
        }
    }

    # If current node an array -> match each element in sequence...
    elsif ($expected_type eq 'ARRAY') {
        for my $idx ( 0..$#{$expected} ) {
            compare($indent,"[$idx]", $rep->[$idx], $expected->[$idx]);
        }
    }

    # Otherwise current node is raw text -> simple string comparison...
    else {
        is $rep, $expected  =>  "$indent$desc content was correct";
    }
}