Commit | Line | Data |
e9b0b5f0 |
1 | $|++; |
2 | use strict; |
3 | use Test::More; |
4 | |
0e3e3555 |
5 | plan skip_all => "upgrade_db.pl doesn't actually do anything correct."; |
6 | |
e9b0b5f0 |
7 | # Add skips here |
8 | BEGIN { |
45f047f8 |
9 | plan skip_all => "Skipping the upgrade_db.pl tests on Win32/cygwin for now." |
10 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ); |
11 | |
08164b50 |
12 | plan skip_all => "Skipping the upgrade_db.pl tests on *bsd for now." |
13 | if ( $^O =~ /bsd/i ); |
14 | |
e9b0b5f0 |
15 | my @failures; |
9c87a079 |
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 $@; |
e9b0b5f0 |
19 | if ( @failures ) { |
20 | my $missing = join ',', @failures; |
21 | plan skip_all => "'$missing' must be installed to run these tests"; |
22 | } |
23 | } |
24 | |
9c7d9738 |
25 | plan tests => 302; |
e9b0b5f0 |
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 | |
5a70a6c0 |
60 | unlink $input_filename;unlink $output_filename; |
61 | |
e9b0b5f0 |
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', |
1cff45d7 |
69 | '1-0003', |
e9b0b5f0 |
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', |
1cff45d7 |
76 | '1.00', '1.000', '1.0000', '1.0001', '1.0002', |
9c7d9738 |
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', |
e9b0b5f0 |
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(); |
f709c026 |
92 | |
e9b0b5f0 |
93 | my $output = run_prog( |
94 | $PROG, |
95 | "-input $input_filename", |
96 | "-output $output_filename", |
97 | "-version $v", |
98 | ); |
99 | |
a5bdb1ac |
100 | #warn "Testing $input_filename against $v\n"; |
9c7d9738 |
101 | |
e00d0eb3 |
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 | |
e9b0b5f0 |
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" ); |
f709c026 |
131 | die "'$input_filename' -> '$v' : $output\n" if $output; |
e9b0b5f0 |
132 | |
133 | my $db; |
9c7d9738 |
134 | if ( $v =~ /^1\.001[0-4]/ || $v =~ /^1\.000[3-9]/ ) { |
5a70a6c0 |
135 | push @INC, 'lib'; |
f709c026 |
136 | eval "use DBM::Deep $v"; die $@ if $@; |
5a70a6c0 |
137 | $db = DBM::Deep->new( $output_filename ); |
e9b0b5f0 |
138 | } |
1cff45d7 |
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 | } |
5a70a6c0 |
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 ); |
e9b0b5f0 |
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 { |
151e0077 |
167 | open( my $fh, '-|', "$^X @_ 2>&1" ) |
e9b0b5f0 |
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 | } |