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 1.3;
  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.0013',
  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   if ( $@ ) {
  62       _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" );
  63   }
  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};
  74   if ( $ver =~ /^1\.001[0-3]/) {
  75     $ver = 3;
  76   }
  77   elsif ( $ver =~ /^1\.000[3-9]/) {
  78     $ver = 3;
  79   }
  80   elsif ( $ver =~ /^1\.000?[0-2]?/) {
  81     $ver = 2;
  82   }
  83   elsif ( $ver =~ /^0\.99/) {
  84     $ver = 1;
  85   }
  86   elsif ( $ver =~ /^0\.9[1-8]/ ) {
  87     $ver = 0;
  88   }
  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;";
 102   if ( $@ ) {
 103       _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" );
 104   }
 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} );
 115 undef $db{output};
 116
 117 ################################################################################
 118
 119 sub _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
 141 sub _read_buffer {
 142   my ($fh, $len) = @_;
 143   my $buffer;
 144   read( $fh, $buffer, $len );
 145   return $buffer;
 146 }
 147
 148 sub _exit {
 149   my ($msg) = @_;
 150   pod2usage( -verbose => 0, -msg => $msg );
 151 }
 152
 153 __END__
 154
 155 =head1 NAME
 156
 157 upgrade_db.pl
 158
 159 =head1 SYNOPSIS
 160
 161   upgrade_db.pl -input <oldfile> -output <newfile>
 162
 163 =head1 DESCRIPTION
 164
 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.
 169
 170 =head1 OPTIONS
 171
 172 =over 4
 173
 174 =item B<-input> (required)
 175
 176 This is the name of original DB file.
 177
 178 =item B<-output> (required)
 179
 180 This is the name of target output DB file.
 181
 182 =item B<-version>
 183
 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
 186 0.91.
 187
 188 If the version is the same as the input file, this acts like a compressed copy
 189 of the database.
 190
 191 =item B<-autobless>
 192
 193 In pre-1.0000 versions, autoblessing was an optional setting defaulting to
 194 false. Autobless in upgrade_db.pl defaults to true.
 195
 196 =item B<-help>
 197
 198 Prints a brief help message, then exits.
 199
 200 =item B<-man>
 201
 202 Prints a much longer message, then exits;
 203
 204 =back
 205
 206 =head1 CAVEATS
 207
 208 The following are known issues with this converter.
 209
 210 =over 4
 211
 212 =item * Diskspace requirements
 213
 214 This will require about twice the diskspace of the input file.
 215
 216 =item * Feature support
 217
 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.
 221
 222 =back
 223
 224 =head1 MAINTAINER(S)
 225
 226 Rob Kinyon, L<rkinyon@cpan.org>
 227
 228 Originally written by Rob Kinyon, L<rkinyon@cpan.org>
 229
 230 =head1 LICENSE
 231
 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.
 235
 236 =cut