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