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