Test::Less - Test Categorization and Subset Execution

    # Mark foo and bar tests with 4 tags
    > test-less -tag slow unit 3743 gui t/foo.t t/bar.t

    # Unmark t/bar.t as a gui test
    > test-less -untag gui t/bar.t

    # Show tags for all the tests in t/
    > test-less -show t/*.t

    # List the unit tests for ticket 3743, except the gui ones
    > test-less -list unit,3743,^gui

    # Prove (run) all gui unit tests
    > test-less -prove -v gui,unit

    # Same as above
    > prove -l `test-less -list gui,unit`

    # Without `test-less` program:
    > perl -MTest::Less -e "run" -prove -l gui,unit

    test-less -prove foo bar baz

    test-less -prove foo,bar,baz

    test-less -prove foo,^bar

    test-less -prove ^foo

    test-less -list foo | test-less -prove -
    test-less -lisr foo | test-less -untag bar

    use Test::Less;

    my $tl = Test::Less->new(
        index_file => 'my_index',
    );

    $tl->prove('-l', '-b', 'foo,bar,^baz boom');

    tag file    optional_comment

    alias tl='test-less'
    alias tlp='test-less -prove'
    alias tlt='test-less -tag'

package Test::Less;
use Spiffy 0.24 -Base;
use Spiffy ':XXX';
our $VERSION = '0.11';
our @EXPORT = qw(run);

field silent => 0;
field quiet => 0;
field verbose => 0;
field 'comment';

field index => 
      -init => '$self->index_class->new(file => $self->index_file)';
field index_file => 
      $ENV{TEST_LESS_INDEX} || 
      't/Test-Less/index.txt';
field index_class => 'Test::Less::Index';

sub run {
    my @args = @_ ? @_ : @ARGV;
    @args = map {
        $_ eq '-'
        ? do {
            local $/;
            split /\s+/, <STDIN>
        }
        : ($_);
    } @args;
    Test::Less->new->run_command_line(@args);
}

sub run_command_line {
    my ($command, @arguments) = $self->parse_command_line(@_);
    my $method ="run_$command";
    $self->$method(@arguments);
}

sub run_tag { $self->tag(@_) }
sub run_untag { $self->untag(@_) }
sub run_prove { $self->prove(@_) }
sub run_show { $self->show(@_) }
sub run_list { 
    print "$_\n" for $self->list(@_);
}

# Action handlers
sub tag {
    my ($tags, $files) = $self->parse_tags_and_files(@_);
    warn "No files specified\n" unless @$files;
    for my $file (@$files) {
        $self->tag_file($file, @$tags);
    }
}

sub untag {
    my ($tags, $files) = $self->parse_tags_and_files(@_);
    for my $file (@$files) {
        $self->untag_file($file, @$tags);
    }
}

sub show {
    for my $file ($self->parse_files(@_)) {
        my @tags = $self->index->tags_for_file($file);
        print "$file:\n  @tags\n";
    }
}

sub list {
    my $spec = $self->parse_spec(@_);
    $self->index->files_matching_spec($spec);
}

sub prove {
    my ($flags, @args) = $self->parse_flags(@_);
    exec {$self->bin_path('prove')} 'prove', @$flags, $self->list(@args);
}

# Command parsers
sub parse_flags {
    my @args = @_;
    my @flags;
    while (@args and $args[0] =~ /^-/) {
        push @flags, shift @args;
    }
    return ([@flags], @args);
}

sub parse_spec {
    my @args = @_;
    my $spec = [];
    for my $part (@args) {
        if ($part =~ /,/) {
            push @$spec, [split ',', $part];
        }
        else {
            push @$spec, $part;
        }
    }
    return $spec;
}

sub parse_command_line {
    my @words = @_;
    while (my ($word) = @words) {
        if ($word =~ /^(-q|--quiet)$/) {
            $self->quiet(1);
            shift @words;
            next;
        }
        if ($word =~ /^(-v|--verbose)$/) {
            $self->verbose(1);
            shift @words;
            next;
        }
        if ($word =~ /^(?:-f|--file)(?:=(\S+))?$/) {
            shift @words;
            my $file = $1 || shift(@words)
              or $self->usage;
            $self->index_file($file);
            next;
        }
        last;
    }

    my $word = shift(@words)
      or $self->usage;
    my $command =
        $word =~ /^-?-t(ag)?$/ ? 'tag' :
        $word =~ /^-?-u(ntag)?$/ ? 'untag' :
        $word =~ /^-?-s(how)?$/ ? 'show' :
        $word =~ /^-?-l(ist)?$/ ? 'list' :
        $word =~ /^-?-p(rove)?$/ ? 'prove' :
        $self->usage;
    return ($command, @words);
}

sub parse_tags_and_files {
    my @args = @_;
    my (@tags, @files);
    while (@args) {
        last unless $args[0] =~ /^[\w-]+$/;
        push @tags, shift @args;
    }
    @files = @args;
    return (\@tags, \@files);
}

sub parse_files {
    my @args = @_;
    return @args
    ? (@args)
    : ($self->index->all_files);
}

# Other routines
sub tag_file {
    my $file = shift;
    my @tags = @_;
    my $index = $self->index;
    for my $tag (@tags) {
        $index->add_tag_file($tag, $file, $self->get_comment)
          or $self->msg2("Can't add tag '$tag' to file '$file'");
    }
    $index->write;
}

sub untag_file {
    my $file = shift;
    my @tags = @_;
    my $index = $self->index;
    for my $tag (@tags) {
        $index->remove_tag_file($tag, $file)
          or $self->msg2("Can't remove tag '$tag' from file '$file'");
    }
    $index->write;
}

sub get_comment {
    my $comment = $self->comment;
    $comment = $ENV{TEST_LESS_COMMENT} || ''
      unless defined $comment;
    my $date = scalar(gmtime);
    $date =~ s/^(mon|tue|wed|thu|fri|sat|sun)\s+//i;
    $date .= ' GMT';
    $comment =~ s/\$d/$date/ge;
    $comment =~ s/\$u/$ENV{USER}/ge;
    return $comment;
}

sub bin_path {
    require Config;
    require File::Spec;
    my $bin = $Config::Config{sitebin};
    File::Spec->catfile($bin, shift);
}

sub usage {
    print <<'END'; exit 0;
Usage: test-less [options] command [arguments] [-]

Options:
  -file path_to_index_file
  -quiet
  -verbose

Commands:
  -help
  -tag tags test-files
  -untag tags test-files
  -show test-files
  -list tag-specification
  -prove [prove-flags] tag-specification

Options and commands may be abbreviated to their first letter.

An argument of '-' is replaced by the contents of STDIN split on whitespace.

END
}

# I/O Stuff

sub msg {
    my @args = @_;
    chomp $args[-1];
    warn join '', @_, "\n";
}

sub msg_threshold {
    return 4 if $self->silent;
    2 + $self->quiet - $self->verbose;
}

sub msg1 {
    return if $self->msg_threshold > 1;
    $self->msg(@_);
}

sub msg2 {
    return if $self->msg_threshold > 2;
    $self->msg(@_);
}

sub msg3 {
    return if $self->msg_threshold > 3;
    $self->msg(@_);
}

sub prompt {
    print shift;
    my $answer = <>;
    chomp $answer;
    return $answer;
}

package Test::Less::Index;
use Spiffy -base;
use Spiffy ':XXX';

field file => -init => 'die';
field index => -init => '$self->read';

sub add_tag_file {
    my ($tag, $file, $comment) = @_;
    return unless -f $file;
    $comment ||= '';
    $self->index->{$tag}{$file} = $comment;
    return 1;
}

sub remove_tag_file {
    my ($tag, $file) = @_;
    my $index = $self->index;
    return defined(delete $index->{$tag}{$file}) ? 1 : 0;
}

sub all_files {
    my $index = $self->index;
    my %set = map {
        map { ($_, 1) } keys %{$index->{$_}};
    } keys %$index;
    return sort keys %set;
}

sub files_matching_spec {
    my $spec = shift;
    my $files = {};
    for my $sub (@$spec) {
        if (ref $sub) {
            $self->list_add($files, $self->files_matching_list($sub));
        }
        elsif ($sub =~ /^\^(.*)/) {
            my $term = $1;
            $self->list_add($files, $self->all_files);
            $self->list_del($files, $self->files_matching($term));
        }
        else {
            $self->list_add($files, $self->files_matching($sub));
        }
    }
    return sort keys %$files;
}

sub files_matching_list {
    my $spec = shift;
    my $files = {};
    $self->list_add($files, $self->all_files);
    for my $term (@$spec) {
        if ($term =~ s/^\^//) {
            $self->list_del($files, $self->files_matching($term));
        }
        else {
            $self->list_neg($files, $self->files_matching($term));
        }
    }
    return keys %$files;
}

sub files_matching {
    my @files = ();
    for my $term (@_) {
        if ($term =~ /[^\w\-]/) {
            push @files, $term;
        }
        else {
            push @files, keys %{$self->index->{$term}};
        }
    }
    return @files;
}

sub list_add {
    my $list = shift;
    for my $file (@_) {
        $list->{$file} = '';
    }
}

sub list_del {
    my $list = shift;
    for my $file (@_) {
        delete $list->{$file};
    }
}

sub list_neg {
    my $list = shift;
    my %keep = map {($_, 1)} @_;
    for my $file (keys %$list) {
        delete $list->{$file}
          unless defined $keep{$file};
    }
}

sub tags_for_file {
    my $query = shift;
    my $index = $self->index;
    my @set;
    for my $tag (sort keys %$index) {
        for my $file (keys %{$index->{$tag}}) {
            push @set, $tag
              if $file eq $query;
        }
    }
    return @set;
}

sub read {
    my $index = {};
    my $file = $self->file;
    return $index
      unless -f $file and 
      open INDEX, $file;
    while (my $line = <INDEX>) {
        next if $line =~ /^#/;
        chomp $line;
        my ($tag, $file, $comment) = split /\s+/, $line, 3;
        $comment ||= '';
        $index->{$tag}{$file} = $comment;
    }
    close INDEX;
    return $index;
}

sub write {
    my $index = $self->index;
    my $file = $self->file;
    $self->assert_path($file);
    open INDEX, "> $file"
      or die "Can't open $file for output:\n$!";
    print INDEX $self->preamble;
    for my $tag (sort keys %$index) {
        my $files = $index->{$tag};
        for my $file (sort keys %$files) {
            my $comment = $files->{$file};
            print INDEX "$tag $file";
            print INDEX "\t$comment"
              if $comment;
            print INDEX "\n";
        }
    }
    print INDEX $self->postamble;
    close INDEX;
    $self->index(undef);
}

sub preamble {
    return <<'_';
# This file is an index for the `test-less` facility.
#
# More information can be found at:
#   http://search.cpan.org/search?query=Test-Less;mode=dist
#
_
}

sub postamble {
    '';
}

sub assert_path {
    my $file = shift;
    return if -e $file;
    return unless $file =~ /(.+)[\\\/]/;
    my $dir = $1 or return;
    return if -d $dir;
    mkdir $dir;
}

__DATA__