Commit | Line | Data |
---|---|---|
8f90a6c7 | 1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
ca092af1 JH |
6 | if (ord('A') == 193) { |
7 | print "1..0 # skip: EBCDIC\n"; | |
8 | exit 0; | |
9 | } | |
8f90a6c7 | 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 | } |