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