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