File Coverage

inc/My/Module/Test.pm

Criterion	Covered	Total	%
statement	256	285	89.8
branch	92	126	73.0
condition	33	68	48.5
subroutine	41	42	97.6
pod	22	24	91.6
total	444	545	81.4

package My::Module::Test;

use strict;
use warnings;

use Exporter;

our @ISA = ( qw{ Exporter } );

use PPIx::Regexp;
use PPIx::Regexp::Constant qw{ INFINITY };
use PPIx::Regexp::Dumper;
use PPIx::Regexp::Element;
use PPIx::Regexp::Tokenizer;
use PPIx::Regexp::Util qw{ __choose_tokenizer_class __instance };
use Scalar::Util qw{ looks_like_number refaddr };
use Test::More 0.88;

our $VERSION = '0.087';

use constant ARRAY_REF	=> ref [];

our @EXPORT_OK = qw{
    builder
    cache_count
    choose
    klass
    cmp_ok
    content
    count
    diag
    different
    done_testing
    dump_result
    equals
    error
    fail
    false
    finis
    format_want
    invocant
    is
    navigate
    note
    ok
    parse
    pass
    plan
    ppi
    raw_width
    result
    replace_characters
    skip
    tokenize
    true
    value
    width
    INFINITY
};

our @EXPORT = @EXPORT_OK;	## no critic (ProhibitAutomaticExportation)

push @EXPORT_OK, qw{ __quote };

my (
    $initial_class,	# For static methods; set by parse() or tokenize()
    $kind,		# of thing; set by parse() or tokenize()
    $nav,		# Navigation used to get to current object, as a
			#    string.
    $obj,		# Current object:
    			#    PPIx::Regexp::Tokenizer if set by tokenize(),
			#    PPIx::Regexp if set by parse(), or
			#    PPIx::Regexp::Element if set by navigate().
    $parse,		# Result of parse:
    			#    array ref if set by tokenize(), or
			#    PPIx::Regexp object if set by parse()
    %replace_characters, # Troublesome characters replaced in output
			# before testing
    $result,		# Operation result.
);

sub builder {
    return Test::More->builder();
}

sub cache_count {
    my ( $expect ) = @_;
    defined $expect or $expect = 0;
    $obj = undef;
    $parse = undef;
    _pause();
    $result = PPIx::Regexp->__cache_size();
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    return is( $result, $expect,
	"Should be $expect leftover cache contents" );
}

sub choose {
    my @args = @_;
    $obj = $parse;
    return navigate( @args );
}

sub klass {
    my ( $class ) = @_;
    $result = ref $obj || $obj;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( defined $class ) {
	my $rslt = isa_ok( $obj, $class, "$kind $nav" )
	    or diag "    Instead, $kind $nav isa $result";
	return $rslt;
    } else {
	return is( ref $obj || undef, $class, "Class of $kind $nav" );
    }
}

sub content {		## no critic (RequireArgUnpacking)
    # For some reason cperl seems to have no problem with this
    unshift @_, 'content';
    goto &_method_result;
}

sub count {
    my ( @args ) = @_;
    my $expect = pop @args;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( ARRAY_REF eq ref $parse ) {
	$result = @{ $parse };
	return is( $result, $expect, "Expect $expect tokens" );
    } elsif ( ARRAY_REF eq ref $obj ) {
	$result = @{ $obj };
	return is( $result, $expect, "Expect $expect tokens" );
    } elsif ( $obj->can( 'children' ) ) {
	$result = $obj->children();
	return is( $result, $expect, "Expect $expect children" );
    } else {
	$result = $obj->can( 'children' );
	return ok( $result, ref( $obj ) . "->can( 'children')" );
    }
}

