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',
  21 );
  22
  23 my %is_dev = (
  24   '1' => 1,
  25 );
  26
  27 my %opts = (
  28   man => 0,
  29   help => 0,
  30   version => '1.0000',
  31   autobless => 0,
  32 );
  33 GetOptions( \%opts,
  34   'input=s', 'output=s', 'version:s', 'autobless:i',
  35   'help|?', 'man',
  36 ) || pod2man(2);
  37 pod2usage(1) if $opts{help};
  38 pod2usage(-exitstatus => 0, -verbose => 2) if $opts{man};
  39
  40 pod2usage(-msg => "Missing required parameters.", verbose => 1)
  41   unless $opts{input} && $opts{output};
  42
  43 if ( $opts{input} eq $opts{output} ) {
  44   _exit( "Cannot use the same filename for both input and output." );
  45 }
  46
  47 unless ( -f $opts{input} ) {
  48   _exit( "'$opts{input}' is not a file." );
  49 }
  50
  51 my %db;
  52 {
  53   my $ver = _read_file_header( $opts{input} );
  54   if ( $is_dev{ $ver } ) {
  55     _exit( "'$opts{input}' is a dev release and not supported." );
  56   }
  57
  58   my $mod = $headerver_to_module{ $ver };
  59   eval "use $mod;";
  60   $db{input} = $mod->new({
  61     file      => $opts{input},
  62     locking   => 1,
  63     autobless => $opts{autobless},
  64   });
  65   $db{input}->lock;
  66 }
  67
  68 {
  69   my $ver = $opts{version};
  70   if ( $ver =~ /^0\.9[1-8]/ ) {
  71     $ver = 0;
  72   }
  73   elsif ( $ver =~ /^0\.99/) {
  74     $ver = 1;
  75   }
  76   elsif ( $ver =~ /^1\.000?0?/) {
  77     $ver = 2;
  78   }
  79   else {
  80     _exit( "'$ver' is an unrecognized version." );
  81   }
  82
  83   if ( $is_dev{ $ver } ) {
  84     _exit( "-version '$opts{version}' is a dev release and not supported." );
  85   }
  86
  87   # First thing is to destroy the file, in case it's an incompatible version.
  88   unlink $opts{output};
  89
  90   my $mod = $headerver_to_module{ $ver };
  91   eval "use $mod;";
  92   $db{output} = $mod->new({
  93     file      => $opts{output},
  94     locking   => 1,
  95     autobless => $opts{autobless},
  96   });
  97   $db{output}->lock;
  98 }
  99
 100 # Do the actual conversion. This is the code that compress uses.
 101 $db{input}->_copy_node( $db{output} );
 102 undef $db{output};
 103
 104 ################################################################################
 105
 106 sub _read_file_header {
 107   my ($file) = @_;
 108
 109   open my $fh, '<', $file
 110     or _exit( "Cannot open '$file' for reading: $!" );
 111
 112   my $buffer = _read_buffer( $fh, 9 );
 113   _exit( "'$file' is not a DBM::Deep file." )
 114     unless length $buffer == 9;
 115
 116   my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer );
 117
 118   # SIG_FILE == 'DPDB'
 119   _exit( "'$file' is not a DBM::Deep file." )
 120     unless $file_sig eq 'DPDB';
 121
 122   # SIG_HEADER == 'h' - this means that this is a pre-1.0 file
 123   return 0 unless ($header_sig eq 'h');
 124
 125   return $header_ver;
 126 }
 127
 128 sub _read_buffer {
 129   my ($fh, $len) = @_;
 130   my $buffer;
 131   read( $fh, $buffer, $len );
 132   return $buffer;
 133 }
 134
 135 sub _exit {
 136   my ($msg) = @_;
 137   pod2usage( -verbose => 0, -msg => $msg );
 138 }
 139
 140 __END__
 141
 142 =head1 NAME
 143
 144 upgrade_db.pl
 145
 146 =head1 SYNOPSIS
 147
 148   upgrade_db.pl -input <oldfile> -output <newfile>
 149
 150 =head1 DESCRIPTION
 151
 152 This will attempt to upgrade DB files from one version of DBM::Deep to
 153 another. The version of the input file is detected from the file header. The
 154 version of the output file defaults to the version of the distro in this file,
 155 but can be set, if desired.
 156
 157 =head1 OPTIONS
 158
 159 =over 4
 160
 161 =item B<-input> (required)
 162
 163 This is the name of original DB file.
 164
 165 =item B<-output> (required)
 166
 167 This is the name of target output DB file.
 168
 169 =item B<-version>
 170
 171 Optionally, you can specify the version of L<DBM::Deep> for the output file.
 172 This can either be an upgrade or a downgrade. The minimum version supported is
 173 0.91.
 174
 175 If the version is the same as the input file, this acts like a compressed copy
 176 of the database.
 177
 178 =item B<-autobless>
 179
 180 In pre-1.0000 versions, autoblessing was an optional setting. This defaults to
 181 false.
 182
 183 =item B<-help>
 184
 185 Prints a brief help message, then exits.
 186
 187 =item B<-man>
 188
 189 Prints a much longer message, then exits;
 190
 191 =back
 192
 193 =head1 CAVEATS
 194
 195 The following are known issues with this converter.
 196
 197 =over 4
 198
 199 =item * Diskspace requirements
 200
 201 This will require about twice the diskspace of the input file.
 202
 203 =item * Feature support
 204
 205 Not all versions support the same features. In particular, internal references
 206 were supported in 0.983 and support was removed in 1.000. There is no
 207 detection of this by upgrade_db.pl.
 208
 209 =back
 210
 211 =head1 MAINTAINER(S)
 212
 213 Rob Kinyon, L<rkinyon@cpan.org>
 214
 215 Originally written by Rob Kinyon, L<rkinyon@cpan.org>
 216
 217 =head1 LICENSE
 218
 219 Copyright (c) 2007 Rob Kinyon. All Rights Reserved.
 220 This is free software, you may use it and distribute it under the
 221 same terms as Perl itself.
 222
 223 =cut