File Coverage

blib/lib/Data/Dx.pm

Criterion	Covered	Total	%
statement	77	116	66.3
branch	16	32	50.0
condition	12	26	46.1
subroutine	18	22	81.8
pod			n/a
total	123	196	62.7

package Data::Dx;

use 5.012;
use utf8;
use warnings;

our $VERSION = '0.000008';

use Keyword::Declare;

my %COLOUR = (
    key     => 'bold ansi136',  # Soft orange
    value   => 'cyan',
    punct   => 'bold ansi245',  # Mid-grey
    comment => 'blue',
);

my @OUTPUT;
BEGIN { @OUTPUT = \*STDERR }

sub _dx {
    my ($expr) = @_;
    use List::Util 'max';

    # Flatten the expression to a single line...
    $expr =~ s{\s+}{ }g;

    # Simple arrays and hashes need to be dumped by reference...
    my $ref = $expr =~ /^[\@%][\w:]++$/ ? q{\\} : q{};

    # How much to indent...
    my $indent = ' ' x (length($expr) + 3);

    # Handle unbalanced {...} in the expression...
    my $str_expr = $expr;
       $str_expr =~ s{ ( [\\\{\}] ) }{\\$1}xmsg;

    # Generate the source...
    return qq{Data::Dx::_format_data(__LINE__, __FILE__, q{$str_expr}, q{$indent}, $ref $expr);};
}


sub import {
    my (undef, $opt_ref) = @_;

    # Lexical colour control...
    $^H{'Data::Dx no_colour'} = 1
        if exists($opt_ref->{colour}) && !$opt_ref->{colour};

    # Lexical output redirect...
    if ($opt_ref->{to}) {
        $^H{'Data::Dx output'} = @OUTPUT;
        push @OUTPUT, $opt_ref->{to};
    }

    keyword Dx (Expr $expr) { _dx($expr) }
    keyword Dₓ (Expr $expr) { _dx($expr) }

}

sub unimport {
    keyword Dx (Expr $expr) { }
    keyword Dₓ (Expr $expr) { }
}

sub _color {
    state $colorer = eval {
            require Win32::Console::ANSI if $^O eq 'MSWin32';
            require Term::ANSIColor;
            sub { return shift if ((caller 1)[10]//{})->{'Data::Dx no_colour'}
                            || ((caller 2)[10]//{})->{'Data::Dx no_colour'};
                 goto &Term::ANSIColor::colored;
            }
    } // sub { shift };
    $colorer->(@_);
}

sub _format_data {
    # Unpack leadings args...
    my $linenum  = shift;
    my $filename = shift;
    my $expr     = shift;
    my $indent   = shift;

    # Serialize any Contextual::Return::Value objects (which break dump())...
    for my $arg (@_) {
        if ((ref($arg)||q{}) =~ m{\A Contextual::Return}xms) {
            require Contextual::Return;
            Contextual::Return::FREEZE($arg);
        }
    }

    # Then repack data...
    my $data     = @_ > 1 ? [@_] : shift;

    # Lexical configurations...
    my $hint = ((caller 0)[10] // {});

    # Dump the data...
    my $dump;
    if (!defined $data) {
        $dump = _color('undef', $COLOUR{value});
    }
    else {
        use Data::Dump 'dump';
        $dump = dump($data);

        if (!$hint->{'Data::Dx no_colour'}) {
            my $bw_dump = $dump;
            $dump = q{};
            $bw_dump
                =~ s{ $PPR::GRAMMAR
                      (?: (?     (?: (?&PerlString) | (?&PerlBareword) )   (?= \s*+ => ) )
                      |   (? (?&PerlLiteral) | sub \s*+ { \s*+ ... \s*+ } )
                      |   (?   \S                                           )
                      |   (?   .                                            )
                      )
                     }{
                        $dump .= exists $+{key}     ? _color( "$+{key}",     $COLOUR{key}   )
                               : exists $+{punct}   ? _color( "$+{punct}",   $COLOUR{punct} )
                               : exists $+{literal} ? _color( "$+{literal}", $COLOUR{value} )
                               :                              "$+{space}";
                        "";
                     }gxmseo;
        }

        $dump =~ s{ (?! \A ) ^ }{$indent}gxms;
    }

    my $output = $OUTPUT[$hint->{'Data::Dx output'} // 0];

    print {$output}
        _color("#line $linenum  $filename\n", $COLOUR{comment}),
        _color($expr,                         $COLOUR{key}),
        _color(' = ',                         $COLOUR{punct}),
              "$dump\n\n";
}




1; # Magic true value required at end of module
__END__