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