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