01driver.t #1

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

=head1 NAME

01driver.t - testing of VCP::Driver services

=cut

use strict ;

use Carp ;
use Test ;
use VCP::Driver;

my $p ;

sub flatten_spec {
   my ( $obj ) = @_ ;

   return join(
      ' ',
      map(
         {
            local $_ = $obj->$_();
            defined $_ ? $_ : '-' ;
         }
         qw( repo_scheme repo_user repo_password repo_server repo_filespec )
      )
   ) ;
}

my @repo_vectors = (
[ 'scheme:user:password@server:files',
  'scheme user password server files' ],   

[ 'scheme:user:password@ser@:ver:files',
  'scheme user password ser@:ver files' ],   

[ 'scheme:files',
  'scheme - - - files' ],   

[ 'scheme:user@files',
  'scheme - - - user@files' ],   

[ 'scheme:user@:files',
  'scheme user - - files' ],   

) ;

my @tests = (
sub { $p = VCP::Driver->new() ; ok( ref $p, 'VCP::Driver' ) },

##
## rev_root cleanup
##
sub { $p->rev_root( '\\//foo\\//bar\\//' )     ; ok( $p->rev_root, 'foo/bar' )},
sub { $p->deduce_rev_root( '\\foo/bar' )               ;   ok( $p->rev_root, 'foo' )},
sub { $p->deduce_rev_root( '\\foo/bar/' )              ;   ok( $p->rev_root, 'foo/bar' )},
sub { $p->deduce_rev_root( '\\foo/bar/blah*blop/baz' ) ;   ok( $p->rev_root, 'foo/bar' )},
sub { $p->deduce_rev_root( '\\foo/bar/blah?blop/baz' ) ;   ok( $p->rev_root, 'foo/bar' )},
sub { $p->deduce_rev_root( '\\foo/bar/blah...blop/baz' ) ; ok( $p->rev_root, 'foo/bar' )},

##
## Normalization & de-normalization
##
sub { ok( $p->normalize_name( '/foo/bar/baz' ), 'baz' ) },
#sub { eval {$p->normalize_name( '/foo/hmmm/baz' ) }, ok( $@ ) },
sub { ok( $p->denormalize_name( 'barf' ), 'foo/bar/barf' ) },

( map {
      my ( $spec, $flattened ) = @$_ ;
      sub {
         $p = VCP::Driver->new();  # make sure spec fields initialized
         $p->parse_repo_spec( $spec );
         ok( flatten_spec( $p ), $flattened );
      },
   } @repo_vectors
),

sub {
   $p = VCP::Driver->new();  # make sure spec fields initialized
   $p->parse_repo_spec( 'scheme:user:password@server:files' ) ;
   ok( $p->repo_user, 'user' ) ;
},

sub {
   ok( $p->repo_password, 'password' ) ;
},

sub {
   ok( $p->repo_server, 'server' ) ;
},

## Subprocesses that behave as expected
sub {
   $p->run_safely( [ $^X, qw( -e exit(0) ) ] );
   ok $p->command_result_code, 0;
},

sub {
   ok ! eval { $p->run_safely( [ $^X, qw( -e exit(1) ) ] ); 1 };
},

sub {
   ok $p->command_result_code, 1;
},

sub {
   $p->run_safely( [ $^X, qw( -e exit(1) ) ], { ok_result_codes => [ 1 ] } );
   ok $p->command_result_code, 1;
},

sub {
   $p->run_safely( [ $^X, qw( -e exit(1) ) ], { ok_result_codes => [ 0, 1 ] } );
   ok $p->command_result_code, 1;
},

sub {
   ok ! eval { $p->run_safely( [ $^X, qw( -e exit(2) ) ], { ok_result_codes => [ 0, 1 ] } ) };
},

sub {
   ok $p->command_result_code, 2;
},

sub {
   $p->run_safely( [ $^X, qw( -e warn("hi\n") ) ], { stderr_filter => qr/^hi\r?\n/ } );
   ok 1;
},

sub {
   ok join( " ", $p->options_spec ), qr/repo-id.*SCALAR/s;
},

sub {
   ok join( " ", $p->options_as_strings ), qr/#--repo-id/;
},

sub {
   $p->repo_id( "foo" );
   ok join( " ", map "'$_'", $p->options_as_strings ), qr/'--repo-id=foo'/;
},

sub {
   $p->repo_id( "" );
   ok join( " ", map "'$_'", $p->options_as_strings ), qr/'--repo-id='/;
},

) ;

plan tests => scalar( @tests ) ;

$_->() for @tests ;