Initial draft (unworking) of upgrade_db.pl

diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl
new file mode 100755 (executable)
index 0000000..0385a59
--- /dev/null
+++ b/utils/upgrade_db.pl
@@ -0,0 +1,206 @@
+#!/usr/bin/perl
+
+use 5.6.0;
+
+use strict;
+use warnings FATAL => 'all';
+
+use FindBin;
+use File::Spec ();
+use lib File::Spec->catdir( $FindBin::Bin, 'lib' );
+
+# This is for the latest version.
+use lib File::Spec->catdir( $FindBin::Bin, '..', 'lib' );
+
+use Getopt::Long qw( GetOptions );
+use Pod::Usage;
+
+my %headerver_to_module = (
+  '0' => 'DBM::Deep::09830',
+  '2' => 'DBM::Deep', 
+);
+
+my %is_dev = (
+  '1' => 1,
+);
+
+my %opts = (
+  man => 0,
+  help => 0,
+  version => '1.0000',
+  autobless => 0,
+);
+GetOptions( \%opts,
+  'input=s', 'output=s', 'version:s', 'autobless:i',
+  'help|?', 'man',
+) || pod2man(2);
+pod2usage(1) if $opts{help};
+pod2usage(-exitstatus => 0, -verbose => 2) if $opts{man};
+
+pod2usage(-msg => "Missing required parameters", verbose => 1)
+  unless $opts{input} && $opts{output};
+
+if ( $opts{input} eq $opts{output} ) {
+  _exit( "Cannot use the same filename for both input and output." );
+}
+
+foreach my $p ( qw( input output ) ) {
+  unless ( -f $opts{$p} ) {
+    _exit( "'$opts{$p}' is not a file." );
+  }
+}
+
+my %db;
+{
+  my $ver = _read_file_header( $opts{input} );
+  if ( $is_dev{ $ver } ) {
+    _exit( "'$opts{input}' is a dev release and not supported." );
+  }
+
+  my $mod = $headerver_to_module{ $ver };
+  require $mod;
+  $db{input} = $mod->new({
+    file    => $opts{input},
+    locking => 1,
+    autobless => $opts{autobless},
+  });
+  $db{input}->lock;
+}
+
+{
+  my $ver = $opts{version};
+  #if ( $ver =~ /^0\.98/ ) {
+  if ( $is_dev{ $ver } ) {
+    _exit( "'$opts{version}' is a dev release and not supported." );
+  }
+
+  my $mod = $headerver_to_module{ $ver };
+  require $mod;
+  $db{input} = $mod->new({
+    file    => $opts{input},
+    locking => 1,
+    autobless => $opts{autobless},
+  });
+  $db{input}->lock;
+}
+
+# Do the actual conversion
+
+################################################################################
+
+sub _read_file_header {
+  my ($file) = @_;
+
+  open my $fh, '<', $file
+    or _exit( "Cannot open '$file' for reading: $!" );
+
+  my $buffer = _read_buffer( $fh, 9 );
+  _exit( "'$file' is not a DBM::Deep file." )
+    unless length $buffer == 9;
+
+  my ($file_sig, $header_sig, $header_ver) = unpack( 'A4 A N', $buffer );
+
+  # SIG_FILE == 'DPDB'
+  _exit( "'$file' is not a DBM::Deep file." )
+    unless $file_sig eq 'DPDB';
+
+  # SIG_HEADER == 'h'
+  return 0 unless ($header_sig eq 'h');
+
+  return $header_ver;
+}
+
+sub _read_buffer {
+  my ($fh, $len) = @_;
+  my $buffer;
+  read( $fh, $buffer, $len );
+  return $buffer;
+}
+
+sub _exit {
+  my ($msg) = @_;
+  pod2usage( -verbose => 0, -msg => $msg );
+}
+
+__END__
+
+=head1 NAME
+
+upgrade_db.pl
+
+=head1 SYNOPSIS
+
+  upgrade_db.pl -input <oldfile> -output <newfile>
+
+=head1 DESCRIPTION
+
+This will attempt to upgrade DB files from one version of DBM::Deep to
+another. The version of the input file is detected from the file header. The
+version of the output file defaults to the version of the distro in this file,
+but can be set, if desired.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-input> (required)
+
+This is the name of original DB file.
+
+=item B<-output> (required)
+
+This is the name of target output DB file.
+
+=item B<-version>
+
+Optionally, you can specify the version of L<DBM::Deep> for the output file.
+This can either be an upgrade or a downgrade.
+
+If the version is the same, this is just like a call to compress().
+
+=item B<-autobless>
+
+In pre-1.0000 versions, autoblessing was an optional setting. This defaults to
+false.
+
+=item B<-help>
+
+Prints a brief help message, then exits.
+
+=item B<-man>
+
+Prints this longer message, then exits;
+
+=back
+
+=head1 CAVEATS
+
+The following are known issues with this converter.
+
+=over 4
+
+=item * Diskspace requirements
+
+This will require about twice the diskspace of the input file.
+
+=item * Feature support
+
+Not all versions support the same features. In particular, internal references
+were supported in 0.983 and support was removed in 1.000. There is no
+detection of this by upgrade_db.pl.
+
+=back
+
+=head1 MAINTAINER(S)
+
+Rob Kinyon, L<rkinyon@cpan.org>
+
+Originally written by Rob Kinyon, L<rkinyon@cpan.org>
+
+=head1 LICENSE
+
+Copyright (c) 2007 Rob Kinyon. All Rights Reserved.
+This is free software, you may use it and distribute it under the
+same terms as Perl itself.
+
+=cut