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