Commit | Line | Data |
---|---|---|
99331854 | 1 | #!./perl -T |
9ec58fb7 JH |
2 | |
3 | BEGIN { | |
9ec58fb7 | 4 | require Config; import Config; |
e7ecf62c | 5 | if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) { |
9ec58fb7 JH |
6 | print "1..0 # Skip: Devel::Peek was not built\n"; |
7 | exit 0; | |
8 | } | |
9 | } | |
10 | ||
06a5cade | 11 | use Test::More; |
e7ecf62c | 12 | |
9248c45a JH |
13 | use Devel::Peek; |
14 | ||
9248c45a | 15 | our $DEBUG = 0; |
277ddfaf | 16 | open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; |
9248c45a | 17 | |
bfe27a58 NC |
18 | # If I reference any lexicals in this, I get the entire outer subroutine (or |
19 | # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to | |
20 | # maintain that. | |
21 | format PIE = | |
22 | Pie @<<<<< | |
23 | $::type | |
24 | Good @>>>>> | |
25 | $::mmmm | |
26 | . | |
27 | ||
9248c45a | 28 | sub do_test { |
000fd473 NC |
29 | my $todo = $_[3]; |
30 | my $repeat_todo = $_[4]; | |
31 | my $pattern = $_[2]; | |
277ddfaf GS |
32 | if (open(OUT,">peek$$")) { |
33 | open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; | |
9248c45a | 34 | Dump($_[1]); |
e9569a7a GG |
35 | print STDERR "*****\n"; |
36 | Dump($_[1]); # second dump to compare with the first to make sure nothing changed. | |
277ddfaf GS |
37 | open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; |
38 | close(OUT); | |
9248c45a JH |
39 | if (open(IN, "peek$$")) { |
40 | local $/; | |
41 | $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; | |
8aacddc1 | 42 | $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g; |
fd0854ff | 43 | # handle DEBUG_LEAKING_SCALARS prefix |
d94a5950 | 44 | $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg; |
bf53b3a5 | 45 | |
000fd473 NC |
46 | # Need some clear generic mechanism to eliminate (or add) lines |
47 | # of dump output dependant on perl version. The (previous) use of | |
48 | # things like $IVNV gave the illusion that the string passed in was | |
49 | # a regexp into which variables were interpolated, but this wasn't | |
50 | # actually true as those 'variables' actually also ate the | |
b7b1e41b | 51 | # whitespace on the line. So it seems better to mark lines that |
000fd473 NC |
52 | # need to be eliminated. I considered (?# ... ) and (?{ ... }), |
53 | # but whilst embedded code or comment syntax would keep it as a | |
54 | # legitimate regexp, it still isn't true. Seems easier and clearer | |
55 | # things that look like comments. | |
56 | ||
c2485e0c | 57 | my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/; |
000fd473 NC |
58 | # Could do this is in a s///mge but seems clearer like this: |
59 | $pattern = join '', map { | |
60 | # If we identify the version condition, take *it* out whatever | |
c2485e0c | 61 | s/\s*# ($version_condition(?: && $version_condition)?)$// |
000fd473 NC |
62 | ? (eval $1 ? $_ : '') |
63 | : $_ # Didn't match, so this line is in | |
64 | } split /^/, $pattern; | |
65 | ||
66 | $pattern =~ s/\$PADMY/ | |
67 | ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY'; | |
68 | /mge; | |
69 | $pattern =~ s/\$PADTMP/ | |
70 | ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP'; | |
71 | /mge; | |
2b631c93 NC |
72 | $pattern =~ s/\$RV/ |
73 | ($] < 5.011) ? 'RV' : 'IV'; | |
74 | /mge; | |
d04ba589 | 75 | |
9248c45a | 76 | print $pattern, "\n" if $DEBUG; |
e9569a7a | 77 | my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>; |
9248c45a | 78 | print $dump, "\n" if $DEBUG; |
06a5cade NC |
79 | like( $dump, qr/\A$pattern\Z/ms, $_[0]) |
80 | or note("line " . (caller)[2]); | |
e9569a7a | 81 | |
000fd473 | 82 | local $TODO = $repeat_todo; |
06a5cade NC |
83 | is($dump2, $dump, "$_[0] (unchanged by dump)") |
84 | or note("line " . (caller)[2]); | |
e9569a7a | 85 | |
9248c45a | 86 | close(IN); |
e9569a7a | 87 | |
59d8ce62 | 88 | return $1; |
9248c45a JH |
89 | } else { |
90 | die "$0: failed to open peek$$: !\n"; | |
91 | } | |
92 | } else { | |
93 | die "$0: failed to create peek$$: $!\n"; | |
94 | } | |
95 | } | |
96 | ||
97 | our $a; | |
98 | our $b; | |
99 | my $c; | |
208edb77 | 100 | local $d = 0; |
9248c45a | 101 | |
e7ecf62c RGS |
102 | END { |
103 | 1 while unlink("peek$$"); | |
104 | } | |
bf53b3a5 | 105 | |
06a5cade | 106 | do_test('assignment of immediate constant (string)', |
9248c45a JH |
107 | $a = "foo", |
108 | 'SV = PV\\($ADDR\\) at $ADDR | |
109 | REFCNT = 1 | |
110 | FLAGS = \\(POK,pPOK\\) | |
111 | PV = $ADDR "foo"\\\0 | |
112 | CUR = 3 | |
1badabf5 | 113 | LEN = \\d+' |
9248c45a JH |
114 | ); |
115 | ||
06a5cade | 116 | do_test('immediate constant (string)', |
9248c45a JH |
117 | "bar", |
118 | 'SV = PV\\($ADDR\\) at $ADDR | |
119 | REFCNT = 1 | |
7766e686 | 120 | FLAGS = \\(.*POK,READONLY,pPOK\\) |
9248c45a JH |
121 | PV = $ADDR "bar"\\\0 |
122 | CUR = 3 | |
1badabf5 | 123 | LEN = \\d+'); |
9248c45a | 124 | |
b7b1e41b | 125 | do_test('assignment of immediate constant (integer)', |
9248c45a JH |
126 | $b = 123, |
127 | 'SV = IV\\($ADDR\\) at $ADDR | |
128 | REFCNT = 1 | |
129 | FLAGS = \\(IOK,pIOK\\) | |
130 | IV = 123'); | |
131 | ||
06a5cade | 132 | do_test('immediate constant (integer)', |
9248c45a JH |
133 | 456, |
134 | 'SV = IV\\($ADDR\\) at $ADDR | |
135 | REFCNT = 1 | |
7766e686 | 136 | FLAGS = \\(.*IOK,READONLY,pIOK\\) |
9248c45a JH |
137 | IV = 456'); |
138 | ||
06a5cade | 139 | do_test('assignment of immediate constant (integer)', |
9248c45a JH |
140 | $c = 456, |
141 | 'SV = IV\\($ADDR\\) at $ADDR | |
142 | REFCNT = 1 | |
000fd473 | 143 | FLAGS = \\($PADMY,IOK,pIOK\\) |
9248c45a JH |
144 | IV = 456'); |
145 | ||
59d8ce62 NC |
146 | # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers |
147 | # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then | |
148 | # maths is done in floating point always, and this scalar will be an NV. | |
149 | # ([NI]) captures the type, referred to by \1 in this regexp and $type for | |
150 | # building subsequent regexps. | |
06a5cade | 151 | my $type = do_test('result of addition', |
9248c45a | 152 | $c + $d, |
59d8ce62 | 153 | 'SV = ([NI])V\\($ADDR\\) at $ADDR |
9248c45a | 154 | REFCNT = 1 |
59d8ce62 NC |
155 | FLAGS = \\(PADTMP,\1OK,p\1OK\\) |
156 | \1V = 456'); | |
9248c45a JH |
157 | |
158 | ($d = "789") += 0.1; | |
159 | ||
06a5cade | 160 | do_test('floating point value', |
9248c45a JH |
161 | $d, |
162 | 'SV = PVNV\\($ADDR\\) at $ADDR | |
163 | REFCNT = 1 | |
164 | FLAGS = \\(NOK,pNOK\\) | |
78d00c47 | 165 | IV = \d+ |
ac634a9a | 166 | NV = 789\\.(?:1(?:000+\d+)?|0999+\d+) |
9248c45a JH |
167 | PV = $ADDR "789"\\\0 |
168 | CUR = 3 | |
1badabf5 | 169 | LEN = \\d+'); |
9248c45a | 170 | |
06a5cade | 171 | do_test('integer constant', |
9248c45a JH |
172 | 0xabcd, |
173 | 'SV = IV\\($ADDR\\) at $ADDR | |
174 | REFCNT = 1 | |
28e5dec8 JH |
175 | FLAGS = \\(.*IOK,READONLY,pIOK\\) |
176 | IV = 43981'); | |
9248c45a | 177 | |
06a5cade | 178 | do_test('undef', |
9248c45a JH |
179 | undef, |
180 | 'SV = NULL\\(0x0\\) at $ADDR | |
181 | REFCNT = 1 | |
182 | FLAGS = \\(\\)'); | |
183 | ||
06a5cade | 184 | do_test('reference to scalar', |
9248c45a | 185 | \$a, |
4df7f6af | 186 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
187 | REFCNT = 1 |
188 | FLAGS = \\(ROK\\) | |
189 | RV = $ADDR | |
190 | SV = PV\\($ADDR\\) at $ADDR | |
191 | REFCNT = 2 | |
192 | FLAGS = \\(POK,pPOK\\) | |
193 | PV = $ADDR "foo"\\\0 | |
194 | CUR = 3 | |
1badabf5 | 195 | LEN = \\d+'); |
9248c45a | 196 | |
59d8ce62 NC |
197 | my $c_pattern; |
198 | if ($type eq 'N') { | |
199 | $c_pattern = ' | |
200 | SV = PVNV\\($ADDR\\) at $ADDR | |
201 | REFCNT = 1 | |
202 | FLAGS = \\(IOK,NOK,pIOK,pNOK\\) | |
203 | IV = 456 | |
204 | NV = 456 | |
205 | PV = 0'; | |
206 | } else { | |
207 | $c_pattern = ' | |
208 | SV = IV\\($ADDR\\) at $ADDR | |
209 | REFCNT = 1 | |
210 | FLAGS = \\(IOK,pIOK\\) | |
211 | IV = 456'; | |
212 | } | |
06a5cade | 213 | do_test('reference to array', |
9248c45a | 214 | [$b,$c], |
4df7f6af | 215 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
216 | REFCNT = 1 |
217 | FLAGS = \\(ROK\\) | |
218 | RV = $ADDR | |
219 | SV = PVAV\\($ADDR\\) at $ADDR | |
78c72037 | 220 | REFCNT = 1 |
9248c45a | 221 | FLAGS = \\(\\) |
1bcecb77 NC |
222 | IV = 0 # $] < 5.009 |
223 | NV = 0 # $] < 5.009 | |
9248c45a JH |
224 | ARRAY = $ADDR |
225 | FILL = 1 | |
226 | MAX = 1 | |
227 | ARYLEN = 0x0 | |
228 | FLAGS = \\(REAL\\) | |
229 | Elt No. 0 | |
230 | SV = IV\\($ADDR\\) at $ADDR | |
231 | REFCNT = 1 | |
232 | FLAGS = \\(IOK,pIOK\\) | |
233 | IV = 123 | |
59d8ce62 | 234 | Elt No. 1' . $c_pattern); |
9248c45a | 235 | |
06a5cade | 236 | do_test('reference to hash', |
9248c45a | 237 | {$b=>$c}, |
4df7f6af | 238 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
239 | REFCNT = 1 |
240 | FLAGS = \\(ROK\\) | |
241 | RV = $ADDR | |
242 | SV = PVHV\\($ADDR\\) at $ADDR | |
78c72037 | 243 | REFCNT = 1 |
9248c45a | 244 | FLAGS = \\(SHAREKEYS\\) |
1bcecb77 NC |
245 | IV = 1 # $] < 5.009 |
246 | NV = $FLOAT # $] < 5.009 | |
9248c45a | 247 | ARRAY = $ADDR \\(0:7, 1:1\\) |
b8fa94d8 | 248 | hash quality = 100.0% |
9248c45a JH |
249 | KEYS = 1 |
250 | FILL = 1 | |
251 | MAX = 7 | |
252 | RITER = -1 | |
253 | EITER = 0x0 | |
000fd473 NC |
254 | Elt "123" HASH = $ADDR' . $c_pattern, |
255 | '', | |
256 | $] > 5.009 && 'The hash iterator used in dump.c sets the OOK flag'); | |
9248c45a | 257 | |
06a5cade | 258 | do_test('reference to anon sub with empty prototype', |
9248c45a | 259 | sub(){@_}, |
4df7f6af | 260 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
261 | REFCNT = 1 |
262 | FLAGS = \\(ROK\\) | |
263 | RV = $ADDR | |
264 | SV = PVCV\\($ADDR\\) at $ADDR | |
265 | REFCNT = 2 | |
cfc1e951 | 266 | FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) |
1bcecb77 NC |
267 | IV = 0 # $] < 5.009 |
268 | NV = 0 # $] < 5.009 | |
9248c45a JH |
269 | PROTOTYPE = "" |
270 | COMP_STASH = $ADDR\\t"main" | |
271 | START = $ADDR ===> \\d+ | |
272 | ROOT = $ADDR | |
1bcecb77 NC |
273 | XSUB = 0x0 # $] < 5.009 |
274 | XSUBANY = 0 # $] < 5.009 | |
208edb77 | 275 | GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" |
084d946d | 276 | FILE = ".*\\b(?i:peek\\.t)" |
000fd473 NC |
277 | DEPTH = 0(?: |
278 | MUTEXP = $ADDR | |
279 | OWNER = $ADDR)? | |
1bcecb77 | 280 | FLAGS = 0x404 # $] < 5.009 |
cfc1e951 | 281 | FLAGS = 0x490 # $] >= 5.009 |
a3985cdc | 282 | OUTSIDE_SEQ = \\d+ |
9248c45a | 283 | PADLIST = $ADDR |
dd2155a4 | 284 | PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) |
9248c45a JH |
285 | OUTSIDE = $ADDR \\(MAIN\\)'); |
286 | ||
06a5cade | 287 | do_test('reference to named subroutine without prototype', |
9248c45a | 288 | \&do_test, |
4df7f6af | 289 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
290 | REFCNT = 1 |
291 | FLAGS = \\(ROK\\) | |
292 | RV = $ADDR | |
293 | SV = PVCV\\($ADDR\\) at $ADDR | |
9856a127 | 294 | REFCNT = (3|4) |
9248c45a | 295 | FLAGS = \\(\\) |
1bcecb77 NC |
296 | IV = 0 # $] < 5.009 |
297 | NV = 0 # $] < 5.009 | |
9248c45a JH |
298 | COMP_STASH = $ADDR\\t"main" |
299 | START = $ADDR ===> \\d+ | |
300 | ROOT = $ADDR | |
1bcecb77 NC |
301 | XSUB = 0x0 # $] < 5.009 |
302 | XSUBANY = 0 # $] < 5.009 | |
9248c45a | 303 | GVGV::GV = $ADDR\\t"main" :: "do_test" |
084d946d | 304 | FILE = ".*\\b(?i:peek\\.t)" |
9248c45a | 305 | DEPTH = 1 |
9856a127 | 306 | (?: MUTEXP = $ADDR |
208edb77 MG |
307 | OWNER = $ADDR |
308 | )? FLAGS = 0x0 | |
a3985cdc | 309 | OUTSIDE_SEQ = \\d+ |
9248c45a | 310 | PADLIST = $ADDR |
dd2155a4 | 311 | PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) |
000fd473 NC |
312 | \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo" |
313 | \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo" | |
ee6cee0c | 314 | \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern" |
c2485e0c | 315 | \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition" |
000fd473 NC |
316 | \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009 |
317 | \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009 | |
ee6cee0c | 318 | \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump" |
e9569a7a | 319 | \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2" |
9248c45a JH |
320 | OUTSIDE = $ADDR \\(MAIN\\)'); |
321 | ||
3ce3ed55 | 322 | if ($] >= 5.011) { |
06a5cade | 323 | do_test('reference to regexp', |
3ce3ed55 NC |
324 | qr(tic), |
325 | 'SV = $RV\\($ADDR\\) at $ADDR | |
326 | REFCNT = 1 | |
327 | FLAGS = \\(ROK\\) | |
328 | RV = $ADDR | |
5c35adbb | 329 | SV = REGEXP\\($ADDR\\) at $ADDR |
c2123ae3 | 330 | REFCNT = 1 |
b9ad13ac | 331 | FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) |
fb85c044 KW |
332 | PV = $ADDR "\\(\\?\\^:tic\\)" |
333 | CUR = 8 | |
c2123ae3 | 334 | LEN = 0 |
d63e6659 DM |
335 | STASH = $ADDR\\t"Regexp"' |
336 | . ($] < 5.013 ? '' : | |
337 | ' | |
338 | EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) | |
339 | INTFLAGS = 0x0 | |
340 | NPARENS = 0 | |
341 | LASTPAREN = 0 | |
342 | LASTCLOSEPAREN = 0 | |
343 | MINLEN = 3 | |
344 | MINLENRET = 3 | |
345 | GOFS = 0 | |
346 | PRE_PREFIX = 4 | |
347 | SEEN_EVALS = 0 | |
348 | SUBLEN = 0 | |
349 | SUBBEG = 0x0 | |
350 | ENGINE = $ADDR | |
351 | MOTHER_RE = $ADDR | |
352 | PAREN_NAMES = 0x0 | |
353 | SUBSTRS = $ADDR | |
354 | PPRIVATE = $ADDR | |
355 | OFFS = $ADDR' | |
356 | )); | |
3ce3ed55 | 357 | } else { |
06a5cade | 358 | do_test('reference to regexp', |
9248c45a | 359 | qr(tic), |
4df7f6af | 360 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
361 | REFCNT = 1 |
362 | FLAGS = \\(ROK\\) | |
363 | RV = $ADDR | |
364 | SV = PVMG\\($ADDR\\) at $ADDR | |
365 | REFCNT = 1 | |
faf82a0b | 366 | FLAGS = \\(OBJECT,SMG\\) |
9248c45a JH |
367 | IV = 0 |
368 | NV = 0 | |
369 | PV = 0 | |
370 | MAGIC = $ADDR | |
371 | MG_VIRTUAL = $ADDR | |
14befaf4 | 372 | MG_TYPE = PERL_MAGIC_qr\(r\) |
9248c45a | 373 | MG_OBJ = $ADDR |
fb85c044 | 374 | PAT = "\(\?^:tic\)" # $] >= 5.009 |
1bcecb77 | 375 | REFCNT = 2 # $] >= 5.009 |
9248c45a | 376 | STASH = $ADDR\\t"Regexp"'); |
3ce3ed55 | 377 | } |
9248c45a | 378 | |
06a5cade | 379 | do_test('reference to blessed hash', |
9248c45a | 380 | (bless {}, "Tac"), |
4df7f6af | 381 | 'SV = $RV\\($ADDR\\) at $ADDR |
9248c45a JH |
382 | REFCNT = 1 |
383 | FLAGS = \\(ROK\\) | |
384 | RV = $ADDR | |
385 | SV = PVHV\\($ADDR\\) at $ADDR | |
78c72037 | 386 | REFCNT = 1 |
9248c45a | 387 | FLAGS = \\(OBJECT,SHAREKEYS\\) |
1bcecb77 NC |
388 | IV = 0 # $] < 5.009 |
389 | NV = 0 # $] < 5.009 | |
9248c45a JH |
390 | STASH = $ADDR\\t"Tac" |
391 | ARRAY = 0x0 | |
392 | KEYS = 0 | |
393 | FILL = 0 | |
394 | MAX = 7 | |
395 | RITER = -1 | |
000fd473 NC |
396 | EITER = 0x0', '', |
397 | $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag' | |
398 | : "Something causes the HV's array to become allocated"); | |
9248c45a | 399 | |
06a5cade | 400 | do_test('typeglob', |
9248c45a JH |
401 | *a, |
402 | 'SV = PVGV\\($ADDR\\) at $ADDR | |
403 | REFCNT = 5 | |
000fd473 NC |
404 | FLAGS = \\(MULTI(?:,IN_PAD)?\\) # $] >= 5.009 |
405 | FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) # $] < 5.009 | |
406 | IV = 0 # $] < 5.009 | |
407 | NV = 0 # $] < 5.009 | |
408 | PV = 0 # $] < 5.009 | |
409 | MAGIC = $ADDR # $] < 5.009 | |
410 | MG_VIRTUAL = &PL_vtbl_glob # $] < 5.009 | |
411 | MG_TYPE = PERL_MAGIC_glob\(\*\) # $] < 5.009 | |
412 | MG_OBJ = $ADDR # $] < 5.009 | |
9248c45a JH |
413 | NAME = "a" |
414 | NAMELEN = 1 | |
415 | GvSTASH = $ADDR\\t"main" | |
416 | GP = $ADDR | |
417 | SV = $ADDR | |
418 | REFCNT = 1 | |
419 | IO = 0x0 | |
420 | FORM = 0x0 | |
421 | AV = 0x0 | |
422 | HV = 0x0 | |
423 | CV = 0x0 | |
424 | CVGEN = 0x0 | |
000fd473 | 425 | GPFLAGS = 0x0 # $] < 5.009 |
9ec58fb7 | 426 | LINE = \\d+ |
084d946d | 427 | FILE = ".*\\b(?i:peek\\.t)" |
e39917cc | 428 | FLAGS = $ADDR |
9248c45a JH |
429 | EGV = $ADDR\\t"a"'); |
430 | ||
cdb2dd7b | 431 | if (ord('A') == 193) { |
06a5cade | 432 | do_test('string with Unicode', |
cdb2dd7b JH |
433 | chr(256).chr(0).chr(512), |
434 | 'SV = PV\\($ADDR\\) at $ADDR | |
435 | REFCNT = 1 | |
000fd473 | 436 | FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) |
cdb2dd7b JH |
437 | PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] |
438 | CUR = 5 | |
1badabf5 | 439 | LEN = \\d+'); |
cdb2dd7b | 440 | } else { |
06a5cade | 441 | do_test('string with Unicode', |
e6abe6d8 JH |
442 | chr(256).chr(0).chr(512), |
443 | 'SV = PV\\($ADDR\\) at $ADDR | |
444 | REFCNT = 1 | |
000fd473 | 445 | FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) |
98c991d1 | 446 | PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] |
e6abe6d8 | 447 | CUR = 5 |
1badabf5 | 448 | LEN = \\d+'); |
cdb2dd7b | 449 | } |
e6abe6d8 | 450 | |
cdb2dd7b | 451 | if (ord('A') == 193) { |
06a5cade | 452 | do_test('reference to hash containing Unicode', |
cdb2dd7b | 453 | {chr(256)=>chr(512)}, |
4df7f6af | 454 | 'SV = $RV\\($ADDR\\) at $ADDR |
cdb2dd7b JH |
455 | REFCNT = 1 |
456 | FLAGS = \\(ROK\\) | |
457 | RV = $ADDR | |
458 | SV = PVHV\\($ADDR\\) at $ADDR | |
78c72037 | 459 | REFCNT = 1 |
b2caaddd | 460 | FLAGS = \\(SHAREKEYS,HASKFLAGS\\) |
1bcecb77 NC |
461 | UV = 1 # $] < 5.009 |
462 | NV = $FLOAT # $] < 5.009 | |
cdb2dd7b JH |
463 | ARRAY = $ADDR \\(0:7, 1:1\\) |
464 | hash quality = 100.0% | |
465 | KEYS = 1 | |
466 | FILL = 1 | |
467 | MAX = 7 | |
468 | RITER = -1 | |
469 | EITER = $ADDR | |
6cbfa5b4 | 470 | Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR |
cdb2dd7b JH |
471 | SV = PV\\($ADDR\\) at $ADDR |
472 | REFCNT = 1 | |
473 | FLAGS = \\(POK,pPOK,UTF8\\) | |
474 | PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\] | |
475 | CUR = 2 | |
000fd473 NC |
476 | LEN = \\d+', |
477 | $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag' | |
478 | : 'sv_length has been called on the element, and cached the result in MAGIC'); | |
cdb2dd7b | 479 | } else { |
06a5cade | 480 | do_test('reference to hash containing Unicode', |
98c991d1 | 481 | {chr(256)=>chr(512)}, |
4df7f6af | 482 | 'SV = $RV\\($ADDR\\) at $ADDR |
98c991d1 JH |
483 | REFCNT = 1 |
484 | FLAGS = \\(ROK\\) | |
485 | RV = $ADDR | |
486 | SV = PVHV\\($ADDR\\) at $ADDR | |
78c72037 | 487 | REFCNT = 1 |
19692e8d | 488 | FLAGS = \\(SHAREKEYS,HASKFLAGS\\) |
1bcecb77 NC |
489 | UV = 1 # $] < 5.009 |
490 | NV = 0 # $] < 5.009 | |
98c991d1 JH |
491 | ARRAY = $ADDR \\(0:7, 1:1\\) |
492 | hash quality = 100.0% | |
493 | KEYS = 1 | |
494 | FILL = 1 | |
495 | MAX = 7 | |
496 | RITER = -1 | |
497 | EITER = $ADDR | |
498 | Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR | |
499 | SV = PV\\($ADDR\\) at $ADDR | |
500 | REFCNT = 1 | |
501 | FLAGS = \\(POK,pPOK,UTF8\\) | |
502 | PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\] | |
503 | CUR = 2 | |
000fd473 NC |
504 | LEN = \\d+', '', |
505 | $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag' | |
506 | : 'sv_length has been called on the element, and cached the result in MAGIC'); | |
cdb2dd7b | 507 | } |
98c991d1 | 508 | |
99331854 YST |
509 | my $x=""; |
510 | $x=~/.??/g; | |
06a5cade | 511 | do_test('scalar with pos magic', |
99331854 YST |
512 | $x, |
513 | 'SV = PVMG\\($ADDR\\) at $ADDR | |
514 | REFCNT = 1 | |
000fd473 | 515 | FLAGS = \\($PADMY,SMG,POK,pPOK\\) |
99331854 YST |
516 | IV = 0 |
517 | NV = 0 | |
518 | PV = $ADDR ""\\\0 | |
519 | CUR = 0 | |
1936d2a7 | 520 | LEN = \d+ |
99331854 YST |
521 | MAGIC = $ADDR |
522 | MG_VIRTUAL = &PL_vtbl_mglob | |
523 | MG_TYPE = PERL_MAGIC_regex_global\\(g\\) | |
524 | MG_FLAGS = 0x01 | |
525 | MINMATCH'); | |
526 | ||
f24fdb76 HS |
527 | # |
528 | # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS | |
529 | # environment variables may be invisibly case-forced, hence the (?i:PATH) | |
5e836f43 | 530 | # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)? |
d9baf692 JM |
531 | # VMS is setting FAKE and READONLY flags. What VMS uses for storing |
532 | # ENV hashes is also not always null terminated. | |
f24fdb76 | 533 | # |
06a5cade | 534 | do_test('tainted value in %ENV', |
99331854 YST |
535 | $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value |
536 | 'SV = PVMG\\($ADDR\\) at $ADDR | |
537 | REFCNT = 1 | |
538 | FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\) | |
539 | IV = 0 | |
540 | NV = 0 | |
541 | PV = $ADDR "0"\\\0 | |
542 | CUR = 1 | |
543 | LEN = \d+ | |
544 | MAGIC = $ADDR | |
545 | MG_VIRTUAL = &PL_vtbl_envelem | |
546 | MG_TYPE = PERL_MAGIC_envelem\\(e\\) | |
d25a523c | 547 | (?: MG_FLAGS = 0x01 |
99331854 | 548 | TAINTEDDIR |
143a3e5e CB |
549 | )? MG_LEN = -?\d+ |
550 | MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY | |
5e836f43 | 551 | SV = PV(?:IV)?\\($ADDR\\) at $ADDR |
143a3e5e | 552 | REFCNT = \d+ |
11e2783c | 553 | FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\) |
f0fabfd7 | 554 | (?: IV = 0 |
d9baf692 | 555 | )? PV = $ADDR "(?i:PATH)"(?:\\\0)? |
143a3e5e CB |
556 | CUR = \d+ |
557 | LEN = \d+) | |
99331854 YST |
558 | MAGIC = $ADDR |
559 | MG_VIRTUAL = &PL_vtbl_taint | |
560 | MG_TYPE = PERL_MAGIC_taint\\(t\\)'); | |
561 | ||
06a5cade | 562 | do_test('blessed reference', |
6bf47b08 | 563 | bless(\\undef, 'Foobar'), |
4df7f6af | 564 | 'SV = $RV\\($ADDR\\) at $ADDR |
6bf47b08 SR |
565 | REFCNT = 1 |
566 | FLAGS = \\(ROK\\) | |
567 | RV = $ADDR | |
568 | SV = PVMG\\($ADDR\\) at $ADDR | |
569 | REFCNT = 2 | |
570 | FLAGS = \\(OBJECT,ROK\\) | |
7957ad98 MB |
571 | IV = -?\d+ |
572 | NV = $FLOAT | |
6bf47b08 SR |
573 | RV = $ADDR |
574 | SV = NULL\\(0x0\\) at $ADDR | |
575 | REFCNT = \d+ | |
576 | FLAGS = \\(READONLY\\) | |
577 | PV = $ADDR "" | |
578 | CUR = 0 | |
579 | LEN = 0 | |
580 | STASH = $ADDR\s+"Foobar"'); | |
b1886099 | 581 | |
b1886099 NC |
582 | sub const () { |
583 | "Perl rules"; | |
584 | } | |
585 | ||
06a5cade | 586 | do_test('constant subroutine', |
b1886099 | 587 | \&const, |
4df7f6af | 588 | 'SV = $RV\\($ADDR\\) at $ADDR |
b1886099 NC |
589 | REFCNT = 1 |
590 | FLAGS = \\(ROK\\) | |
591 | RV = $ADDR | |
592 | SV = PVCV\\($ADDR\\) at $ADDR | |
593 | REFCNT = (2) | |
31d45e0c | 594 | FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) |
1bcecb77 NC |
595 | IV = 0 # $] < 5.009 |
596 | NV = 0 # $] < 5.009 | |
b1886099 NC |
597 | PROTOTYPE = "" |
598 | COMP_STASH = 0x0 | |
1bcecb77 | 599 | ROOT = 0x0 # $] < 5.009 |
b1886099 NC |
600 | XSUB = $ADDR |
601 | XSUBANY = $ADDR \\(CONST SV\\) | |
602 | SV = PV\\($ADDR\\) at $ADDR | |
603 | REFCNT = 1 | |
604 | FLAGS = \\(.*POK,READONLY,pPOK\\) | |
605 | PV = $ADDR "Perl rules"\\\0 | |
606 | CUR = 10 | |
607 | LEN = \\d+ | |
608 | GVGV::GV = $ADDR\\t"main" :: "const" | |
609 | FILE = ".*\\b(?i:peek\\.t)" | |
000fd473 NC |
610 | DEPTH = 0(?: |
611 | MUTEXP = $ADDR | |
612 | OWNER = $ADDR)? | |
1bcecb77 | 613 | FLAGS = 0x200 # $] < 5.009 |
c2485e0c NC |
614 | FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013 |
615 | FLAGS = 0xc # $] >= 5.013 | |
b1886099 NC |
616 | OUTSIDE_SEQ = 0 |
617 | PADLIST = 0x0 | |
618 | OUTSIDE = 0x0 \\(null\\)'); | |
2e94196c | 619 | |
06a5cade | 620 | do_test('isUV should show on PVMG', |
2e94196c NC |
621 | do { my $v = $1; $v = ~0; $v }, |
622 | 'SV = PVMG\\($ADDR\\) at $ADDR | |
623 | REFCNT = 1 | |
624 | FLAGS = \\(IOK,pIOK,IsUV\\) | |
625 | UV = \d+ | |
626 | NV = 0 | |
627 | PV = 0'); | |
c0a413d1 | 628 | |
06a5cade | 629 | do_test('IO', |
c0a413d1 NC |
630 | *STDOUT{IO}, |
631 | 'SV = $RV\\($ADDR\\) at $ADDR | |
632 | REFCNT = 1 | |
633 | FLAGS = \\(ROK\\) | |
634 | RV = $ADDR | |
635 | SV = PVIO\\($ADDR\\) at $ADDR | |
636 | REFCNT = 3 | |
637 | FLAGS = \\(OBJECT\\) | |
3cf51070 | 638 | IV = 0 # $] < 5.011 |
1bcecb77 | 639 | NV = 0 # $] < 5.011 |
d963bf01 | 640 | STASH = $ADDR\s+"IO::File" |
c0a413d1 NC |
641 | IFP = $ADDR |
642 | OFP = $ADDR | |
643 | DIRP = 0x0 | |
644 | LINES = 0 | |
645 | PAGE = 0 | |
646 | PAGE_LEN = 60 | |
647 | LINES_LEFT = 0 | |
648 | TOP_GV = 0x0 | |
649 | FMT_GV = 0x0 | |
650 | BOTTOM_GV = 0x0 | |
1bcecb77 | 651 | SUBPROCESS = 0 # $] < 5.009 |
c0a413d1 | 652 | TYPE = \'>\' |
50a9fad1 | 653 | FLAGS = 0x4'); |
bfe27a58 | 654 | |
06a5cade | 655 | do_test('FORMAT', |
bfe27a58 NC |
656 | *PIE{FORMAT}, |
657 | 'SV = $RV\\($ADDR\\) at $ADDR | |
658 | REFCNT = 1 | |
659 | FLAGS = \\(ROK\\) | |
660 | RV = $ADDR | |
661 | SV = PVFM\\($ADDR\\) at $ADDR | |
662 | REFCNT = 2 | |
663 | FLAGS = \\(\\) | |
30ec677d | 664 | IV = 0 # $] < 5.009 |
bfe27a58 | 665 | NV = 0 # $] < 5.009 |
251a4af1 DM |
666 | (?: PV = 0 |
667 | )? COMP_STASH = 0x0 | |
bfe27a58 NC |
668 | START = $ADDR ===> \\d+ |
669 | ROOT = $ADDR | |
670 | XSUB = 0x0 # $] < 5.009 | |
671 | XSUBANY = 0 # $] < 5.009 | |
672 | GVGV::GV = $ADDR\\t"main" :: "PIE" | |
673 | FILE = ".*\\b(?i:peek\\.t)" | |
c12100a4 DM |
674 | (?: DEPTH = 0 |
675 | MUTEXP = $ADDR | |
bfe27a58 NC |
676 | OWNER = $ADDR |
677 | )? FLAGS = 0x0 | |
678 | OUTSIDE_SEQ = \\d+ | |
679 | LINES = 0 | |
680 | PADLIST = $ADDR | |
681 | PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) | |
682 | OUTSIDE = $ADDR \\(MAIN\\)'); | |
d7d51f4b | 683 | |
b7b1e41b | 684 | do_test('blessing to a class with embedded NUL characters', |
d7d51f4b YO |
685 | (bless {}, "\0::foo::\n::baz::\t::\0"), |
686 | 'SV = $RV\\($ADDR\\) at $ADDR | |
687 | REFCNT = 1 | |
688 | FLAGS = \\(ROK\\) | |
689 | RV = $ADDR | |
690 | SV = PVHV\\($ADDR\\) at $ADDR | |
691 | REFCNT = 1 | |
692 | FLAGS = \\(OBJECT,SHAREKEYS\\) | |
693 | IV = 0 # $] < 5.009 | |
694 | NV = 0 # $] < 5.009 | |
695 | STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0" | |
696 | ARRAY = $ADDR | |
697 | KEYS = 0 | |
698 | FILL = 0 | |
699 | MAX = 7 | |
700 | RITER = -1 | |
701 | EITER = 0x0', '', | |
702 | $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag' | |
703 | : "Something causes the HV's array to become allocated"); | |
704 | ||
bed53064 NC |
705 | do_test('ENAME on a stash', |
706 | \%RWOM::, | |
707 | 'SV = $RV\\($ADDR\\) at $ADDR | |
708 | REFCNT = 1 | |
709 | FLAGS = \\(ROK\\) | |
710 | RV = $ADDR | |
711 | SV = PVHV\\($ADDR\\) at $ADDR | |
712 | REFCNT = 2 | |
713 | FLAGS = \\(OOK,SHAREKEYS\\) | |
714 | IV = 1 # $] < 5.009 | |
715 | NV = $FLOAT # $] < 5.009 | |
716 | ARRAY = $ADDR | |
717 | KEYS = 0 | |
718 | FILL = 0 | |
719 | MAX = 7 | |
720 | RITER = -1 | |
721 | EITER = 0x0 | |
722 | NAME = "RWOM" | |
723 | ENAME = "RWOM" # $] > 5.012 | |
724 | '); | |
725 | ||
726 | *KLANK:: = \%RWOM::; | |
727 | ||
728 | do_test('ENAMEs on a stash', | |
729 | \%RWOM::, | |
730 | 'SV = $RV\\($ADDR\\) at $ADDR | |
731 | REFCNT = 1 | |
732 | FLAGS = \\(ROK\\) | |
733 | RV = $ADDR | |
734 | SV = PVHV\\($ADDR\\) at $ADDR | |
735 | REFCNT = 3 | |
736 | FLAGS = \\(OOK,SHAREKEYS\\) | |
737 | IV = 1 # $] < 5.009 | |
738 | NV = $FLOAT # $] < 5.009 | |
739 | ARRAY = $ADDR | |
740 | KEYS = 0 | |
741 | FILL = 0 | |
742 | MAX = 7 | |
743 | RITER = -1 | |
744 | EITER = 0x0 | |
745 | NAME = "RWOM" | |
746 | NAMECOUNT = 2 # $] > 5.012 | |
747 | ENAME = "RWOM", "KLANK" # $] > 5.012 | |
748 | '); | |
749 | ||
750 | undef %RWOM::; | |
751 | ||
752 | do_test('ENAMEs on a stash with no NAME', | |
753 | \%RWOM::, | |
754 | 'SV = $RV\\($ADDR\\) at $ADDR | |
755 | REFCNT = 1 | |
756 | FLAGS = \\(ROK\\) | |
757 | RV = $ADDR | |
758 | SV = PVHV\\($ADDR\\) at $ADDR | |
759 | REFCNT = 3 | |
760 | FLAGS = \\(OOK,SHAREKEYS\\) | |
761 | IV = 1 # $] < 5.009 | |
762 | NV = $FLOAT # $] < 5.009 | |
763 | ARRAY = $ADDR | |
764 | KEYS = 0 | |
765 | FILL = 0 | |
766 | MAX = 7 | |
767 | RITER = -1 | |
768 | EITER = 0x0 | |
769 | NAMECOUNT = -3 # $] > 5.012 | |
770 | ENAME = "RWOM", "KLANK" # $] > 5.012 | |
771 | '); | |
772 | ||
06a5cade | 773 | done_testing(); |