1#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*- 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require Config; 7 if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ 8 print "1..0 # Skip -- Perl configured without List::Util module\n"; 9 exit 0; 10 } 11} 12 13use strict; 14 15$|=1; 16 17my @prgs; 18{ 19 local $/; 20 @prgs = split "########\n", <DATA>; 21 close DATA; 22} 23 24use Test::More; 25 26plan tests => scalar @prgs; 27 28require "dumpvar.pl"; 29 30sub unctrl { print dumpvar::unctrl($_[0]), "\n" } 31sub uniescape { print dumpvar::uniescape($_[0]), "\n" } 32sub stringify { print dumpvar::stringify($_[0]), "\n" } 33sub dumpvalue { 34 # Call main::dumpValue exactly as the perl5db.pl calls it. 35 local $\ = ''; 36 local $, = ''; 37 local $" = ' '; 38 my @params = @_; 39 &main::dumpValue(\@params,-1); 40} 41 42package Foo; 43 44sub new { my $class = shift; bless [ @_ ], $class } 45 46package Bar; 47 48sub new { my $class = shift; bless [ @_ ], $class } 49 50use overload '""' => sub { "Bar<@{$_[0]}>" }; 51 52package Tyre; 53 54sub TIESCALAR{bless[]} 55# other methods intentionally omitted 56 57package Kerb; 58 59sub TIEHASH{bless{}} 60# other methods intentionally omitted 61 62package main; 63 64my $foo = Foo->new(1..5); 65my $bar = Bar->new(1..5); 66 67for (@prgs) { 68 my($prog, $expected) = split(/\nEXPECT\n?/, $_); 69 # TODO: dumpvar::stringify() is controlled by a pile of package 70 # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify, 71 # and so forth. We need to test with various settings of those. 72 my $out = tie *STDOUT, 'TieOut'; 73 eval $prog; 74 my $ERR = $@; 75 untie $out; 76 if ($ERR) { 77 ok(0, "$prog - $ERR"); 78 } else { 79 if ($expected =~ m:^/:) { 80 like($$out, $expected, $prog); 81 } else { 82 is($$out, $expected, $prog); 83 } 84 } 85} 86 87package TieOut; 88 89sub TIEHANDLE { 90 bless( \(my $self), $_[0] ); 91} 92 93sub PRINT { 94 my $self = shift; 95 $$self .= join('', @_); 96} 97 98sub read { 99 my $self = shift; 100 substr( $$self, 0, length($$self), '' ); 101} 102 103__END__ 104unctrl("A"); 105EXPECT 106A 107######## 108unctrl("\cA"); 109EXPECT 110^A 111######## 112uniescape("A"); 113EXPECT 114A 115######## 116uniescape("\x{100}"); 117EXPECT 118\x{0100} 119######## 120stringify(undef); 121EXPECT 122undef 123######## 124stringify("foo"); 125EXPECT 126'foo' 127######## 128stringify("\cA"); 129EXPECT 130"\cA" 131######## 132stringify(*a); 133EXPECT 134*main::a 135######## 136stringify(\undef); 137EXPECT 138/^'SCALAR\(0x[0-9a-f]+\)'$/i 139######## 140stringify([]); 141EXPECT 142/^'ARRAY\(0x[0-9a-f]+\)'$/i 143######## 144stringify({}); 145EXPECT 146/^'HASH\(0x[0-9a-f]+\)'$/i 147######## 148stringify(sub{}); 149EXPECT 150/^'CODE\(0x[0-9a-f]+\)'$/i 151######## 152stringify(\*a); 153EXPECT 154/^'GLOB\(0x[0-9a-f]+\)'$/i 155######## 156stringify($foo); 157EXPECT 158/^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i 159######## 160stringify($bar); 161EXPECT 162/^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i 163######## 164dumpValue(undef); 165EXPECT 166undef 167######## 168dumpValue(1); 169EXPECT 1701 171######## 172dumpValue("\cA"); 173EXPECT 174"\cA" 175######## 176dumpValue("\x{100}"); 177EXPECT 178'\x{0100}' 179######## 180dumpValue("1\n2\n3"); 181EXPECT 182'1 1832 1843' 185######## 186dumpValue([1..3],1); 187EXPECT 1880 1 1891 2 1902 3 191######## 192dumpValue([1..3]); 193EXPECT 1940 1 1951 2 1962 3 197######## 198dumpValue({1..4},1); 199EXPECT 2001 => 2 2013 => 4 202######## 203dumpValue({1..4}); 204EXPECT 2051 => 2 2063 => 4 207######## 208dumpValue($foo,1); 209EXPECT 2100 1 2111 2 2122 3 2133 4 2144 5 215######## 216dumpValue($foo); 217EXPECT 2180 1 2191 2 2202 3 2213 4 2224 5 223######## 224dumpValue($bar,1); 225EXPECT 2260 1 2271 2 2282 3 2293 4 2304 5 231######## 232dumpValue($bar); 233EXPECT 2340 1 2351 2 2362 3 2373 4 2384 5 239######## 240dumpvalue("a"); 241EXPECT 2420 'a' 243######## 244dumpvalue("\cA"); 245EXPECT 2460 "\cA" 247######## 248dumpvalue("\x{100}"); 249EXPECT 2500 '\x{0100}' 251######## 252dumpvalue(undef); 253EXPECT 2540 undef 255######## 256dumpvalue("foo"); 257EXPECT 2580 'foo' 259######## 260dumpvalue(\undef); 261EXPECT 262/0 SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i 263######## 264dumpvalue(\\undef); 265EXPECT 266/0 REF\(0x[0-9a-f]+\)\n -> SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i 267######## 268dumpvalue([]); 269EXPECT 270/0 ARRAY\(0x[0-9a-f]+\)\n empty array/i 271######## 272dumpvalue({}); 273EXPECT 274/0 HASH\(0x[0-9a-f]+\)\n\s+empty hash/i 275######## 276dumpvalue(sub{}); 277EXPECT 278/0 CODE\(0x[0-9a-f]+\)\n -> &CODE\(0x[0-9a-f]+\) in /i 279######## 280dumpvalue(\*a); 281EXPECT 282/0 GLOB\(0x[0-9a-f]+\)\n -> \*main::a\n/i 283######## 284dumpvalue($foo); 285EXPECT 286/0 Foo=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i 287######## 288dumpvalue($bar); 289EXPECT 290/0 Bar=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i 291######## 292dumpvalue("1\n2\n3") 293EXPECT 294/0 '1\n2\n3'\n/i 295######## 296dumpvalue([1..4]); 297EXPECT 298/0 ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i 299######## 300dumpvalue({1..4}); 301EXPECT 302/0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i 303######## 304dumpvalue({1=>2,3=>4}); 305EXPECT 306/0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i 307######## 308dumpvalue({a=>1,b=>2}); 309EXPECT 310/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i 311######## 312dumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]); 313EXPECT 314/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 315######## 316dumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)}) 317EXPECT 318/0 HASH\(0x[0-9a-f]+\)\n 1 => 'brown'\n/i 319######## 320my @x=qw(a b c); dumpvalue(\@x); 321EXPECT 322/0 ARRAY\(0x[0-9a-f]+\)\n 0 'a'\n 1 'b'\n 2 'c'\n/i 323######## 324my %x=(a=>1, b=>2); dumpvalue(\%x); 325EXPECT 326/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i 327######## 328dumpvalue(bless[1,2,3,4],"a=b=c"); 329EXPECT 330/0 a=b=c=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i 331######## 332local *_; tie $_, 'Tyre'; stringify(''); 333EXPECT 334'' 335######## 336local *_; tie $_, 'Tyre'; unctrl('abc'); 337EXPECT 338abc 339######## 340tie my %h, 'Kerb'; my $v = { a => 1, b => \%h, c => 2 }; dumpvalue($v); 341EXPECT 342/'a' => 1\n.+Can't locate object method.+'c' => 2/s 343