t/44_upgrade_db.t

   1 $|++;
   2 use strict;
   3 use Test::More;
   4
   5 # Add skips here
   6 BEGIN {
   7   eval { use Pod::Usage };
   8   if ( $@ ) {
   9     plan skip_all => "Pod::Usage must be installed to run these tests";
  10   }
  11 }
  12
  13 plan tests => 109;
  14
  15 use t::common qw( new_fh );
  16 use File::Spec;
  17 use Test::Deep;
  18
  19 my $PROG = File::Spec->catfile( qw( utils upgrade_db.pl ) );
  20
  21 my $short = get_pod( $PROG, 0 );
  22 my $long = get_pod( $PROG, 1 );
  23
  24 is( run_prog( $PROG ), "Missing required parameters.\n$long", "Failed no params" );
  25 is( run_prog( $PROG, '-input foo' ), "Missing required parameters.\n$long", "Failed only -input" );
  26 is( run_prog( $PROG, '-output foo' ), "Missing required parameters.\n$long", "Failed only -output" );
  27 is(
  28     run_prog( $PROG, '-input foo', '-output foo' ),
  29     "Cannot use the same filename for both input and output.\n$short",
  30     "Failed same name",
  31 );
  32
  33 is(
  34     run_prog( $PROG, '-input foo', '-output bar' ),
  35     "'foo' is not a file.\n$short",
  36     "Failed input does not exist",
  37 );
  38
  39 my (undef, $input_filename) = new_fh();
  40 my (undef, $output_filename) = new_fh();
  41
  42 is(
  43     run_prog( $PROG, "-input $input_filename", "-output $output_filename" ),
  44     "'$input_filename' is not a DBM::Deep file.\n$short",
  45     "Input is not a DBM::Deep file",
  46 );
  47
  48 # All files are of the form:
  49 #   $db->{foo} = [ 1 .. 3 ];
  50
  51 my @input_files = (
  52     '0-983',
  53     '0-99_04',
  54     '1-0000',
  55 );
  56
  57 my @output_versions = (
  58     '0.91', '0.92', '0.93', '0.94', '0.95', '0.96', '0.97', '0.98',
  59     '0.981', '0.982', '0.983',
  60     '0.99_01', '0.99_02', '0.99_03', '0.99_04',
  61     '1.00', '1.0000',
  62 );
  63
  64 foreach my $input_filename (
  65     map {
  66         File::Spec->catfile( qw( t etc ), "db-$_" )
  67     } @input_files
  68 ) {
  69     foreach my $v ( @output_versions ) {
  70         #print "$input_filename => $output_filename ($v)\n";
  71         my $output = run_prog(
  72             $PROG,
  73             "-input $input_filename",
  74             "-output $output_filename",
  75             "-version $v",
  76         );
  77
  78         if ( $input_filename =~ /_/ ) {
  79             is(
  80                 $output, "'$input_filename' is a dev release and not supported.\n$short",
  81                 "Input file is a dev release - not supported",
  82             );
  83
  84             next;
  85         }
  86
  87         if ( $v =~ /_/ ) {
  88             is(
  89                 $output, "-version '$v' is a dev release and not supported.\n$short",
  90                 "Output version is a dev release - not supported",
  91             );
  92
  93             next;
  94         }
  95
  96         # Now, read the output file with the right version.
  97         ok( !$output, "A successful run produces no output" );
  98         die "$output\n" if $output;
  99
 100         my $db;
 101         if ( $v =~ /^0/ ) {
 102             push @INC, File::Spec->catdir( 'utils', 'lib' );
 103             eval "use DBM::Deep::09830";
 104             $db = DBM::Deep::09830->new( $output_filename );
 105         }
 106         elsif ( $v =~ /^1/ ) {
 107             push @INC, 'lib';
 108             eval "use DBM::Deep";
 109             $db = DBM::Deep->new( $output_filename );
 110         }
 111         else {
 112             die "How did we get here?!\n";
 113         }
 114
 115         ok( $db, "Writing to version $v made a file" );
 116
 117         cmp_deeply(
 118             $db->export,
 119             {
 120                 foo => [ 1 .. 3 ],
 121             },
 122             "We can read the output file",
 123         );
 124     }
 125 }
 126
 127 ################################################################################
 128
 129 sub run_prog {
 130   #print "Launching '@_'\n";
 131   #XXX This needs to be made OS-portable
 132   open( my $fh, '-|', "@_ 2>&1" ) or die "Cannot launch '@_': $!\n";
 133   return join '', <$fh>;
 134 }
 135
 136 sub get_pod {
 137   my ($p,$v) = @_;
 138   #XXX This needs retro'ed to 5.6.0
 139   open( my $fh, '>', \my $pod ) or die "Cannot open in-memory filehandle: $!\n";
 140   pod2usage({
 141     -input   => $p,
 142     -output  => $fh,
 143     -verbose => $v,
 144     -exitval => 'NOEXIT',
 145   });
 146   return $pod;
 147 }