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

   1 package CGI::Ex::Dump;
   2
   3 ### CGI Extended Data::Dumper Extension
   4
   5 ###----------------------------------------------------------------###
   6 #  Copyright 2004 - Paul Seamons                                     #
   7 #  Distributed under the Perl Artistic License without warranty      #
   8 ###----------------------------------------------------------------###
   9
  10 ### See perldoc at bottom
  11
  12 use vars qw(@ISA @EXPORT @EXPORT_OK $ON $SUB $QR1 $QR2 $full_filename);
  13 use strict;
  14 use Exporter;
  15
  16 @ISA       = qw(Exporter);
  17 @EXPORT    = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
  18 @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug what_is_this);
  19
  20 ### is on or off
  21 sub on  { $ON = 1 };
  22 sub off { $ON = 0; }
  23 &on();
  24
  25 sub set_deparse {
  26   $Data::Dumper::Deparse = eval {require B::Deparse};
  27 }
  28
  29 ###----------------------------------------------------------------###
  30
  31 BEGIN {
  32   ### setup the Data::Dumper usage
  33   $Data::Dumper::Sortkeys  = 1    if ! defined $Data::Dumper::Sortkeys; # not avail pre 5.8
  34   $Data::Dumper::Useqq     = 1    if ! defined $Data::Dumper::Useqq;
  35   $Data::Dumper::Quotekeys = 0    if ! defined $Data::Dumper::Quotekeys;
  36   $Data::Dumper::Pad       = '  ' if ! defined $Data::Dumper::Pad;
  37   #$Data::Dumper::Deparse   = 1    if ! defined $Data::Dumper::Deparse; # very useful
  38   $SUB = sub {
  39     require Data::Dumper;
  40     return Data::Dumper->Dumpperl(\@_);
  41   };
  42
  43   ### how to display or parse the filename
  44   $QR1 = qr{\A(?:/[^/]+){2,}/(?:perl|lib)/(.+)\Z};
  45   $QR2 = qr{\A.+?([\w\.\-]+/[\w\.\-]+)\Z};
  46 }
  47
  48 ###----------------------------------------------------------------###
  49
  50
  51 ### same as dumper but with more descriptive output and auto-formatting
  52 ### for cgi output
  53 sub what_is_this {
  54   return if ! $ON;
  55   ### figure out which sub we called
  56   my ($pkg, $file, $line_n, $called) = caller(0);
  57   ($pkg, $file, $line_n, $called) = caller(1) if $pkg eq __PACKAGE__;
  58   substr($called, 0, length(__PACKAGE__) + 2, '');
  59
  60   ### get the actual line
  61   my $line = '';
  62   if (open(IN,$file)) {
  63     $line = <IN> for 1 .. $line_n;
  64     close IN;
  65   }
  66
  67   ### get rid of extended filename
  68   if (! $full_filename) {
  69     $file =~ s/$QR1/$1/ || $file =~ s/$QR2/$1/;
  70   }
  71
  72   ### dump it out
  73   my @dump = map {&$SUB($_)} @_;
  74   my @var  = ('$VAR') x ($#dump + 1);
  75   if ($line =~ s/^ .*\b \Q$called\E ( \(?\s* | \s+ )//x
  76       && $line =~ s/(?:\s+if\s+.+)? ;? \s*$//x) {
  77     $line =~ s/ \s*\) $ //x if $1 && $1 =~ /\(/;
  78     my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line);
  79     @var = @_var if $#var == $#_var;
  80   }
  81
  82   ### spit it out
  83   if ($called eq 'dex_text'
  84       || $called eq 'dex_warn'
  85       || ! $ENV{REQUEST_METHOD}) {
  86     my $txt = "$called: $file line $line_n\n";
  87     for (0 .. $#dump) {
  88       $dump[$_] =~ s|\$VAR1|$var[$_]|g;
  89       $txt .= $dump[$_];
  90     }
  91     if    ($called eq 'dex_text') { return $txt }
  92     elsif ($called eq 'dex_warn') { warn  $txt  }
  93     else                          { print $txt  }
  94   } else {
  95     my $html = "<pre><b>$called: $file line $line_n</b>\n";
  96     for (0 .. $#dump) {
  97       $dump[$_] =~ s/\\n/\n/g;
  98       $dump[$_] = _html_quote($dump[$_]);
  99       $dump[$_] =~ s|\$VAR1|<b>$var[$_]</b>|g;
 100       $html .= $dump[$_];
 101     }
 102     $html .= "</pre>\n";
 103     return $html if $called eq 'dex_html';
 104     require CGI::Ex;
 105     &CGI::Ex::print_content_type();
 106     print $html;
 107   }
 108 }
 109
 110 ### some aliases
 111 sub debug    { &what_is_this }
 112 sub dex      { &what_is_this }
 113 sub dex_warn { &what_is_this }
 114 sub dex_text { &what_is_this }
 115 sub dex_html { &what_is_this }
 116
 117 sub _html_quote {
 118   my $value = shift;
 119   return '' if ! defined $value;
 120   $value =~ s/&/&amp;/g;
 121   $value =~ s/</&lt;/g;
 122   $value =~ s/>/&gt;/g;
 123 #  $value =~ s/\"/&quot;/g;
 124   return $value;
 125 }
 126
 127 ### ctrace is intended for work with perl 5.8 or higher's Carp
 128 sub ctrace {
 129   require 5.8.0;
 130   require Carp::Heavy;
 131   local $Carp::MaxArgNums = 3;
 132   local $Carp::MaxArgLen  = 20;
 133   my $i = shift || 0;
 134   my @i = ();
 135   my $max1 = 0;
 136   my $max2 = 0;
 137   my $max3 = 0;
 138   while (my %i = &Carp::caller_info(++$i)) {
 139     $i{sub_name} =~ s/\((.*)\)$//;
 140     $i{args} = $i{has_args} ? $1 : "";
 141     $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
 142     $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
 143     $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
 144     $max2 = length($i{file})     if length($i{file})     > $max2;
 145     $max3 = length($i{line})     if length($i{line})     > $max3;
 146     push @i, \%i;
 147   }
 148   foreach my $ref (@i) {
 149     $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
 150       . ($ref->{args} ? " ($ref->{args})" : "");
 151   }
 152   return \@i;
 153 }
 154
 155 sub dex_trace {
 156   &what_is_this(ctrace(1));
 157 }
 158
 159 ###----------------------------------------------------------------###
 160
 161 1;
 162
 163 __END__
 164
 165 =head1 NAME
 166
 167 CGI::Ex::Dump - A debug utility
 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