Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Dump.pm

   1 package CGI::Ex::Dump;
   2
   3 =head1 NAME
   4
   5 CGI::Ex::Dump - A debug utility
   6
   7 =cut
   8
   9 ###----------------------------------------------------------------###
  10 #  Copyright 2004-2012 - Paul Seamons                                #
  11 #  Distributed under the Perl Artistic License without warranty      #
  12 ###----------------------------------------------------------------###
  13
  14 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION
  15             $CALL_LEVEL
  16             $ON $SUB $QR1 $QR2 $full_filename $DEPARSE);
  17 use strict;
  18 use Exporter;
  19
  20 $VERSION   = '2.37';
  21 @ISA       = qw(Exporter);
  22 @EXPORT    = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
  23 @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug caller_trace);
  24
  25 ### is on or off
  26 sub on  { $ON = 1 };
  27 sub off { $ON = 0; }
  28
  29 sub set_deparse { $DEPARSE = 1 }
  30
  31 ###----------------------------------------------------------------###
  32
  33 BEGIN {
  34   on();
  35
  36   $SUB = sub {
  37     ### setup the Data::Dumper usage
  38     local $Data::Dumper::Deparse   = $DEPARSE && eval {require B::Deparse};
  39     local $Data::Dumper::Pad       = '  ';
  40     local $Data::Dumper::Sortkeys  = 1;
  41     local $Data::Dumper::Useqq     = 1;
  42     local $Data::Dumper::Quotekeys = 0;
  43
  44     require Data::Dumper;
  45     return Data::Dumper->Dumpperl(\@_);
  46   };
  47
  48   ### how to display or parse the filename
  49   $QR1 = qr{\A(?:/[^/]+){2,}/(?:perl|lib)/(.+)\Z};
  50   $QR2 = qr{\A.+?([\w\.\-]+/[\w\.\-]+)\Z};
  51 }
  52
  53 ###----------------------------------------------------------------###
  54
  55
  56 ### same as dumper but with more descriptive output and auto-formatting
  57 ### for cgi output
  58 sub _what_is_this {
  59   return if ! $ON;
  60   ### figure out which sub we called
  61   my ($pkg, $file, $line_n, $called) = caller(1 + ($CALL_LEVEL || 0));
  62   substr($called, 0, length(__PACKAGE__) + 2, '');
  63
  64   ### get the actual line
  65   my $line = '';
  66   if (open(IN,$file)) {
  67     $line = <IN> for 1 .. $line_n;
  68     close IN;
  69   }
  70
  71   ### get rid of extended filename
  72   if (! $full_filename) {
  73     $file =~ s/$QR1/$1/ || $file =~ s/$QR2/$1/;
  74   }
  75
  76   ### dump it out
  77   my @dump = map {&$SUB($_)} @_;
  78   my @var  = ('$VAR') x ($#dump + 1);
  79   my $hold;
  80   if ($line =~ s/^ .*\b \Q$called\E ( \s* \( \s* | \s+ )//x
  81       && ($hold = $1)
  82       && (   $line =~ s/ \s* \b if \b .* \n? $ //x
  83           || $line =~ s/ \s* ; \s* $ //x
  84           || $line =~ s/ \s+ $ //x)) {
  85     $line =~ s/ \s*\) $ //x if $hold =~ /^\s*\(/;
  86     my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line);
  87     @var = @_var if $#var == $#_var;
  88   }
  89
  90   ### spit it out
  91   if ($called eq 'dex_text'
  92       || $called eq 'dex_warn'
  93       || ! $ENV{REQUEST_METHOD}) {
  94     my $txt = "$called: $file line $line_n\n";
  95     for (0 .. $#dump) {
  96       $dump[$_] =~ s|\$VAR1|$var[$_]|g;
  97       $txt .= $dump[$_];
  98     }
  99     if    ($called eq 'dex_text') { return $txt }
 100     elsif ($called eq 'dex_warn') { warn  $txt  }
 101     else                          { print $txt  }
 102   } else {
 103     my $html = "<pre class=debug><span class=debughead><b>$called: $file line $line_n</b></span>\n";
 104     for (0 .. $#dump) {
 105       $dump[$_] =~ s/(?<!\\)\\n/\n/g;
 106       $dump[$_] = _html_quote($dump[$_]);
 107       $dump[$_] =~ s|\$VAR1|<span class=debugvar><b>$var[$_]</b></span>|g;
 108       $html .= $dump[$_];
 109     }
 110     $html .= "</pre>\n";
 111     return $html if $called eq 'dex_html';
 112     require CGI::Ex;
 113     CGI::Ex::print_content_type();
 114     ($CGI::Ex::CURRENT || CGI::Ex->new)->print_body($html);
 115   }
 116   return @_[0..$#_];
 117 }
 118
 119 ### some aliases
 120 sub debug    { &_what_is_this }
 121 sub dex      { &_what_is_this }
 122 sub dex_warn { &_what_is_this }
 123 sub dex_text { &_what_is_this }
 124 sub dex_html { &_what_is_this }
 125
 126 sub _html_quote {
 127   my $value = shift;
 128   return '' if ! defined $value;
 129   $value =~ s/&/&amp;/g;
 130   $value =~ s/</&lt;/g;
 131   $value =~ s/>/&gt;/g;
 132 #  $value =~ s/\"/&quot;/g;
 133   return $value;
 134 }
 135
 136 ### ctrace is intended for work with perl 5.8 or higher's Carp
 137 sub ctrace {
 138   require 5.8.0;
 139   require Carp::Heavy;
 140   local $Carp::MaxArgNums = 3;
 141   local $Carp::MaxArgLen  = 20;
 142   my $i = shift || 0;
 143   my @i = ();
 144   my $max1 = 0;
 145   my $max2 = 0;
 146   my $max3 = 0;
 147   while (my %i = Carp::caller_info(++$i)) {
 148     $i{sub_name} =~ s/\((.*)\)$//;
 149     $i{args} = $i{has_args} ? $1 : "";
 150     $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
 151     $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
 152     $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
 153     $max2 = length($i{file})     if length($i{file})     > $max2;
 154     $max3 = length($i{line})     if length($i{line})     > $max3;
 155     push @i, \%i;
 156   }
 157   foreach my $ref (@i) {
 158     $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
 159       . ($ref->{args} ? " ($ref->{args})" : "");
 160   }
 161   return \@i;
 162 }
 163
 164 *caller_trace = \&ctrace;
 165
 166 sub dex_trace {
 167   _what_is_this(ctrace(1));
 168 }
 169
 170 ###----------------------------------------------------------------###
 171
 172 1;
 173
 174 __END__
 175
 176 =head1 SYNOPSIS
 177
 178   use CGI::Ex::Dump; # auto imports dex, dex_warn, dex_text and others
 179
 180   my $hash = {
 181     foo => ['a', 'b', 'Foo','a', 'b', 'Foo','a', 'b', 'Foo','a'],
 182   };
 183
 184   dex $hash; # or dex_warn $hash;
 185
 186   dex;
 187
 188   dex "hi";
 189
 190   dex $hash, "hi", $hash;
 191
 192   dex \@INC; # print to STDOUT, or format for web if $ENV{REQUEST_METHOD}
 193
 194   dex_warn \@INC;  # same as dex but to STDOUT
 195
 196   print FOO dex_text \@INC; # same as dex but return dump
 197
 198   # ALSO #
 199
 200   use CGI::Ex::Dump qw(debug);
 201
 202   debug; # same as dex
 203
 204 =head1 DESCRIPTION
 205
 206 Uses the base Data::Dumper of the distribution and gives it nicer formatting - and
 207 allows for calling just about anytime during execution.
 208
 209 Calling &CGI::Ex::set_deparse() will allow for dumped output of subroutines
 210 if available.
 211
 212 perl -e 'use CGI::Ex::Dump;  dex "foo";'
 213
 214 See also L<Data::Dumper>.
 215
 216 Setting any of the Data::Dumper globals will alter the output.
 217
 218 =head1 SUBROUTINES
 219
 220 =over 4
 221
 222 =item C<dex>, C<debug>
 223
 224 Prints out pretty output to STDOUT.  Formatted for the web if on the web.
 225
 226 =item C<dex_warn>
 227
 228 Prints to STDERR.
 229
 230 =item C<dex_text>
 231
 232 Return the text as a scalar.
 233
 234 =item C<ctrace>
 235
 236 Caller trace returned as an arrayref.  Suitable for use like "debug ctrace".
 237 This does require at least perl 5.8.0's Carp.
 238
 239 =item C<on>, C<off>
 240
 241 Turns calls to routines on or off.  Default is to be on.
 242
 243 =back
 244
 245 =head1 LICENSE
 246
 247 This module may distributed under the same terms as Perl itself.
 248
 249 =head1 AUTHORS
 250
 251 Paul Seamons <perl at seamons dot com>
 252
 253 =cut