lib/WAIT/Index.pm

#                              -*- Mode: Cperl -*- 
# Index.pm -- 
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Thu Aug  8 13:05:10 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Nov 22 18:44:43 1998
# Language        : CPerl
# Update Count    : 107
# Status          : Unknown, Use with caution!
# 
# Copyright (c) 1996-1997, Ulrich Pfeifer
# 

package WAIT::Index;
use WAIT::IndexScan;
use strict;
use BerkeleyDB;
use Fcntl;
use Carp;
use vars qw($VERSION);

$VERSION = "2.000"; # Table.pm tests if we are loaded by checking $VERSION

sub new {
  my $type = shift;
  my %parm = @_;
  my $self = {};

  for my $x (qw(path attr env subname maindbfile tablename)) {
    unless ($self->{$x} = $parm{$x}) {
      confess("No $x specified");
    }
  }
  bless $self, ref($type) || $type;
}

for my $accessor (qw(maindbfile tablename subname)) {
  no strict 'refs';
  *{$accessor} = sub {
    my($self) = @_;
    return $self->{$accessor} if $self->{$accessor};
    require Carp;
    Carp::confess("accessor $accessor not there");
  }
}

sub drop {
  my $self = shift;
  if ((caller)[0] eq 'WAIT::Table') { # Table knows about this
    my $path = $self->{path};
    ! (!-e $path or unlink $path);
  } else {                            # notify our database
    require Carp;
    Carp::croak(ref($self)."::drop called directly");
  }
}

sub open {
  my $self = shift;
  my $path = $self->{path};

  if (exists $self->{dbh}) {
    $self->{dbh};
  } else {
    my $flags;
    if ($self->{mode} & O_RDWR) {
      $flags = DB_CREATE; # | DB_INIT_MPOOL | DB_INIT_CDB;
      # warn "Flags on index $path set to 'writing'";
    } else {
      $flags = DB_RDONLY;
      # warn "Flags on index $path set to 'readonly'";
    }
    $self->{dbh} = tie(%{$self->{db}}, 'BerkeleyDB::Btree',
                       # Filename => $path,
                       Filename => $self->maindbfile,
                       $self->{env} ? (Env => $self->{env}) : (),
                       Subname => join("/",$self->tablename,$self->subname),
                       Mode => 0664,
                       Flags => $flags,
                       $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
                       $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
                      ) or die $BerkeleyDB::Error;
  }
}

sub insert {
  my $self  = shift;
  my $key   = shift;
  my %parm  = @_;

  defined $self->{db} or $self->open;

  my $tuple = join($;, map($parm{$_}, @{$self->{attr}}));

  if (exists $self->{db}->{$tuple}) {
    # duplicate entry
    return undef;
  }
  $self->{db}->{$tuple} = $key;
}

sub have {
  my $self  = shift;
  my %parm  = @_;

  defined $self->{db} or $self->open;

  my $tuple = join($;, map($parm{$_}, @{$self->{attr}}));

  $self->{db}->{$tuple};
}

sub fetch {
  my $self  = shift;
  my %parm  = @_;
  my @keys  = @{$self->{attr}->[0]};

  defined $self->{db} or $self->open;

  my $key   = join($;, map($parm{$_}, @keys));
  $self->{db}->{$key};
}

sub delete {
  my $self  = shift;
  my $key   = shift;
  my %parm  = @_;

  defined $self->{db} or $self->open;

  my $tuple = join($;, map($parm{$_}||"", @{$self->{attr}}));

  delete $self->{db}->{$tuple};
}

sub sync {
  my $self = shift;
  #warn "DEBUG: sync dbh[$self->{dbh}]";
  if ($self->{dbh}) {
        unless (defined($self->{dbh}->db_sync)) {
                carp "sync failed: $BerkeleyDB::Error";
        }
  } else {
        confess "sync called without dbh";
  }
}

sub close {
  my $self = shift;

  delete $self->{scans} if defined $self->{scans};

  delete $self->{env};
  if ($self->{dbh}) {
    delete $self->{dbh};
    delete $self->{_attr};

    warn "DEBUG: close index (still possible bug)";
    #use Devel::Peek;
    #print Dump($self->{dbh});
    
    untie %{$self->{db}};
    for my $att (qw(db path maindbfile)) {
      delete $self->{$att};
    }
  }
}

#sub DESTROY { $_[0]->close }

sub open_scan {
  my $self = shift;
  my $code = shift;

  $self->{dbh} or $self->open;
  new WAIT::IndexScan $self, $code;
}

