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