POD linebreak cleanup
[dbsrgits/DBM-Deep.git] / 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.0014',
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-4]/ ) {
75     $ver = 3;
76   }
77   elsif ( $ver =~ /^1\.000[3-9]/ ) {
78     $ver = 3;
79   }
80   elsif ( $ver eq '1.00' || $ver eq '1.000' || $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