/[wait]/trunk/lib/WAIT/Table.pm

This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!

Diff of /trunk/lib/WAIT/Table.pm

Parent Directory | Revision Log | View Patch Patch

-branches/CPAN/lib/WAIT/Table.pm
revision 13 by ulpfr,
Fri Apr 28 15:42:44 2000 UTC
+trunk/lib/WAIT/Table.pm
revision 109 by dpavlin,
Tue Jul 13 17:50:27 2004 UTC
 Line 4
  # Author          : Ulrich Pfeifer
  # Created On      : Thu Aug  8 13:05:10 1996
  # Last Modified By: Ulrich Pfeifer
- # Last Modified On: Sun May 30 20:42:30 1999
+ # Last Modified On: Wed Jan 23 14:15:15 2002
  # Language        : CPerl
- # Update Count    : 56
+ # Update Count    : 152
  # Status          : Unknown, Use with caution!
  #
  # Copyright (c) 1996-1997, Ulrich Pfeifer
 Line 25 
 WAIT::Table -- Module for maintaining Ta
  =cut
  package WAIT::Table;
+ our $VERSION = "2.000";
  use WAIT::Table::Handle ();
  require WAIT::Parse::Base;
-Line 32 
 require WAIT::Parse::Base;
+Line 33 
 require WAIT::Parse::Base;
  use strict;
  use Carp;
  # use autouse Carp => qw( croak($) );
- use DB_File;
+ use BerkeleyDB;
  use Fcntl;
- my $USE_RECNO = 0;
  =head2 Creating a Table.
  The constructor WAIT::Table-E<gt>new is normally called via the
