File Coverage

blib/lib/CGI/Ex/Dump.pm

Criterion	Covered	Total	%
statement	14	95	14.7
branch	0	38	0.0
condition	0	22	0.0
subroutine	5	16	31.2
pod	7	10	70.0
total	26	181	14.3

package CGI::Ex::Dump;

=head1 NAME

CGI::Ex::Dump - A debug utility

=head1 VERSION

version 2.52

=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.52'; # 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 =  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 = "$called: $file line $line_n\n";
    for (0 .. $#dump) {
      $dump[$_] =~ s/(?
      $dump[$_] = _html_quote($dump[$_]);
      $dump[$_] =~ s|\$VAR1|$var[$_]|g;
      $html .= $dump[$_];
    }
    $html .= "\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 }
sub dex_warn { &_what_is_this }
sub dex_text { &_what_is_this }
sub dex_html { &_what_is_this }

sub _html_quote {
  my $value = shift;
  return '' if ! defined $value;
  $value =~ s/&/&/g;
  $value =~ s/
  $value =~ s/>/>/g;
#  $value =~ s/\"/"/g;
  return $value;
}

### ctrace is intended for work with perl 5.8 or higher's Carp
sub ctrace {
  require 5.8.0;
  require Carp::Heavy;
  local $Carp::MaxArgNums = 3;
  local $Carp::MaxArgLen  = 20;
  my $i = shift || 0;
  my @i = ();
  my $max1 = 0;
  my $max2 = 0;
  my $max3 = 0;
  while (my %i = Carp::caller_info(++$i)) {
    $i{sub_name} =~ s/\((.*)\)$//;
    $i{args} = $i{has_args} ? $1 : "";
    $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
    $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
    $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
    $max2 = length($i{file})     if length($i{file})     > $max2;
    $max3 = length($i{line})     if length($i{line})     > $max3;
    push @i, \%i;
  }
  foreach my $ref (@i) {
    $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
      . ($ref->{args} ? " ($ref->{args})" : "");
  }
  return \@i;
}

*caller_trace = \&ctrace;

sub dex_trace {
  _what_is_this(ctrace(1));
}

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

1;

__END__