6 use warnings FATAL => 'all';
10 use lib File::Spec->catdir( $FindBin::Bin, 'lib' );
12 # This is for the latest version.
13 use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' );
15 use Getopt::Long qw( GetOptions );
18 my %headerver_to_module = (
19 '0' => 'DBM::Deep::09830',
20 '2' => 'DBM::Deep::10002',
35 'input=s', 'output=s', 'version:s', 'autobless:i',
38 pod2usage(1) if $opts{help};
39 pod2usage(-exitstatus => 0, -verbose => 2) if $opts{man};
41 pod2usage(-msg => "Missing required parameters.", verbose => 1)
42 unless $opts{input} && $opts{output};
44 if ( $opts{input} eq $opts{output} ) {
45 _exit( "Cannot use the same filename for both input and output." );
48 unless ( -f $opts{input} ) {
49 _exit( "'$opts{input}' is not a file." );
54 my $ver = _read_file_header( $opts{input} );
55 if ( $is_dev{ $ver } ) {
56 _exit( "'$opts{input}' is a dev release and not supported." );
59 my $mod = $headerver_to_module{ $ver };
62 _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" );
64 $db{input} = $mod->new({
67 autobless => $opts{autobless},
73 my $ver = $opts{version};
74 if ( $ver =~ /^1\.001[0-4]/ || $ver =~ /^1\.000[3-9]/) {
77 elsif ( $ver =~ /^1\.000?[0-2]?/) {
80 elsif ( $ver =~ /^0\.99/) {
83 elsif ( $ver =~ /^0\.9[1-8]/ ) {
87 _exit( "'$ver' is an unrecognized version." );
90 if ( $is_dev{ $ver } ) {
91 _exit( "-version '$opts{version}' is a dev release and not supported." );
94 # First thing is to destroy the file, in case it's an incompatible version.
97 my $mod = $headerver_to_module{ $ver };
100 _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" );
102 $db{output} = $mod->new({
103 file => $opts{output},
105 autobless => $opts{autobless},
110 # Do the actual conversion. This is the code that compress uses.
111 $db{input}->_copy_node( $db{output} );
114 ################################################################################
116 sub _read_file_header {
119 open my $fh, '<', $file
120 or _exit( "Cannot open '$file' for reading: $!" );
122 my $buffer = _read_buffer( $fh, 9 );
123 _exit( "'$file' is not a DBM::Deep file." )
124 unless length $buffer == 9;
126 my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer );
129 _exit( "'$file' is not a DBM::Deep file." )
130 unless $file_sig eq 'DPDB';
132 # SIG_HEADER == 'h' - this means that this is a pre-1.0 file
133 return 0 unless ($header_sig eq 'h');
141 read( $fh, $buffer, $len );
147 pod2usage( -verbose => 0, -msg => $msg );
158 upgrade_db.pl -input <oldfile> -output <newfile>
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.
171 =item B<-input> (required)
173 This is the name of original DB file.
175 =item B<-output> (required)
177 This is the name of target output DB file.
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
185 If the version is the same as the input file, this acts like a compressed copy
190 In pre-1.0000 versions, autoblessing was an optional setting defaulting to
191 false. Autobless in upgrade_db.pl defaults to true.
195 Prints a brief help message, then exits.
199 Prints a much longer message, then exits;
205 The following are known issues with this converter.
209 =item * Diskspace requirements
211 This will require about twice the diskspace of the input file.
213 =item * Feature support
215 Not all versions support the same features. In particular, internal references
216 were supported in 0.983, removed in 1.000, and re-added in 1.0003. There is no
217 detection of this by upgrade_db.pl.
223 Rob Kinyon, L<rkinyon@cpan.org>
225 Originally written by Rob Kinyon, L<rkinyon@cpan.org>
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.