1#!./perl 2 3BEGIN { 4 if (ord('A') == 193) { 5 print "1..0 # skip: EBCDIC\n"; 6 exit 0; 7 } 8 require Config; 9 if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ 10 print "1..0 # Skip -- Perl configured without List::Util module\n"; 11 exit 0; 12 } 13 14 # `make test` in the CPAN version of this module runs us with -w, but 15 # Dumpvalue.pm relies on all sorts of things that can cause warnings. I 16 # don't think that's worth fixing, so we just turn off all warnings 17 # during testing. 18 $^W = 0; 19} 20 21use vars qw( $foo @bar %baz ); 22 23use Test::More tests => 88; 24 25use_ok( 'Dumpvalue' ); 26 27my $d; 28ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' ); 29 30$d->set( globPrint => 1, dumpReused => 1 ); 31is( $d->{globPrint}, 1, 'set an option correctly' ); 32is( $d->get('globPrint'), 1, 'get an option correctly' ); 33is( $d->get('globPrint', 'dumpReused'), qw( 1 1 ), 'get multiple options' ); 34 35# check to see if unctrl works 36is( ref( Dumpvalue::unctrl(*FOO) ), 'GLOB', 'unctrl should not modify GLOB' ); 37is( Dumpvalue::unctrl('donotchange'), 'donotchange', "unctrl shouldn't modify"); 38like( Dumpvalue::unctrl("bo\007nd"), qr/bo\^.nd/, 'unctrl should escape' ); 39 40# check to see if stringify works 41is( $d->stringify(), 'undef', 'stringify handles undef okay' ); 42 43# the default is 1, but we want two single quotes 44$d->{printUndef} = 0; 45is( $d->stringify(), "''", 'stringify skips undef when asked nicely' ); 46 47is( $d->stringify(*FOO), *FOO . "", 'stringify stringifies globs alright' ); 48 49# check for double-quotes if there's an unprintable character 50$d->{tick} = 'auto'; 51like( $d->stringify("hi\005"), qr/^"hi/, 'added double-quotes when necessary' ); 52 53# if no unprintable character, escape ticks or backslashes 54is( $d->stringify('hi'), "'hi'", 'used single-quotes when appropriate' ); 55 56# if 'unctrl' is set 57$d->{unctrl} = 'unctrl'; 58like( $d->stringify('double and whack:\ "'), qr!\\ \"!, 'escaped with unctrl' ); 59like( $d->stringify("a\005"), qr/^"a\^/, 'escaped ASCII value in unctrl' ); 60like( $d->stringify("b\205"), qr!^'b.'$!, 'no high-bit escape value in unctrl'); 61 62$d->{quoteHighBit} = 1; 63like( $d->stringify("b\205"), qr!^'b\\205!, 'high-bit now escaped in unctrl'); 64 65# if 'quote' is set 66$d->{unctrl} = 'quote'; 67is( $d->stringify('5@ $1'), "'5\@ \$1'", 'quoted $ and @ fine' ); 68is( $d->stringify("5@\033\$1"), '"5\@\e\$1"', 'quoted $ and @ and \033 fine' ); 69like( $d->stringify("\037"), qr/^"\\c/, 'escaped ASCII value okay' ); 70 71# add ticks, if necessary 72is( $d->stringify("no ticks", 1), 'no ticks', 'avoid ticks if asked' ); 73 74my $out = tie *OUT, 'TieOut'; 75select(OUT); 76 77# test DumpElem, it does its magic with veryCompact set 78$d->{veryCompact} = 1; 79$d->DumpElem([1, 2, 3]); 80is( $out->read, "0..2 1 2 3\n", 'DumpElem worked on array ref'); 81$d->DumpElem({ one => 1, two => 2 }); 82is( $out->read, "'one' => 1, 'two' => 2\n", 'DumpElem worked on hash ref' ); 83$d->DumpElem('hi'); 84is( $out->read, "'hi'\n", 'DumpElem worked on simple scalar' ); 85$d->{veryCompact} = 0; 86$d->DumpElem([]); 87like( $out->read, qr/ARRAY/, 'DumpElem okay with reference and no veryCompact'); 88 89# should compact simple arrays just fine 90$d->{veryCompact} = 1; 91$d->DumpElem([1, 2, 3]); 92is( $out->read, "0..2 1 2 3\n", 'dumped array fine' ); 93$d->{arrayDepth} = 2; 94$d->DumpElem([1, 2, 3]); 95is( $out->read, "0..2 1 2 ...\n", 'dumped limited array fine' ); 96 97# should compact simple hashes just fine 98$d->DumpElem({ a => 1, b => 2, c => 3 }); 99is( $out->read, "'a' => 1, 'b' => 2, 'c' => 3\n", 'dumped hash fine' ); 100$d->{hashDepth} = 2; 101$d->DumpElem({ a => 1, b => 2, c => 3 }); 102is( $out->read, "'a' => 1, 'b' => 2 ...\n", 'dumped limited hash fine' ); 103 104# should just stringify what it is 105$d->{veryCompact} = 0; 106$d->DumpElem([]); 107like( $out->read, qr/ARRAY.+empty array/s, 'stringified empty array ref' ); 108$d->DumpElem({}); 109like( $out->read, qr/HASH.+empty hash/s, 'stringified empty hash ref' ); 110$d->DumpElem(1); 111is( $out->read, "1\n", 'stringified simple scalar' ); 112 113# test unwrap 114$DB::signal = $d->{stopDbSignal} = 1; 115is( $d->unwrap(), undef, 'unwrap returns if DB signal is set' ); 116undef $DB::signal; 117 118my $foo = 7; 119$d->{dumpReused} = 0; 120$d->unwrap(\$foo); 121is( $out->read, "-> 7\n", 'unwrap worked on scalar' ); 122$d->unwrap(\$foo); 123is( $out->read, "-> REUSED_ADDRESS\n", 'unwrap worked on scalar' ); 124$d->unwrap({ one => 1 }); 125 126# leaving this at zero may cause some subsequent tests to fail 127# if they reuse an address creating an anonymous variable 128$d->{dumpReused} = 1; 129is( $out->read, "'one' => 1\n", 'unwrap worked on hash' ); 130$d->unwrap([ 2, 3 ]); 131is( $out->read, "0 2\n1 3\n", 'unwrap worked on array' ); 132$d->unwrap(*FOO); 133is( $out->read, '', 'unwrap ignored glob on first try'); 134$d->unwrap(*FOO); 135is( $out->read, "*DUMPED_GLOB*\n", 'unwrap worked on glob'); 136$d->unwrap(qr/foo(.+)/); 137 138my $modifiers = (qr// =~ /\Q(?^/) ? '^' : '-xism'; 139is( $out->read, "-> qr/(?${modifiers}:foo(.+))/\n", 'unwrap worked on Regexp' ); 140 141$d->unwrap( sub {} ); 142like( $out->read, qr/^-> &CODE/, 'unwrap worked on sub ref' ); 143 144# test matchvar 145# test to see if first arg 'eq' second 146ok( Dumpvalue::matchvar(1, 1), 'matchvar matched numbers fine' ); 147ok( Dumpvalue::matchvar('hi', 'hi'), 'matchvar matched strings fine' ); 148ok( !Dumpvalue::matchvar('hello', 1), 'matchvar caught failed match fine' ); 149 150# test compactDump, which doesn't do much 151is( $d->compactDump(3), 3, 'set compactDump to 3' ); 152is( $d->compactDump(1), 479, 'compactDump reset to 6*80-1 when less than 2' ); 153 154# test veryCompact, which does slightly more, setting compactDump sometimes 155$d->{compactDump} = 0; 156is( $d->veryCompact(1), 1, 'set veryCompact successfully' ); 157ok( $d->compactDump(), 'and it set compactDump as well' ); 158 159# test set_unctrl 160$d->set_unctrl('impossible value'); 161like( $out->read, qr/^Unknown value/, 'set_unctrl caught bad value' ); 162is( $d->set_unctrl('quote'), 'quote', 'set quote fine' ); 163is( $d->set_unctrl(), 'quote', 'retrieved quote fine' ); 164 165# test set_quote 166$d->set_quote('"'); 167is( $d->{tick}, '"', 'set_quote set tick right' ); 168is( $d->{unctrl}, 'quote', 'set unctrl right too' ); 169$d->set_quote('auto'); 170is( $d->{tick}, 'auto', 'set_quote set auto right' ); 171$d->set_quote('foo'); 172is( $d->{tick}, "'", 'default value set to " correctly' ); 173 174# test dumpglob 175# should do nothing if debugger signal flag is raised 176$d->{stopDbSignal} = $DB::signal = 1; 177is( $d->dumpglob(*DB::signal), undef, 'returned early with DB signal set' ); 178undef $DB::signal; 179 180# test dumping "normal" variables, this is a nasty glob trick 181$foo = 1; 182$d->dumpglob( '', 2, 'foo', local *foo = \$foo ); 183is( $out->read, " \$foo = 1\n", 'dumped glob for $foo correctly' ); 184@bar = (1, 2); 185 186# the key name is a little different here 187$d->dumpglob( '', 0, 'boo', *bar ); 188is( $out->read, "\@boo = (\n 0..1 1 2\n)\n", 'dumped glob for @bar fine' ); 189 190%baz = ( one => 1, two => 2 ); 191$d->dumpglob( '', 0, 'baz', *baz ); 192is( $out->read, "\%baz = (\n 'one' => 1, 'two' => 2\n)\n", 193 'dumped glob for %baz fine' ); 194 195SKIP: { 196 skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, $0); 197 my $fileno = fileno(FILE); 198 $d->dumpglob( '', 0, 'FILE', *FILE ); 199 is( $out->read, "FileHandle(FILE) => fileno($fileno)\n", 200 'dumped filehandle from glob fine' ); 201} 202 203$d->dumpglob( '', 0, 'read', *TieOut::read ); 204is( $out->read, '', 'no sub dumped without $all set' ); 205$d->dumpglob( '', 0, 'read', \&TieOut::read, 1 ); 206is( $out->read, "&read in ???\n", 'sub dumped when requested' ); 207 208# see if it dumps DB-like values correctly 209$d->{dumpDBFiles} = 1; 210$d->dumpglob( '', 0, '_<foo', *foo ); 211is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' ); 212 213# test CvGV name 214SKIP: { 215 if (" $Config::Config{'extensions'} " !~ m[ Devel/Peek ]) { 216 skip( 'no Devel::Peek', 2 ); 217 } 218 use_ok( 'Devel::Peek' ); 219 is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' ); 220} 221 222# test dumpsub 223$d->dumpsub( '', 'TieOut::read' ); 224like( $out->read, qr/&TieOut::read in/, 'dumpsub found sub fine' ); 225 226# test findsubs 227is( $d->findsubs(), undef, 'findsubs returns nothing without %DB::sub' ); 228$DB::sub{'TieOut::read'} = 'TieOut'; 229is( $d->findsubs( \&TieOut::read ), 'TieOut::read', 'findsubs reported sub' ); 230 231# now that it's capable of finding the package... 232$d->dumpsub( '', 'TieOut::read' ); 233is( $out->read, "&TieOut::read in TieOut\n", 'dumpsub found sub fine again' ); 234 235# this should print just a usage message 236$d->{usageOnly} = 1; 237$d->dumpvars( 'Fake', 'veryfake' ); 238like( $out->read, qr/^String space:/, 'printed usage message fine' ); 239delete $d->{usageOnly}; 240 241# this should report @INC and %INC 242$d->dumpvars( 'main', 'INC' ); 243like( $out->read, qr/\@INC =/, 'dumped variables from a package' ); 244 245# this should report nothing 246$DB::signal = 1; 247$d->dumpvars( 'main', 'INC' ); 248is( $out->read, '', 'no dump when $DB::signal is set' ); 249undef $DB::signal; 250 251is( $d->scalarUsage('12345'), 5, 'scalarUsage reports length correctly' ); 252is( $d->arrayUsage( [1, 2, 3], 'a' ), 3, 'arrayUsage reports correct lengths' ); 253is( $out->read, "\@a = 3 items (data: 3 bytes)\n", 'arrayUsage message okay' ); 254is( $d->hashUsage({ one => 1 }, 'b'), 4, 'hashUsage reports correct lengths' ); 255is( $out->read, "\%b = 1 item (keys: 3; values: 1; total: 4 bytes)\n", 256 'hashUsage message okay' ); 257is( $d->hashUsage({ one => [ 1, 2, 3 ]}, 'c'), 6, 'complex hash okay' ); 258is( $out->read, "\%c = 1 item (keys: 3; values: 3; total: 6 bytes)\n", 259 'hashUsage complex message okay' ); 260 261$foo = 'one'; 262@foo = ('two'); 263%foo = ( three => '123' ); 264is( $d->globUsage(\*foo, 'foo'), 14, 'globUsage reports length correctly' ); 265like( $out->read, qr/\@foo =.+\%foo =/s, 'globValue message okay' ); 266 267# and now, the real show 268$d->dumpValue(undef); 269is( $out->read, "undef\n", 'dumpValue caught undef value okay' ); 270$d->dumpValue($foo); 271is( $out->read, "'one'\n", 'dumpValue worked' ); 272$d->dumpValue(@foo); 273is( $out->read, "'two'\n", 'dumpValue worked on array' ); 274$d->dumpValue(\$foo); 275is( $out->read, "-> 'one'\n", 'dumpValue worked on scalar ref' ); 276 277# dumpValues (the rest of these should be caught by unwrap) 278$d->dumpValues(undef); 279is( $out->read, "undef\n", 'dumpValues caught undef value fine' ); 280$d->dumpValues(\@foo); 281is( $out->read, "0 0..0 'two'\n", 'dumpValues worked on array ref' ); 282$d->dumpValues('one', 'two'); 283is( $out->read, "0..1 'one' 'two'\n", 'dumpValues worked on multiple values' ); 284 285 286package TieOut; 287use overload '"' => sub { "overloaded!" }; 288 289sub TIEHANDLE { 290 my $class = shift; 291 bless(\( my $ref), $class); 292} 293 294sub PRINT { 295 my $self = shift; 296 $$self .= join('', @_); 297} 298 299sub read { 300 my $self = shift; 301 return substr($$self, 0, length($$self), ''); 302} 303