Peek.pm

   1 package Data::Peek;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DynaLoader ();
   7
   8 use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
   9 $VERSION   = "0.32";
  10 @ISA       = qw( DynaLoader Exporter );
  11 @EXPORT    = qw( DDumper DDsort DPeek DDisplay DDump DHexDump DDual DGrow );
  12 @EXPORT_OK = qw( triplevar :tidy );
  13 push @EXPORT, "DDump_IO";
  14
  15 bootstrap Data::Peek $VERSION;
  16
  17 ### ############# DDumper () ##################################################
  18
  19 use Data::Dumper;
  20
  21 my %sk = (
  22     undef       => 0,
  23     ""          => 0,
  24     0           => 0,
  25     1           => 1,
  26
  27     V   => sub {        # Sort by value
  28             my $r = shift;
  29             [         sort { $r->{$a} cmp $r->{$b} } keys %$r ];
  30             },
  31     VN  => sub {        # Sort by value numeric
  32             my $r = shift;
  33             [         sort { $r->{$a} <=> $r->{$b} } keys %$r ];
  34             },
  35     VNR => sub {        # Sort by value numeric reverse
  36             my $r = shift;
  37             [         sort { $r->{$b} <=> $r->{$a} } keys %$r ];
  38             },
  39     VR  => sub {        # Sort by value reverse
  40             my $r = shift;
  41             [         sort { $r->{$b} cmp $r->{$a} } keys %$r ];
  42             },
  43     R   => sub {        # Sort reverse
  44             my $r = shift;
  45             [ reverse sort                           keys %$r ];
  46             },
  47     );
  48 my $_sortkeys = 1;
  49 my $_perltidy;
  50
  51 sub DDsort
  52 {
  53     @_ or return;
  54
  55     $_sortkeys = exists $sk{$_[0]} ? $sk{$_[0]} : $_[0];
  56     } # DDsort
  57
  58 sub import
  59 {
  60     my @exp = @_;
  61     my @etl;
  62     foreach my $p (@exp) {
  63         exists $sk{$p} and DDsort ($p), next;
  64
  65         if ($p eq ":tidy") {
  66             $_perltidy = eval q{use Perl::Tidy; $Perl::Tidy::VERSION };
  67             next;
  68             }
  69
  70         push @etl, $p;
  71         }
  72     __PACKAGE__->export_to_level (1, @etl);
  73     } # import
  74
  75 sub DDumper
  76 {
  77     local $Data::Dumper::Sortkeys  = $_sortkeys;
  78     local $Data::Dumper::Indent    = 1;
  79     local $Data::Dumper::Quotekeys = 0;
  80     local $Data::Dumper::Deparse   = 1;
  81     local $Data::Dumper::Terse     = 1;
  82     local $Data::Dumper::Useqq     = 0; # I want unicode visible
  83
  84     my $s = Data::Dumper::Dumper @_;
  85     if ($_perltidy) {
  86         Perl::Tidy::perltidy (source => \$s, destination => \my $t);
  87         $s = $t;
  88         }
  89     else {
  90         $s =~ s/^(\s*)(.*?)\s*=>/sprintf "%s%-16s =>", $1, $2/gme;  # Align =>
  91         $s =~ s/\bbless\s*\(\s*/bless (/gm and $s =~ s/\s+\)([;,])$/)$1/gm;
  92         $s =~ s/^(?= *[]}](?:[;,]|$))/  /gm;
  93         $s =~ s/^(\s*[{[]) *\n *(?=\S)(?![{[])/$1   /gm;
  94         $s =~ s/^(\s+)/$1$1/gm;
  95         }
  96
  97     defined wantarray or warn $s;
  98     return $s;
  99     } # DDumper
 100
 101 ### ############# DDump () ####################################################
 102
 103 our $has_perlio;
 104
 105 BEGIN {
 106     use Config;
 107     $has_perlio = ($Config{useperlio} || "undef") eq "define";
 108     }
 109
 110 sub _DDump_ref
 111 {
 112     my (undef, $down) = (@_, 0);
 113
 114     my $ref = ref $_[0];
 115     if ($ref eq "SCALAR" || $ref eq "REF") {
 116         my %hash = DDump (${$_[0]}, $down);
 117         return { %hash };
 118         }
 119     if ($ref eq "ARRAY") {
 120         my @list;
 121         foreach my $list (@{$_[0]}) {
 122             my %hash = DDump ($list, $down);
 123             push @list, { %hash };
 124             }
 125         return [ @list ];
 126         }
 127     if ($ref eq "HASH") {
 128         my %hash;
 129         foreach my $key (sort keys %{$_[0]}) {
 130             $hash{DPeek ($key)} = { DDump ($_[0]->{$key}, $down) };
 131             }
 132         return { %hash };
 133         }
 134     undef;
 135     } # _DDump_ref
 136
 137 sub _DDump
 138 {
 139     my (undef, $down, $dump, $fh) = (@_, "");
 140
 141     if ($has_perlio and open $fh, ">", \$dump) {
 142         #print STDERR "Using DDump_IO\n";
 143         DDump_IO ($fh, $_[0], $down);
 144         close $fh;
 145         }
 146     else {
 147         #print STDERR "Using DDump_XS\n";
 148         $dump = DDump_XS ($_[0]);
 149         }
 150
 151     return $dump;
 152     } # _DDump
 153
 154 sub DDump ($;$)
 155 {
 156     my (undef, $down) = (@_, 0);
 157     my @dump = split m/[\r\n]+/, _DDump ($_[0], wantarray || $down) or return;
 158
 159     if (wantarray) {
 160         my %hash;
 161         ($hash{sv} = $dump[0]) =~ s/^SV\s*=\s*//;
 162         m/^\s+(\w+)\s*=\s*(.*)/ and $hash{$1} = $2 for @dump;
 163
 164         if (exists $hash{FLAGS}) {
 165             $hash{FLAGS} =~ tr/()//d;
 166             $hash{FLAGS} = { map { $_ => 1 } split m/,/ => $hash{FLAGS} };
 167             }
 168
 169         $down && ref $_[0] and
 170             $hash{RV} = _DDump_ref ($_[0], $down - 1) || $_[0];
 171         return %hash;
 172         }
 173
 174     my $dump = join "\n", @dump, "";
 175
 176     defined wantarray and return $dump;
 177
 178     warn $dump;
 179     } # DDump
 180
 181 sub DHexDump
 182 {
 183     use bytes;
 184     my $off = 0;
 185     my @out;
 186     my $var = @_ ? $_[0] : $_;
 187     defined $var or return;
 188     my $str = "$var";   # force stringification
 189     for (unpack "(A32)*", unpack "H*", $str) {
 190         my @b = unpack "(A2)*", $_;
 191         my $out = sprintf "%04x ", $off;
 192         $out .= " ".($b[$_]||"  ") for 0 ..  7;
 193         $out .= " ";
 194         $out .= " ".($b[$_]||"  ") for 8 .. 15;
 195         $out .= "  ";
 196         $out .= ($_ < 0x20 || $_ >= 0x7f ? "." : chr $_) for map { hex $_ } @b;
 197         push @out, $out."\n";
 198         $off += 16;
 199         }
 200
 201     wantarray and return @out;
 202
 203     defined wantarray and return join "", @out;
 204
 205     warn join "", @out;
 206     } # DHexDump
 207
 208 "Indent";
 209
 210 __END__
 211
 212 =head1 NAME
 213
 214 Data::Peek - A collection of low-level debug facilities
 215
 216 =head1 SYNOPSIS
 217
 218  use Data::Peek;
 219
 220  print DDumper \%hash;    # Same syntax as Data::Dumper
 221
 222  print DPeek \$var;
 223  my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]);
 224  print DPeek for DDual ($!, 1);
 225  print DDisplay ("ab\nc\x{20ac}\rdef\n");
 226  print DHexDump ("ab\nc\x{20ac}\rdef\n");
 227
 228  my $dump = DDump $var;
 229  my %hash = DDump \@list;
 230  DDump \%hash;
 231
 232  my %hash = DDump (\%hash, 5);  # dig 5 levels deep
 233
 234  my $dump;
 235  open my $fh, ">", \$dump;
 236  DDump_IO ($fh, \%hash, 6);
 237  close $fh;
 238  print $dump;
 239
 240  use Data::Peek qw( DGrow triplevar );
 241  my $x = ""; DGrow ($x, 10000);
 242  my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415");
 243
 244 =head1 DESCRIPTION
 245
 246 Data::Peek started off as C<DDumper> being a wrapper module over
 247 L<Data::Dumper>, but grew out to be a set of low-level data
 248 introspection utilities that no other module provided yet, using the
 249 lowest level of the perl internals API as possible.
 250
 251 =head2 DDumper ($var, ...)
 252
 253 Not liking the default output of Data::Dumper, and always feeling the need
 254 to set C<$Data::Dumper::Sortkeys = 1;>, and not liking any of the default
 255 layouts, this function is just a wrapper around Data::Dumper::Dumper with
 256 everything set as I like it.
 257
 258     $Data::Dumper::Sortkeys = 1;
 259     $Data::Dumper::Indent   = 1;
 260
 261 And the result is further beautified to meet my needs:
 262
 263   * quotation of hash keys has been removed (with the disadvantage
 264     that the output might not be parseable again).
 265   * arrows for hashes are aligned at 16 (longer keys don't align)
 266   * closing braces and brackets are now correctly aligned
 267
 268 In void context, C<DDumper ()> warn ()'s.
 269
 270 Example
 271
 272   $ perl -MDP \
 273     -e'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};'
 274
 275   {   ape              => 1,
 276       bar              => [
 277           2,
 278           'baz',
 279           undef
 280           ],
 281       foo              => 'egg'
 282       };
 283
 284 If C<Data::Peek> is C<use>d with import argument C<:tidy>, the output
 285 of C<DDumper> is formatted using C<Perl::Tidy> (if available) according
 286 to your C<.perltidyrc>, maybe somewhat like (YMMV):
 287
 288   $ perl -MDP=:tidy \
 289     -we'DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};'
 290   {   ape => 1,
 291       bar => [2, 'baz', undef],
 292       foo => 'egg'
 293       }
 294
 295 =head2 DDsort ( 0 | 1 | R | V | VR | VN | VNR )
 296
 297 Set the hash sort algorithm for DDumper. The default is to sort by key value.
 298
 299   0   - Do not sort
 300   1   - Sort by key
 301   R   - Reverse sort by key
 302   V   - Sort by value
 303   VR  - Reverse sort by value
 304   VN  - Sort by value numerical
 305   VNR - Reverse sort by value numerical
 306
 307 These can also be passed to import:
 308
 309   $ perl -MDP=VNR \
 310     -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }'
 311   {   gum              => 13,
 312       zap              => 3,
 313       bar              => 2,
 314       foo              => 1
 315       };
 316   $ perl -MDP=V \
 317     -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }'
 318   {   foo              => 1,
 319       gum              => 13,
 320       bar              => 2,
 321       zap              => 3
 322       };
 323
 324 =head2 DPeek
 325
 326 =head2 DPeek ($var)
 327
 328 Playing with C<sv_dump ()>, I found C<Perl_sv_peek ()>, and it might be
 329 very useful for simple checks. If C<$var> is omitted, uses $_.
 330
 331 Example
 332
 333   print DPeek "abc\x{0a}de\x{20ac}fg";
 334
 335   PV("abc\nde\342\202\254fg"\0) [UTF8 "abc\nde\x{20ac}fg"]
 336
 337 In void context, C<DPeek ()> prints to C<STDERR> plus a newline.
 338
 339 =head2 DDisplay
 340
 341 =head2 DDisplay ($var)
 342
 343 Show the PV content of a scalar the way perl debugging would have done.
 344 UTF-8 detection is on, so this is effectively the same as returning the
 345 first part the C<DPeek ()> returns for non-UTF8 PV's or the second part
 346 for UTF-8 PV's. C<DDisplay ()> returns the empty string for scalars that
 347 no have a valid PV.
 348
 349 Example
 350
 351   print DDisplay "abc\x{0a}de\x{20ac}fg";
 352
 353   "abc\nde\x{20ac}fg"
 354
 355 =head2 DHexDump
 356
 357 =head2 DHexDump ($var)
 358
 359 Show the (stringified) content of a scalar as a hex-dump.  If C<$var>
 360 is omitted, C<$_> is dumped. Returns C<undef> or an empty list if
 361 C<$var> (or C<$_>) is undefined.
 362
 363 In void context, the dump is done to STDERR. In scalar context, the
 364 complete dump is returned as a single string. In list context, the dump
 365 is returned as lines.
 366
 367 Example
 368
 369   print DHexDump "abc\x{0a}de\x{20ac}fg";
 370
 371   0000  61 62 63 0a 64 65 e2 82  ac 66 67                 abc.de...fg
 372
 373 =head2 my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic])
 374
 375 DDual will return the basic elements in a variable, guaranteeing that no
 376 conversion takes place. This is very useful for dual-var variables, or
 377 when checking is a variable has defined entries for a certain type of
 378 scalar. For each String (PV), Integer (IV), Double (NV), and Reference (RV),
 379 the current value of C<$var> is returned or undef if it is not set (yet).
 380 The 5th element is an indicator if C<$var> has magic, which is B<not> invoked
 381 in the returned values, unless explicitly asked for with a true optional
 382 second argument.
 383
 384 Example
 385
 386   print DPeek for DDual ($!, 1);
 387
 388 In void context, DDual does the equivalent of
 389
 390   { my @d = DDual ($!, 1);
 391     print STDERR
 392       DPeek ($!), "\n",
 393       "  PV: ", DPeek ($d[0]), "\n",
 394       "  IV: ", DPeek ($d[1]), "\n",
 395       "  NV: ", DPeek ($d[2]), "\n",
 396       "  RV: ", DPeek ($d[3]), "\n";
 397     }
 398
 399 =head2 my $len = DGrow ($pv, $size)
 400
 401 Fastest way to preallocate space for a PV scalar. Returns the allocated
 402 length. If $size is smaller than the already allocated space, it will
 403 not shrink.
 404
 405  cmpthese (-2, {
 406      pack => q{my $x = ""; $x = pack "x20000"; $x = "";},
 407      op_x => q{my $x = ""; $x = "x"  x 20000;  $x = "";},
 408      grow => q{my $x = ""; DGrow ($x,  20000); $x = "";},
 409      });
 410
 411            Rate  op_x  pack  grow
 412  op_x   62127/s    --  -59%  -96%
 413  pack  152046/s  145%    --  -91%
 414  grow 1622943/s 2512%  967%    --
 415
 416
 417 =head2 my $tp = triplevar ($pv, $iv, $nv)
 418
 419 When making C<DDual ()> I wondered if it were possible to create triple-val
 420 scalar variables. L<Scalar::Util> already gives us C<dualvar ()>, that creates
 421 you a scalar with different numeric and string values that return different
 422 values in different context. Not that C<triplevar ()> would be very useful,
 423 compared to C<dualvar ()>, but at least this shows that it is possible.
 424
 425 C<triplevar ()> is not exported by default.
 426
 427 Example:
 428
 429   print DPeek for DDual
 430       Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415);
 431
 432   PV("\317\200"\0) [UTF8 "\x{3c0}"]
 433   IV(3)
 434   NV(3.1415)
 435   SV_UNDEF
 436   IV(0)
 437
 438 =head2 DDump ($var [, $dig_level])
 439
 440 A very useful module when debugging is C<Devel::Peek>, but is has one big
 441 disadvantage: it only prints to STDERR, which is not very handy when your
 442 code wants to inspect variables at a low level.
 443
 444 Perl itself has C<sv_dump ()>, which does something similar, but still
 445 prints to STDERR, and only one level deep.
 446
 447 C<DDump ()> is an attempt to make the innards available to the script level
 448 with a reasonable level of compatibility. C<DDump ()> is context sensitive.
 449
 450 In void context, it behaves exactly like C<Perl_sv_dump ()>.
 451
 452 In scalar context, it returns what C<Perl_sv_dump ()> would have printed.
 453
 454 In list context, it returns a hash of the variable's properties. In this mode
 455 you can pass an optional second argument that determines the depth of digging.
 456
 457 Example
 458
 459   print scalar DDump "abc\x{0a}de\x{20ac}fg"
 460
 461   SV = PV(0x723250) at 0x8432b0
 462     REFCNT = 1
 463     FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8)
 464     PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"]
 465     CUR = 11
 466     LEN = 16
 467
 468   my %h = DDump "abc\x{0a}de\x{20ac}fg";
 469   print DDumper \%h;
 470
 471   {   CUR              => '11',
 472       FLAGS            => {
 473           PADBUSY          => 1,
 474           PADMY            => 1,
 475           POK              => 1,
 476           UTF8             => 1,
 477           pPOK             => 1
 478           },
 479       LEN              => '16',
 480       PV               => '0x731ac0 "abc\\nde\\342\\202\\254fg"\\0 [UTF8 "abc\\nde\\x{20ac}fg"]',
 481       REFCNT           => '1',
 482       sv               => 'PV(0x723250) at 0x8432c0'
 483       };
 484
 485   my %h = DDump {
 486       ape => 1,
 487       foo => "egg",
 488       bar => [ 2, "baz", undef ],
 489       }, 1;
 490   print DDumper \%h;
 491
 492   {   FLAGS            => {
 493           PADBUSY          => 1,
 494           PADMY            => 1,
 495           ROK              => 1
 496           },
 497       REFCNT           => '1',
 498       RV               => {
 499           PVIV("ape")      => {
 500               FLAGS            => {
 501                   IOK              => 1,
 502                   PADBUSY          => 1,
 503                   PADMY            => 1,
 504                   pIOK             => 1
 505                   },
 506               IV               => '1',
 507               REFCNT           => '1',
 508               sv               => 'IV(0x747020) at 0x843a10'
 509               },
 510           PVIV("bar")      => {
 511               CUR              => '0',
 512               FLAGS            => {
 513                   PADBUSY          => 1,
 514                   PADMY            => 1,
 515                   ROK              => 1
 516                   },
 517               IV               => '1',
 518               LEN              => '0',
 519               PV               => '0x720210 ""',
 520               REFCNT           => '1',
 521               RV               => '0x720210',
 522               sv               => 'PVIV(0x7223e0) at 0x843a10'
 523               },
 524           PVIV("foo")      => {
 525               CUR              => '3',
 526               FLAGS            => {
 527                   PADBUSY          => 1,
 528                   PADMY            => 1,
 529                   POK              => 1,
 530                   pPOK             => 1
 531                   },
 532               IV               => '1',
 533               LEN              => '8',
 534               PV               => '0x7496c0 "egg"\\0',
 535               REFCNT           => '1',
 536               sv               => 'PVIV(0x7223e0) at 0x843a10'
 537               }
 538           },
 539       sv               => 'RV(0x79d058) at 0x843310'
 540       };
 541
 542 =head2 DDump_IO ($io, $var [, $dig_level])
 543
 544 A wrapper function around perl's internal C<Perl_do_sv_dump ()>, which
 545 makes C<Devel::Peek> completely superfluous.
 546
 547 Example
 548
 549   my $dump;
 550   open my $eh, ">", \$dump;
 551   DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6);
 552   close $eh;
 553   print $dump;
 554
 555   SV = RV(0x79d9e0) at 0x843f00
 556     REFCNT = 1
 557     FLAGS = (TEMP,ROK)
 558     RV = 0x741090
 559       SV = PVHV(0x79c948) at 0x741090
 560         REFCNT = 1
 561         FLAGS = (SHAREKEYS)
 562         IV = 2
 563         NV = 0
 564         ARRAY = 0x748ff0  (0:7, 2:1)
 565         hash quality = 62.5%
 566         KEYS = 2
 567         FILL = 1
 568         MAX = 7
 569         RITER = -1
 570         EITER = 0x0
 571           Elt "ape" HASH = 0x97623e03
 572           SV = RV(0x79d9d8) at 0x8440e0
 573             REFCNT = 1
 574             FLAGS = (ROK)
 575             RV = 0x741470
 576               SV = PVAV(0x7264b0) at 0x741470
 577                 REFCNT = 2
 578                 FLAGS = ()
 579                 IV = 0
 580                 NV = 0
 581                 ARRAY = 0x822f70
 582                 FILL = 3
 583                 MAX = 3
 584                 ARYLEN = 0x0
 585                 FLAGS = (REAL)
 586                   Elt No. 0
 587                   SV = IV(0x7467c8) at 0x7c1aa0
 588                     REFCNT = 1
 589                     FLAGS = (IOK,pIOK)
 590                     IV = 5
 591                   Elt No. 1
 592                   SV = IV(0x7467b0) at 0x8440f0
 593                     REFCNT = 1
 594                     FLAGS = (IOK,pIOK)
 595                     IV = 6
 596                   Elt No. 2
 597                   SV = IV(0x746810) at 0x75be00
 598                     REFCNT = 1
 599                     FLAGS = (IOK,pIOK)
 600                     IV = 7
 601                   Elt No. 3
 602                   SV = IV(0x746d38) at 0x7799d0
 603                     REFCNT = 1
 604                     FLAGS = (IOK,pIOK)
 605                     IV = 8
 606           Elt "3" HASH = 0xa400c7f3
 607           SV = IV(0x746fd0) at 0x7200e0
 608             REFCNT = 1
 609             FLAGS = (IOK,pIOK)
 610             IV = 4
 611
 612 =head1 INTERNALS
 613
 614 C<DDump ()> uses an XS wrapper around C<Perl_sv_dump ()> where the
 615 STDERR is temporarily caught to a pipe. The internal XS helper functions
 616 are not meant for user space
 617
 618 =head2 DDump_XS (SV *sv)
 619
 620 Base interface to internals for C<DDump ()>.
 621
 622 =head1 BUGS
 623
 624 Windows and AIX might be using a build where not all symbols that were
 625 supposed to be exported in the public API are not. Perl_pv_peek () is
 626 one of them.
 627
 628 Not all types of references are supported.
 629
 630 No idea how far back this goes in perl support, but Devel::PPPort has
 631 proven to be a big help.
 632
 633 =head1 SEE ALSO
 634
 635 L<Devel::Peek>, L<Data::Dumper>, L<Data::Dump>, L<Devel::Dumpvar>,
 636 L<Data::Dump::Streamer>
 637
 638 =head1 AUTHOR
 639
 640 H.Merijn Brand <h.m.brand@xs4all.nl>
 641
 642 =head1 COPYRIGHT AND LICENSE
 643
 644 Copyright (C) 2008-2010 H.Merijn Brand
 645
 646 This library is free software; you can redistribute it and/or modify
 647 it under the same terms as Perl itself.
 648
 649 =cut