t/44_upgrade_db.t

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