Contents 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	#!/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	my $file = shift \|\| die "$0: need index name\n";
19	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