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