view release on metacpan or  search on metacpan

lib/CGI/Ex/Dump.pm  view on Meta::CPAN

=head1 NAME

CGI::Ex::Dump - A debug utility

=head1 VERSION

version 2.55

=cut

###----------------------------------------------------------------###
#  Copyright - Paul Seamons                                          #
#  Distributed under the Perl Artistic License without warranty      #
###----------------------------------------------------------------###

use vars qw($CALL_LEVEL $ON $SUB $QR1 $QR2 $full_filename $DEPARSE);
use strict;
use Exporter qw(import);

our $VERSION = '2.55'; # VERSION
our @EXPORT    = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
our @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug caller_trace);

### is on or off
sub on  { $ON = 1 };
sub off { $ON = 0; }

sub set_deparse { $DEPARSE = 1 }

###----------------------------------------------------------------###

BEGIN {
  on();

  $SUB = sub {
    ### setup the Data::Dumper usage
    local $Data::Dumper::Deparse   = $DEPARSE && eval {require B::Deparse};
    local $Data::Dumper::Pad       = '  ';
    local $Data::Dumper::Sortkeys  = 1;
    local $Data::Dumper::Useqq     = 1;
    local $Data::Dumper::Quotekeys = 0;

    require Data::Dumper;
    return Data::Dumper->Dumpperl(\@_);
  };

  ### how to display or parse the filename
  $QR1 = qr{\A(?:/[^/]+){2,}/(?:perl|lib)/(.+)\Z};
  $QR2 = qr{\A.+?([\w\.\-]+/[\w\.\-]+)\Z};
}

###----------------------------------------------------------------###


### same as dumper but with more descriptive output and auto-formatting
### for cgi output
sub _what_is_this {
  return if ! $ON;
  ### figure out which sub we called
  my ($pkg, $file, $line_n, $called) = caller(1 + ($CALL_LEVEL || 0));
  substr($called, 0, length(__PACKAGE__) + 2, '');

  ### get the actual line
  my $line = '';
  if (open(IN,$file)) {
    $line = <IN> for 1 .. $line_n;
    close IN;
  }

  ### get rid of extended filename
  if (! $full_filename) {
    $file =~ s/$QR1/$1/ || $file =~ s/$QR2/$1/;
  }

  ### dump it out
  my @dump = map {&$SUB($_)} @_;
  my @var  = ('$VAR') x ($#dump + 1);
  my $hold;
  if ($line =~ s/^ .*\b \Q$called\E ( \s* \( \s* | \s+ )//x
      && ($hold = $1)
      && (   $line =~ s/ \s* \b if \b .* \n? $ //x
          || $line =~ s/ \s* ; \s* $ //x
          || $line =~ s/ \s+ $ //x)) {
    $line =~ s/ \s*\) $ //x if $hold =~ /^\s*\(/;
    my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line);
    @var = @_var if $#var == $#_var;
  }

  ### spit it out
  if ($called eq 'dex_text'
      || $called eq 'dex_warn'
      || ! $ENV{REQUEST_METHOD}) {
    my $txt = "$called: $file line $line_n\n";
    for (0 .. $#dump) {
      $dump[$_] =~ s|\$VAR1|$var[$_]|g;
      $txt .= $dump[$_];
    }
    if    ($called eq 'dex_text') { return $txt }
    elsif ($called eq 'dex_warn') { warn  $txt  }
    else                          { print $txt  }
  } else {
    my $html = "<pre class=debug><span class=debughead><b>$called: $file line $line_n</b></span>\n";
    for (0 .. $#dump) {
      $dump[$_] =~ s/(?<!\\)\\n/\n/g;
      $dump[$_] = _html_quote($dump[$_]);
      $dump[$_] =~ s|\$VAR1|<span class=debugvar><b>$var[$_]</b></span>|g;
      $html .= $dump[$_];
    }
    $html .= "</pre>\n";
    return $html if $called eq 'dex_html';
    require CGI::Ex;
    CGI::Ex::print_content_type();
    print $html;
  }
  return @_[0..$#_];
}

### some aliases
sub debug    { &_what_is_this }
sub dex      { &_what_is_this }