File Coverage

blib/lib/Test/Run/Plugin/TrimDisplayedFilenames.pm

Criterion	Covered	Total	%
statement	59	63	93.6
branch	9	16	56.2
condition	1	2	50.0
subroutine	17	17	100.0
pod			n/a
total	86	98	87.7

package Test::Run::Plugin::TrimDisplayedFilenames;

use warnings;
use strict;

use 5.014;

use Moose;

use MRO::Compat;
use File::Spec ();
use File::Basename qw/ basename dirname /;
use List::SomeUtils ();

extends('Test::Run::Base');

=head1 NAME

Test::Run::Plugin::TrimDisplayedFilenames - trim the first components
of the displayed filename to deal with excessively long ones.

=head1 VERSION

Version 0.0127

=cut

our $VERSION = '0.0127';

has 'trim_displayed_filenames_query' => ( is => "rw", isa => "Str" );

sub _process_filename_dirs
{
    my ( $self, $fn, $callback ) = @_;

    my $basename = basename($fn);
    my $dirpath  = dirname($fn);

    my ( $volume, $directories, $filename ) =
        File::Spec->splitpath( $dirpath, 1 );

    # The actual manipulation.
    my $dirs = $callback->( [ File::Spec->splitdir($directories) ] );

    my $final_dir =
        File::Spec->catpath( $volume, File::Spec->catdir(@$dirs), $filename );

    if ( $final_dir eq "" )
    {
        return $basename;
    }
    else
    {
        return File::Spec->catfile( $final_dir, $basename );
    }
}

sub _get_search_from_callback
{
    my ( $self, $options ) = @_;

    return +( $options->{search_from} eq "start" )
        ? \&List::SomeUtils::firstidx
        : \&List::SomeUtils::lasttidx;
}

sub _get_array_portion
{
    my ( $self, $options, $dirs, $idx ) = @_;

    my @copy = @$dirs;

    return [
        +( $options->{keep_from} eq "start" )
        ? splice( @copy, 0, $idx )
        : splice( @copy, $idx + 1 )
    ];
}

sub _trim_filename_dir_components
{
    my ( $self, $filename, $component_callback, $options ) = @_;

    $options ||= { 'search_from' => "start", 'keep_from' => "end" };

    return $self->_process_filename_dirs(
        $filename,
        sub {
            my $dirs = shift;

            my $idx =
                $self->_get_search_from_callback($options)
                ->( $component_callback, @$dirs );

            if ( !defined($idx) )
            {
                return $dirs;
            }

            return $self->_get_array_portion( $options, $dirs, $idx );
        },
    );
}

sub _process_output_leader_fn
{
    my ( $self, $fn ) = @_;

    my $query = $self->trim_displayed_filenames_query();

    if ( !defined($query) )
    {
        return $fn;
    }

    if ( $query =~ m{\A(fromre|keep):(.*)}ms )
    {
        my ( $cmd, $arg ) = ( $1, $2 );

        if ( $cmd eq "fromre" )
        {
            my $re = qr{$arg};

            return $self->_trim_filename_dir_components(
                $fn,
                sub { $_ =~ m{$re} },
                +{ search_from => "start", keep_from => "end" }
            );
        }
        else    # $cmd eq "keep"
        {
            # We need to decrement 1 because there's also the filename.
            my $num_keep = int($arg);
            return $self->_process_filename_dirs(
                $fn,
                sub {
                    my @dirs = @{ shift() };
                    return +( $num_keep <= 1 )
                        ? []
                        : [ splice( @dirs, -( $num_keep - 1 ) ) ];
                },
            );
        }
    }
    else
    {
        # TODO - Replace with an exception object.
        die "Unrecognized trim_displayed_filename_query.";
    }
}

sub _calc_test_file_data_display_path
{
    my ( $self, $idx, $test_file ) = @_;

    return $self->_process_output_leader_fn($test_file);
}

=head1 SYNOPSIS

    package MyTestRun;

    use Moose;

    extends('Test::Run::Plugin::TrimDisplayedFilenames');

=head1 FUNCTIONS

=cut

=head1 AUTHOR

Shlomi Fish, C<< <shlomif at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-test-run-plugin-alternateinterpreters at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test::Run::Plugin::TrimDisplayedFilenames>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Test::Run::Plugin::TrimDisplayedFilenames

You can also look for information at:

=over 4

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Test::Run::Plugin::TrimDisplayedFilenames>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test::Run::Plugin::TrimDisplayedFilenames>

=item * MetaCPAN

L<http://metacpan.org/release/Test-Run-Plugin-TrimDisplayedFilenames>

=back

=head1 ACKNOWLEDGEMENTS

Curtis "Ovid" Poe ( L<http://search.cpan.org/~ovid/> ) who gave the idea
of testing several tests from several interpreters in one go here:

L<http://use.perl.org/~Ovid/journal/32092>

=head1 SEE ALSO

L<Test::Run>, L<Test::Run::CmdLine>, L<TAP::Parser>,
L<Test::Run::CmdLine::Plugin::TrimDisplayedFilenames>

=head1 COPYRIGHT & LICENSE

Copyright 2007 Shlomi Fish, all rights reserved.

This program is released under the following license: MIT X11.

=cut

1;    # End of Test::Run::Plugin::TrimDisplayedFilenames