t/44_upgrade_db.t

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