-Line 132 
 sub new {
+Line 131 
 sub new {
    my $self = {};
    # Check for mandatory attrs early
-   $self->{name}     = $parm{name}     or croak "No name specified";
+   for my $x (qw(name attr env maindbfile tablename)) {
-   $self->{attr}     = $parm{attr}     or croak "No attributes specified";
+     $self->{$x}     = $parm{$x}     or croak "No $x specified";
+   }
    # Do that before we eventually add '_weight' to attributes.
    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];
 Line 157 
 sub new {
      unshift @{$parm{attr}}, '_weight' unless $attr{'_weight'};
    }
-   $self->{file}     = $parm{file}     or croak "No file specified";
+   $self->{path}     = $parm{path}     or croak "No path specified";
-   if (-d  $self->{file}){
+   bless $self, $type;
-     warn "Warning: Directory '$self->{file}' already exists\n";
-   } elsif (!mkdir($self->{file}, 0775)) {
-     croak "Could not 'mkdir $self->{file}': $!\n";
-   }
    $self->{djk}      = $parm{djk}      if defined $parm{djk};
    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;
    $self->{access}   = $parm{access} if defined $parm{access};
-Line 170 
 sub new {
+Line 167 
 sub new {
    $self->{deleted}  = {};       # no deleted records yet
    $self->{indexes}  = {};
-   bless $self, $type;
+   # Checking for readers is not necessary, but let's go with the
+   # generic method.
    # Call create_index() and create_index() for compatibility
    for (@{$self->{keyset}||[]}) {
      #carp "Specification of indexes at table create time is deprecated";
-Line 180 
 sub new {
+Line 179 
 sub new {
      # carp "Specification of inverted indexes at table create time is deprecated";
      my $att  = shift @{$parm{invindex}};
      my @spec = @{shift @{$parm{invindex}}};
-     my @opt;
+     my @opt  = ();
      if (ref($spec[0])) {
-       carp "Secondary pipelines are deprecated\n";
+       warn "Secondary pipelines are deprecated";
        @opt = %{shift @spec};
      }
-     $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);
+     $self->create_inverted_index(attribute => $att,
+                                  pipeline  => \@spec,
+                                  @opt);
    }
    $self;
    # end of backwarn compatibility stuff
  }
+ for my $accessor (qw(maindbfile tablename)) {
+   no strict 'refs';
+   *{$accessor} = sub {
+     my($self) = @_;
+     return $self->{$accessor} if $self->{$accessor};
+     require Carp;
+     Carp::confess("accessor $accessor not there");
+   }
+ }
  =head2 Creating an index
    $tb->create_index('docid');
- =item C<create_index>
+ C<create_index>
  must be called with a list of attributes. This must be a subset of the
  attributes specified when the table was created. Currently this
  method must be called before the first tuple is inserted in the
-Line 214 
 sub create_index {
+Line 225 
 sub create_index {
    require WAIT::Index;
    my $name = join '-', @_;
+   #### warn "WARNING: Suspect use of \$_ in method create_index. name[$name]_[$_]";
    $self->{indexes}->{$name} =
-     new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;
+     WAIT::Index->new(
+                      file => $self->file.'/'.$name,
+                      subname => $name,
+                      env  => $self->{env},
+                      maindbfile => $self->maindbfile,
+                      tablename => $self->tablename,
+                      attr => $_,
+                     );
  }
  =head2 Creating an inverted index
-Line 276 
 sub create_inverted_index {
+Line 295 
 sub create_inverted_index {
    }
    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
-   my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,
+   my $idx = WAIT::InvertedIndex->new(file   => $self->file.'/'.$name,
-                                     filter => [@{$parm{pipeline}}], # clone
+                                      subname=> $name,
-                                     name   => $name,
+                                      env    => $self->{env},
-                                     attr   => $parm{attribute},
+                                      maindbfile => $self->maindbfile,
-                                     %opt, # backward compatibility stuff
+                                      tablename => $self->tablename,
-                                    );
+                                      filter => [@{$parm{pipeline}}], # clone
+                                      name   => $name,
+                                      attr   => $parm{attribute},
+                                      %opt, # backward compatibility stuff
+                                     );
    # We will have to use $parm{predicate} here
    push @{$self->{inverted}->{$parm{attribute}}}, $idx;
  }
  sub dir {
-   $_[0]->{file};
+   $_[0]->file;
  }
  =head2 C<$tb-E<gt>layout>
-Line 315 
 Must be called via C<WAIT::Database::dro
+Line 338 
 Must be called via C<WAIT::Database::dro
  sub drop {
    my $self = shift;
    if ((caller)[0] eq 'WAIT::Database') { # database knows about this
      $self->close;               # just make sure
-     my $file = $self->{file};
+     my $file = $self->file;
      for (values %{$self->{indexes}}) {
        $_->drop;
      }
      unlink "$file/records";
-     ! (!-e $file or rmdir $file);
+     rmdir "$file/read" or warn "Could not rmdir '$file/read'";
    } else {
      croak ref($self)."::drop called directly";
    }
-Line 337 
 sub mrequire ($) {
+Line 363 
 sub mrequire ($) {
    require $module;
  }
+ sub path {
+   my($self) = @_;
+   return $self->{path} if $self->{path};
+   require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
+   require Carp;
+   Carp::confess("NO file attr");
+ }
  sub open {
    my $self = shift;
-   my $file = $self->{file} . '/records';
+   my $file = $self->file . '/records';
    mrequire ref($self);           # that's tricky eh?
    if (defined $self->{'layout'}) {
-Line 350 
 sub open {
+Line 384 
 sub open {
    }
    if (exists $self->{indexes}) {
      require WAIT::Index;
-     for (values %{$self->{indexes}}) {
+     for my $Ind (values %{$self->{indexes}}) {
-       $_->{mode} = $self->{mode};
+       for my $x (qw(mode env maindbfile)) {
+         $Ind->{$x} = $self->{$x};
+       }
      }
    }
    if (exists $self->{inverted}) {
      my ($att, $idx);
      for $att (keys %{$self->{inverted}}) {
        for $idx (@{$self->{inverted}->{$att}}) {
-         $idx->{mode} = $self->{mode};
+         for my $x (qw(mode env maindbfile)) {
+           $idx->{$x} = $self->{$x};
+         }
        }
      }
      require WAIT::InvertedIndex;
    }
+   # CONFUSION: WAIT knows two *modes*: read-only or read-write.
+   # BerkeleyDB means file permissions when talking about Mode.
+   # BerkeleyDB has the "Flags" attribute to specify
+   # read/write/lock/etc subsystems.
+   my $flags;
+   if ($self->{mode} & O_RDWR) {
+     $flags = DB_CREATE; # | DB_INIT_MPOOL | DB_PRIVATE | DB_INIT_CDB;
+     warn "Flags on table $file set to 'writing'";
+   } else {
+     $flags = DB_RDONLY;
+     # warn "Flags on table $file set to 'readonly'";
+   }
    unless (defined $self->{dbh}) {
-     if ($USE_RECNO) {
+     my $subname = $self->tablename . "/records";
-       $self->{dbh} = tie(@{$self->{db}}, 'DB_File', $file,
+     $self->{dbh} =
-                          $self->{mode}, 0664, $DB_RECNO);
+         tie(%{$self->{db}}, 'BerkeleyDB::Btree',
-     } else {
+             $self->{env} ? (Env => $self->{env}) : (),
-       $self->{dbh} =
+             # Filename => $file,
-         tie(%{$self->{db}}, 'DB_File', $file,
+             Filename => $self->maindbfile,
-                          $self->{mode}, 0664, $DB_BTREE);
+             Subname => $subname,
-     }
+             Mode => 0664,
+             Flags => $flags,
+             $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
+             $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
+            )
+             or die "Cannot tie: $BerkeleyDB::Error;
+  DEBUG: Filename[$self->{maindbfile}]subname[$subname]Mode[0664]Flags[$flags]";
    }
    $self;
  }
-Line 432 
 sub insert {
+Line 490 
 sub insert {
    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
    my $key;
    my @deleted = keys %{$self->{deleted}};
+   my $gotkey = 0;
    if (@deleted) {
      $key = pop @deleted;
      delete $self->{deleted}->{$key};
+     # Sanity check
+     if ($key && $key>0) {
+       $gotkey=1;
    } else {
-     $key = $self->{nextk}++;
+       warn(sprintf("WAIT database inconsistency during insert ".
+                    "key[%s]: Please rebuild index\n",
+                    $key
+                   ));
+     }
    }
-   if ($USE_RECNO) {
+   unless ($gotkey) {
-     $self->{db}->[$key] = $tuple;
+     $key = $self->{nextk}++;
-   } else {
-     $self->{db}->{$key} = $tuple;
    }
+   $self->{db}->{$key} = $tuple;
    for (values %{$self->{indexes}}) {
      unless ($_->insert($key, %parm)) {
        # duplicate key, undo changes
        if ($key == $self->{nextk}-1) {
          $self->{nextk}--;
        } else {
+         # warn "setting key[$key] deleted during insert";
          $self->{deleted}->{$key}=1;
        }
        my $idx;
-Line 493 
 sub fetch {
+Line 559 
 sub fetch {
    return () if exists $self->{deleted}->{$key};
    defined $self->{db} or $self->open;
-   if ($USE_RECNO) {
+   $self->unpack($self->{db}->{$key});
-     $self->unpack($self->{db}->[$key]);
-   } else {
-     $self->unpack($self->{db}->{$key});
-   }
  }
  sub delete_by_key {
    my $self  = shift;
    my $key   = shift;
+   unless ($key) {
+     Carp::cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
+     return;
+   }
    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
    my %tuple = $self->fetch($key);
    for (values %{$self->{indexes}}) {
-Line 520 
 sub delete_by_key {
+Line 587 
 sub delete_by_key {
        }
      }
    }
+   # warn "setting key[$key] deleted during delete_by_key";
    ++$self->{deleted}->{$key};
  }
  sub delete {
    my $self  = shift;
    my $tkey = $self->have(@_);
+   # warn "tkey[$tkey]\@_[@_]";
    defined $tkey && $self->delete_by_key($tkey, @_);
  }
  sub unpack {
-   my $self = shift;
+   my($self, $tuple) = @_;
-   my $tuple = shift;
+   unless (defined $tuple){
+     # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
+     warn("Debug: somebody called unpack without argument tuple!");
+     return;
+   }
    my $att;
    my @result;
-Line 544 
 sub unpack {
+Line 617 
 sub unpack {
    @result;
  }
+ sub set {
+   my ($self, $iattr, $value) = @_;
+   # in the rare case that they haven't written a single record yet, we
+   # make sure, the inverted inherits our $self->{mode}:
+   defined $self->{db} or $self->open;
+   for my $att (keys %{$self->{inverted}}) {
+     if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
+       my $idx;
+       for $idx (@{$self->{inverted}->{$att}}) {
+         $idx->set($iattr, $value);
+       }
+     } else {
+       map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
+     }
+   }
+;
+ }
  sub close {
    my $self = shift;
+   require Carp; Carp::cluck("------->Closing A Table<-------");
    if (exists $self->{'access'}) {
      eval {$self->{'access'}->close}; # dont bother if not opened
    }
-   for (values %{$self->{indexes}}) {
+   if ($WAIT::Index::VERSION) {
-     $_->close();
+     for (values %{$self->{indexes}}) {
+       $_->close();
+     }
    }
-   if (defined $self->{inverted}) {
+   if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
+     # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
+     # if WAIT::InvertedIndex has not been loaded, they cannot have
+     # been altered so far
      my $att;
      for $att (keys %{$self->{inverted}}) {
        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
-Line 568 
 sub close {
+Line 668 
 sub close {
    }
    if ($self->{dbh}) {
      delete $self->{dbh};
+   }
-     if ($USE_RECNO) {
+   untie %{$self->{db}};
-       untie @{$self->{db}};
+   for my $att (qw(env db file maindbfile)) {
-     } else {
+     delete $self->{$att};
-       untie %{$self->{db}};
+     warn "----->Deleted att $att<-----";
-     }
-     delete $self->{db};
    }
 ;
-Line 583 
 sub close {
+Line 681 
 sub close {
  sub DESTROY {
    my $self = shift;
-   warn "Table handle destroyed without closing it first"
+   delete $self->{env};
-     if $self->{db} and $self->{mode}&O_RDWR;
+   # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
  }
  sub open_scan {
-Line 641 
 sub intervall {
+Line 741 
 sub intervall {
    bless \%result, 'WAIT::Query::Raw';
  }
- sub search {
+ sub search_ref {
-   my $self = shift;
+   my $self  = shift;
-   my $attr = shift;
+   my ($query, $attr, $cont, $raw);
-   my $cont = shift;
+   if (ref $_[0]) {
-   my $raw  = shift;
+     $query = shift;
+     # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$query],[qw()])->Indent(1)->Useqq(1)->Dump; # XXX
+     $attr = $query->{attr};
+     $cont = $query->{cont};
+     $raw  = $query->{raw};
+   } else {
+     require Carp;
+     Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");
+     $attr = shift;
+     $cont = shift;
+     $raw  = shift;
+     $query = {
+               attr => $attr,
+               cont => $cont,
+               raw  => $raw,
+              };
+   }
    my %result;
    defined $self->{db} or $self->open; # require layout
-Line 655 
 sub search {
+Line 773 
 sub search {
        my $name = $_->name;
        if (exists $raw->{$name} and @{$raw->{$name}}) {
          my $scale = 1/scalar(@{$raw->{$name}});
-         my %r = $_->search_raw(@{$raw->{$name}});
+         my %r = $_->search_raw($query, @{$raw->{$name}});
          my ($key, $val);
          while (($key, $val) = each %r) {
            if (exists $result{$key}) {
-Line 669 
 sub search {
+Line 787 
 sub search {
    }
    if (defined $cont and $cont ne '') {
      for (@{$self->{inverted}->{$attr}}) {
-       my %r = $_->search($cont);
+       my $r = $_->search_ref($query, $cont);
        my ($key, $val);
-       while (($key, $val) = each %r) {
+       while (($key, $val) = each %$r) {
          if (exists $result{$key}) {
            $result{$key} += $val;
          } else {
-Line 685 
 sub search {
+Line 803 
 sub search {
    for (keys %result) {
      delete $result{$_} if $self->{deleted}->{$_}
    }
-   %result;
+   \%result;
+ }
+ sub parse_query {
+   my($self, $attr, $query) = @_;
+   return unless defined $query && length $query;
+   my %qt;
+   for (@{$self->{inverted}->{$attr}}) {
+     grep $qt{$_}++, $_->parse($query);
+   }
+   [keys %qt];
  }
  sub hilight_positions {

 Legend:



Removed from v.13
 


changed lines


 
Added in v.109
 Legend:



Removed from v.13
 


changed lines


 
Added in v.109
-Removed from v.13
+Added in v.109

	ViewVC Help
Powered by ViewVC 1.1.26