File Coverage

blib/lib/Data/HTMLDumper.pm

Criterion	Covered	Total	%
statement	33	39	84.6
branch	3	4	75.0
condition			n/a
subroutine	10	12	83.3
pod	0	4	0.0
total	46	59	77.9

package Data::HTMLDumper;
use strict; use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
	Dumper
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	Dumper
);

our $VERSION = '0.08';

use Data::HTMLDumper::Output;
use Data::Dumper ();
use Parse::RecDescent;

our $actions  = new Data::HTMLDumper::Output();
our $Maxdepth;
our $Varname;
our $Sortkeys;

tie $Maxdepth, 'SpecialVars', \$Data::Dumper::Maxdepth;
tie $Varname,  'SpecialVars', \$Data::Dumper::Varname;
tie $Sortkeys, 'SpecialVars', \$Data::Dumper::Sortkeys;

sub actions {
    my $class   = shift;
    my $new_val = shift;

    $actions    = $new_val if (defined $new_val);
    return $actions;
}

#$::RD_HINT = 1;
#$::RD_TRACE = 1;

my $grammar = q{
    { our $actions = sub { return Data::HTMLDumper::actions(); } }
    output : expression(s) { &{$actions}->output($item[1]) }

    expression : SIGIL ID_NAME '=' item ';' {
                     &{$actions}->expression(%item);
                 }
               |

    item : value       COMMA(?) { &{$actions}->item_value ($item{value},
                                                            $arg[0])     }
         | array       COMMA(?) { &{$actions}->item_array ($item{array}) }
         | hash        COMMA(?) { &{$actions}->item_hash  ($item{hash} ) }
         | object      COMMA(?) { &{$actions}->item_object($item{object})}
         | inside_out_object COMMA(?) {
                &{$actions}->item_inside_out_object(
                    $item{inside_out_object}
                );
           }

    array  : '[' item(s) ']'    { &{$actions}->array($item{'item(s)'}) }
           | '[' ']'            { &{$actions}->array_empty()           }

    hash   : '{' pair(s) '}'    { &{$actions}->hash($item{'pair(s)'}) }
           | '{' '}'            { &{$actions}->hash_empty()           }

    pair   : string '=>' item['make_row'] {
        &{$actions}->pair($item{string}, $item{item});
    }

    object : 'bless(' item string ')' {
        &{$actions}->object($item{item}, $item{string});
    }

    inside_out_object : 'bless(' do_block COMMA string ')' {
        &{$actions}->inside_out_object($item{do_block}, $item{string});
    }

    do_block : 'do' '{' NOT_BRACE '}' { $item{NOT_BRACE}; }

    NOT_BRACE : /[^\}]*/ { $item[1]; }

    value : string | NUMBER | 'undef'

    string : TICK text TICK { &{$actions}->string($item{text}) }

    KEY_NAME : /[.\w\d_]+/

    ID_NAME  : /\w[\w\d_]*/

    NUMBER : /[+-]?(\d\.?\d*|\d*.\d+)/

    SIGIL : '$' | '@' | '%'

    text  : text_letter(s)     {local $" = "", "@{$item{'text_letter(s)'}}" }

    text_letter : ESCAPED_TICK
                | NON_TICK

    NON_TICK : /[^'\\\]*/

    ESCAPED_TICK : /(\\\')/  { "'" }

    COMMA : ','

    TICK  : "'"
};

#    do_block : 'do' '{' /[^}]*/ '}' { $item[3]; }

my $parse   = new Parse::RecDescent($grammar);

sub Dumper  {
    my $original_output = Data::Dumper::Dumper(@_);
    my $output          = $parse->output($original_output);
    return $output;
}

sub new {
    my $class  = shift;
    my $dumper = Data::Dumper->new(@_);

    return bless {dumper => $dumper}, $class;
}

sub Dump {
    my $invocant = shift;
    my $original_output;
    my $output;

    if (ref $invocant) { $original_output = $invocant->{dumper}->Dump(@_); }
    else               { $original_output = Data::Dumper->Dump(@_);        }

    return $parse->output($original_output);
}

package SpecialVars;

sub TIESCALAR {
    my $class      = shift;
    my $dumper_var = shift;

    return bless $dumper_var, $class;
}

sub FETCH {
    my $self = shift;

    return $$self;
}

sub STORE {
    my $self  = shift;
    my $value = shift;

    $$self = $value;
}

1;
__END__