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