1#!./perl -T
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require Config; import Config;
7    if ($Config{'extensions'} !~ /\bPeek\b/) {
8        print "1..0 # Skip: Devel::Peek was not built\n";
9        exit 0;
10    }
11}
12
13use Devel::Peek;
14
15print "1..22\n";
16
17our $DEBUG = 0;
18open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
19
20sub do_test {
21    my $pattern = pop;
22    if (open(OUT,">peek$$")) {
23	open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
24	Dump($_[1]);
25	open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
26	close(OUT);
27	if (open(IN, "peek$$")) {
28	    local $/;
29	    $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
30	    $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
31	    # handle DEBUG_LEAKING_SCALARS prefix
32	    $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
33	    print $pattern, "\n" if $DEBUG;
34	    my $dump = <IN>;
35	    print $dump, "\n"    if $DEBUG;
36	    print "got:\n[\n$dump\n]\nexpected:\n[\n$pattern\n]\nnot "
37		unless $dump =~ /\A$pattern\Z/ms;
38	    print "ok $_[0]\n";
39	    close(IN);
40            return $1;
41	} else {
42	    die "$0: failed to open peek$$: !\n";
43	}
44    } else {
45	die "$0: failed to create peek$$: $!\n";
46    }
47}
48
49our   $a;
50our   $b;
51my    $c;
52local $d = 0;
53
54do_test( 1,
55	$a = "foo",
56'SV = PV\\($ADDR\\) at $ADDR
57  REFCNT = 1
58  FLAGS = \\(POK,pPOK\\)
59  PV = $ADDR "foo"\\\0
60  CUR = 3
61  LEN = \\d+'
62       );
63
64do_test( 2,
65        "bar",
66'SV = PV\\($ADDR\\) at $ADDR
67  REFCNT = 1
68  FLAGS = \\(.*POK,READONLY,pPOK\\)
69  PV = $ADDR "bar"\\\0
70  CUR = 3
71  LEN = \\d+');
72
73do_test( 3,
74        $b = 123,
75'SV = IV\\($ADDR\\) at $ADDR
76  REFCNT = 1
77  FLAGS = \\(IOK,pIOK\\)
78  IV = 123');
79
80do_test( 4,
81        456,
82'SV = IV\\($ADDR\\) at $ADDR
83  REFCNT = 1
84  FLAGS = \\(.*IOK,READONLY,pIOK\\)
85  IV = 456');
86
87do_test( 5,
88        $c = 456,
89'SV = IV\\($ADDR\\) at $ADDR
90  REFCNT = 1
91  FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\)
92  IV = 456');
93
94# If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
95# where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
96# maths is done in floating point always, and this scalar will be an NV.
97# ([NI]) captures the type, referred to by \1 in this regexp and $type for
98# building subsequent regexps.
99my $type = do_test( 6,
100        $c + $d,
101'SV = ([NI])V\\($ADDR\\) at $ADDR
102  REFCNT = 1
103  FLAGS = \\(PADTMP,\1OK,p\1OK\\)
104  \1V = 456');
105
106($d = "789") += 0.1;
107
108do_test( 7,
109       $d,
110'SV = PVNV\\($ADDR\\) at $ADDR
111  REFCNT = 1
112  FLAGS = \\(NOK,pNOK\\)
113  IV = 0
114  NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
115  PV = $ADDR "789"\\\0
116  CUR = 3
117  LEN = \\d+');
118
119do_test( 8,
120        0xabcd,
121'SV = IV\\($ADDR\\) at $ADDR
122  REFCNT = 1
123  FLAGS = \\(.*IOK,READONLY,pIOK\\)
124  IV = 43981');
125
126do_test( 9,
127        undef,
128'SV = NULL\\(0x0\\) at $ADDR
129  REFCNT = 1
130  FLAGS = \\(\\)');
131
132do_test(10,
133        \$a,
134'SV = RV\\($ADDR\\) at $ADDR
135  REFCNT = 1
136  FLAGS = \\(ROK\\)
137  RV = $ADDR
138  SV = PV\\($ADDR\\) at $ADDR
139    REFCNT = 2
140    FLAGS = \\(POK,pPOK\\)
141    PV = $ADDR "foo"\\\0
142    CUR = 3
143    LEN = \\d+');
144
145my $c_pattern;
146if ($type eq 'N') {
147  $c_pattern = '
148    SV = PVNV\\($ADDR\\) at $ADDR
149      REFCNT = 1
150      FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
151      IV = 456
152      NV = 456
153      PV = 0';
154} else {
155  $c_pattern = '
156    SV = IV\\($ADDR\\) at $ADDR
157      REFCNT = 1
158      FLAGS = \\(IOK,pIOK\\)
159      IV = 456';
160}
161do_test(11,
162       [$b,$c],
163'SV = RV\\($ADDR\\) at $ADDR
164  REFCNT = 1
165  FLAGS = \\(ROK\\)
166  RV = $ADDR
167  SV = PVAV\\($ADDR\\) at $ADDR
168    REFCNT = 2
169    FLAGS = \\(\\)
170    IV = 0
171    NV = 0
172    ARRAY = $ADDR
173    FILL = 1
174    MAX = 1
175    ARYLEN = 0x0
176    FLAGS = \\(REAL\\)
177    Elt No. 0
178    SV = IV\\($ADDR\\) at $ADDR
179      REFCNT = 1
180      FLAGS = \\(IOK,pIOK\\)
181      IV = 123
182    Elt No. 1' . $c_pattern);
183
184do_test(12,
185       {$b=>$c},
186'SV = RV\\($ADDR\\) at $ADDR
187  REFCNT = 1
188  FLAGS = \\(ROK\\)
189  RV = $ADDR
190  SV = PVHV\\($ADDR\\) at $ADDR
191    REFCNT = 2
192    FLAGS = \\(SHAREKEYS\\)
193    IV = 1
194    NV = $FLOAT
195    ARRAY = $ADDR  \\(0:7, 1:1\\)
196    hash quality = 100.0%
197    KEYS = 1
198    FILL = 1
199    MAX = 7
200    RITER = -1
201    EITER = 0x0
202    Elt "123" HASH = $ADDR' . $c_pattern);
203
204do_test(13,
205        sub(){@_},
206'SV = RV\\($ADDR\\) at $ADDR
207  REFCNT = 1
208  FLAGS = \\(ROK\\)
209  RV = $ADDR
210  SV = PVCV\\($ADDR\\) at $ADDR
211    REFCNT = 2
212    FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
213    IV = 0
214    NV = 0
215    PROTOTYPE = ""
216    COMP_STASH = $ADDR\\t"main"
217    START = $ADDR ===> \\d+
218    ROOT = $ADDR
219    XSUB = 0x0
220    XSUBANY = 0
221    GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
222    FILE = ".*\\b(?i:peek\\.t)"
223    DEPTH = 0
224(?:    MUTEXP = $ADDR
225    OWNER = $ADDR
226)?    FLAGS = 0x404
227    OUTSIDE_SEQ = \\d+
228    PADLIST = $ADDR
229    PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
230    OUTSIDE = $ADDR \\(MAIN\\)');
231
232do_test(14,
233        \&do_test,
234'SV = RV\\($ADDR\\) at $ADDR
235  REFCNT = 1
236  FLAGS = \\(ROK\\)
237  RV = $ADDR
238  SV = PVCV\\($ADDR\\) at $ADDR
239    REFCNT = (3|4)
240    FLAGS = \\(\\)
241    IV = 0
242    NV = 0
243    COMP_STASH = $ADDR\\t"main"
244    START = $ADDR ===> \\d+
245    ROOT = $ADDR
246    XSUB = 0x0
247    XSUBANY = 0
248    GVGV::GV = $ADDR\\t"main" :: "do_test"
249    FILE = ".*\\b(?i:peek\\.t)"
250    DEPTH = 1
251(?:    MUTEXP = $ADDR
252    OWNER = $ADDR
253)?    FLAGS = 0x0
254    OUTSIDE_SEQ = \\d+
255    PADLIST = $ADDR
256    PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
257       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
258      \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"
259      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
260    OUTSIDE = $ADDR \\(MAIN\\)');
261
262do_test(15,
263        qr(tic),
264'SV = RV\\($ADDR\\) at $ADDR
265  REFCNT = 1
266  FLAGS = \\(ROK\\)
267  RV = $ADDR
268  SV = PVMG\\($ADDR\\) at $ADDR
269    REFCNT = 1
270    FLAGS = \\(OBJECT,SMG\\)
271    IV = 0
272    NV = 0
273    PV = 0
274    MAGIC = $ADDR
275      MG_VIRTUAL = $ADDR
276      MG_TYPE = PERL_MAGIC_qr\(r\)
277      MG_OBJ = $ADDR
278    STASH = $ADDR\\t"Regexp"');
279
280do_test(16,
281        (bless {}, "Tac"),
282'SV = RV\\($ADDR\\) at $ADDR
283  REFCNT = 1
284  FLAGS = \\(ROK\\)
285  RV = $ADDR
286  SV = PVHV\\($ADDR\\) at $ADDR
287    REFCNT = 2
288    FLAGS = \\(OBJECT,SHAREKEYS\\)
289    IV = 0
290    NV = 0
291    STASH = $ADDR\\t"Tac"
292    ARRAY = 0x0
293    KEYS = 0
294    FILL = 0
295    MAX = 7
296    RITER = -1
297    EITER = 0x0');
298
299do_test(17,
300	*a,
301'SV = PVGV\\($ADDR\\) at $ADDR
302  REFCNT = 5
303  FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
304  IV = 0
305  NV = 0
306  MAGIC = $ADDR
307    MG_VIRTUAL = &PL_vtbl_glob
308    MG_TYPE = PERL_MAGIC_glob\(\*\)
309    MG_OBJ = $ADDR
310  NAME = "a"
311  NAMELEN = 1
312  GvSTASH = $ADDR\\t"main"
313  GP = $ADDR
314    SV = $ADDR
315    REFCNT = 1
316    IO = 0x0
317    FORM = 0x0
318    AV = 0x0
319    HV = 0x0
320    CV = 0x0
321    CVGEN = 0x0
322    GPFLAGS = 0x0
323    LINE = \\d+
324    FILE = ".*\\b(?i:peek\\.t)"
325    FLAGS = $ADDR
326    EGV = $ADDR\\t"a"');
327
328if (ord('A') == 193) {
329do_test(18,
330	chr(256).chr(0).chr(512),
331'SV = PV\\($ADDR\\) at $ADDR
332  REFCNT = 1
333  FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\)
334  PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
335  CUR = 5
336  LEN = \\d+');
337} else {
338do_test(18,
339	chr(256).chr(0).chr(512),
340'SV = PV\\($ADDR\\) at $ADDR
341  REFCNT = 1
342  FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\)
343  PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
344  CUR = 5
345  LEN = \\d+');
346}
347
348if (ord('A') == 193) {
349do_test(19,
350	{chr(256)=>chr(512)},
351'SV = RV\\($ADDR\\) at $ADDR
352  REFCNT = 1
353  FLAGS = \\(ROK\\)
354  RV = $ADDR
355  SV = PVHV\\($ADDR\\) at $ADDR
356    REFCNT = 2
357    FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
358    UV = 1
359    NV = $FLOAT
360    ARRAY = $ADDR  \\(0:7, 1:1\\)
361    hash quality = 100.0%
362    KEYS = 1
363    FILL = 1
364    MAX = 7
365    RITER = -1
366    EITER = $ADDR
367    Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
368    SV = PV\\($ADDR\\) at $ADDR
369      REFCNT = 1
370      FLAGS = \\(POK,pPOK,UTF8\\)
371      PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
372      CUR = 2
373      LEN = \\d+');
374} else {
375do_test(19,
376	{chr(256)=>chr(512)},
377'SV = RV\\($ADDR\\) at $ADDR
378  REFCNT = 1
379  FLAGS = \\(ROK\\)
380  RV = $ADDR
381  SV = PVHV\\($ADDR\\) at $ADDR
382    REFCNT = 2
383    FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
384    UV = 1
385    NV = 0
386    ARRAY = $ADDR  \\(0:7, 1:1\\)
387    hash quality = 100.0%
388    KEYS = 1
389    FILL = 1
390    MAX = 7
391    RITER = -1
392    EITER = $ADDR
393    Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
394    SV = PV\\($ADDR\\) at $ADDR
395      REFCNT = 1
396      FLAGS = \\(POK,pPOK,UTF8\\)
397      PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
398      CUR = 2
399      LEN = \\d+');
400}
401
402my $x="";
403$x=~/.??/g;
404do_test(20,
405        $x,
406'SV = PVMG\\($ADDR\\) at $ADDR
407  REFCNT = 1
408  FLAGS = \\(PADBUSY,PADMY,SMG,POK,pPOK\\)
409  IV = 0
410  NV = 0
411  PV = $ADDR ""\\\0
412  CUR = 0
413  LEN = \d+
414  MAGIC = $ADDR
415    MG_VIRTUAL = &PL_vtbl_mglob
416    MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
417    MG_FLAGS = 0x01
418      MINMATCH');
419
420#
421# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
422# environment variables may be invisibly case-forced, hence the (?i:PATH)
423# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
424# VMS is setting FAKE and READONLY flags.  What VMS uses for storing
425# ENV hashes is also not always null terminated.
426#
427do_test(21,
428        $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
429'SV = PVMG\\($ADDR\\) at $ADDR
430  REFCNT = 1
431  FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
432  IV = 0
433  NV = 0
434  PV = $ADDR "0"\\\0
435  CUR = 1
436  LEN = \d+
437  MAGIC = $ADDR
438    MG_VIRTUAL = &PL_vtbl_envelem
439    MG_TYPE = PERL_MAGIC_envelem\\(e\\)
440(?:    MG_FLAGS = 0x01
441      TAINTEDDIR
442)?    MG_LEN = -?\d+
443    MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
444    SV = PV(?:IV)?\\($ADDR\\) at $ADDR
445      REFCNT = \d+
446      FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
447(?:      IV = 0
448)?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
449      CUR = \d+
450      LEN = \d+)
451  MAGIC = $ADDR
452    MG_VIRTUAL = &PL_vtbl_taint
453    MG_TYPE = PERL_MAGIC_taint\\(t\\)');
454
455END {
456  1 while unlink("peek$$");
457}
458
459# blessed refs
460do_test(22,
461	bless(\\undef, 'Foobar'),
462'SV = RV\\($ADDR\\) at $ADDR
463  REFCNT = 1
464  FLAGS = \\(ROK\\)
465  RV = $ADDR
466  SV = PVMG\\($ADDR\\) at $ADDR
467    REFCNT = 2
468    FLAGS = \\(OBJECT,ROK\\)
469    IV = -?\d+
470    NV = $FLOAT
471    RV = $ADDR
472    SV = NULL\\(0x0\\) at $ADDR
473      REFCNT = \d+
474      FLAGS = \\(READONLY\\)
475    PV = $ADDR ""
476    CUR = 0
477    LEN = 0
478    STASH = $ADDR\s+"Foobar"');
479