185009909Smillert#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*- 285009909Smillert 385009909SmillertBEGIN { 485009909Smillert chdir 't' if -d 't'; 585009909Smillert @INC = '../lib'; 643890927Smillert require Config; 743890927Smillert if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ 843890927Smillert print "1..0 # Skip -- Perl configured without List::Util module\n"; 943890927Smillert exit 0; 1043890927Smillert } 1185009909Smillert} 1285009909Smillert 1385009909Smillertuse strict; 1485009909Smillert 1585009909Smillert$|=1; 1685009909Smillert 1785009909Smillertmy @prgs; 1885009909Smillert{ 1985009909Smillert local $/; 2085009909Smillert @prgs = split "########\n", <DATA>; 2185009909Smillert close DATA; 2285009909Smillert} 2385009909Smillert 2485009909Smillertuse Test::More; 2585009909Smillert 2685009909Smillertrequire "dumpvar.pl"; 2785009909Smillert 2885009909Smillertsub unctrl { print dumpvar::unctrl($_[0]), "\n" } 2985009909Smillertsub uniescape { print dumpvar::uniescape($_[0]), "\n" } 3085009909Smillertsub stringify { print dumpvar::stringify($_[0]), "\n" } 3185009909Smillertsub dumpvalue { 3285009909Smillert # Call main::dumpValue exactly as the perl5db.pl calls it. 3385009909Smillert local $\ = ''; 3485009909Smillert local $, = ''; 3585009909Smillert local $" = ' '; 3685009909Smillert my @params = @_; 3785009909Smillert &main::dumpValue(\@params,-1); 3885009909Smillert} 3985009909Smillert 4085009909Smillertpackage Foo; 4185009909Smillert 4285009909Smillertsub new { my $class = shift; bless [ @_ ], $class } 4385009909Smillert 4485009909Smillertpackage Bar; 4585009909Smillert 4685009909Smillertsub new { my $class = shift; bless [ @_ ], $class } 4785009909Smillert 4885009909Smillertuse overload '""' => sub { "Bar<@{$_[0]}>" }; 4985009909Smillert 50898184e3Ssthenpackage Tyre; 51898184e3Ssthen 52898184e3Ssthensub TIESCALAR{bless[]} 53898184e3Ssthen# other methods intentionally omitted 54898184e3Ssthen 5591f110e0Safresh1package Kerb; 5691f110e0Safresh1 5791f110e0Safresh1sub TIEHASH{bless{}} 5891f110e0Safresh1# other methods intentionally omitted 5991f110e0Safresh1 6085009909Smillertpackage main; 6185009909Smillert 6285009909Smillertmy $foo = Foo->new(1..5); 6385009909Smillertmy $bar = Bar->new(1..5); 6485009909Smillert 6585009909Smillertfor (@prgs) { 6685009909Smillert my($prog, $expected) = split(/\nEXPECT\n?/, $_); 6785009909Smillert # TODO: dumpvar::stringify() is controlled by a pile of package 6885009909Smillert # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify, 6985009909Smillert # and so forth. We need to test with various settings of those. 7085009909Smillert my $out = tie *STDOUT, 'TieOut'; 7185009909Smillert eval $prog; 7285009909Smillert my $ERR = $@; 7385009909Smillert untie $out; 7485009909Smillert if ($ERR) { 7585009909Smillert ok(0, "$prog - $ERR"); 7685009909Smillert } else { 7785009909Smillert if ($expected =~ m:^/:) { 7885009909Smillert like($$out, $expected, $prog); 7985009909Smillert } else { 8085009909Smillert is($$out, $expected, $prog); 8185009909Smillert } 8285009909Smillert } 8385009909Smillert} 8485009909Smillert 85*256a93a4Safresh1done_testing(); 86*256a93a4Safresh1 8785009909Smillertpackage TieOut; 8885009909Smillert 8985009909Smillertsub TIEHANDLE { 9085009909Smillert bless( \(my $self), $_[0] ); 9185009909Smillert} 9285009909Smillert 9385009909Smillertsub PRINT { 9485009909Smillert my $self = shift; 9585009909Smillert $$self .= join('', @_); 9685009909Smillert} 9785009909Smillert 9885009909Smillertsub read { 9985009909Smillert my $self = shift; 10085009909Smillert substr( $$self, 0, length($$self), '' ); 10185009909Smillert} 10285009909Smillert 10385009909Smillert__END__ 10485009909Smillertunctrl("A"); 10585009909SmillertEXPECT 10685009909SmillertA 10785009909Smillert######## 10885009909Smillertunctrl("\cA"); 10985009909SmillertEXPECT 11085009909Smillert^A 11185009909Smillert######## 11285009909Smillertuniescape("A"); 11385009909SmillertEXPECT 11485009909SmillertA 11585009909Smillert######## 11685009909Smillertuniescape("\x{100}"); 11785009909SmillertEXPECT 11885009909Smillert\x{0100} 11985009909Smillert######## 12085009909Smillertstringify(undef); 12185009909SmillertEXPECT 12285009909Smillertundef 12385009909Smillert######## 12485009909Smillertstringify("foo"); 12585009909SmillertEXPECT 12685009909Smillert'foo' 12785009909Smillert######## 12885009909Smillertstringify("\cA"); 12985009909SmillertEXPECT 13085009909Smillert"\cA" 13185009909Smillert######## 13285009909Smillertstringify(*a); 13385009909SmillertEXPECT 13485009909Smillert*main::a 13585009909Smillert######## 13685009909Smillertstringify(\undef); 13785009909SmillertEXPECT 13885009909Smillert/^'SCALAR\(0x[0-9a-f]+\)'$/i 13985009909Smillert######## 14085009909Smillertstringify([]); 14185009909SmillertEXPECT 14285009909Smillert/^'ARRAY\(0x[0-9a-f]+\)'$/i 14385009909Smillert######## 14485009909Smillertstringify({}); 14585009909SmillertEXPECT 14685009909Smillert/^'HASH\(0x[0-9a-f]+\)'$/i 14785009909Smillert######## 14885009909Smillertstringify(sub{}); 14985009909SmillertEXPECT 15085009909Smillert/^'CODE\(0x[0-9a-f]+\)'$/i 15185009909Smillert######## 15285009909Smillertstringify(\*a); 15385009909SmillertEXPECT 15485009909Smillert/^'GLOB\(0x[0-9a-f]+\)'$/i 15585009909Smillert######## 15685009909Smillertstringify($foo); 15785009909SmillertEXPECT 15885009909Smillert/^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i 15985009909Smillert######## 16085009909Smillertstringify($bar); 16185009909SmillertEXPECT 16285009909Smillert/^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i 16385009909Smillert######## 16485009909SmillertdumpValue(undef); 16585009909SmillertEXPECT 16685009909Smillertundef 16785009909Smillert######## 16885009909SmillertdumpValue(1); 16985009909SmillertEXPECT 17085009909Smillert1 17185009909Smillert######## 17285009909SmillertdumpValue("\cA"); 17385009909SmillertEXPECT 17485009909Smillert"\cA" 17585009909Smillert######## 17685009909SmillertdumpValue("\x{100}"); 17785009909SmillertEXPECT 17885009909Smillert'\x{0100}' 17985009909Smillert######## 18085009909SmillertdumpValue("1\n2\n3"); 18185009909SmillertEXPECT 18285009909Smillert'1 18385009909Smillert2 18485009909Smillert3' 18585009909Smillert######## 18685009909SmillertdumpValue([1..3],1); 18785009909SmillertEXPECT 18885009909Smillert0 1 18985009909Smillert1 2 19085009909Smillert2 3 19185009909Smillert######## 19285009909SmillertdumpValue([1..3]); 19385009909SmillertEXPECT 19485009909Smillert0 1 19585009909Smillert1 2 19685009909Smillert2 3 19785009909Smillert######## 19885009909SmillertdumpValue({1..4},1); 19985009909SmillertEXPECT 20085009909Smillert1 => 2 20185009909Smillert3 => 4 20285009909Smillert######## 20385009909SmillertdumpValue({1..4}); 20485009909SmillertEXPECT 20585009909Smillert1 => 2 20685009909Smillert3 => 4 20785009909Smillert######## 20885009909SmillertdumpValue($foo,1); 20985009909SmillertEXPECT 21085009909Smillert0 1 21185009909Smillert1 2 21285009909Smillert2 3 21385009909Smillert3 4 21485009909Smillert4 5 21585009909Smillert######## 21685009909SmillertdumpValue($foo); 21785009909SmillertEXPECT 21885009909Smillert0 1 21985009909Smillert1 2 22085009909Smillert2 3 22185009909Smillert3 4 22285009909Smillert4 5 22385009909Smillert######## 22485009909SmillertdumpValue($bar,1); 22585009909SmillertEXPECT 22685009909Smillert0 1 22785009909Smillert1 2 22885009909Smillert2 3 22985009909Smillert3 4 23085009909Smillert4 5 23185009909Smillert######## 23285009909SmillertdumpValue($bar); 23385009909SmillertEXPECT 23485009909Smillert0 1 23585009909Smillert1 2 23685009909Smillert2 3 23785009909Smillert3 4 23885009909Smillert4 5 23985009909Smillert######## 24085009909Smillertdumpvalue("a"); 24185009909SmillertEXPECT 24285009909Smillert0 'a' 24385009909Smillert######## 24485009909Smillertdumpvalue("\cA"); 24585009909SmillertEXPECT 24685009909Smillert0 "\cA" 24785009909Smillert######## 24885009909Smillertdumpvalue("\x{100}"); 24985009909SmillertEXPECT 25085009909Smillert0 '\x{0100}' 25185009909Smillert######## 25285009909Smillertdumpvalue(undef); 25385009909SmillertEXPECT 25485009909Smillert0 undef 25585009909Smillert######## 25685009909Smillertdumpvalue("foo"); 25785009909SmillertEXPECT 25885009909Smillert0 'foo' 25985009909Smillert######## 26085009909Smillertdumpvalue(\undef); 26185009909SmillertEXPECT 26285009909Smillert/0 SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i 26385009909Smillert######## 26485009909Smillertdumpvalue(\\undef); 26585009909SmillertEXPECT 26685009909Smillert/0 REF\(0x[0-9a-f]+\)\n -> SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i 26785009909Smillert######## 26885009909Smillertdumpvalue([]); 26985009909SmillertEXPECT 27085009909Smillert/0 ARRAY\(0x[0-9a-f]+\)\n empty array/i 27185009909Smillert######## 27285009909Smillertdumpvalue({}); 27385009909SmillertEXPECT 27485009909Smillert/0 HASH\(0x[0-9a-f]+\)\n\s+empty hash/i 27585009909Smillert######## 27685009909Smillertdumpvalue(sub{}); 27785009909SmillertEXPECT 27885009909Smillert/0 CODE\(0x[0-9a-f]+\)\n -> &CODE\(0x[0-9a-f]+\) in /i 27985009909Smillert######## 28085009909Smillertdumpvalue(\*a); 28185009909SmillertEXPECT 28285009909Smillert/0 GLOB\(0x[0-9a-f]+\)\n -> \*main::a\n/i 28385009909Smillert######## 28485009909Smillertdumpvalue($foo); 28585009909SmillertEXPECT 28685009909Smillert/0 Foo=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i 28785009909Smillert######## 28885009909Smillertdumpvalue($bar); 28985009909SmillertEXPECT 29085009909Smillert/0 Bar=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i 29185009909Smillert######## 29285009909Smillertdumpvalue("1\n2\n3") 29385009909SmillertEXPECT 29485009909Smillert/0 '1\n2\n3'\n/i 29585009909Smillert######## 29685009909Smillertdumpvalue([1..4]); 29785009909SmillertEXPECT 29885009909Smillert/0 ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i 29985009909Smillert######## 30085009909Smillertdumpvalue({1..4}); 30185009909SmillertEXPECT 30285009909Smillert/0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i 30385009909Smillert######## 30485009909Smillertdumpvalue({1=>2,3=>4}); 30585009909SmillertEXPECT 30685009909Smillert/0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i 30785009909Smillert######## 30885009909Smillertdumpvalue({a=>1,b=>2}); 30985009909SmillertEXPECT 31085009909Smillert/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i 31185009909Smillert######## 31285009909Smillertdumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]); 31385009909SmillertEXPECT 31485009909Smillert/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 31585009909Smillert######## 31685009909Smillertdumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)}) 31785009909SmillertEXPECT 31885009909Smillert/0 HASH\(0x[0-9a-f]+\)\n 1 => 'brown'\n/i 31985009909Smillert######## 32085009909Smillertmy @x=qw(a b c); dumpvalue(\@x); 32185009909SmillertEXPECT 32285009909Smillert/0 ARRAY\(0x[0-9a-f]+\)\n 0 'a'\n 1 'b'\n 2 'c'\n/i 32385009909Smillert######## 32485009909Smillertmy %x=(a=>1, b=>2); dumpvalue(\%x); 32585009909SmillertEXPECT 32685009909Smillert/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i 327898184e3Ssthen######## 328898184e3Ssthendumpvalue(bless[1,2,3,4],"a=b=c"); 329898184e3SsthenEXPECT 330898184e3Ssthen/0 a=b=c=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i 331898184e3Ssthen######## 332898184e3Ssthenlocal *_; tie $_, 'Tyre'; stringify(''); 333898184e3SsthenEXPECT 334898184e3Ssthen'' 335898184e3Ssthen######## 336898184e3Ssthenlocal *_; tie $_, 'Tyre'; unctrl('abc'); 337898184e3SsthenEXPECT 338898184e3Ssthenabc 33991f110e0Safresh1######## 34091f110e0Safresh1tie my %h, 'Kerb'; my $v = { a => 1, b => \%h, c => 2 }; dumpvalue($v); 34191f110e0Safresh1EXPECT 34291f110e0Safresh1/'a' => 1\n.+Can't locate object method.+'c' => 2/s 343