#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*-

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require Config;
    if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
	print "1..0 # Skip -- Perl configured without List::Util module\n";
	exit 0;
    }
}

use strict;

$|=1;

my @prgs;
{
    local $/;
    @prgs = split "########\n", <DATA>;
    close DATA;
}

use Test::More;

plan tests => scalar @prgs;

require "dumpvar.pl";

sub unctrl    { print dumpvar::unctrl($_[0]), "\n" }
sub uniescape { print dumpvar::uniescape($_[0]), "\n" }
sub stringify { print dumpvar::stringify($_[0]), "\n" }
sub dumpvalue { 
	# Call main::dumpValue exactly as the perl5db.pl calls it.
        local $\ = '';
        local $, = '';
        local $" = ' ';
        my @params = @_;
        &main::dumpValue(\@params,-1);
}

package Foo;

sub new { my $class = shift; bless [ @_ ], $class }

package Bar;

sub new { my $class = shift; bless [ @_ ], $class }

use overload '""' => sub { "Bar<@{$_[0]}>" };

package Tyre;

sub TIESCALAR{bless[]}
# other methods intentionally omitted

package main;

my $foo = Foo->new(1..5);
my $bar = Bar->new(1..5);

for (@prgs) {
    my($prog, $expected) = split(/\nEXPECT\n?/, $_);
    # TODO: dumpvar::stringify() is controlled by a pile of package
    # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify,
    # and so forth.  We need to test with various settings of those.
    my $out = tie *STDOUT, 'TieOut';
    eval $prog;
    my $ERR = $@;
    untie $out;
    if ($ERR) {
        ok(0, "$prog - $ERR");
    } else {
	if ($expected =~ m:^/:) {
	    like($$out, $expected, $prog);
	} else {
	    is($$out, $expected, $prog);
	}
    }
}

package TieOut;

sub TIEHANDLE {
    bless( \(my $self), $_[0] );
}

sub PRINT {
    my $self = shift;
    $$self .= join('', @_);
}

sub read {
    my $self = shift;
    substr( $$self, 0, length($$self), '' );
}

