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