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.0007',
  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\.000[3-7]/) {
  75     $ver = 3;
  76   }
  77   elsif ( $ver =~ /^1\.000?[0-2]?/) {
  78     $ver = 2;
  79   }
  80   elsif ( $ver =~ /^0\.99/) {
  81     $ver = 1;
  82   }
  83   elsif ( $ver =~ /^0\.9[1-8]/ ) {
  84     $ver = 0;
  85   }
  86   else {
  87     _exit( "'$ver' is an unrecognized version." );
  88   }
  89
  90   if ( $is_dev{ $ver } ) {
  91     _exit( "-version '$opts{version}' is a dev release and not supported." );
  92   }
  93
  94   # First thing is to destroy the file, in case it's an incompatible version.
  95   unlink $opts{output};
  96
  97   my $mod = $headerver_to_module{ $ver };
  98   eval "use $mod;";
  99   if ( $@ ) {
 100       _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" );
 101   }
 102   $db{output} = $mod->new({
 103     file      => $opts{output},
 104     locking   => 1,
 105     autobless => $opts{autobless},
 106   });
 107   $db{output}->lock;
 108 }
 109
 110 # Do the actual conversion. This is the code that compress uses.
 111 $db{input}->_copy_node( $db{output} );
 112 undef $db{output};
 113
 114 ################################################################################
 115
 116 sub _read_file_header {
 117   my ($file) = @_;
 118
 119   open my $fh, '<', $file
 120     or _exit( "Cannot open '$file' for reading: $!" );
 121
 122   my $buffer = _read_buffer( $fh, 9 );
 123   _exit( "'$file' is not a DBM::Deep file." )
 124     unless length $buffer == 9;
 125
 126   my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer );
 127
 128   # SIG_FILE == 'DPDB'
 129   _exit( "'$file' is not a DBM::Deep file." )
 130     unless $file_sig eq 'DPDB';
 131
 132   # SIG_HEADER == 'h' - this means that this is a pre-1.0 file
 133   return 0 unless ($header_sig eq 'h');
 134
 135   return $header_ver;
 136 }
 137
 138 sub _read_buffer {
 139   my ($fh, $len) = @_;
 140   my $buffer;
 141   read( $fh, $buffer, $len );
 142   return $buffer;
 143 }
 144
 145 sub _exit {
 146   my ($msg) = @_;
 147   pod2usage( -verbose => 0, -msg => $msg );
 148 }
 149
 150 __END__
 151
 152 =head1 NAME
 153
 154 upgrade_db.pl
 155
 156 =head1 SYNOPSIS
 157
 158   upgrade_db.pl -input <oldfile> -output <newfile>
 159
 160 =head1 DESCRIPTION
 161
 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.
 166
 167 =head1 OPTIONS
 168
 169 =over 4
 170
 171 =item B<-input> (required)
 172
 173 This is the name of original DB file.
 174
 175 =item B<-output> (required)
 176
 177 This is the name of target output DB file.
 178
 179 =item B<-version>
 180
 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
 183 0.91.
 184
 185 If the version is the same as the input file, this acts like a compressed copy
 186 of the database.
 187
 188 =item B<-autobless>
 189
 190 In pre-1.0000 versions, autoblessing was an optional setting defaulting to
 191 false. Autobless in upgrade_db.pl defaults to true.
 192
 193 =item B<-help>
 194
 195 Prints a brief help message, then exits.
 196
 197 =item B<-man>
 198
 199 Prints a much longer message, then exits;
 200
 201 =back
 202
 203 =head1 CAVEATS
 204
 205 The following are known issues with this converter.
 206
 207 =over 4
 208
 209 =item * Diskspace requirements
 210
 211 This will require about twice the diskspace of the input file.
 212
 213 =item * Feature support
 214
 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.
 218
 219 =back
 220
 221 =head1 MAINTAINER(S)
 222
 223 Rob Kinyon, L<rkinyon@cpan.org>
 224
 225 Originally written by Rob Kinyon, L<rkinyon@cpan.org>
 226
 227 =head1 LICENSE
 228
 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.
 232
 233 =cut