File Coverage

blib/lib/PPIx/QuoteLike/Dumper.pm

Criterion	Covered	Total	%
statement	126	164	76.8
branch	44	94	46.8
condition	6	14	42.8
subroutine	26	29	89.6
pod	5	5	100.0
total	207	306	67.6

package PPIx::QuoteLike::Dumper;

use 5.006;

use strict;
use warnings;

use Carp;
use PPI::Document;
use PPIx::QuoteLike;
use PPIx::QuoteLike::Constant qw{ @CARP_NOT };
use PPIx::QuoteLike::Utils qw{ __instance };
use Scalar::Util ();

our $VERSION = '0.022';

use constant SCALAR_REF	=> ref \0;

{
    my $default = {
	encoding	=> undef,
	file		=> undef,
	indent		=> 2,
	locations	=> 0,
	margin		=> 0,
	perl_version	=> 0,
	ppi		=> 0,
	short		=> 0,
	significant	=> 0,
	tokens		=> 0,
	variables	=> 0,
    };

    sub new {
	my ( $class, $source, %arg ) = @_;

	my $self = {
	    %{ $default },
	    object	=> undef,
	    source	=> $source,
	};

	foreach my $key ( keys %{ $default } ) {
	    defined $arg{$key}
		and $self->{$key} = $arg{$key};
	}

	$self->{object} = _isa( $source, 'PPIx::QuoteLike' ) ? $source :
	    PPIx::QuoteLike->new( $source,
		__instance( $source, 'PPI::Element' ) ? () : (
		    location	=> [ 1, 1, 1, 1, -f $source ? $source :
			undef ],
		),
		map { $_ => $arg{$_} } qw{ encoding },
	    )
	    or return;

	return bless $self, ref $class || $class;
    }
}

