File Coverage

lib/Data/Dumper/Simple.pm

Criterion	Covered	Total	%
statement	35	39	89.7
branch	8	10	80.0
condition	2	3	66.6
subroutine	7	8	87.5
pod			n/a
total	52	60	86.6

package Data::Dumper::Simple;

$REVISION = '$Id: Simple.pm,v 1.10 2005/05/20 01:37:08 ovid Exp $';
$VERSION  = '0.11';
use Filter::Simple;
use Data::Dumper ();
use strict;

my $DUMPER_FUNCTION = 'Dumper';
my $AUTOWARN;

my $COMMA      = qr/(?:,|=>)/;
my $ATOM       = qr/(?!\d)[[:word:]]+/;
my $SEP        = qr/::/;
my $NAME       = qr/$SEP?$ATOM(?:$SEP$ATOM)*/;

my $SCALAR     = qr/\$$NAME/;
my $ARRAY_ELEM = qr/\$$NAME\[[^]]+\]/;
my $ARRAY      = qr/\@$NAME/;
my $HASH_ELEM  = qr/\$$NAME\{[^}]+\}/;
my $HASH       = qr/\%$NAME/;

my $VAR        = qr/(?:$ARRAY|$HASH|$ARRAY_ELEM|$HASH_ELEM|$SCALAR)/;
my $END_STMT   = qr/(?=\s*[;}])/;

my $ARG_LIST   = qr/$VAR(?:\s*$COMMA\s*$VAR)*$END_STMT/;
my $PAREN_LIST = qr/\([^)]+\)/;

sub import {
    my ( $class, @args ) = @_;
    @args = $class->_validate_args(@args);
    my %args = @args;
    $DUMPER_FUNCTION = $args{as}       if $args{as};
    $AUTOWARN        = $args{autowarn} if $args{autowarn};
}

FILTER_ONLY executable =>
  sub {    # not using code due to a possible bug in Filter::Simple
    s{
            $DUMPER_FUNCTION\s*($PAREN_LIST|$ARG_LIST)
        }{
            my $args = $1;
            $args =~ s/^\((.*)\)$/$1/s;        # strip parens, if any
            my ($references, $names) = _munge_argument_list($args);
            # keep it on a single line so users can comment it out
            my $output = "Data::Dumper->Dump( [$references], [qw/$names/] )";
            if ($AUTOWARN) {
                $output = "$AUTOWARN($output)";
            }
            "($output)"; # parens prevent accidental indirect method syntax
        }gex
  };

sub _validate_args {
    my ( $class, @args ) = @_;
    if ( @args % 2 ) {
        _croak("$class->import requires an even sized list");
    }
    my %args = @args;
    if ( $args{as} && !_valid_sub_name( $args{as} ) ) {
        _croak("$args{as} is not a valid name for a subroutine");
    }
    if ( $args{autowarn} ) {
        $args{autowarn} = 'warn' unless _valid_sub_name( $args{autowarn} );
    }
    return %args;
}

sub _valid_sub_name { shift =~ /^[[:alpha:]][[:word:]]*$/ }

sub _croak {
    require Carp;
    Carp::croak(shift);
}

sub _munge_argument_list {
    my $arguments     = shift;
    my $sigils        = '@%&';
    my @raw_var_names =
      map { _strip_whitespace($_) }
      split /(?:,|=>)/ => $arguments;
    my @raw_escaped = @raw_var_names;
    my $varnames = join ' ' => map {
        s/(\\)?[$sigils]/$1 ? '$' : '*'/ge;
        s/\\//g;
        $_
      }    # turn @array into => [$*]array
      @raw_var_names;

    my $escaped_vars =
      join ', ' => map { s/\\\$/\$/g; $_ } # do not take a reference to a scalar
      map { s/(?
      @raw_escaped;
    return ( $escaped_vars, $varnames );
}

sub _strip_whitespace {
    $_[0] =~ s/\s//g;
    return $_[0];
}

1;

__END__