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 2007 - 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.07';
  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);
  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     print $html;
 115   }
 116 }
 117
 118 ### some aliases
 119 sub debug    { &_what_is_this }
 120 sub dex      { &_what_is_this }
 121 sub dex_warn { &_what_is_this }
 122 sub dex_text { &_what_is_this }
 123 sub dex_html { &_what_is_this }
 124
 125 sub _html_quote {
 126   my $value = shift;
 127   return '' if ! defined $value;
 128   $value =~ s/&/&amp;/g;
 129   $value =~ s/</&lt;/g;
 130   $value =~ s/>/&gt;/g;
 131 #  $value =~ s/\"/&quot;/g;
 132   return $value;
 133 }
 134
 135 ### ctrace is intended for work with perl 5.8 or higher's Carp
 136 sub ctrace {
 137   require 5.8.0;
 138   require Carp::Heavy;
 139   local $Carp::MaxArgNums = 3;
 140   local $Carp::MaxArgLen  = 20;
 141   my $i = shift || 0;
 142   my @i = ();
 143   my $max1 = 0;
 144   my $max2 = 0;
 145   my $max3 = 0;
 146   while (my %i = Carp::caller_info(++$i)) {
 147     $i{sub_name} =~ s/\((.*)\)$//;
 148     $i{args} = $i{has_args} ? $1 : "";
 149     $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
 150     $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
 151     $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
 152     $max2 = length($i{file})     if length($i{file})     > $max2;
 153     $max3 = length($i{line})     if length($i{line})     > $max3;
 154     push @i, \%i;
 155   }
 156   foreach my $ref (@i) {
 157     $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
 158       . ($ref->{args} ? " ($ref->{args})" : "");
 159   }
 160   return \@i;
 161 }
 162
 163 sub dex_trace {
 164   _what_is_this(ctrace(1));
 165 }
 166
 167 ###----------------------------------------------------------------###
 168
 169 1;
 170
 171 __END__
 172
 173 =head1 SYNOPSIS
 174
 175   use CGI::Ex::Dump; # auto imports dex, dex_warn, dex_text and others
 176
 177   my $hash = {
 178     foo => ['a', 'b', 'Foo','a', 'b', 'Foo','a', 'b', 'Foo','a'],
 179   };
 180
 181   dex $hash; # or dex_warn $hash;
 182
 183   dex;
 184
 185   dex "hi";
 186
 187   dex $hash, "hi", $hash;
 188
 189   dex \@INC; # print to STDOUT, or format for web if $ENV{REQUEST_METHOD}
 190
 191   dex_warn \@INC;  # same as dex but to STDOUT
 192
 193   print FOO dex_text \@INC; # same as dex but return dump
 194
 195   # ALSO #
 196
 197   use CGI::Ex::Dump qw(debug);
 198
 199   debug; # same as dex
 200
 201 =head1 DESCRIPTION
 202
 203 Uses the base Data::Dumper of the distribution and gives it nicer formatting - and
 204 allows for calling just about anytime during execution.
 205
 206 Calling &CGI::Ex::set_deparse() will allow for dumped output of subroutines
 207 if available.
 208
 209 perl -e 'use CGI::Ex::Dump;  dex "foo";'
 210
 211 See also L<Data::Dumper>.
 212
 213 Setting any of the Data::Dumper globals will alter the output.
 214
 215 =head1 SUBROUTINES
 216
 217 =over 4
 218
 219 =item C<dex>, C<debug>
 220
 221 Prints out pretty output to STDOUT.  Formatted for the web if on the web.
 222
 223 =item C<dex_warn>
 224
 225 Prints to STDERR.
 226
 227 =item C<dex_text>
 228
 229 Return the text as a scalar.
 230
 231 =item C<ctrace>
 232
 233 Caller trace returned as an arrayref.  Suitable for use like "debug ctrace".
 234 This does require at least perl 5.8.0's Carp.
 235
 236 =item C<on>, C<off>
 237
 238 Turns calls to routines on or off.  Default is to be on.
 239
 240 =back
 241
 242 =head1 AUTHORS
 243
 244 Paul Seamons <perlspam at seamons dot com>
 245
 246 =cut