01sort.t #6

#!/usr/local/bin/perl -w

=head1 NAME

01sort.t - test sorting of VCP::Rev

=cut

use strict ;

use Carp ;
use Test ;
use VCP::Rev ;
use VCP::Dest ;
use VCP::Debug qw( enable_debug );

enable_debug( split /,/, $ENV{VCPDEBUG} ) if defined $ENV{VCPDEBUG} ;

my @field_names=
(qw( name change_id rev_id comment )) ;

## This defines the sort specs for the test and maps them to field names
## that are used to test the result order.  This allows us to do multiple
## sort-by keys and check some field that is unique in every rev, as well
## testing aliases for real fields, like "rev" is for "rev_id".
my %specs = (
   qw(
      name         name
      change_id    change_id
      rev_id       rev_id
      comment      comment
   ),
   "name,rev_id" => "rev_id",
) ;

## Notes:
##    - columns are in order of @field_names
##    - Each column is in reverse expected order here.
##    - For name: '-' < '/' < 'a' in ASCII.
my @rev_data = (
[qw( aa/b/c         5 1.20   d  )],
[qw( a-c            4 1.10   c  )],
[qw( a/b/c          3 1.2    b  )],
[qw( a/b/a          2 1.1.1  aa )],
[qw( a/b/a          2 1.1    aa )],
[qw( a              1 1.0    a  )],
[(   "",            0,"",    "" )],
#[], ## All fields undefined.
) ;

my @revs = map {
   my @a ;
   for my $i ( 0..$#field_names ) {
      push @a, $field_names[$i], $_->[$i] ;
   }
   VCP::Rev->new( @a ) ;
} @rev_data ;

my $d = VCP::Dest->new ;

sub _get_field {
    my $field_name = shift ;
    my $sub = VCP::Rev->can( $field_name ) ;
    die "Can't call VCP::Rev->$field_name()" unless defined $sub ;
    map defined $_ ? length $_ ? $_ : '""' : "<undef>", map $sub->( $_ ), @_ ;
}

sub _do_split { join ",", VCP::Rev->split_id( shift ) }

my @tests = (
(
## check that %specs has at least one alias for every field.
map {
   my $field_name = $_ ;
   sub {
      my %aliased_names = map { ( $field_name => 1 ) ; } values %specs ;
      ok $aliased_names{$field_name} || 0, 1, "$_ in \%specs" ;
   },
} @field_names
),
sub { ok _do_split      "10",        "10",     "_split_id" },
sub { ok _do_split   "20.10",     "20,10",     "_split_id" },
sub { ok _do_split   "20a10",   "20,a,10",     "_split_id" },
sub { ok _do_split "20.a.10",   "20,a,10",     "_split_id" },
sub { ok _do_split  "20..10",    "20,,10",     "_split_id" },
(
   map {
      my $sort_spec  = ( $_ ) ;
      my $field_name = $specs{$_} ;
      sub {
	 $d->set_sort_spec( $sort_spec ) ;

	 my @r = @revs ;
	 my $revs = VCP::Revs->new ;
	 my $ok = eval {
            $revs->set( @r ) ;
	    $d->full_sort_revs( $revs ) ;
            1;
         };
	 my $exp_order = join",", reverse _get_field $field_name, @revs ;
	 my $got_order = $ok
            ?            join",",         _get_field $field_name, $revs->get
            :            $@;
	 ok $got_order, $exp_order, "sort by $sort_spec" ;
      },
   } keys %specs
),

sub {
   ## This hides @revs
   my @revs = map
      VCP::Rev->new( name => $_, change_id => $_, time => $_ * 10 ),
      qw( 5 4 3 2 1 );

   ## This hides $d
   my $d = VCP::Dest->new;

   for ( my $i = 0; $i <= $#revs - 1; ++$i ) {
      $revs[$i]->previous( $revs[$i+1] );
   }

   my $r = VCP::Rev->new( name => "3a", change_id => 2, previous => $revs[-3] );
   push @revs, $r;
   $r =  VCP::Rev->new( name => "3b", change_id => 3, previous => $r );
   push @revs, $r;

   my $revs = VCP::Revs->new ;
   $revs->set( @revs ) ;
   $d->sort_revs( $revs ) ;

   my $exp_order = join ",", sort map $_->name, @revs ;
   my $got_order = join ",",      map $_->name, $revs->get;
   ok $got_order, $exp_order, "natural sort" ;
},

) ;

plan tests => scalar( @tests ) ;

$_->() for @tests ;