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 =head2 triplevar ($pv, $iv, $nv)
 332
 333 When making C<DDual ()> I wondered if it were possible to create triple-val
 334 scalar variables. L<Scalar::Util> already gives us C<dualvar ()>, that creates
 335 you a scalar with different numeric and string values that return different
 336 values in different context. Not that C<triplevar ()> would be very useful,
 337 compared to C<dualvar ()>, but at least this shows that it is possible.
 338
 339 C<triplevar ()> is not exported by default.
 340
 341 Example:
 342
 343   print DPeek for DDual
 344       Data::Peek::triplevar ("\N{GREEK SMALL LETTER PI}", 3, 3.1415);
 345
 346   PV("\317\200"\0) [UTF8 "\x{3c0}"]
 347   IV(3)
 348   NV(3.1415)
 349   SV_UNDEF
 350   IV(0)
 351
 352 =head2 DDump ($var [, $dig_level])
 353
 354 A very useful module when debugging is C<Devel::Peek>, but is has one big
 355 disadvantage: it only prints to STDERR, which is not very handy when your
 356 code wants to inspect variables al a low level.
 357
 358 Perl itself has C<sv_dump ()>, which does something similar, but still
 359 prints to STDERR, and only one level deep.
 360
 361 C<DDump ()> is an attempt to make the innards available to the script level
 362 with a reasonable level of compatibility. C<DDump ()> is context sensitive.
 363
 364 In void context, it behaves exactly like C<Perl_sv_dump ()>.
 365
 366 In scalar context, it returns what C<Perl_sv_dump ()> would have printed.
 367
 368 In list context, it returns a hash of the variable's properties. In this mode
 369 you can pass an optional second argument that determines the depth of digging.
 370
 371 Example
 372
 373   print scalar DDump "abc\x{0a}de\x{20ac}fg"
 374
 375   SV = PV(0x723250) at 0x8432b0
 376     REFCNT = 1
 377     FLAGS = (PADBUSY,PADMY,POK,pPOK,UTF8)
 378     PV = 0x731ac0 "abc\nde\342\202\254fg"\0 [UTF8 "abc\nde\x{20ac}fg"]
 379     CUR = 11
 380     LEN = 16
 381
 382   my %h = DDump "abc\x{0a}de\x{20ac}fg";
 383   print DDumper \%h;
 384
 385   $VAR1 = {
 386       CUR              => '11',
 387       FLAGS            => {
 388           PADBUSY          => 1,
 389           PADMY            => 1,
 390           POK              => 1,
 391           UTF8             => 1,
 392           pPOK             => 1
 393           },
 394       LEN              => '16',
 395       PV               => '0x731ac0 "abc\\nde\\342\\202\\254fg"\\0 [UTF8 "abc\\nde\\x{20ac}fg"]',
 396       REFCNT           => '1',
 397       sv               => 'PV(0x723250) at 0x8432c0'
 398       };
 399
 400   my %h = DDump {
 401       ape => 1,
 402       foo => "egg",
 403       bar => [ 2, "baz", undef ],
 404       }, 1;
 405   print DDumper \%h;
 406
 407   $VAR1 = {
 408       FLAGS            => {
 409           PADBUSY          => 1,
 410           PADMY            => 1,
 411           ROK              => 1
 412           },
 413       REFCNT           => '1',
 414       RV               => {
 415           PVIV("ape")      => {
 416               FLAGS            => {
 417                   IOK              => 1,
 418                   PADBUSY          => 1,
 419                   PADMY            => 1,
 420                   pIOK             => 1
 421                   },
 422               IV               => '1',
 423               REFCNT           => '1',
 424               sv               => 'IV(0x747020) at 0x843a10'
 425               },
 426           PVIV("bar")      => {
 427               CUR              => '0',
 428               FLAGS            => {
 429                   PADBUSY          => 1,
 430                   PADMY            => 1,
 431                   ROK              => 1
 432                   },
 433               IV               => '1',
 434               LEN              => '0',
 435               PV               => '0x720210 ""',
 436               REFCNT           => '1',
 437               RV               => '0x720210',
 438               sv               => 'PVIV(0x7223e0) at 0x843a10'
 439               },
 440           PVIV("foo")      => {
 441               CUR              => '3',
 442               FLAGS            => {
 443                   PADBUSY          => 1,
 444                   PADMY            => 1,
 445                   POK              => 1,
 446                   pPOK             => 1
 447                   },
 448               IV               => '1',
 449               LEN              => '8',
 450               PV               => '0x7496c0 "egg"\\0',
 451               REFCNT           => '1',
 452               sv               => 'PVIV(0x7223e0) at 0x843a10'
 453               }
 454           },
 455       sv               => 'RV(0x79d058) at 0x843310'
 456       };
 457
 458 =head2 DDump_IO ($io, $var [, $dig_level])
 459
 460 A wrapper function around perl's internal C<Perl_do_sv_dump ()>, which
 461 makes C<Devel::Peek> completely superfluous. As PerlIO is only available
 462 perl version 5.7.3 and up, this function is not available in older perls.
 463
 464 Example
 465
 466   my $dump;
 467   open my $eh, ">", \$dump;
 468   DDump_IO ($eh, { 3 => 4, ape => [5..8]}, 6);
 469   close $eh;
 470   print $dump;
 471
 472   SV = RV(0x79d9e0) at 0x843f00
 473     REFCNT = 1
 474     FLAGS = (TEMP,ROK)
 475     RV = 0x741090
 476       SV = PVHV(0x79c948) at 0x741090
 477         REFCNT = 1
 478         FLAGS = (SHAREKEYS)
 479         IV = 2
 480         NV = 0
 481         ARRAY = 0x748ff0  (0:7, 2:1)
 482         hash quality = 62.5%
 483         KEYS = 2
 484         FILL = 1
 485         MAX = 7
 486         RITER = -1
 487         EITER = 0x0
 488           Elt "ape" HASH = 0x97623e03
 489           SV = RV(0x79d9d8) at 0x8440e0
 490             REFCNT = 1
 491             FLAGS = (ROK)
 492             RV = 0x741470
 493               SV = PVAV(0x7264b0) at 0x741470
 494                 REFCNT = 2
 495                 FLAGS = ()
 496                 IV = 0
 497                 NV = 0
 498                 ARRAY = 0x822f70
 499                 FILL = 3
 500                 MAX = 3
 501                 ARYLEN = 0x0
 502                 FLAGS = (REAL)
 503                   Elt No. 0
 504                   SV = IV(0x7467c8) at 0x7c1aa0
 505                     REFCNT = 1
 506                     FLAGS = (IOK,pIOK)
 507                     IV = 5
 508                   Elt No. 1
 509                   SV = IV(0x7467b0) at 0x8440f0
 510                     REFCNT = 1
 511                     FLAGS = (IOK,pIOK)
 512                     IV = 6
 513                   Elt No. 2
 514                   SV = IV(0x746810) at 0x75be00
 515                     REFCNT = 1
 516                     FLAGS = (IOK,pIOK)
 517                     IV = 7
 518                   Elt No. 3
 519                   SV = IV(0x746d38) at 0x7799d0
 520                     REFCNT = 1
 521                     FLAGS = (IOK,pIOK)
 522                     IV = 8
 523           Elt "3" HASH = 0xa400c7f3
 524           SV = IV(0x746fd0) at 0x7200e0
 525             REFCNT = 1
 526             FLAGS = (IOK,pIOK)
 527             IV = 4
 528
 529 =head1 INTERNALS
 530
 531 C<DDump ()> uses an XS wrapper around C<Perl_sv_dump ()> where the
 532 STDERR is temporarily caught to a pipe. The internal XS helper functions
 533 are not meant for user space
 534
 535 =head2 DDump_XS (SV *sv)
 536
 537 Base interface to internals for C<DDump ()>.
 538
 539 =head1 BUGS
 540
 541 Windows and AIX might be using a build where not all symbols that were
 542 supposed to be exported in the public API are not. Perl_pv_peek () is
 543 one of them.
 544
 545 Not all types of references are supported.
 546
 547 No idea how far back this goes in perl support, but Devel::PPPort has
 548 proven to be a big help.
 549
 550 =head1 SEE ALSO
 551
 552 L<Devel::Peek(3)>, L<Data::Dumper(3)>, L<Data::Dump(3)>, L<Devel::Dumpvar>,
 553 L<Data::Dump::Streamer(3)>
 554
 555 =head1 AUTHOR
 556
 557 H.Merijn Brand <h.m.brand@xs4all.nl>
 558
 559 =head1 COPYRIGHT AND LICENSE
 560
 561 Copyright (C) 2008-2009 H.Merijn Brand
 562
 563 This library is free software; you can redistribute it and/or modify
 564 it under the same terms as Perl itself.
 565
 566 =cut