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]/ ) {
77 elsif ( $ver =~ /^1\.000[3-9]/ ) {
80 elsif ( $ver eq '1.00' || $ver eq '1.000' || $ver =~ /^1\.000[0-2]/ ) {
83 elsif ( $ver =~ /^0\.99/ ) {
86 elsif ( $ver =~ /^0\.9[1-8]/ ) {
90 _exit( "'$ver' is an unrecognized version." );
93 if ( $is_dev{ $ver } ) {
94 _exit( "-version '$opts{version}' is a dev release and not supported." );
97 # First thing is to destroy the file, in case it's an incompatible version.
100 my $mod = $headerver_to_module{ $ver };
103 _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" );
105 $db{output} = $mod->new({
106 file => $opts{output},
108 autobless => $opts{autobless},
113 # Do the actual conversion. This is the code that compress uses.
114 $db{input}->_copy_node( $db{output} );
117 ################################################################################
119 sub _read_file_header {
122 open my $fh, '<', $file
123 or _exit( "Cannot open '$file' for reading: $!" );
125 my $buffer = _read_buffer( $fh, 9 );
126 _exit( "'$file' is not a DBM::Deep file." )
127 unless length $buffer == 9;
129 my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer );
132 _exit( "'$file' is not a DBM::Deep file." )
133 unless $file_sig eq 'DPDB';
135 # SIG_HEADER == 'h' - this means that this is a pre-1.0 file
136 return 0 unless ($header_sig eq 'h');
144 read( $fh, $buffer, $len );
150 pod2usage( -verbose => 0, -msg => $msg );
161 upgrade_db.pl -input <oldfile> -output <newfile>
165 This will attempt to upgrade DB files from one version of DBM::Deep to
166 another. The version of the input file is detected from the file header. The
167 version of the output file defaults to the version of the distro in this file,
168 but can be set, if desired.
174 =item B<-input> (required)
176 This is the name of original DB file.
178 =item B<-output> (required)
180 This is the name of target output DB file.
184 Optionally, you can specify the version of L<DBM::Deep> for the output file.
185 This can either be an upgrade or a downgrade. The minimum version supported is
188 If the version is the same as the input file, this acts like a compressed copy
193 In pre-1.0000 versions, autoblessing was an optional setting defaulting to
194 false. Autobless in upgrade_db.pl defaults to true.
198 Prints a brief help message, then exits.
202 Prints a much longer message, then exits;
208 The following are known issues with this converter.
212 =item * Diskspace requirements
214 This will require about twice the diskspace of the input file.
216 =item * Feature support
218 Not all versions support the same features. In particular, internal references
219 were supported in 0.983, removed in 1.000, and re-added in 1.0003. There is no
220 detection of this by upgrade_db.pl.
226 Rob Kinyon, L<rkinyon@cpan.org>
228 Originally written by Rob Kinyon, L<rkinyon@cpan.org>
232 Copyright (c) 2007 Rob Kinyon. All Rights Reserved.
233 This is free software, you may use it and distribute it under the
234 same terms as Perl itself.