Annotation of /trunk/script/dump_index

#!/usr/local/bin/perl -w
#                              -*- Mode: Perl -*- 
# $Basename$
# $Revision: 1.1 $
# Author          : Ulrich Pfeifer
# Created On      : Mon Apr 17 12:33:23 2000
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sat Nov 11 16:27:32 2000
# Language        : CPerl
# 
# (C) Copyright 2000, UUNET Deutschland GmbH, Germany
# 

use DB_File;
use strict;

my %idx;
my $file = shift || die "$0: need index name\n";
my $dbh = tie %idx, 'DB_File', $file, O_RDONLY, 0664, $DB_BTREE
  or die;

sub is_an_old_index {
  my $dbh = shift;

  my $O = pack('C', 0xff)."o";
  my ($word, $value) = ($O.$;);
  $dbh->seq($word, $value, R_CURSOR);
  for (my $i=0; $i<10;$i++) {
    if (not $value or $value !~ /^\d+$/) {
      return 0;
    }
    if ($dbh->seq($word, $value, R_NEXT) or # no values left
        $word !~ /^$O/o                     # no $O values left
       ) {
      # we are not sure enough that this is an old index
      print "Hmm, that's difficult\n";
      return 0;
    }
  }
  return 1;
}

sub pl {
  my $value = shift;
  my @p = unpack 'w*', $value;
  my @r;
  while (@p) {
    push @r, join '', shift @p, ":", shift @p;
  }
  join ", ", @r;
}

my $old= is_an_old_index($dbh);
warn sprintf("%s is %s old index\n", $file,
             $old ? "a":"not an");

if ($old) {
  while (my($key, $value) = each %idx) {
    if ($key =~ /^\377([om]).(.*)/) {
      print "$1\t$2\t$value\n";
    } else {
      print "p\t", $key, "\t", pl($value), "\n";
    }
  }
} else {
  while (my($key, $value) = each %idx) {
    my $type = substr($key,0,1);
    my $word = substr($key,1);
    print $type, "\t", $word, "\t";
    if ($type eq 'p') {
      print pl($value);
    } else {
      print $value;
    }
    print "\n";
  }
}
undef $dbh;
untie %idx;

1	ulpfr	22	#!/usr/local/bin/perl -w
2			# -- Mode: Perl --
3			# $Basename$
4			# $Revision: 1.1 $
5			# Author : Ulrich Pfeifer
6			# Created On : Mon Apr 17 12:33:23 2000
7			# Last Modified By: Ulrich Pfeifer
8			# Last Modified On: Sat Nov 11 16:27:32 2000
9			# Language : CPerl
10			#
11			# (C) Copyright 2000, UUNET Deutschland GmbH, Germany
12			#
13
14			use DB_File;
15			use strict;
16
17			my %idx;
18	dpavlin	100	my $file = shift \|\| die "$0: need index name\n";
19	ulpfr	22	my $dbh = tie %idx, 'DB_File', $file, O_RDONLY, 0664, $DB_BTREE
20			or die;
21
22			sub is_an_old_index {
23			my $dbh = shift;
24
25			my $O = pack('C', 0xff)."o";
26			my ($word, $value) = ($O.$;);
27			$dbh->seq($word, $value, R_CURSOR);
28			for (my $i=0; $i<10;$i++) {
29			if (not $value or $value !~ /^\d+$/) {
30			return 0;
31			}
32			if ($dbh->seq($word, $value, R_NEXT) or # no values left
33			$word !~ /^$O/o # no $O values left
34			) {
35			# we are not sure enough that this is an old index
36			print "Hmm, that's difficult\n";
37			return 0;
38			}
39			}
40			return 1;
41			}
42
43			sub pl {
44			my $value = shift;
45			my @p = unpack 'w*', $value;
46			my @r;
47			while (@p) {
48			push @r, join '', shift @p, ":", shift @p;
49			}
50			join ", ", @r;
51			}
52
53			my $old= is_an_old_index($dbh);
54			warn sprintf("%s is %s old index\n", $file,
55			$old ? "a":"not an");
56
57			if ($old) {
58			while (my($key, $value) = each %idx) {
59			if ($key =~ /^\377([om]).(.*)/) {
60			print "$1\t$2\t$value\n";
61			} else {
62			print "p\t", $key, "\t", pl($value), "\n";
63			}
64			}
65			} else {
66			while (my($key, $value) = each %idx) {
67			my $type = substr($key,0,1);
68			my $word = substr($key,1);
69			print $type, "\t", $word, "\t";
70			if ($type eq 'p') {
71			print pl($value);
72			} else {
73			print $value;
74			}
75			print "\n";
76			}
77			}
78			undef $dbh;
79			untie %idx;
80