File Coverage

blib/lib/Data/Show.pm

Criterion	Covered	Total	%
statement	52	54	96.3
branch	7	10	70.0
condition	4	7	57.1
subroutine	9	9	100.0
pod	1	1	100.0
total	73	81	90.1

package Data::Show;

use warnings;
use strict;
use Data::Dump 'dump';
use 5.010;

our $VERSION = '0.002004';

# Unconditionally export show()...
sub import {
    no strict 'refs';
    *{caller().'::show'} = \&show;
}


# Useful patterns...

my $IDENT = qr{
    [^\W\d]\w* (?: :: [^\W\d]\w* )* | [_\W]
}xms;

use re 'eval';
my $CODE = qr{
        (?&CODE_FRAGMENT)

        (?(DEFINE)
            (?
                (?: (?"ED)
                  | \b (?: q[qxr]?+ | [msy] | tr ) \s* (?&DELIMITED)
                  | (?&NESTED)
                  | [%\$\@] (?: (?&BRACE_DELIMS) | $IDENT) (?&NESTED)?
                  | [^][{}()"'`;]
                )++
            )

            (?
                (?: (?"ED)
                  | \b (?: q[qxr]?+ | [msy] | tr ) \s* (?&DELIMITED)
                  | (?&NESTED)
                  | [^][{}()"'`]
                )++
            )

            (?
                   " [^\\"]++ (?: \\. [^\\"]++ )*  "
                |  ' [^\\']++ (?: \\. [^\\']++ )*  '
                |  ` [^\\`]++ (?: \\. [^\\`]++ )*  `
                |  / [^\\/]++ (?: \\. [^\\/]++ )*  /
                | \? [^\\?]++ (?: \\. [^\\?]++ )* \?
            )

            (?
                  (?&BRACE_DELIMS)
                | (?&PAREN_DELIMS)
                | (?&ANGLE_DELIMS)
                | (?&SQUARE_DELIMS)
                | \s++ (?\w) (?:\\.|(?!\g{DELIM_W}).)*+ \g{DELIM_W}
                |      (?[^\w\s]) (?:\\.|(?!\g{DELIM_S}).)*+ \g{DELIM_S}
            )

            (?
                  \( (?&NESTED_CODE_FRAGMENT) \)
                | \[ (?&NESTED_CODE_FRAGMENT) \]
                | \{ (?&NESTED_CODE_FRAGMENT) \}
                | \< (?&NESTED_CODE_FRAGMENT) \>
            )

            (?   \{ (?: [^{}] | \\. | (?&BRACE_DELIMS)  )*+ \} )
            (?   \( (?: [^()] | \\. | (?&PAREN_DELIMS)  )*+ \) )
            (?   \< (?: [^<>] | \\. | (?&ANGLE_DELIMS)  )*+ \> )
            (?  \[ (?: [^][] | \\. | (?&SQUARE_DELIMS) )*+ \] )
        )
}xms;


# Configuration for layout of representation...
my $DEFAULT_INDENT = 4;
my $MAX_WIDTH      = 72;
my $TITLE_POS      = 6;

# Be a ninja...
our @CARP_NOT;

# The whole point of the module...
sub show {

    # Determine context...
    my (undef, $file, $line) = caller();

    # Extract description of arglist from context...
    my ( $desc, $context );
    if (open my $fh, '<', $file) {
        for (1..$line-1) { readline($fh) // last }
        $desc = do { local $/; readline $fh; };
    }

    {
        # local-ize %+ to avoid clobbering any values with regexes below...
        local %+;

        # Trim filename and format context info and description...
        $file =~ s{.*[/\\]}{}xms;
        $context = "'$file', line $line";
        $desc //= $context;

        # Isolate arg list and compress internal whitespace...
        $desc =~ s{ \A (?: (?!\bshow) . )*? \b show \b \s* ($CODE) \s* (?: [;\}] .* | \Z ) }{$1}xms;
        $desc =~ s{\A \( | \) \Z}{}gxms;
        $desc =~ s{\s+}{ }gxms;
    }

    # Serialize 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);
        }
    }

    # Serialize argument (restoring it, if it was inappropriately flattened)...
    my $representation = $desc =~ m{ \A \@ $IDENT \s* \Z }xms ? dump(\@_ )
                       : $desc =~ m{ \A \% $IDENT \s* \Z }xms ? dump({@_})
                       :                                        dump( @_ );

    # Indent representation wrt heading...
    $representation =~ s{^}{ q{ } x $DEFAULT_INDENT }gxmse;

    # Clean up parens around title...
    $desc =~ s{ \A \s* (?| \( \s* (.*?) \s* \) | \s* (.*?) \s* ) \Z }
              {(  $1  )}xms;

    # Insert title into header...
    my $header = '=' x $MAX_WIDTH;
    substr($header, $TITLE_POS, length($desc), $desc);

    # Add context if it isn't just context...
    if ($desc ne "(  $context  )") {
        $context = "[ $context ]";
        substr($header, -length($context)-$TITLE_POS, -$TITLE_POS, $context);
    }

    # Display data...
    print {*STDERR} "$header\n\n$representation\n\n\n";

    return;
}


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