sub dump : method {	## no critic (ProhibitBuiltinHomonyms)
    my ( $class, $source, %arg ) = @_;
    my $rslt;
    my $margin = ' ' x ( $arg{margin} || 0 );
    my $none = delete $arg{none};
    foreach my $obj ( $class->_source_to_dumpers( $source, %arg ) ) {
	my $src = $obj->{object}->source();
	$rslt .= "\n$margin$src";
	if ( _isa( $src, 'PPI::Element' ) and my $loc = $src->location() ) {
	    $rslt .= sprintf ' %s line %d column %d',
		_dor( $loc->[4], $obj->{file}, '?' ),
		$loc->[0], $loc->[1];
	}
	$rslt .= "\n" . $obj->string();
    }
    defined $rslt
	and return $rslt;
    defined $none
	or return;
    $none =~ s/ (?: \A | (?
    return $none;
}

sub list {
    my ( $self ) = @_;
    my $indent;
    my $obj = $self->{object};
    my @rslt;
    my $selector;
    if ( $self->{tokens} ) {
	$indent = '';
	$selector = sub { return @{
	    $obj->find( 'PPIx::QuoteLike::Token' ) || [] };
	};
    } else {
	$indent = ' ' x $self->{indent};
	my $string = sprintf '%s%s...%s',
	    map { _format_content( $obj, $_ ) }
	    qw{ type start finish };
	push @rslt,
	    join "\t", $self->_class_name( $obj ), $string,
	    _format_attr( $obj, qw{ encoding failures interpolates
		indentation } ),
	    $self->_perl_version( $obj ),
	    $self->_variables( $obj ),
	    ;
	$selector = sub { return $obj->children() };
    }
    foreach my $elem ( $selector->() ) {
	$self->{significant}
	    and not $elem->significant()
	    and next;
	my $locn = $self->{locations} ?
	    __instance( $elem, 'PPIx::QuoteLike::Token' ) ?
		sprintf '[ % 4d, % 3d, % 3d ] ',
		    $elem->logical_line_number(),
		    $elem->column_number(),
		    $elem->visual_column_number() :
		' ' x 19 :
	    '';
	my @line = (
	    $self->_class_name( $elem ),
	    _quote( $elem->content() ),
	    $self->_perl_version( $elem ),
	    $self->_variables( $elem ),
	);
	my @ppi;
	@ppi = $self->_ppi( $elem )
	    and shift @ppi;	# Ignore PPI::Document
	foreach ( @ppi ) {
	    if ( $self->{locations} ) {
		s/ ( [0-9]+ \s+ \] ) /$1  /smxg
		    or substr $_, 0, 0, '  ';
	    } else {
		substr $_, 0, 0, '  ';
	    }
	}
	my $leader = "$locn$indent";
	foreach ( join( "\t", @line ), @ppi ) {
	    push @rslt, "$leader$_";
	    # $locn = $self->{locations} ? ' ' x 19 : '';
	    $leader = '';
	}
    }
    return @rslt;
}

sub print : method {	## no critic (ProhibitBuiltinHomonyms)
    my ( $self ) = @_;
    print $self->string();
    return;
}

sub string {
    my ( $self ) = @_;
    my $margin = ' ' x $self->{margin};
    return join '', map { "$margin$_\n" } $self->list();
}

sub _class_name {
    my ( $self, $obj ) = @_;
    my $class = ref $obj;
    $self->{short}
	and $class =~ s/ \A PPIx::QuoteLike:: //smx;
    return $class;
}

{
    # We have to hold a reference to the PPI document until we're done
    # with all its elements, otherwise they evaporate. Holding it here
    # works as long as we actually format the dump for all elements
    # before calling this again.
    my $doc;

    sub _doc_to_dumper {
	my ( $class, $path, %arg ) = @_;
	$doc = PPI::Document->new( $path )
	    or return;
	ref $path
	    or $arg{file} = $path;
	return map { $class->new( $_, %arg ) }
	    @{ $doc->find( 'PPI::Token' ) || [] };
    }
}

sub _dor {
    my @arg = @_;
    foreach my $a ( @arg ) {
	defined $a
	    and return $a;
    }
    return;
}

sub _format_attr {
    my ( $obj, @arg ) = @_;
    my @rslt;
    foreach my $attr ( @arg ) {
	defined( my $val = $obj->$attr() )
	    or next;
	push @rslt, sprintf '%s=%s', $attr, _quote( $val );
    }
    return @rslt;
}

sub _format_content {
    my ( $obj, $method, @arg ) = @_;
    my @val = map { $_->content() }
	    grep { $_->significant() }
	    $obj->$method( @arg )
	or return '?';
    return join '', @val;
}

sub _isa {
    my ( $arg, $class ) = @_;
    Scalar::Util::blessed( $arg )
	or return 0;
    return $arg->isa( $class );
}

sub _perl_version {
    my ( $self, $elem ) = @_;
    $self->{perl_version}
	or return;
    my $intro = $elem->perl_version_introduced();
    my $remov = $elem->perl_version_removed();
    return defined $remov ? "$intro <= \$] < $remov" : "$intro <= \$]";
}

sub _ppi {
    my ( $self, $elem ) = @_;

    $self->{ppi}
	and $elem->can( 'ppi' )
	or return;

    require PPI::Dumper;

    # PPI::Dumper reports line_number(), but I want
    # logical_line_number(). There is no configuration for this, but the
    # interface is public, so I mung it to do what I want.
    my $locn = PPI::Element->can( 'location' );
    local *PPI::Element::location = sub {
	my $loc = $locn->( @_ );
	$loc->[0] = $loc->[3];
	return $loc;
    };

    my $dumper = PPI::Dumper->new( $elem->ppi(),
	map { $_ => $self->{$_} } qw{ indent locations },
    );

    return $dumper->list();
}

sub _quote {
    my ( $val ) = @_;
    ref $val
	and $val = $val->content();
    defined $val
	or return 'undef';
    Scalar::Util::looks_like_number( $val )
	and return $val;
    if ( $val =~ m/ \A << /smx ) {
	chomp $val;
	return "<<'__END_OF_HERE_DOCUMENT'
$val
__END_OF_HERE_DOCUMENT
";
    }

    $val =~ s/ (?= [\\'] )/\\/smxg;
    return "'$val'";
}

sub _source_to_dumpers {
    my ( $class, $path, %arg ) = @_;
    if ( Scalar::Util::blessed( $path ) ) {
	if ( _isa( $path, 'PPI::Node' ) ) {
	    return map {
		PPIx::QuoteLike->handles( $_ ) ?
		    $class->new( $_, %arg ) : () }
		@{ $path->find( 'PPI::Token' ) || [] };
	} elsif ( _isa( $path, 'PPI::Element' ) ) {
	    PPIx::QuoteLike->handles( $path )
		and return $class->new( $path, %arg );
	}
    } elsif ( my $ref = ref $path ) {
	SCALAR_REF eq $ref
	    or return;
	return $class->_doc_to_dumper( $path, %arg );
    } else {
	-f $path
	    or return $class->new( $path, %arg );
	-T _
	    or return;
	unless ( $path =~ m/ [.] (?: (?i: pl ) | pm | t ) \z /smx ) {
	    open my $fh, '<', $path
		or return;
	    defined( local $_ = <$fh> )
		or return;
	    close $fh;
	    m/ perl /smx
		or return;
	}
	return $class->_doc_to_dumper( $path, %arg );
    }
    return;
}

sub _variables {
    my ( $self, $elem ) = @_;

    $self->{variables}
	or return;

    my @var = $elem->variables()
	or return;

    return join ',', sort @var;
}

1;

__END__