1;
1	ulpfr	13	# -- Mode: Cperl --
2	ulpfr	10	# Index.pm --
3			# ITIID : $ITI$ $Header $__Header$
4			# Author : Ulrich Pfeifer
5			# Created On : Thu Aug 8 13:05:10 1996
6			# Last Modified By: Ulrich Pfeifer
7	dpavlin	89	# Last Modified On: Sun Nov 22 18:44:43 1998
8	ulpfr	10	# Language : CPerl
9	dpavlin	89	# Update Count : 107
10	ulpfr	10	# Status : Unknown, Use with caution!
11			#
12			# Copyright (c) 1996-1997, Ulrich Pfeifer
13			#
14
15			package WAIT::Index;
16			use WAIT::IndexScan;
17			use strict;
18	dpavlin	108	use BerkeleyDB;
19	ulpfr	10	use Fcntl;
20	dpavlin	115	use Carp;
21	laperla	29	use vars qw($VERSION);
22	ulpfr	10
23	dpavlin	108	$VERSION = "2.000"; # Table.pm tests if we are loaded by checking $VERSION
24	laperla	29
25	ulpfr	10	sub new {
26			my $type = shift;
27			my %parm = @_;
28			my $self = {};
29
30	dpavlin	114	for my $x (qw(path attr env subname maindbfile tablename)) {
31	dpavlin	108	unless ($self->{$x} = $parm{$x}) {
32	dpavlin	116	confess("No $x specified");
33	dpavlin	108	}
34	ulpfr	13	}
35	dpavlin	108	bless $self, ref($type) \|\| $type;
36			}
37
38			for my $accessor (qw(maindbfile tablename subname)) {
39			no strict 'refs';
40			*{$accessor} = sub {
41			my($self) = @_;
42			return $self->{$accessor} if $self->{$accessor};
43	ulpfr	13	require Carp;
44	dpavlin	108	Carp::confess("accessor $accessor not there");
45	ulpfr	13	}
46	ulpfr	10	}
47
48			sub drop {
49			my $self = shift;
50			if ((caller)[0] eq 'WAIT::Table') { # Table knows about this
51	dpavlin	114	my $path = $self->{path};
52			! (!-e $path or unlink $path);
53	ulpfr	13	} else { # notify our database
54			require Carp;
55			Carp::croak(ref($self)."::drop called directly");
56	ulpfr	10	}
57			}
58
59			sub open {
60			my $self = shift;
61	dpavlin	114	my $path = $self->{path};
62	ulpfr	10
63	dpavlin	89	if (exists $self->{dbh}) {
64	ulpfr	10	$self->{dbh};
65			} else {
66	dpavlin	108	my $flags;
67			if ($self->{mode} & O_RDWR) {
68			$flags = DB_CREATE; # \| DB_INIT_MPOOL \| DB_INIT_CDB;
69	dpavlin	114	# warn "Flags on index $path set to 'writing'";
70	dpavlin	108	} else {
71			$flags = DB_RDONLY;
72	dpavlin	114	# warn "Flags on index $path set to 'readonly'";
73	dpavlin	108	}
74			$self->{dbh} = tie(%{$self->{db}}, 'BerkeleyDB::Btree',
75	dpavlin	114	# Filename => $path,
76	dpavlin	108	Filename => $self->maindbfile,
77			$self->{env} ? (Env => $self->{env}) : (),
78			Subname => join("/",$self->tablename,$self->subname),
79			Mode => 0664,
80			Flags => $flags,
81			$WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
82			$WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
83			) or die $BerkeleyDB::Error;
84	ulpfr	10	}
85			}
86
87			sub insert {
88			my $self = shift;
89			my $key = shift;
90			my %parm = @_;
91
92			defined $self->{db} or $self->open;
93
94			my $tuple = join($;, map($parm{$_}, @{$self->{attr}}));
95
96			if (exists $self->{db}->{$tuple}) {
97			# duplicate entry
98			return undef;
99			}
100			$self->{db}->{$tuple} = $key;
101			}
102
103			sub have {
104			my $self = shift;
105			my %parm = @_;
106
107			defined $self->{db} or $self->open;
108
109			my $tuple = join($;, map($parm{$_}, @{$self->{attr}}));
110
111	ulpfr	82	$self->{db}->{$tuple};
112	ulpfr	10	}
113
114			sub fetch {
115			my $self = shift;
116			my %parm = @_;
117			my @keys = @{$self->{attr}->[0]};
118	ulpfr	13
119	ulpfr	10	defined $self->{db} or $self->open;
120
121			my $key = join($;, map($parm{$_}, @keys));
122			$self->{db}->{$key};
123			}
124
125			sub delete {
126			my $self = shift;
127			my $key = shift;
128			my %parm = @_;
129
130			defined $self->{db} or $self->open;
131
132	ulpfr	19	my $tuple = join($;, map($parm{$_}\|\|"", @{$self->{attr}}));
133	ulpfr	13
134	ulpfr	10	delete $self->{db}->{$tuple};
135			}
136
137			sub sync {
138			my $self = shift;
139	dpavlin	115	#warn "DEBUG: sync dbh[$self->{dbh}]";
140			if ($self->{dbh}) {
141			unless (defined($self->{dbh}->db_sync)) {
142			carp "sync failed: $BerkeleyDB::Error";
143			}
144			} else {
145			confess "sync called without dbh";
146			}
147	ulpfr	10	}
148
149			sub close {
150			my $self = shift;
151
152			delete $self->{scans} if defined $self->{scans};
153
154	dpavlin	108	delete $self->{env};
155	ulpfr	10	if ($self->{dbh}) {
156			delete $self->{dbh};
157	dpavlin	116	delete $self->{_attr};
158
159			warn "DEBUG: close index (still possible bug)";
160			#use Devel::Peek;
161			#print Dump($self->{dbh});
162
163	dpavlin	89	untie %{$self->{db}};
164	dpavlin	114	for my $att (qw(db path maindbfile)) {
165	dpavlin	108	delete $self->{$att};
166			}
167	ulpfr	10	}
168			}
169
170			#sub DESTROY { $_[0]->close }
171
172			sub open_scan {
173			my $self = shift;
174			my $code = shift;
175	ulpfr	13
176	ulpfr	10	$self->{dbh} or $self->open;
177			new WAIT::IndexScan $self, $code;
178			}
179
180			1;