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