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 2006 - 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);
  17 use strict;
  18 use Exporter;
  19
  20 $VERSION   = '2.02';
  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 &on();
  29
  30 sub set_deparse {
  31   $Data::Dumper::Deparse = eval {require B::Deparse};
  32 }
  33
  34 ###----------------------------------------------------------------###
  35
  36 BEGIN {
  37   ### setup the Data::Dumper usage
  38   $Data::Dumper::Sortkeys  = 1    if ! defined $Data::Dumper::Sortkeys; # not avail pre 5.8
  39   $Data::Dumper::Useqq     = 1    if ! defined $Data::Dumper::Useqq;
  40   $Data::Dumper::Quotekeys = 0    if ! defined $Data::Dumper::Quotekeys;
  41   $Data::Dumper::Pad       = '  ' if ! defined $Data::Dumper::Pad;
  42   #$Data::Dumper::Deparse   = 1    if ! defined $Data::Dumper::Deparse; # very useful
  43   $SUB = sub {
  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   if ($line =~ s/^ .*\b \Q$called\E ( \(?\s* | \s+ )//x
  80       && $line =~ s/(?:\s+if\s+.+)? ;? \s*$//x) {
  81     $line =~ s/ \s*\) $ //x if $1 && $1 =~ /\(/;
  82     my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line);
  83     @var = @_var if $#var == $#_var;
  84   }
  85
  86   ### spit it out
  87   if ($called eq 'dex_text'
  88       || $called eq 'dex_warn'
  89       || ! $ENV{REQUEST_METHOD}) {
  90     my $txt = "$called: $file line $line_n\n";
  91     for (0 .. $#dump) {
  92       $dump[$_] =~ s|\$VAR1|$var[$_]|g;
  93       $txt .= $dump[$_];
  94     }
  95     if    ($called eq 'dex_text') { return $txt }
  96     elsif ($called eq 'dex_warn') { warn  $txt  }
  97     else                          { print $txt  }
  98   } else {
  99     my $html = "<pre class=debug><span class=debughead><b>$called: $file line $line_n</b></span>\n";
 100     for (0 .. $#dump) {
 101       $dump[$_] =~ s/\\n/\n/g;
 102       $dump[$_] = _html_quote($dump[$_]);
 103       $dump[$_] =~ s|\$VAR1|<span class=debugvar><b>$var[$_]</b></span>|g;
 104       $html .= $dump[$_];
 105     }
 106     $html .= "</pre>\n";
 107     return $html if $called eq 'dex_html';
 108     require CGI::Ex;
 109     CGI::Ex::print_content_type();
 110     print $html;
 111   }
 112 }
 113
 114 ### some aliases
 115 sub debug    { &_what_is_this }
 116 sub dex      { &_what_is_this }
 117 sub dex_warn { &_what_is_this }
 118 sub dex_text { &_what_is_this }
 119 sub dex_html { &_what_is_this }
 120
 121 sub _html_quote {
 122   my $value = shift;
 123   return '' if ! defined $value;
 124   $value =~ s/&/&amp;/g;
 125   $value =~ s/</&lt;/g;
 126   $value =~ s/>/&gt;/g;
 127 #  $value =~ s/\"/&quot;/g;
 128   return $value;
 129 }
 130
 131 ### ctrace is intended for work with perl 5.8 or higher's Carp
 132 sub ctrace {
 133   require 5.8.0;
 134   require Carp::Heavy;
 135   local $Carp::MaxArgNums = 3;
 136   local $Carp::MaxArgLen  = 20;
 137   my $i = shift || 0;
 138   my @i = ();
 139   my $max1 = 0;
 140   my $max2 = 0;
 141   my $max3 = 0;
 142   while (my %i = Carp::caller_info(++$i)) {
 143     $i{sub_name} =~ s/\((.*)\)$//;
 144     $i{args} = $i{has_args} ? $1 : "";
 145     $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
 146     $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
 147     $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
 148     $max2 = length($i{file})     if length($i{file})     > $max2;
 149     $max3 = length($i{line})     if length($i{line})     > $max3;
 150     push @i, \%i;
 151   }
 152   foreach my $ref (@i) {
 153     $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
 154       . ($ref->{args} ? " ($ref->{args})" : "");
 155   }
 156   return \@i;
 157 }
 158
 159 sub dex_trace {
 160   _what_is_this(ctrace(1));
 161 }
 162
 163 ###----------------------------------------------------------------###
 164
 165 1;
 166
 167 __END__
 168
 169 =head1 SYNOPSIS
 170
 171   use CGI::Ex::Dump; # auto imports dex, dex_warn, dex_text and others
 172
 173   my $hash = {
 174     foo => ['a', 'b', 'Foo','a', 'b', 'Foo','a', 'b', 'Foo','a'],
 175   };
 176
 177   dex $hash; # or dex_warn $hash;
 178
 179   dex;
 180
 181   dex "hi";
 182
 183   dex $hash, "hi", $hash;
 184
 185   dex \@INC; # print to STDOUT, or format for web if $ENV{REQUEST_METHOD}
 186
 187   dex_warn \@INC;  # same as dex but to STDOUT
 188
 189   print FOO dex_text \@INC; # same as dex but return dump
 190
 191   # ALSO #
 192
 193   use CGI::Ex::Dump qw(debug);
 194
 195   debug; # same as dex
 196
 197 =head1 DESCRIPTION
 198
 199 Uses the base Data::Dumper of the distribution and gives it nicer formatting - and
 200 allows for calling just about anytime during execution.
 201
 202 Calling &CGI::Ex::set_deparse() will allow for dumped output of subroutines
 203 if available.
 204
 205 perl -e 'use CGI::Ex::Dump;  dex "foo";'
 206
 207 See also L<Data::Dumper>.
 208
 209 Setting any of the Data::Dumper globals will alter the output.
 210
 211 =head1 SUBROUTINES
 212
 213 =over 4
 214
 215 =item C<dex>, C<debug>
 216
 217 Prints out pretty output to STDOUT.  Formatted for the web if on the web.
 218
 219 =item C<dex_warn>
 220
 221 Prints to STDERR.
 222
 223 =item C<dex_text>
 224
 225 Return the text as a scalar.
 226
 227 =item C<ctrace>
 228
 229 Caller trace returned as an arrayref.  Suitable for use like "debug ctrace".
 230 This does require at least perl 5.8.0's Carp.
 231
 232 =item C<on>, C<off>
 233
 234 Turns calls to routines on or off.  Default is to be on.
 235
 236 =back
 237
 238 =head1 AUTHORS
 239
 240 Paul Seamons <perlspam at seamons dot com>
 241
 242 =cut