Commit | Line | Data |
151e0077 |
1 | #!perl |
e9b0b5f0 |
2 | |
3 | use 5.6.0; |
4 | |
5 | use strict; |
6 | use warnings FATAL => 'all'; |
7 | |
8 | use FindBin; |
9 | use File::Spec (); |
10 | use lib File::Spec->catdir( $FindBin::Bin, 'lib' ); |
11 | |
12 | # This is for the latest version. |
13 | use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' ); |
14 | |
15 | use Getopt::Long qw( GetOptions ); |
5a70a6c0 |
16 | use Pod::Usage 1.3; |
e9b0b5f0 |
17 | |
18 | my %headerver_to_module = ( |
19 | '0' => 'DBM::Deep::09830', |
1cff45d7 |
20 | '2' => 'DBM::Deep::10002', |
21 | '3' => 'DBM::Deep', |
e9b0b5f0 |
22 | ); |
23 | |
24 | my %is_dev = ( |
25 | '1' => 1, |
26 | ); |
27 | |
28 | my %opts = ( |
29 | man => 0, |
30 | help => 0, |
9c7d9738 |
31 | version => '1.0014', |
1cff45d7 |
32 | autobless => 1, |
e9b0b5f0 |
33 | ); |
34 | GetOptions( \%opts, |
35 | 'input=s', 'output=s', 'version:s', 'autobless:i', |
36 | 'help|?', 'man', |
37 | ) || pod2man(2); |
38 | pod2usage(1) if $opts{help}; |
39 | pod2usage(-exitstatus => 0, -verbose => 2) if $opts{man}; |
40 | |
41 | pod2usage(-msg => "Missing required parameters.", verbose => 1) |
42 | unless $opts{input} && $opts{output}; |
43 | |
44 | if ( $opts{input} eq $opts{output} ) { |
45 | _exit( "Cannot use the same filename for both input and output." ); |
46 | } |
47 | |
48 | unless ( -f $opts{input} ) { |
49 | _exit( "'$opts{input}' is not a file." ); |
50 | } |
51 | |
52 | my %db; |
53 | { |
54 | my $ver = _read_file_header( $opts{input} ); |
55 | if ( $is_dev{ $ver } ) { |
56 | _exit( "'$opts{input}' is a dev release and not supported." ); |
57 | } |
58 | |
59 | my $mod = $headerver_to_module{ $ver }; |
60 | eval "use $mod;"; |
e00d0eb3 |
61 | if ( $@ ) { |
62 | _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); |
63 | } |
e9b0b5f0 |
64 | $db{input} = $mod->new({ |
65 | file => $opts{input}, |
66 | locking => 1, |
67 | autobless => $opts{autobless}, |
68 | }); |
69 | $db{input}->lock; |
70 | } |
71 | |
72 | { |
73 | my $ver = $opts{version}; |
9c7d9738 |
74 | if ( $ver =~ /^1\.001[0-4]/ || $ver =~ /^1\.000[3-9]/) { |
5a70a6c0 |
75 | $ver = 3; |
e9b0b5f0 |
76 | } |
807f63a7 |
77 | elsif ( $ver =~ /^1\.000?[0-2]?/) { |
e9b0b5f0 |
78 | $ver = 2; |
79 | } |
5a70a6c0 |
80 | elsif ( $ver =~ /^0\.99/) { |
81 | $ver = 1; |
82 | } |
83 | elsif ( $ver =~ /^0\.9[1-8]/ ) { |
84 | $ver = 0; |
1cff45d7 |
85 | } |
e9b0b5f0 |
86 | else { |
87 | _exit( "'$ver' is an unrecognized version." ); |
88 | } |
89 | |
90 | if ( $is_dev{ $ver } ) { |
91 | _exit( "-version '$opts{version}' is a dev release and not supported." ); |
92 | } |
93 | |
94 | # First thing is to destroy the file, in case it's an incompatible version. |
95 | unlink $opts{output}; |
96 | |
97 | my $mod = $headerver_to_module{ $ver }; |
98 | eval "use $mod;"; |
e00d0eb3 |
99 | if ( $@ ) { |
100 | _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); |
101 | } |
e9b0b5f0 |
102 | $db{output} = $mod->new({ |
103 | file => $opts{output}, |
104 | locking => 1, |
105 | autobless => $opts{autobless}, |
106 | }); |
107 | $db{output}->lock; |
108 | } |
109 | |
110 | # Do the actual conversion. This is the code that compress uses. |
111 | $db{input}->_copy_node( $db{output} ); |
112 | undef $db{output}; |
113 | |
114 | ################################################################################ |
115 | |
116 | sub _read_file_header { |
117 | my ($file) = @_; |
118 | |
119 | open my $fh, '<', $file |
120 | or _exit( "Cannot open '$file' for reading: $!" ); |
121 | |
122 | my $buffer = _read_buffer( $fh, 9 ); |
123 | _exit( "'$file' is not a DBM::Deep file." ) |
124 | unless length $buffer == 9; |
125 | |
126 | my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer ); |
127 | |
128 | # SIG_FILE == 'DPDB' |
129 | _exit( "'$file' is not a DBM::Deep file." ) |
130 | unless $file_sig eq 'DPDB'; |
131 | |
132 | # SIG_HEADER == 'h' - this means that this is a pre-1.0 file |
133 | return 0 unless ($header_sig eq 'h'); |
134 | |
135 | return $header_ver; |
136 | } |
137 | |
138 | sub _read_buffer { |
139 | my ($fh, $len) = @_; |
140 | my $buffer; |
141 | read( $fh, $buffer, $len ); |
142 | return $buffer; |
143 | } |
144 | |
145 | sub _exit { |
146 | my ($msg) = @_; |
147 | pod2usage( -verbose => 0, -msg => $msg ); |
148 | } |
149 | |
150 | __END__ |
151 | |
152 | =head1 NAME |
153 | |
154 | upgrade_db.pl |
155 | |
156 | =head1 SYNOPSIS |
157 | |
158 | upgrade_db.pl -input <oldfile> -output <newfile> |
159 | |
160 | =head1 DESCRIPTION |
161 | |
162 | This will attempt to upgrade DB files from one version of DBM::Deep to |
163 | another. The version of the input file is detected from the file header. The |
164 | version of the output file defaults to the version of the distro in this file, |
165 | but can be set, if desired. |
166 | |
167 | =head1 OPTIONS |
168 | |
169 | =over 4 |
170 | |
171 | =item B<-input> (required) |
172 | |
173 | This is the name of original DB file. |
174 | |
175 | =item B<-output> (required) |
176 | |
177 | This is the name of target output DB file. |
178 | |
179 | =item B<-version> |
180 | |
181 | Optionally, you can specify the version of L<DBM::Deep> for the output file. |
182 | This can either be an upgrade or a downgrade. The minimum version supported is |
183 | 0.91. |
184 | |
185 | If the version is the same as the input file, this acts like a compressed copy |
186 | of the database. |
187 | |
188 | =item B<-autobless> |
189 | |
1cff45d7 |
190 | In pre-1.0000 versions, autoblessing was an optional setting defaulting to |
191 | false. Autobless in upgrade_db.pl defaults to true. |
e9b0b5f0 |
192 | |
193 | =item B<-help> |
194 | |
195 | Prints a brief help message, then exits. |
196 | |
197 | =item B<-man> |
198 | |
199 | Prints a much longer message, then exits; |
200 | |
201 | =back |
202 | |
203 | =head1 CAVEATS |
204 | |
205 | The following are known issues with this converter. |
206 | |
207 | =over 4 |
208 | |
209 | =item * Diskspace requirements |
210 | |
211 | This will require about twice the diskspace of the input file. |
212 | |
213 | =item * Feature support |
214 | |
215 | Not all versions support the same features. In particular, internal references |
1cff45d7 |
216 | were supported in 0.983, removed in 1.000, and re-added in 1.0003. There is no |
e9b0b5f0 |
217 | detection of this by upgrade_db.pl. |
218 | |
219 | =back |
220 | |
221 | =head1 MAINTAINER(S) |
222 | |
223 | Rob Kinyon, L<rkinyon@cpan.org> |
224 | |
225 | Originally written by Rob Kinyon, L<rkinyon@cpan.org> |
226 | |
227 | =head1 LICENSE |
228 | |
229 | Copyright (c) 2007 Rob Kinyon. All Rights Reserved. |
230 | This is free software, you may use it and distribute it under the |
231 | same terms as Perl itself. |
232 | |
233 | =cut |