Make Data::Dumper handle blessed regexes properly, bump version as well. This may...
[perl.git] / ext / Data / Dumper / Dumper.pm
1 #
2 # Data/Dumper.pm
3 #
4 # convert perl data structures into perl syntax suitable for both printing
5 # and eval
6 #
7 # Documentation at the __END__
8 #
9
10 package Data::Dumper;
11
12 $VERSION = '2.121_15';
13
14 #$| = 1;
15
16 use 5.006_001;
17 require Exporter;
18 require overload;
19
20 use Carp;
21
22 BEGIN {
23     @ISA = qw(Exporter);
24     @EXPORT = qw(Dumper);
25     @EXPORT_OK = qw(DumperX);
26
27     # if run under miniperl, or otherwise lacking dynamic loading,
28     # XSLoader should be attempted to load, or the pure perl flag
29     # toggled on load failure.
30     eval {
31         require XSLoader;
32     };
33     $Useperl = 1 if $@;
34 }
35
36 XSLoader::load( 'Data::Dumper' ) unless $Useperl;
37
38 # module vars and their defaults
39 $Indent     = 2         unless defined $Indent;
40 $Purity     = 0         unless defined $Purity;
41 $Pad        = ""        unless defined $Pad;
42 $Varname    = "VAR"     unless defined $Varname;
43 $Useqq      = 0         unless defined $Useqq;
44 $Terse      = 0         unless defined $Terse;
45 $Freezer    = ""        unless defined $Freezer;
46 $Toaster    = ""        unless defined $Toaster;
47 $Deepcopy   = 0         unless defined $Deepcopy;
48 $Quotekeys  = 1         unless defined $Quotekeys;
49 $Bless      = "bless"   unless defined $Bless;
50 #$Expdepth   = 0         unless defined $Expdepth;
51 $Maxdepth   = 0         unless defined $Maxdepth;
52 $Pair       = ' => '    unless defined $Pair;
53 $Useperl    = 0         unless defined $Useperl;
54 $Sortkeys   = 0         unless defined $Sortkeys;
55 $Deparse    = 0         unless defined $Deparse;
56
57 #
58 # expects an arrayref of values to be dumped.
59 # can optionally pass an arrayref of names for the values.
60 # names must have leading $ sign stripped. begin the name with *
61 # to cause output of arrays and hashes rather than refs.
62 #
63 sub new {
64   my($c, $v, $n) = @_;
65
66   croak "Usage:  PACKAGE->new(ARRAYREF, [ARRAYREF])" 
67     unless (defined($v) && (ref($v) eq 'ARRAY'));
68   $n = [] unless (defined($n) && (ref($n) eq 'ARRAY'));
69
70   my($s) = { 
71              level      => 0,           # current recursive depth
72              indent     => $Indent,     # various styles of indenting
73              pad        => $Pad,        # all lines prefixed by this string
74              xpad       => "",          # padding-per-level
75              apad       => "",          # added padding for hash keys n such
76              sep        => "",          # list separator
77              pair       => $Pair,       # hash key/value separator: defaults to ' => '
78              seen       => {},          # local (nested) refs (id => [name, val])
79              todump     => $v,          # values to dump []
80              names      => $n,          # optional names for values []
81              varname    => $Varname,    # prefix to use for tagging nameless ones
82              purity     => $Purity,     # degree to which output is evalable
83              useqq      => $Useqq,      # use "" for strings (backslashitis ensues)
84              terse      => $Terse,      # avoid name output (where feasible)
85              freezer    => $Freezer,    # name of Freezer method for objects
86              toaster    => $Toaster,    # name of method to revive objects
87              deepcopy   => $Deepcopy,   # dont cross-ref, except to stop recursion
88              quotekeys  => $Quotekeys,  # quote hash keys
89              'bless'    => $Bless,      # keyword to use for "bless"
90 #            expdepth   => $Expdepth,   # cutoff depth for explicit dumping
91              maxdepth   => $Maxdepth,   # depth beyond which we give up
92              useperl    => $Useperl,    # use the pure Perl implementation
93              sortkeys   => $Sortkeys,   # flag or filter for sorting hash keys
94              deparse    => $Deparse,    # use B::Deparse for coderefs
95            };
96
97   if ($Indent > 0) {
98     $s->{xpad} = "  ";
99     $s->{sep} = "\n";
100   }
101   return bless($s, $c);
102 }
103
104 if ($] >= 5.006) {
105   # Packed numeric addresses take less memory. Plus pack is faster than sprintf
106   *init_refaddr_format = sub {};
107
108   *format_refaddr  = sub {
109     require Scalar::Util;
110     pack "J", Scalar::Util::refaddr(shift);
111   };
112 } else {
113   *init_refaddr_format = sub {
114     require Config;
115     my $f = $Config::Config{uvxformat};
116     $f =~ tr/"//d;
117     our $refaddr_format = "0x%" . $f;
118   };
119
120   *format_refaddr = sub {
121     require Scalar::Util;
122     sprintf our $refaddr_format, Scalar::Util::refaddr(shift);
123   }
124 }
125
126 #
127 # add-to or query the table of already seen references
128 #
129 sub Seen {
130   my($s, $g) = @_;
131   if (defined($g) && (ref($g) eq 'HASH'))  {
132     init_refaddr_format();
133     my($k, $v, $id);
134     while (($k, $v) = each %$g) {
135       if (defined $v and ref $v) {
136         $id = format_refaddr($v);
137         if ($k =~ /^[*](.*)$/) {
138           $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
139                (ref $v eq 'HASH')  ? ( "\\\%" . $1 ) :
140                (ref $v eq 'CODE')  ? ( "\\\&" . $1 ) :
141                                      (   "\$" . $1 ) ;
142         }
143         elsif ($k !~ /^\$/) {
144           $k = "\$" . $k;
145         }
146         $s->{seen}{$id} = [$k, $v];
147       }
148       else {
149         carp "Only refs supported, ignoring non-ref item \$$k";
150       }
151     }
152     return $s;
153   }
154   else {
155     return map { @$_ } values %{$s->{seen}};
156   }
157 }
158
159 #
160 # set or query the values to be dumped
161 #
162 sub Values {
163   my($s, $v) = @_;
164   if (defined($v) && (ref($v) eq 'ARRAY'))  {
165     $s->{todump} = [@$v];        # make a copy
166     return $s;
167   }
168   else {
169     return @{$s->{todump}};
170   }
171 }
172
173 #
174 # set or query the names of the values to be dumped
175 #
176 sub Names {
177   my($s, $n) = @_;
178   if (defined($n) && (ref($n) eq 'ARRAY'))  {
179     $s->{names} = [@$n];         # make a copy
180     return $s;
181   }
182   else {
183     return @{$s->{names}};
184   }
185 }
186
187 sub DESTROY {}
188
189 sub Dump {
190     return &Dumpxs
191         unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
192                $Data::Dumper::Useqq   || (ref($_[0]) && $_[0]->{useqq}) ||
193                $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
194     return &Dumpperl;
195 }
196
197 #
198 # dump the refs in the current dumper object.
199 # expects same args as new() if called via package name.
200 #
201 sub Dumpperl {
202   my($s) = shift;
203   my(@out, $val, $name);
204   my($i) = 0;
205   local(@post);
206   init_refaddr_format();
207
208   $s = $s->new(@_) unless ref $s;
209
210   for $val (@{$s->{todump}}) {
211     my $out = "";
212     @post = ();
213     $name = $s->{names}[$i++];
214     if (defined $name) {
215       if ($name =~ /^[*](.*)$/) {
216         if (defined $val) {
217           $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
218                   (ref $val eq 'HASH')  ? ( "\%" . $1 ) :
219                   (ref $val eq 'CODE')  ? ( "\*" . $1 ) :
220                                           ( "\$" . $1 ) ;
221         }
222         else {
223           $name = "\$" . $1;
224         }
225       }
226       elsif ($name !~ /^\$/) {
227         $name = "\$" . $name;
228       }
229     }
230     else {
231       $name = "\$" . $s->{varname} . $i;
232     }
233
234     # Ensure hash iterator is reset
235     if (ref($val) eq 'HASH') {
236         keys(%$val);
237     }
238
239     my $valstr;
240     {
241       local($s->{apad}) = $s->{apad};
242       $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
243       $valstr = $s->_dump($val, $name);
244     }
245
246     $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
247     $out .= $s->{pad} . $valstr . $s->{sep};
248     $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) 
249       . ';' . $s->{sep} if @post;
250
251     push @out, $out;
252   }
253   return wantarray ? @out : join('', @out);
254 }
255
256 # wrap string in single quotes (escaping if needed)
257 sub _quote {
258     my $val = shift;
259     $val =~ s/([\\\'])/\\$1/g;
260     return  "'" . $val .  "'";
261 }
262
263 #
264 # twist, toil and turn;
265 # and recurse, of course.
266 # sometimes sordidly;
267 # and curse if no recourse.
268 #
269 sub _dump {
270   my($s, $val, $name) = @_;
271   my($sname);
272   my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
273
274   $type = ref $val;
275   $out = "";
276
277   if ($type) {
278
279     # Call the freezer method if it's specified and the object has the
280     # method.  Trap errors and warn() instead of die()ing, like the XS
281     # implementation.
282     my $freezer = $s->{freezer};
283     if ($freezer and UNIVERSAL::can($val, $freezer)) {
284       eval { $val->$freezer() };
285       warn "WARNING(Freezer method call failed): $@" if $@;
286     }
287
288     require Scalar::Util;
289     $realpack = Scalar::Util::blessed($val);
290     $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val;
291     $id = format_refaddr($val);
292
293     # if it has a name, we need to either look it up, or keep a tab
294     # on it so we know when we hit it later
295     if (defined($name) and length($name)) {
296       # keep a tab on it so that we dont fall into recursive pit
297       if (exists $s->{seen}{$id}) {
298 #       if ($s->{expdepth} < $s->{level}) {
299           if ($s->{purity} and $s->{level} > 0) {
300             $out = ($realtype eq 'HASH')  ? '{}' :
301               ($realtype eq 'ARRAY') ? '[]' :
302                 'do{my $o}' ;
303             push @post, $name . " = " . $s->{seen}{$id}[0];
304           }
305           else {
306             $out = $s->{seen}{$id}[0];
307             if ($name =~ /^([\@\%])/) {
308               my $start = $1;
309               if ($out =~ /^\\$start/) {
310                 $out = substr($out, 1);
311               }
312               else {
313                 $out = $start . '{' . $out . '}';
314               }
315             }
316           }
317           return $out;
318 #        }
319       }
320       else {
321         # store our name
322         $s->{seen}{$id} = [ (($name =~ /^[@%]/)     ? ('\\' . $name ) :
323                              ($realtype eq 'CODE' and
324                               $name =~ /^[*](.*)$/) ? ('\\&' . $1 )   :
325                              $name          ),
326                             $val ];
327       }
328     }
329     my $no_bless = 0; 
330     my $is_regex = 0;
331     if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) {
332         $is_regex = 1;
333         $no_bless = $realpack eq 'Regexp';
334     }
335
336     # If purity is not set and maxdepth is set, then check depth: 
337     # if we have reached maximum depth, return the string
338     # representation of the thing we are currently examining
339     # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). 
340     if (!$s->{purity}
341         and $s->{maxdepth} > 0
342         and $s->{level} >= $s->{maxdepth})
343     {
344       return qq['$val'];
345     }
346
347     # we have a blessed ref
348     if ($realpack and !$no_bless) {
349       $out = $s->{'bless'} . '( ';
350       $blesspad = $s->{apad};
351       $s->{apad} .= '       ' if ($s->{indent} >= 2);
352     }
353
354     $s->{level}++;
355     $ipad = $s->{xpad} x $s->{level};
356
357     if ($is_regex) {
358         my $pat;
359         # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in 
360         # universal.c, and even worse we cant just require that re to be loaded
361         # we *have* to use() it. 
362         # We should probably move it to universal.c for 5.10.1 and fix this.
363         # Currently we only use re::regexp_pattern when the re is blessed into another
364         # package. This has the disadvantage of meaning that a DD dump won't round trip
365         # as the pattern will be repeatedly wrapped with the same modifiers.
366         # This is an aesthetic issue so we will leave it for now, but we could use
367         # regexp_pattern() in list context to get the modifiers separately.
368         # But since this means loading the full debugging engine in process we wont
369         # bother unless its necessary for accuracy.
370         if ($realpack ne 'Regexp' and $] > 5.009005) {
371             defined *re::regexp_pattern{CODE} 
372                 or do { eval 'use re (regexp_pattern); 1' or die $@ };
373             $pat = re::regexp_pattern($val);
374         } else {
375             $pat = "$val";
376         }
377         $pat =~ s,/,\\/,g;
378         $out .= "qr/$pat/";
379     }
380     elsif ($realtype eq 'SCALAR' || $realtype eq 'REF') {
381       if ($realpack) {
382         $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
383       }
384       else {
385         $out .= '\\' . $s->_dump($$val, "\${$name}");
386       }
387     }
388     elsif ($realtype eq 'GLOB') {
389         $out .= '\\' . $s->_dump($$val, "*{$name}");
390     }
391     elsif ($realtype eq 'ARRAY') {
392       my($v, $pad, $mname);
393       my($i) = 0;
394       $out .= ($name =~ /^\@/) ? '(' : '[';
395       $pad = $s->{sep} . $s->{pad} . $s->{apad};
396       ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : 
397         # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
398         ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
399           ($mname = $name . '->');
400       $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
401       for $v (@$val) {
402         $sname = $mname . '[' . $i . ']';
403         $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
404         $out .= $pad . $ipad . $s->_dump($v, $sname);
405         $out .= "," if $i++ < $#$val;
406       }
407       $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
408       $out .= ($name =~ /^\@/) ? ')' : ']';
409     }
410     elsif ($realtype eq 'HASH') {
411       my($k, $v, $pad, $lpad, $mname, $pair);
412       $out .= ($name =~ /^\%/) ? '(' : '{';
413       $pad = $s->{sep} . $s->{pad} . $s->{apad};
414       $lpad = $s->{apad};
415       $pair = $s->{pair};
416       ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
417         # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
418         ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
419           ($mname = $name . '->');
420       $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
421       my ($sortkeys, $keys, $key) = ("$s->{sortkeys}");
422       if ($sortkeys) {
423         if (ref($s->{sortkeys}) eq 'CODE') {
424           $keys = $s->{sortkeys}($val);
425           unless (ref($keys) eq 'ARRAY') {
426             carp "Sortkeys subroutine did not return ARRAYREF";
427             $keys = [];
428           }
429         }
430         else {
431           $keys = [ sort keys %$val ];
432         }
433       }
434       while (($k, $v) = ! $sortkeys ? (each %$val) :
435              @$keys ? ($key = shift(@$keys), $val->{$key}) :
436              () ) 
437       {
438         my $nk = $s->_dump($k, "");
439         $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
440         $sname = $mname . '{' . $nk . '}';
441         $out .= $pad . $ipad . $nk . $pair;
442
443         # temporarily alter apad
444         $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
445         $out .= $s->_dump($val->{$k}, $sname) . ",";
446         $s->{apad} = $lpad if $s->{indent} >= 2;
447       }
448       if (substr($out, -1) eq ',') {
449         chop $out;
450         $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
451       }
452       $out .= ($name =~ /^\%/) ? ')' : '}';
453     }
454     elsif ($realtype eq 'CODE') {
455       if ($s->{deparse}) {
456         require B::Deparse;
457         my $sub =  'sub ' . (B::Deparse->new)->coderef2text($val);
458         $pad    =  $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
459         $sub    =~ s/\n/$pad/gse;
460         $out   .=  $sub;
461       } else {
462         $out .= 'sub { "DUMMY" }';
463         carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
464       }
465     }
466     else {
467       croak "Can\'t handle $realtype type.";
468     }
469     
470     if ($realpack and !$no_bless) { # we have a blessed ref
471       $out .= ', ' . _quote($realpack) . ' )';
472       $out .= '->' . $s->{toaster} . '()'  if $s->{toaster} ne '';
473       $s->{apad} = $blesspad;
474     }
475     $s->{level}--;
476
477   }
478   else {                                 # simple scalar
479
480     my $ref = \$_[1];
481     # first, catalog the scalar
482     if ($name ne '') {
483       $id = format_refaddr($ref);
484       if (exists $s->{seen}{$id}) {
485         if ($s->{seen}{$id}[2]) {
486           $out = $s->{seen}{$id}[0];
487           #warn "[<$out]\n";
488           return "\${$out}";
489         }
490       }
491       else {
492         #warn "[>\\$name]\n";
493         $s->{seen}{$id} = ["\\$name", $ref];
494       }
495     }
496     if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) {  # glob
497       my $name = substr($val, 1);
498       if ($name =~ /^[A-Za-z_][\w:]*$/) {
499         $name =~ s/^main::/::/;
500         $sname = $name;
501       }
502       else {
503         $sname = $s->_dump($name, "");
504         $sname = '{' . $sname . '}';
505       }
506       if ($s->{purity}) {
507         my $k;
508         local ($s->{level}) = 0;
509         for $k (qw(SCALAR ARRAY HASH)) {
510           my $gval = *$val{$k};
511           next unless defined $gval;
512           next if $k eq "SCALAR" && ! defined $$gval;  # always there
513
514           # _dump can push into @post, so we hold our place using $postlen
515           my $postlen = scalar @post;
516           $post[$postlen] = "\*$sname = ";
517           local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
518           $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
519         }
520       }
521       $out .= '*' . $sname;
522     }
523     elsif (!defined($val)) {
524       $out .= "undef";
525     }
526     elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number
527       $out .= $val;
528     }
529     else {                               # string
530       if ($s->{useqq} or $val =~ tr/\0-\377//c) {
531         # Fall back to qq if there's Unicode
532         $out .= qquote($val, $s->{useqq});
533       }
534       else {
535         $out .= _quote($val);
536       }
537     }
538   }
539   if ($id) {
540     # if we made it this far, $id was added to seen list at current
541     # level, so remove it to get deep copies
542     if ($s->{deepcopy}) {
543       delete($s->{seen}{$id});
544     }
545     elsif ($name) {
546       $s->{seen}{$id}[2] = 1;
547     }
548   }
549   return $out;
550 }
551   
552 #
553 # non-OO style of earlier version
554 #
555 sub Dumper {
556   return Data::Dumper->Dump([@_]);
557 }
558
559 # compat stub
560 sub DumperX {
561   return Data::Dumper->Dumpxs([@_], []);
562 }
563
564 sub Dumpf { return Data::Dumper->Dump(@_) }
565
566 sub Dumpp { print Data::Dumper->Dump(@_) }
567
568 #
569 # reset the "seen" cache 
570 #
571 sub Reset {
572   my($s) = shift;
573   $s->{seen} = {};
574   return $s;
575 }
576
577 sub Indent {
578   my($s, $v) = @_;
579   if (defined($v)) {
580     if ($v == 0) {
581       $s->{xpad} = "";
582       $s->{sep} = "";
583     }
584     else {
585       $s->{xpad} = "  ";
586       $s->{sep} = "\n";
587     }
588     $s->{indent} = $v;
589     return $s;
590   }
591   else {
592     return $s->{indent};
593   }
594 }
595
596 sub Pair {
597     my($s, $v) = @_;
598     defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair};
599 }
600
601 sub Pad {
602   my($s, $v) = @_;
603   defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
604 }
605
606 sub Varname {
607   my($s, $v) = @_;
608   defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
609 }
610
611 sub Purity {
612   my($s, $v) = @_;
613   defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
614 }
615
616 sub Useqq {
617   my($s, $v) = @_;
618   defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
619 }
620
621 sub Terse {
622   my($s, $v) = @_;
623   defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
624 }
625
626 sub Freezer {
627   my($s, $v) = @_;
628   defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
629 }
630
631 sub Toaster {
632   my($s, $v) = @_;
633   defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
634 }
635
636 sub Deepcopy {
637   my($s, $v) = @_;
638   defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
639 }
640
641 sub Quotekeys {
642   my($s, $v) = @_;
643   defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
644 }
645
646 sub Bless {
647   my($s, $v) = @_;
648   defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
649 }
650
651 sub Maxdepth {
652   my($s, $v) = @_;
653   defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
654 }
655
656 sub Useperl {
657   my($s, $v) = @_;
658   defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
659 }
660
661 sub Sortkeys {
662   my($s, $v) = @_;
663   defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
664 }
665
666 sub Deparse {
667   my($s, $v) = @_;
668   defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
669 }
670
671 # used by qquote below
672 my %esc = (  
673     "\a" => "\\a",
674     "\b" => "\\b",
675     "\t" => "\\t",
676     "\n" => "\\n",
677     "\f" => "\\f",
678     "\r" => "\\r",
679     "\e" => "\\e",
680 );
681
682 # put a string value in double quotes
683 sub qquote {
684   local($_) = shift;
685   s/([\\\"\@\$])/\\$1/g;
686   my $bytes; { use bytes; $bytes = length }
687   s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
688   return qq("$_") unless 
689     /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/;  # fast exit
690
691   my $high = shift || "";
692   s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
693
694   if (ord('^')==94)  { # ascii
695     # no need for 3 digits in escape for these
696     s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
697     s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
698     # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
699     if ($high eq "iso8859") {
700       s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
701     } elsif ($high eq "utf8") {
702 #     use utf8;
703 #     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
704     } elsif ($high eq "8bit") {
705         # leave it as it is
706     } else {
707       s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
708       s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
709     }
710   }
711   else { # ebcdic
712       s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
713        {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg;
714       s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])}
715        {'\\'.sprintf('%03o',ord($1))}eg;
716   }
717
718   return qq("$_");
719 }
720
721 # helper sub to sort hash keys in Perl < 5.8.0 where we don't have
722 # access to sortsv() from XS
723 sub _sortkeys { [ sort keys %{$_[0]} ] }
724
725 1;
726 __END__
727
728 =head1 NAME
729
730 Data::Dumper - stringified perl data structures, suitable for both printing and C<eval>
731
732 =head1 SYNOPSIS
733
734     use Data::Dumper;
735
736     # simple procedural interface
737     print Dumper($foo, $bar);
738
739     # extended usage with names
740     print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
741
742     # configuration variables
743     {
744       local $Data::Dumper::Purity = 1;
745       eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
746     }
747
748     # OO usage
749     $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]);
750        ...
751     print $d->Dump;
752        ...
753     $d->Purity(1)->Terse(1)->Deepcopy(1);
754     eval $d->Dump;
755
756
757 =head1 DESCRIPTION
758
759 Given a list of scalars or reference variables, writes out their contents in
760 perl syntax. The references can also be objects.  The contents of each
761 variable is output in a single Perl statement.  Handles self-referential
762 structures correctly.
763
764 The return value can be C<eval>ed to get back an identical copy of the
765 original reference structure.
766
767 Any references that are the same as one of those passed in will be named
768 C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references
769 to substructures within C<$VAR>I<n> will be appropriately labeled using arrow
770 notation.  You can specify names for individual values to be dumped if you
771 use the C<Dump()> method, or you can change the default C<$VAR> prefix to
772 something else.  See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse>
773 below.
774
775 The default output of self-referential structures can be C<eval>ed, but the
776 nested references to C<$VAR>I<n> will be undefined, since a recursive
777 structure cannot be constructed using one Perl statement.  You should set the
778 C<Purity> flag to 1 to get additional statements that will correctly fill in
779 these references.  Moreover, if C<eval>ed when strictures are in effect,
780 you need to ensure that any variables it accesses are previously declared.
781
782 In the extended usage form, the references to be dumped can be given
783 user-specified names.  If a name begins with a C<*>, the output will 
784 describe the dereferenced type of the supplied reference for hashes and
785 arrays, and coderefs.  Output of names will be avoided where possible if
786 the C<Terse> flag is set.
787
788 In many cases, methods that are used to set the internal state of the
789 object will return the object itself, so method calls can be conveniently
790 chained together.
791
792 Several styles of output are possible, all controlled by setting
793 the C<Indent> flag.  See L<Configuration Variables or Methods> below 
794 for details.
795
796
797 =head2 Methods
798
799 =over 4
800
801 =item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>)
802
803 Returns a newly created C<Data::Dumper> object.  The first argument is an
804 anonymous array of values to be dumped.  The optional second argument is an
805 anonymous array of names for the values.  The names need not have a leading
806 C<$> sign, and must be comprised of alphanumeric characters.  You can begin
807 a name with a C<*> to specify that the dereferenced type must be dumped
808 instead of the reference itself, for ARRAY and HASH references.
809
810 The prefix specified by C<$Data::Dumper::Varname> will be used with a
811 numeric suffix if the name for a value is undefined.
812
813 Data::Dumper will catalog all references encountered while dumping the
814 values. Cross-references (in the form of names of substructures in perl
815 syntax) will be inserted at all possible points, preserving any structural
816 interdependencies in the original set of values.  Structure traversal is
817 depth-first,  and proceeds in order from the first supplied value to
818 the last.
819
820 =item I<$OBJ>->Dump  I<or>  I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>)
821
822 Returns the stringified form of the values stored in the object (preserving
823 the order in which they were supplied to C<new>), subject to the
824 configuration options below.  In a list context, it returns a list
825 of strings corresponding to the supplied values.
826
827 The second form, for convenience, simply calls the C<new> method on its
828 arguments before dumping the object immediately.
829
830 =item I<$OBJ>->Seen(I<[HASHREF]>)
831
832 Queries or adds to the internal table of already encountered references.
833 You must use C<Reset> to explicitly clear the table if needed.  Such
834 references are not dumped; instead, their names are inserted wherever they
835 are encountered subsequently.  This is useful especially for properly
836 dumping subroutine references.
837
838 Expects an anonymous hash of name => value pairs.  Same rules apply for names
839 as in C<new>.  If no argument is supplied, will return the "seen" list of
840 name => value pairs, in a list context.  Otherwise, returns the object
841 itself.
842
843 =item I<$OBJ>->Values(I<[ARRAYREF]>)
844
845 Queries or replaces the internal array of values that will be dumped.
846 When called without arguments, returns the values.  Otherwise, returns the
847 object itself.
848
849 =item I<$OBJ>->Names(I<[ARRAYREF]>)
850
851 Queries or replaces the internal array of user supplied names for the values
852 that will be dumped.  When called without arguments, returns the names.
853 Otherwise, returns the object itself.
854
855 =item I<$OBJ>->Reset
856
857 Clears the internal table of "seen" references and returns the object
858 itself.
859
860 =back
861
862 =head2 Functions
863
864 =over 4
865
866 =item Dumper(I<LIST>)
867
868 Returns the stringified form of the values in the list, subject to the
869 configuration options below.  The values will be named C<$VAR>I<n> in the
870 output, where I<n> is a numeric suffix.  Will return a list of strings
871 in a list context.
872
873 =back
874
875 =head2 Configuration Variables or Methods
876
877 Several configuration variables can be used to control the kind of output
878 generated when using the procedural interface.  These variables are usually
879 C<local>ized in a block so that other parts of the code are not affected by
880 the change.  
881
882 These variables determine the default state of the object created by calling
883 the C<new> method, but cannot be used to alter the state of the object
884 thereafter.  The equivalent method names should be used instead to query
885 or set the internal state of the object.
886
887 The method forms return the object itself when called with arguments,
888 so that they can be chained together nicely.
889
890 =over 4
891
892 =item *
893
894 $Data::Dumper::Indent  I<or>  I<$OBJ>->Indent(I<[NEWVAL]>)
895
896 Controls the style of indentation.  It can be set to 0, 1, 2 or 3.  Style 0
897 spews output without any newlines, indentation, or spaces between list
898 items.  It is the most compact format possible that can still be called
899 valid perl.  Style 1 outputs a readable form with newlines but no fancy
900 indentation (each level in the structure is simply indented by a fixed
901 amount of whitespace).  Style 2 (the default) outputs a very readable form
902 which takes into account the length of hash keys (so the hash value lines
903 up).  Style 3 is like style 2, but also annotates the elements of arrays
904 with their index (but the comment is on its own line, so array output
905 consumes twice the number of lines).  Style 2 is the default.
906
907 =item *
908
909 $Data::Dumper::Purity  I<or>  I<$OBJ>->Purity(I<[NEWVAL]>)
910
911 Controls the degree to which the output can be C<eval>ed to recreate the
912 supplied reference structures.  Setting it to 1 will output additional perl
913 statements that will correctly recreate nested references.  The default is
914 0.
915
916 =item *
917
918 $Data::Dumper::Pad  I<or>  I<$OBJ>->Pad(I<[NEWVAL]>)
919
920 Specifies the string that will be prefixed to every line of the output.
921 Empty string by default.
922
923 =item *
924
925 $Data::Dumper::Varname  I<or>  I<$OBJ>->Varname(I<[NEWVAL]>)
926
927 Contains the prefix to use for tagging variable names in the output. The
928 default is "VAR".
929
930 =item *
931
932 $Data::Dumper::Useqq  I<or>  I<$OBJ>->Useqq(I<[NEWVAL]>)
933
934 When set, enables the use of double quotes for representing string values.
935 Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
936 characters will be backslashed, and unprintable characters will be output as
937 quoted octal integers.  Since setting this variable imposes a performance
938 penalty, the default is 0.  C<Dump()> will run slower if this flag is set,
939 since the fast XSUB implementation doesn't support it yet.
940
941 =item *
942
943 $Data::Dumper::Terse  I<or>  I<$OBJ>->Terse(I<[NEWVAL]>)
944
945 When set, Data::Dumper will emit single, non-self-referential values as
946 atoms/terms rather than statements.  This means that the C<$VAR>I<n> names
947 will be avoided where possible, but be advised that such output may not
948 always be parseable by C<eval>.
949
950 =item *
951
952 $Data::Dumper::Freezer  I<or>  $I<OBJ>->Freezer(I<[NEWVAL]>)
953
954 Can be set to a method name, or to an empty string to disable the feature.
955 Data::Dumper will invoke that method via the object before attempting to
956 stringify it.  This method can alter the contents of the object (if, for
957 instance, it contains data allocated from C), and even rebless it in a
958 different package.  The client is responsible for making sure the specified
959 method can be called via the object, and that the object ends up containing
960 only perl data types after the method has been called.  Defaults to an empty
961 string.
962
963 If an object does not support the method specified (determined using
964 UNIVERSAL::can()) then the call will be skipped.  If the method dies a
965 warning will be generated.
966
967 =item *
968
969 $Data::Dumper::Toaster  I<or>  $I<OBJ>->Toaster(I<[NEWVAL]>)
970
971 Can be set to a method name, or to an empty string to disable the feature.
972 Data::Dumper will emit a method call for any objects that are to be dumped
973 using the syntax C<bless(DATA, CLASS)-E<gt>METHOD()>.  Note that this means that
974 the method specified will have to perform any modifications required on the
975 object (like creating new state within it, and/or reblessing it in a
976 different package) and then return it.  The client is responsible for making
977 sure the method can be called via the object, and that it returns a valid
978 object.  Defaults to an empty string.
979
980 =item *
981
982 $Data::Dumper::Deepcopy  I<or>  $I<OBJ>->Deepcopy(I<[NEWVAL]>)
983
984 Can be set to a boolean value to enable deep copies of structures.
985 Cross-referencing will then only be done when absolutely essential
986 (i.e., to break reference cycles).  Default is 0.
987
988 =item *
989
990 $Data::Dumper::Quotekeys  I<or>  $I<OBJ>->Quotekeys(I<[NEWVAL]>)
991
992 Can be set to a boolean value to control whether hash keys are quoted.
993 A false value will avoid quoting hash keys when it looks like a simple
994 string.  Default is 1, which will always enclose hash keys in quotes.
995
996 =item *
997
998 $Data::Dumper::Bless  I<or>  $I<OBJ>->Bless(I<[NEWVAL]>)
999
1000 Can be set to a string that specifies an alternative to the C<bless>
1001 builtin operator used to create objects.  A function with the specified
1002 name should exist, and should accept the same arguments as the builtin.
1003 Default is C<bless>.
1004
1005 =item *
1006
1007 $Data::Dumper::Pair  I<or>  $I<OBJ>->Pair(I<[NEWVAL]>)
1008
1009 Can be set to a string that specifies the separator between hash keys
1010 and values. To dump nested hash, array and scalar values to JavaScript,
1011 use: C<$Data::Dumper::Pair = ' : ';>. Implementing C<bless> in JavaScript
1012 is left as an exercise for the reader.
1013 A function with the specified name exists, and accepts the same arguments
1014 as the builtin.
1015
1016 Default is: C< =E<gt> >.
1017
1018 =item *
1019
1020 $Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)
1021
1022 Can be set to a positive integer that specifies the depth beyond which
1023 which we don't venture into a structure.  Has no effect when
1024 C<Data::Dumper::Purity> is set.  (Useful in debugger when we often don't
1025 want to see more than enough).  Default is 0, which means there is 
1026 no maximum depth. 
1027
1028 =item *
1029
1030 $Data::Dumper::Useperl  I<or>  $I<OBJ>->Useperl(I<[NEWVAL]>)
1031
1032 Can be set to a boolean value which controls whether the pure Perl
1033 implementation of C<Data::Dumper> is used. The C<Data::Dumper> module is
1034 a dual implementation, with almost all functionality written in both
1035 pure Perl and also in XS ('C'). Since the XS version is much faster, it
1036 will always be used if possible. This option lets you override the
1037 default behavior, usually for testing purposes only. Default is 0, which
1038 means the XS implementation will be used if possible.
1039
1040 =item *
1041
1042 $Data::Dumper::Sortkeys  I<or>  $I<OBJ>->Sortkeys(I<[NEWVAL]>)
1043
1044 Can be set to a boolean value to control whether hash keys are dumped in
1045 sorted order. A true value will cause the keys of all hashes to be
1046 dumped in Perl's default sort order. Can also be set to a subroutine
1047 reference which will be called for each hash that is dumped. In this
1048 case C<Data::Dumper> will call the subroutine once for each hash,
1049 passing it the reference of the hash. The purpose of the subroutine is
1050 to return a reference to an array of the keys that will be dumped, in
1051 the order that they should be dumped. Using this feature, you can
1052 control both the order of the keys, and which keys are actually used. In
1053 other words, this subroutine acts as a filter by which you can exclude
1054 certain keys from being dumped. Default is 0, which means that hash keys
1055 are not sorted.
1056
1057 =item *
1058
1059 $Data::Dumper::Deparse  I<or>  $I<OBJ>->Deparse(I<[NEWVAL]>)
1060
1061 Can be set to a boolean value to control whether code references are
1062 turned into perl source code. If set to a true value, C<B::Deparse>
1063 will be used to get the source of the code reference. Using this option
1064 will force using the Perl implementation of the dumper, since the fast
1065 XSUB implementation doesn't support it.
1066
1067 Caution : use this option only if you know that your coderefs will be
1068 properly reconstructed by C<B::Deparse>.
1069
1070 =back
1071
1072 =head2 Exports
1073
1074 =over 4
1075
1076 =item Dumper
1077
1078 =back
1079
1080 =head1 EXAMPLES
1081
1082 Run these code snippets to get a quick feel for the behavior of this
1083 module.  When you are through with these examples, you may want to
1084 add or change the various configuration variables described above,
1085 to see their behavior.  (See the testsuite in the Data::Dumper
1086 distribution for more examples.)
1087
1088
1089     use Data::Dumper;
1090
1091     package Foo;
1092     sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]};
1093
1094     package Fuz;                       # a weird REF-REF-SCALAR object
1095     sub new {bless \($_ = \ 'fu\'z'), $_[0]};
1096
1097     package main;
1098     $foo = Foo->new;
1099     $fuz = Fuz->new;
1100     $boo = [ 1, [], "abcd", \*foo,
1101              {1 => 'a', 023 => 'b', 0x45 => 'c'}, 
1102              \\"p\q\'r", $foo, $fuz];
1103
1104     ########
1105     # simple usage
1106     ########
1107
1108     $bar = eval(Dumper($boo));
1109     print($@) if $@;
1110     print Dumper($boo), Dumper($bar);  # pretty print (no array indices)
1111
1112     $Data::Dumper::Terse = 1;          # don't output names where feasible
1113     $Data::Dumper::Indent = 0;         # turn off all pretty print
1114     print Dumper($boo), "\n";
1115
1116     $Data::Dumper::Indent = 1;         # mild pretty print
1117     print Dumper($boo);
1118
1119     $Data::Dumper::Indent = 3;         # pretty print with array indices
1120     print Dumper($boo);
1121
1122     $Data::Dumper::Useqq = 1;          # print strings in double quotes
1123     print Dumper($boo);
1124
1125     $Data::Dumper::Pair = " : ";       # specify hash key/value separator
1126     print Dumper($boo);
1127
1128
1129     ########
1130     # recursive structures
1131     ########
1132
1133     @c = ('c');
1134     $c = \@c;
1135     $b = {};
1136     $a = [1, $b, $c];
1137     $b->{a} = $a;
1138     $b->{b} = $a->[1];
1139     $b->{c} = $a->[2];
1140     print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);
1141
1142
1143     $Data::Dumper::Purity = 1;         # fill in the holes for eval
1144     print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a
1145     print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b
1146
1147
1148     $Data::Dumper::Deepcopy = 1;       # avoid cross-refs
1149     print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
1150
1151
1152     $Data::Dumper::Purity = 0;         # avoid cross-refs
1153     print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
1154
1155     ########
1156     # deep structures
1157     ########
1158
1159     $a = "pearl";
1160     $b = [ $a ];
1161     $c = { 'b' => $b };
1162     $d = [ $c ];
1163     $e = { 'd' => $d };
1164     $f = { 'e' => $e };
1165     print Data::Dumper->Dump([$f], [qw(f)]);
1166
1167     $Data::Dumper::Maxdepth = 3;       # no deeper than 3 refs down
1168     print Data::Dumper->Dump([$f], [qw(f)]);
1169
1170
1171     ########
1172     # object-oriented usage
1173     ########
1174
1175     $d = Data::Dumper->new([$a,$b], [qw(a b)]);
1176     $d->Seen({'*c' => $c});            # stash a ref without printing it
1177     $d->Indent(3);
1178     print $d->Dump;
1179     $d->Reset->Purity(0);              # empty the seen cache
1180     print join "----\n", $d->Dump;
1181
1182
1183     ########
1184     # persistence
1185     ########
1186
1187     package Foo;
1188     sub new { bless { state => 'awake' }, shift }
1189     sub Freeze {
1190         my $s = shift;
1191         print STDERR "preparing to sleep\n";
1192         $s->{state} = 'asleep';
1193         return bless $s, 'Foo::ZZZ';
1194     }
1195
1196     package Foo::ZZZ;
1197     sub Thaw {
1198         my $s = shift;
1199         print STDERR "waking up\n";
1200         $s->{state} = 'awake';
1201         return bless $s, 'Foo';
1202     }
1203
1204     package Foo;
1205     use Data::Dumper;
1206     $a = Foo->new;
1207     $b = Data::Dumper->new([$a], ['c']);
1208     $b->Freezer('Freeze');
1209     $b->Toaster('Thaw');
1210     $c = $b->Dump;
1211     print $c;
1212     $d = eval $c;
1213     print Data::Dumper->Dump([$d], ['d']);
1214
1215
1216     ########
1217     # symbol substitution (useful for recreating CODE refs)
1218     ########
1219
1220     sub foo { print "foo speaking\n" }
1221     *other = \&foo;
1222     $bar = [ \&other ];
1223     $d = Data::Dumper->new([\&other,$bar],['*other','bar']);
1224     $d->Seen({ '*foo' => \&foo });
1225     print $d->Dump;
1226
1227
1228     ########
1229     # sorting and filtering hash keys
1230     ########
1231
1232     $Data::Dumper::Sortkeys = \&my_filter;
1233     my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' };
1234     my $bar = { %$foo };
1235     my $baz = { reverse %$foo };
1236     print Dumper [ $foo, $bar, $baz ];
1237
1238     sub my_filter {
1239         my ($hash) = @_;
1240         # return an array ref containing the hash keys to dump
1241         # in the order that you want them to be dumped
1242         return [
1243           # Sort the keys of %$foo in reverse numeric order
1244             $hash eq $foo ? (sort {$b <=> $a} keys %$hash) :
1245           # Only dump the odd number keys of %$bar
1246             $hash eq $bar ? (grep {$_ % 2} keys %$hash) :
1247           # Sort keys in default order for all other hashes
1248             (sort keys %$hash)
1249         ];
1250     }
1251
1252 =head1 BUGS
1253
1254 Due to limitations of Perl subroutine call semantics, you cannot pass an
1255 array or hash.  Prepend it with a C<\> to pass its reference instead.  This
1256 will be remedied in time, now that Perl has subroutine prototypes.
1257 For now, you need to use the extended usage form, and prepend the
1258 name with a C<*> to output it as a hash or array.
1259
1260 C<Data::Dumper> cheats with CODE references.  If a code reference is
1261 encountered in the structure being processed (and if you haven't set
1262 the C<Deparse> flag), an anonymous subroutine that
1263 contains the string '"DUMMY"' will be inserted in its place, and a warning
1264 will be printed if C<Purity> is set.  You can C<eval> the result, but bear
1265 in mind that the anonymous sub that gets created is just a placeholder.
1266 Someday, perl will have a switch to cache-on-demand the string
1267 representation of a compiled piece of code, I hope.  If you have prior
1268 knowledge of all the code refs that your data structures are likely
1269 to have, you can use the C<Seen> method to pre-seed the internal reference
1270 table and make the dumped output point to them, instead.  See L</EXAMPLES>
1271 above.
1272
1273 The C<Useqq> and C<Deparse> flags makes Dump() run slower, since the
1274 XSUB implementation does not support them.
1275
1276 SCALAR objects have the weirdest looking C<bless> workaround.
1277
1278 Pure Perl version of C<Data::Dumper> escapes UTF-8 strings correctly
1279 only in Perl 5.8.0 and later.
1280
1281 =head2 NOTE
1282
1283 Starting from Perl 5.8.1 different runs of Perl will have different
1284 ordering of hash keys.  The change was done for greater security,
1285 see L<perlsec/"Algorithmic Complexity Attacks">.  This means that
1286 different runs of Perl will have different Data::Dumper outputs if
1287 the data contains hashes.  If you need to have identical Data::Dumper
1288 outputs from different runs of Perl, use the environment variable
1289 PERL_HASH_SEED, see L<perlrun/PERL_HASH_SEED>.  Using this restores
1290 the old (platform-specific) ordering: an even prettier solution might
1291 be to use the C<Sortkeys> filter of Data::Dumper.
1292
1293 =head1 AUTHOR
1294
1295 Gurusamy Sarathy        gsar@activestate.com
1296
1297 Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
1298 This program is free software; you can redistribute it and/or
1299 modify it under the same terms as Perl itself.
1300
1301 =head1 VERSION
1302
1303 Version 2.121  (Aug 24 2003)
1304
1305 =head1 SEE ALSO
1306
1307 perl(1)
1308
1309 =cut