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     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 "Indent";
 170
 171 __END__
 172
 173 =head1 NAME
 174
 175 Data::Peek - A collection of low-level debug facilities
 176
 177 =head1 SYNOPSIS
 178
 179  use Data::Peek;
 180
 181  print DDumper \%hash;    # Same syntax as Data::Dumper
 182
 183  print DPeek \$var;
 184  my ($pv, $iv, $nv, $rv, $magic) = DDual ($var [, 1]);
 185  print DPeek for DDual ($!, 1);
 186  print DDisplay ("ab\nc\x{20ac}\rdef\n");
 187
 188  my $dump = DDump $var;
 189  my %hash = DDump \@list;
 190  DDump \%hash;
 191
 192  my %hash = DDump (\%hash, 5);  # dig 5 levels deep
 193
 194  my $dump;
 195  open my $fh, ">", \$dump;
 196  DDump_IO ($fh, \%hash, 6);
 197  close $fh;
 198  print $dump;
 199
 200  use Data::Peek qw( DGrow triplevar );
 201  my $x = ""; DGrow ($x, 10000);
 202  my $tv = triplevar ("\N{GREEK SMALL LETTER PI}", 3, "3.1415");
 203
 204 =head1 DESCRIPTION
 205
 206 Data::Peek started off as C<DDumper> being a wrapper module over
 207 L<Data::Dumper>, but grew out to be a set of low-level data
 208 introspection utilities that no other module provided yet, using the
 209 lowest level of the perl internals API as possible.
 210
 211 =head2 DDumper ($var, ...)
 212
 213 Not liking the default output of Data::Dumper, and always feeling the need
 214 to set C<$Data::Dumper::Sortkeys = 1;>, and not liking any of the default
 215 layouts, this function is just a wrapper around Data::Dumper::Dumper with
 216 everything set as I like it.
 217
 218     $Data::Dumper::Sortkeys = 1;
 219     $Data::Dumper::Indent   = 1;
 220
 221 And the result is further beautified to meet my needs:
 222
 223   * quotation of hash keys has been removed (with the disadvantage
 224     that the output might not be parseable again).
 225   * arrows for hashes are aligned at 16 (longer keys don't align)
 226   * closing braces and brackets are now correctly aligned
 227
 228 In void context, C<DDumper ()> warn ()'s.
 229
 230 Example
 231
 232   print DDumper { ape => 1, foo => "egg", bar => [ 2, "baz", undef ]};
 233
 234   {   ape              => 1,
 235       bar              => [
 236           2,
 237           'baz',
 238           undef
 239           ],
 240       foo              => 'egg'
 241       };
 242
 243 =head2 DDsort ( 0 | 1 | R | V | VR | VN | VNR )
 244
 245 Set the hash sort algorithm for DDumper. The default is to sort by key value.
 246
 247   0   - Do not sort
 248   1   - Sort by key
 249   R   - Reverse sort by key
 250   V   - Sort by value
 251   VR  - Reverse sort by value
 252   VN  - Sort by value numerical
 253   VNR - Reverse sort by value numerical
 254
 255 These can also be passed to import:
 256
 257   $ perl -MDP=VNR -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }'
 258   {   gum              => 13,
 259       zap              => 3,
 260       bar              => 2,
 261       foo              => 1
 262       };
 263   $ perl -MDP=V   -we'DDumper { foo => 1, bar => 2, zap => 3, gum => 13 }'
 264   {   foo              => 1,
 265       gum              => 13,
 266       bar              => 2,
 267       zap              => 3
 268       };
 269
 270 =head2 DPeek
 271
 272 =head2 DPeek ($var)
 273
 274 Playing with C<sv_dump ()>, I found C<Perl_sv_peek ()>, and it might be
 275 very useful for simple checks. If C<$var> is omitted, uses $_.
 276
 277 Example
 278
 279   print DPeek "abc\x{0a}de\x{20ac}fg";
 280
 281   PV("abc\nde\342\202\254fg"\0) [UTF8 "abc\nde\x{20ac}fg"]
 282
 283 In void context, C<DPeek ()> prints to C<STDERR> plus a newline.
 284
 285 =head2 DDisplay
 286
 287 =head2 DDisplay ($var)
 288
 289 Show the PV content of a scalar the way perl debugging would have done.
 290 UTF-8 detection is on, so this is effectively the same as returning the
 291 first part the C<DPeek ()> returns for non-UTF8 PV's or the second part
 292 for UTF-8 PV's. C<DDisplay ()> returns the empty string for scalars that
 293 no have a valid PV.
 294
 295 Example
 296
 297   print DDisplay "abc\x{0a}de\x{20ac}fg";
 298
 299   "abc\nde\x{20ac}fg"
 300
 301 =head2 my ($pv, $iv, $nv, $rv, $hm) = DDual ($var [, $getmagic])
 302
 303 DDual will return the basic elements in a variable, guaranteeing that no
 304 conversion takes place. This is very useful for dual-var variables, or
 305 when checking is a variable has defined entries for a certain type of
 306 scalar. For each String (PV), Integer (IV), Double (NV), and Reference (RV),
 307 the current value of C<$var> is returned or undef if it is not set (yet).
 308 The 5th element is an indicator if C<$var> has magic, which is B<not> invoked
 309 in the returned values, unless explicitly asked for with a true optional
 310 second argument.
 311
 312 Example
 313
 314   print DPeek for DDual ($!, 1);
 315
 316 In void context, DDual does the equivalent of
 317
 318   { my @d = DDual ($!, 1);
 319     print STDERR
 320       DPeek ($!), "\n",
 321       "  PV: ", DPeek ($d[0]), "\n",
 322       "  IV: ", DPeek ($d[1]), "\n",
 323       "  NV: ", DPeek ($d[2]), "\n",
 324       "  RV: ", DPeek ($d[3]), "\n";
 325     }
 326
 327 =head2 my $LEN = DGrow ($pv, $size)
 328
 329 Fastest way to preallocate space for a PV scalar. Returns the allocated
 330 length. If $size is smaller than the already allocated space, it will
 331 not shrink.
 332
 333  cmpthese (-2, {
 334      pack => q{my $x = ""; $x = pack "x20000"; $x = "";},
 335      op_x => q{my $x = ""; $x = "x"  x 20000;  $x = "";},
 336      grow => q{my $x = ""; DGrow ($x,  20000); $x = "";},
 337      });
 338
 339            Rate  op_x  pack  grow
 340  op_x   62127/s    --  -59%  -96%
 341  pack  152046/s  145%    --  -91%
 342  grow 1622943/s 2512%  967%    --
 343
 344
 345 =head2 triplevar ($pv, $iv, $nv)
 346
 347 When making C<DDual ()> I wondered if it were possible to create triple-val
 348 scalar variables. L<Scalar::Util> already gives us C<dualvar ()>, that creates
 349 you a scalar with different numeric and string values that return different
 350 values in different context. Not that C<triplevar ()> would be very useful,
 351 compared to C<dualvar ()>, but at least this shows that it is possible.
 352
 353 C<triplevar ()> is not exported by default.
 354
 355 Example:
 356
 357   print DPeek for DDual
 358       Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415);
 359
 360   PV("\317\200"\0) [UTF8 "\x{3c0}"]
 361   IV(3)
 362   NV(3.1415)
 363   SV_UNDEF
 364   IV(0)
 365
 366 =head2 DDump ($var [, $dig_level])
 367
 368 A very useful module when debugging is C<Devel::Peek>, but is has one big
 369 disadvantage: it only prints to STDERR, which is not very handy when your
 370 code wants to inspect variables al a low level.
 371
 372 Perl itself has C<sv_dump ()>, which does something similar, but still
 373 prints to STDERR, and only one level deep.
 374
 375 C<DDump ()> is an attempt to make the innards available to the script level
 376 with a reasonable level of compatibility. C<DDump ()> is context sensitive.
 377
 378 In void context, it behaves exactly like C<Perl_sv_dump ()>.
 379
 380 In scalar context, it returns what C<Perl_sv_dump ()> would have printed.
 381
 382 In list context, it returns a hash of the variable's properties. In this mode
 383 you can pass an optional second argument that determines the depth of digging.
 384
 385 Example
 386
 387   print scalar DDump "abc\x{0a}de\x{20ac}fg"
 388
 389   SV = PV(0x723250) at 0x8432b0
 390     REFCNT = 1
 391     FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8)
 392     PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"]
 393     CUR = 11
 394     LEN = 16
 395
 396   my %h = DDump "abc\x{0a}de\x{20ac}fg";
 397   print DDumper \%h;
 398
 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   {   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-2010 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