sub different {
    my @args = @_;
    @args < 3 and unshift @args, $obj;
    my ( $left, $right, $name ) = @args;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( ! defined $left && ! defined $right ) {
	return ok( undef, $name );
    } elsif ( ! defined $left || ! defined $right ) {
	return ok( 1, $name );
    } elsif ( ref $left && ref $right ) {
	return ok( refaddr( $left ) != refaddr( $right ), $name );
    } elsif ( ref $left || ref $right ) {
	return ok( 1, $name );
    } elsif ( looks_like_number( $left ) && looks_like_number( $right ) ) {
	return ok( $left != $right, $name );
    } else {
	return ok( $left ne $right, $name );
    }
}

sub dump_result {
    my ( $opt, @args ) = _parse_constructor_args( { test => 1 }, @_ );
    if ( $opt->{test} ) {
	my ( $expect, $name ) = splice @args, -2;
	my $got = PPIx::Regexp::Dumper->new( $obj, @args )->string();
	# cperl does not seem to like goto &xxx; it throws a deep
	# recursion error if you do it enough times.
	$Test::Builder::Level = $Test::Builder::Level + 1;
	return is( $got, $expect, $name );
    } elsif ( __instance( $result, 'PPIx::Regexp::Tokenizer' ) ||
	__instance( $result, 'PPIx::Regexp::Element' ) ) {
	diag( PPIx::Regexp::Dumper->new( $obj, @args )->string() );
    } elsif ( eval { require YAML; 1; } ) {
	diag( "Result dump:\n", YAML::Dump( $result ) );
    } elsif ( eval { require Data::Dumper; 1 } ) {
	diag( "Result dump:\n", Data::Dumper::Dumper( $result ) );
    } else {
	diag( "Result dump unavailable.\n" );
    }
    return;
}

sub equals {
    my @args = @_;
    @args < 3 and unshift @args, $obj;
    my ( $left, $right, $name ) = @args;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( ! defined $left && ! defined $right ) {
	return ok( 1, $name );
    } elsif ( ! defined $left || ! defined $right ) {
	return ok( undef, $name );
    } elsif ( ref $left && ref $right ) {
	return ok( refaddr( $left ) == refaddr( $right ), $name );
    } elsif ( ref $left || ref $right ) {
	return ok( undef, $name );
    } elsif ( looks_like_number( $left ) && looks_like_number( $right ) ) {
	return ok( $left == $right, $name );
    } else {
	return ok( $left eq $right, $name );
    }
}

sub error {		## no critic (RequireArgUnpacking)
    unshift @_, 'error';
    goto &_method_result;
}

sub false {
    my ( $method, $args ) = @_;
    ARRAY_REF eq ref $args
	or $args = [ $args ];
    my $class = ref $obj;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( $obj->can( $method ) ) {
	$result = $obj->$method( @{ $args } );
	my $fmtd = _format_args( $args );
	return ok( ! $result, "$class->$method$fmtd is false" );
    } else {
	$result = undef;
	return ok( undef, "$class->$method() exists" );
    }
}

sub finis {
    $obj = $parse = $result = undef;
    _pause();
    $result = PPIx::Regexp::Element->__parent_keys();
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    return is( $result, 0, 'Should be no leftover objects' );
}

sub format_want {
    my ( $want ) = @_;
    return _format_args( $want, bare => ref $want ? 0 : 1 );
}

sub invocant {
    return $obj;
}

{

    my %array = map { $_ => 1 } qw{
	children delimiters finish schildren start tokens type
    };

    sub navigate {
	my @args = @_;
	my $scalar = 1;
	@args > 1
	    and ARRAY_REF eq ref $args[-1]
	    and @{ $args[-1] } == 0
	    and $array{$args[-2]}
	    and $scalar = 0;
	my @nav = ();
	while ( @args ) {
	    if ( __instance( $args[0], 'PPIx::Regexp::Element' ) ) {
		$obj = shift @args;
	    } elsif ( ARRAY_REF eq ref $obj ) {
		my $inx = shift @args;
		push @nav, $inx;
		$obj = $obj->[$inx];
	    } else {
		my $method = shift @args;
		my $args = shift @args;
		ARRAY_REF eq ref $args
		    or $args = [ $args ];
		push @nav, $method, $args;
		$obj->can( $method ) or return;
		if ( @args || $scalar ) {
		    $obj = $obj->$method( @{ $args } ) or return;
		} else {
		    $obj = [ $obj->$method( @{ $args } ) ];
		}
	    }
	}
	$nav = __quote( @nav );
	$nav =~ s/ ' ( \w+ ) ' , /$1 =>/smxg;
	$nav =~ s/ \[ \s+ \] /[]/smxg;
	$result = $obj;
	return $obj;
    }

}

