t/44_upgrade_db.t

   1 $|++;
   2 use strict;
   3 use Test::More;
   4
   5 # Add skips here
   6 BEGIN {
   7     plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now."
   8         if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
   9
  10     my @failures;
  11     eval { use Pod::Usage 1.3; }; push @failures, 'Pod::Usage' if $@;
  12     eval { use IO::Scalar; }; push @failures, 'IO::Scalar' if $@;
  13     if ( @failures ) {
  14         my $missing = join ',', @failures;
  15         plan skip_all => "'$missing' must be installed to run these tests";
  16     }
  17 }
  18
  19 plan tests => 252;
  20
  21 use t::common qw( new_fh );
  22 use File::Spec;
  23 use Test::Deep;
  24
  25 my $PROG = File::Spec->catfile( qw( utils upgrade_db.pl ) );
  26
  27 my $short = get_pod( $PROG, 0 );
  28 my $long = get_pod( $PROG, 1 );
  29
  30 is( run_prog( $PROG ), "Missing required parameters.\n$long", "Failed no params" );
  31 is( run_prog( $PROG, '-input foo' ), "Missing required parameters.\n$long", "Failed only -input" );
  32 is( run_prog( $PROG, '-output foo' ), "Missing required parameters.\n$long", "Failed only -output" );
  33 is(
  34     run_prog( $PROG, '-input foo', '-output foo' ),
  35     "Cannot use the same filename for both input and output.\n$short",
  36     "Failed same name",
  37 );
  38
  39 is(
  40     run_prog( $PROG, '-input foo', '-output bar' ),
  41     "'foo' is not a file.\n$short",
  42     "Failed input does not exist",
  43 );
  44
  45 my (undef, $input_filename) = new_fh();
  46 my (undef, $output_filename) = new_fh();
  47
  48 is(
  49     run_prog( $PROG, "-input $input_filename", "-output $output_filename" ),
  50     "'$input_filename' is not a DBM::Deep file.\n$short",
  51     "Input is not a DBM::Deep file",
  52 );
  53
  54 unlink $input_filename;unlink $output_filename;
  55
  56 # All files are of the form:
  57 #   $db->{foo} = [ 1 .. 3 ];
  58
  59 my @input_files = (
  60     '0-983',
  61     '0-99_04',
  62     '1-0000',
  63     '1-0003',
  64 );
  65
  66 my @output_versions = (
  67     '0.91', '0.92', '0.93', '0.94', '0.95', '0.96', '0.97', '0.98',
  68     '0.981', '0.982', '0.983',
  69     '0.99_01', '0.99_02', '0.99_03', '0.99_04',
  70     '1.00', '1.000', '1.0000', '1.0001', '1.0002',
  71     '1.0003', '1.0004', '1.0005', '1.0006', '1.0007', '1.0008', '1.0009',
  72 );
  73
  74 foreach my $input_filename (
  75     map {
  76         File::Spec->catfile( qw( t etc ), "db-$_" )
  77     } @input_files
  78 ) {
  79     # chmod it writable because old DBM::Deep versions don't handle readonly
  80     # files correctly. This is fixed in DBM::Deep 1.0000
  81     chmod 0600, $input_filename;
  82
  83     foreach my $v ( @output_versions ) {
  84         my (undef, $output_filename) = new_fh();
  85         my $output = run_prog(
  86             $PROG,
  87             "-input $input_filename",
  88             "-output $output_filename",
  89             "-version $v",
  90         );
  91
  92         # Clone was removed as a requirement in 1.0006
  93         if ( $output =~ /Can\'t locate Clone\.pm in \@INC/ ) {
  94             ok( 1 );
  95             unless ( $input_filename =~ /_/ || $v =~ /_/ ) {
  96                 ok( 1 ); ok( 1 );
  97             }
  98             next;
  99         }
 100
 101         if ( $input_filename =~ /_/ ) {
 102             is(
 103                 $output, "'$input_filename' is a dev release and not supported.\n$short",
 104                 "Input file is a dev release - not supported",
 105             );
 106
 107             next;
 108         }
 109
 110         if ( $v =~ /_/ ) {
 111             is(
 112                 $output, "-version '$v' is a dev release and not supported.\n$short",
 113                 "Output version is a dev release - not supported",
 114             );
 115
 116             next;
 117         }
 118
 119         # Now, read the output file with the right version.
 120         ok( !$output, "A successful run produces no output" );
 121         die "$output\n" if $output;
 122
 123         my $db;
 124         if ( $v =~ /^1\.000[3-9]/ ) {
 125             push @INC, 'lib';
 126             eval "use DBM::Deep";
 127             $db = DBM::Deep->new( $output_filename );
 128         }
 129         elsif ( $v =~ /^1\.000?[0-2]?/ ) {
 130             push @INC, File::Spec->catdir( 'utils', 'lib' );
 131             eval "use DBM::Deep::10002";
 132             $db = DBM::Deep::10002->new( $output_filename );
 133         }
 134         elsif ( $v =~ /^0/ ) {
 135             push @INC, File::Spec->catdir( 'utils', 'lib' );
 136             eval "use DBM::Deep::09830";
 137             $db = DBM::Deep::09830->new( $output_filename );
 138         }
 139         else {
 140             die "How did we get here?!\n";
 141         }
 142
 143         ok( $db, "Writing to version $v made a file" );
 144
 145         cmp_deeply(
 146             $db->export,
 147             { foo => [ 1 .. 3 ] },
 148             "We can read the output file",
 149         );
 150     }
 151 }
 152
 153 ################################################################################
 154
 155 #XXX This needs to be made OS-portable
 156 sub run_prog {
 157     open( my $fh, '-|', "$^X @_ 2>&1" )
 158       or die "Cannot launch '@_' as a piped filehandle: $!\n";
 159     return join '', <$fh>;
 160 }
 161
 162 # In 5.8, we could use in-memory filehandles and have done:
 163 #     open( my $fh, '>', \my $pod ) or die "Cannot open in-memory filehandle: $!\n";
 164 #     ...
 165 #     return $pod;
 166 # However, DBM::Deep requires 5.6, so this set of contortions will have to do.
 167 sub get_pod {
 168     my ($p,$v) = @_;
 169
 170     my ($fh, $fn) = new_fh();
 171     close $fh;
 172
 173     open $fh, '>', $fn;
 174     pod2usage({
 175         -input   => $p,
 176         -output  => $fh,
 177         -verbose => $v,
 178         -exitval => 'NOEXIT',
 179     });
 180     close $fh;
 181
 182     open $fh, '<', $fn;
 183     return join '', <$fh>;
 184 }