lib/Dumpvalue.t

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