utils/upgrade_db.pl

   1 #!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::10002',
  21   '3' => 'DBM::Deep',
  22 );
  23
  24 my %is_dev = (
  25   '1' => 1,
  26 );
  27
  28 my %opts = (
  29   man => 0,
  30   help => 0,
  31   version => '1.0005',
  32   autobless => 1,
  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   }
  77   elsif ( $ver =~ /^1\.000?[0-2]?/) {
  78     $ver = 2;
  79   }
  80   elsif ( $ver =~ /^1\.000[3-5]/) {
  81     $ver = 3;
  82   }
  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
 184 In pre-1.0000 versions, autoblessing was an optional setting defaulting to
 185 false. Autobless in upgrade_db.pl defaults to true.
 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
 210 were supported in 0.983, removed in 1.000, and re-added in 1.0003. There is no
 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