__END__
unctrl("A");
EXPECT
A
########
unctrl("\cA");
EXPECT
^A
########
uniescape("A");
EXPECT
A
########
uniescape("\x{100}");
EXPECT
\x{0100}
########
stringify(undef);
EXPECT
undef
########
stringify("foo");
EXPECT
'foo'
########
stringify("\cA");
EXPECT
"\cA"
########
stringify(*a);
EXPECT
*main::a
########
stringify(\undef);
EXPECT
/^'SCALAR\(0x[0-9a-f]+\)'$/i
########
stringify([]);
EXPECT
/^'ARRAY\(0x[0-9a-f]+\)'$/i
########
stringify({});
EXPECT
/^'HASH\(0x[0-9a-f]+\)'$/i
########
stringify(sub{});
EXPECT
/^'CODE\(0x[0-9a-f]+\)'$/i
########
stringify(\*a);
EXPECT
/^'GLOB\(0x[0-9a-f]+\)'$/i
########
stringify($foo);
EXPECT
/^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i
########
stringify($bar);
EXPECT
/^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i
########
dumpValue(undef);
EXPECT
undef
########
dumpValue(1);
EXPECT
1
########
dumpValue("\cA");
EXPECT
"\cA"
########
dumpValue("\x{100}");
EXPECT
'\x{0100}'
########
dumpValue("1\n2\n3");
EXPECT
'1
2
3'
########
dumpValue([1..3],1);
EXPECT
0  1
1  2
2  3
########
dumpValue([1..3]);
EXPECT
0  1
1  2
2  3
########
dumpValue({1..4},1);
EXPECT
1 => 2
3 => 4
########
dumpValue({1..4});
EXPECT
1 => 2
3 => 4
########
dumpValue($foo,1);
EXPECT
0  1
1  2
2  3
3  4
4  5
########
dumpValue($foo);
EXPECT
0  1
1  2
2  3
3  4
4  5
########
dumpValue($bar,1);
EXPECT
0  1
1  2
2  3
3  4
4  5
########
dumpValue($bar);
EXPECT
0  1
1  2
2  3
3  4
4  5
########
dumpvalue("a");
EXPECT
0  'a'
########
dumpvalue("\cA");
EXPECT
0  "\cA"
########
dumpvalue("\x{100}");
EXPECT
0  '\x{0100}'
########
dumpvalue(undef);
EXPECT
0  undef
########
dumpvalue("foo");
EXPECT
0  'foo'
########
dumpvalue(\undef);
EXPECT
/0  SCALAR\(0x[0-9a-f]+\)\n   -> undef\n/i
########
dumpvalue(\\undef);
EXPECT
/0  REF\(0x[0-9a-f]+\)\n   -> SCALAR\(0x[0-9a-f]+\)\n         -> undef\n/i
########
dumpvalue([]);
EXPECT
/0  ARRAY\(0x[0-9a-f]+\)\n     empty array/i
########
dumpvalue({});
EXPECT
/0  HASH\(0x[0-9a-f]+\)\n\s+empty hash/i
########
dumpvalue(sub{});
EXPECT
/0  CODE\(0x[0-9a-f]+\)\n   -> &CODE\(0x[0-9a-f]+\) in /i
########
dumpvalue(\*a);
EXPECT
/0  GLOB\(0x[0-9a-f]+\)\n   -> \*main::a\n/i
########
dumpvalue($foo);
EXPECT
/0  Foo=ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n   4  5\n/i
########
dumpvalue($bar);
EXPECT
/0  Bar=ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n   4  5\n/i
########
dumpvalue("1\n2\n3")
EXPECT
/0  '1\n2\n3'\n/i
########
dumpvalue([1..4]);
EXPECT
/0  ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n/i
########
dumpvalue({1..4});
EXPECT
/0  HASH\(0x[0-9a-f]+\)\n   1 => 2\n   3 => 4\n/i
########
dumpvalue({1=>2,3=>4});
EXPECT
/0  HASH\(0x[0-9a-f]+\)\n   1 => 2\n   3 => 4\n/i
########
dumpvalue({a=>1,b=>2});
EXPECT
/0  HASH\(0x[0-9a-f]+\)\n   'a' => 1\n   'b' => 2\n/i
########
dumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]);
EXPECT
/0  ARRAY\(0x[0-9a-f]+\)\n   0  HASH\(0x[0-9a-f]+\)\n      'a' => ARRAY\(0x[0-9a-f]+\)\n         0  1\n         1  2\n         2  3\n      'b' => HASH\(0x[0-9a-f]+\)\n         'c' => 1\n         'd' => 2\n   1  HASH\(0x[0-9a-f]+\)\n      'e' => HASH\(0x[0-9a-f]+\)\n         'f' => 1\n         'g' => 2\n      'h' => ARRAY\(0x[0-9a-f]+\)\n         0  'i'\n         1  'j'\n         2  'k'/i
########
dumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)})
EXPECT
/0  HASH\(0x[0-9a-f]+\)\n   1 => 'brown'\n/i
########
my @x=qw(a b c); dumpvalue(\@x);
EXPECT
/0  ARRAY\(0x[0-9a-f]+\)\n   0  'a'\n   1  'b'\n   2  'c'\n/i
########
my %x=(a=>1, b=>2); dumpvalue(\%x);
EXPECT
/0  HASH\(0x[0-9a-f]+\)\n   'a' => 1\n   'b' => 2\n/i
########
dumpvalue(bless[1,2,3,4],"a=b=c");
EXPECT
/0  a=b=c=ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n/i
########
local *_; tie $_, 'Tyre'; stringify('');
EXPECT
''
########
local *_; tie $_, 'Tyre'; unctrl('abc');
EXPECT
abc