admin/shrinkdbm.pl

   1 #!/usr/bin/perl -w
   2
   3 # $Id: shrinkdbm.pl,v 1.1.2.1.2.3 2005-01-07 14:02:27 rurban Exp $
   4
   5 # shrink a DBM file
   6 # Steve Wainstead, July 2000
   7 # this script is public domain and has no warranty at all.
   8
   9 use strict;
  10 use Fcntl;
  11 use GDBM_File;
  12 use Getopt::Std;
  13 use vars ('$opt_o', '$opt_i');
  14 my (%old_db, %new_db);
  15
  16 # $opt_i == input file
  17 # $opt_o == output file
  18 getopts('i:o:');
  19
  20 # less confusing names
  21 my $input_db_file = $opt_i;
  22 my $output_db_file = $opt_o;
  23
  24
  25 die <<"USAGE" unless ($input_db_file and $output_db_file);
  26 Usage: $0 -i <infile> -o <outfile>
  27   where: infile is a GDBM file and,
  28          outfile is the name of the new file to write to.
  29
  30 The idea is to copy the old DB file to a new one and thereby
  31 save space.
  32
  33 USAGE
  34
  35 # open old file
  36 tie (%old_db, "GDBM_File", $input_db_file, O_RDWR, 0666)
  37   or die "Can't tie $input_db_file: $!\n";
  38
  39 print "There are ", scalar(keys %old_db), " keys in $input_db_file\n";
  40
  41 # open new file, deleting it first if it's already there
  42 if (-e $output_db_file) { unlink $opt_o; }
  43 tie (%new_db, "GDBM_File", $output_db_file, O_RDWR|O_CREAT, 0666)
  44   or die "Can't tie $input_db_file: $!\n";
  45
  46 # copy the files
  47 while (my($key, $value) = each(%old_db)) {
  48    $new_db{$key} = $value;
  49 }
  50
  51 print "There are now ", scalar(keys %old_db), " keys in $input_db_file\n";
  52 print "There are ", scalar(keys %new_db), " keys in $output_db_file\n";
  53 untie(%old_db);
  54 untie(%new_db);
  55