sub parse {		## no critic (RequireArgUnpacking)
    my ( $opt, $regexp, @args ) = _parse_constructor_args(
	{ test => 1 }, @_ );
    $initial_class = 'PPIx::Regexp';
    $kind = 'element';
    $result = $obj = $parse = PPIx::Regexp->new( $regexp, @args );
    $nav = '';
    $opt->{test} or return;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    return isa_ok( $parse, 'PPIx::Regexp',
	_replace_characters( $regexp ) );
}

sub ppi {		## no critic (RequireArgUnpacking)
    my @args = @_;
    my $expect = pop @args;
    $result = undef;
    defined $obj and $result = $obj->ppi()->content();
    my $safe;
    if ( defined $result ) {
	($safe = $result) =~ s/([\\'])/\\$1/smxg;
    } else {
	$safe = 'undef';
    }
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    return is( $result, $expect, "$kind $nav ppi() content '$safe'" );
}

sub raw_width {
    my ( $min, $max, $name ) = @_;
    defined $name
	or $name = sprintf q<%s '%s'>, ref $obj, $obj->content();
    $Test::Builder::Level = $Test::Builder::Level + 1;
    my @width = $obj->raw_width();
    return is( $width[0], $min, "$name raw minimum witdh" ) && is(
	$width[1], $max, "$name raw maximum width" );
}

sub replace_characters {
    %replace_characters	= @_;
    return;
}

sub result {
    return $result;
}

sub tokenize {		## no critic (RequireArgUnpacking)
    my ( $opt, $regexp, @args ) = _parse_constructor_args(
	{ test => 1, tokens => 1 }, @_ );
    my %args = @args;
    $initial_class = __choose_tokenizer_class( $regexp, \%args );
    $kind = 'token';
    $obj = $initial_class->new( $regexp, @args );
    if ( $obj && $opt->{tokens} ) {
	$parse = [ $obj->tokens() ];
    } else {
	$parse = [];
    }
    $result = $parse;
    $nav = '';
    $opt->{test} or return;
    $Test::Builder::Level = $Test::Builder::Level + 1;
    return isa_ok( $obj, 'PPIx::Regexp::Tokenizer',
	_replace_characters( $regexp ) );
}

sub true {		## no critic (RequireArgUnpacking)
    my ( $method, $args ) = @_;
    ARRAY_REF eq ref $args
	or $args = [ $args ];
    my $class = ref $obj;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( $obj->can( $method ) ) {
	$result = $obj->$method( @{ $args } );
	my $fmtd = _format_args( $args );
	return ok( $result, "$class->$method$fmtd is true" );
    } else {
	$result = undef;
	return ok( undef, "$class->$method() exists" );
    }
}

sub value {		## no critic (RequireArgUnpacking)
    my ( $method, $args, $want, $name ) = @_;
    ARRAY_REF eq ref $args
	or $args = [ $args ];

    my $invocant = $obj || $initial_class;
    my $class = ref $obj || $obj || $initial_class;
    # cperl does not seem to like goto &xxx; it throws a deep recursion
    # error if you do it enough times.
    $Test::Builder::Level = $Test::Builder::Level + 1;
    if ( ! $invocant->can( $method ) ) {
	return ok( undef, "$class->$method() exists" );
    }

    $result = ARRAY_REF eq ref $want ?
	[ $invocant->$method( @{ $args } ) ] :
	$invocant->$method( @{ $args } );

    my $fmtd = _format_args( $args );
    my $answer = format_want( $want, bare => ref $want ? 0 : 1 );
    defined $name
	or $name = "${class}->$method$fmtd is $answer";
    if ( ref $result ) {
	return is_deeply( $result, $want, $name );
    } else {
	return is( $result, $want, $name );
    }
}

sub width {
    my ( $min, $max, $name ) = @_;
    defined $name
	or $name = sprintf q<%s '%s'>, ref $obj, $obj->content();
    $Test::Builder::Level = $Test::Builder::Level + 1;
    my @width = $obj->width();
    return is( $width[0], $min, "$name minimum witdh" ) && is(
	$width[1], $max, "$name maximum width" );
}

sub _format_args {
    my ( $args, %opt ) = @_;
    ARRAY_REF eq ref $args
	or $args = [ $args ];
    my @rslt;
    foreach my $arg ( @{ $args } ) {
	if ( ! defined $arg ) {
	    push @rslt, 'undef';
	} elsif ( looks_like_number( $arg ) ) {
	    push @rslt, $arg;
	} else {
	    push @rslt, $arg;
	    $rslt[-1] =~ s/ ' /\\'/smxg;
	    $rslt[-1] = "'$rslt[-1]'";
	}
    }
    my $string = join ', ', @rslt;
    $opt{bare} and return $string;
    @rslt or return '()';
    return "( $string )";
}

sub _method_result {		## no critic (RequireArgUnpacking)
    my ( $method, @args ) = @_;
    my $expect = pop @args;
    $result = undef;
    defined $obj and $result = $obj->$method();
    my $safe;
    if ( defined $result ) {
	($safe = $result) =~ s/([\\'])/\\$1/smxg;
	$safe = "'$safe'";
    } else {
	$safe = 'undef';
    }
    @_ = _replace_characters( $result, $expect, "$kind $nav $method $safe" );
    goto &is;
}

sub _parse_constructor_args {
    my ( $opt, @args ) = @_;
    my @rslt = ( $opt );
    foreach my $arg ( @args ) {
	if ( $arg =~ m/ \A - -? (no)? (\w+) \z /smx &&
	    exists $opt->{$2} ) {
	    $opt->{$2} = !$1;
	} else {
	    push @rslt, $arg;
	}
    }
    return @rslt;
}

sub _pause {
    if ( eval { require Time::HiRes; 1 } ) {	# Cargo cult programming.
	Time::HiRes::sleep( 0.1 );		# Something like this is
    } else {					# in PPI's
	sleep 1;				# t/08_regression.t, and
    }						# who am I to argue?
    return;
}

# quote a string.
sub __quote {
    my @args = @_;
    my @rslt;
    foreach my $item ( @args ) {
	if ( __instance( $item, 'PPIx::Regexp::Element' ) ) {
	    $item = $item->content();
	}
	if ( ! defined $item ) {
	    push @rslt, 'undef';
	} elsif ( ARRAY_REF eq ref $item ) {
	    push @rslt, join( ' ', '[', __quote( @{ $item } ), ']' );
	} elsif ( looks_like_number( $item ) ) {
	    push @rslt, $item;
	} else {
	    $item =~ s/ ( [\\'] ) /\\$1/smxg;
	    push @rslt, "'$item'";
	}
    }
    return join( ', ', @rslt );
}

sub _replace_characters {
    my @arg = @_;
    if ( keys %replace_characters ) {
	foreach ( @arg ) {
	    $_ = join '',
	    # The following assumes I will never want to replace 0.
	    map { $replace_characters{$_} || $_ }
	    split qr<>;
	}
    }
    wantarray
	or return join '', @arg;
    return @arg;
}

1;

__END__