/[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!
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

cvs-head/lib/WAIT/Table.pm revision 24 by ulpfr, Sat Nov 11 17:21:28 2000 UTC trunk/lib/WAIT/Table.pm revision 113 by dpavlin, Tue Jul 13 20:28:45 2004 UTC
# Line 4  Line 4 
4  # Author          : Ulrich Pfeifer  # Author          : Ulrich Pfeifer
5  # Created On      : Thu Aug  8 13:05:10 1996  # Created On      : Thu Aug  8 13:05:10 1996
6  # Last Modified By: Ulrich Pfeifer  # Last Modified By: Ulrich Pfeifer
7  # Last Modified On: Fri May 19 14:51:14 2000  # Last Modified On: Wed Jan 23 14:15:15 2002
8  # Language        : CPerl  # Language        : CPerl
9  # Update Count    : 133  # Update Count    : 152
10  # Status          : Unknown, Use with caution!  # Status          : Unknown, Use with caution!
11  #  #
12  # Copyright (c) 1996-1997, Ulrich Pfeifer  # Copyright (c) 1996-1997, Ulrich Pfeifer
# Line 25  WAIT::Table -- Module for maintaining Ta Line 25  WAIT::Table -- Module for maintaining Ta
25  =cut  =cut
26    
27  package WAIT::Table;  package WAIT::Table;
28    our $VERSION = "2.000";
29    
30  use WAIT::Table::Handle ();  use WAIT::Table::Handle ();
31  require WAIT::Parse::Base;  require WAIT::Parse::Base;
32    
33  use strict;  use strict;
34  use Carp;  use Carp qw(cluck croak);
35  # use autouse Carp => qw( croak($) );  # use autouse Carp => qw( croak($) );
36  use DB_File;  use BerkeleyDB;
37  use Fcntl;  use Fcntl;
 use LockFile::Simple ();  
   
 my $USE_RECNO = 0;  
38    
39  =head2 Creating a Table.  =head2 Creating a Table.
40    
# Line 133  sub new { Line 131  sub new {
131    my $self = {};    my $self = {};
132    
133    # Check for mandatory attrs early    # Check for mandatory attrs early
134    $self->{name}     = $parm{name}     or croak "No name specified";    for my $x (qw(name attr env maindbfile tablename)) {
135    $self->{attr}     = $parm{attr}     or croak "No attributes specified";      $self->{$x}     = $parm{$x}     or croak "No $x specified";
136      }
137    
138    # Do that before we eventually add '_weight' to attributes.    # Do that before we eventually add '_weight' to attributes.
139    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];
# Line 158  sub new { Line 157  sub new {
157      unshift @{$parm{attr}}, '_weight' unless $attr{'_weight'};      unshift @{$parm{attr}}, '_weight' unless $attr{'_weight'};
158    }    }
159    
160    $self->{file}     = $parm{file}     or croak "No file specified";    $self->{path}     = $parm{path}     or croak "No path specified";
161    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";  
   }  
   
   my $lockmgr = LockFile::Simple->make(-autoclean => 1);  
   # aquire a write lock  
   $self->{write_lock} = $lockmgr->lock($self->{file} . '/write')  
     or die "Can't lock '$self->{file}/write'";  
162    
163    $self->{djk}      = $parm{djk}      if defined $parm{djk};    $self->{djk}      = $parm{djk}      if defined $parm{djk};
164    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;
# Line 177  sub new { Line 167  sub new {
167    $self->{deleted}  = {};       # no deleted records yet    $self->{deleted}  = {};       # no deleted records yet
168    $self->{indexes}  = {};    $self->{indexes}  = {};
169    
170    bless $self, $type;    # Checking for readers is not necessary, but let's go with the
171      # generic method.
172      
173    # Call create_index() and create_index() for compatibility    # Call create_index() and create_index() for compatibility
174    for (@{$self->{keyset}||[]}) {    for (@{$self->{keyset}||[]}) {
175      #carp "Specification of indexes at table create time is deprecated";      #carp "Specification of indexes at table create time is deprecated";
# Line 187  sub new { Line 179  sub new {
179      # carp "Specification of inverted indexes at table create time is deprecated";      # carp "Specification of inverted indexes at table create time is deprecated";
180      my $att  = shift @{$parm{invindex}};      my $att  = shift @{$parm{invindex}};
181      my @spec = @{shift @{$parm{invindex}}};      my @spec = @{shift @{$parm{invindex}}};
182      my @opt;      my @opt  = ();
183    
184      if (ref($spec[0])) {      if (ref($spec[0])) {
185        carp "Secondary pipelines are deprecated\n";        warn "Secondary pipelines are deprecated";
186        @opt = %{shift @spec};        @opt = %{shift @spec};
187      }      }
188      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);      $self->create_inverted_index(attribute => $att,
189                                     pipeline  => \@spec,
190                                     @opt);
191    }    }
192    
193    $self;    $self;
194    # end of backwarn compatibility stuff    # end of backwarn compatibility stuff
195  }  }
196    
197    for my $accessor (qw(maindbfile tablename)) {
198      no strict 'refs';
199      *{$accessor} = sub {
200        my($self) = @_;
201        return $self->{$accessor} if $self->{$accessor};
202        require Carp;
203        Carp::confess("accessor $accessor not there");
204      }
205    }
206    
207  =head2 Creating an index  =head2 Creating an index
208    
209    $tb->create_index('docid');    $tb->create_index('docid');
210    
211  =item C<create_index>  C<create_index>
   
212  must be called with a list of attributes. This must be a subset of the  must be called with a list of attributes. This must be a subset of the
213  attributes specified when the table was created. Currently this  attributes specified when the table was created. Currently this
214  method must be called before the first tuple is inserted in the  method must be called before the first tuple is inserted in the
# Line 222  sub create_index { Line 225  sub create_index {
225    require WAIT::Index;    require WAIT::Index;
226    
227    my $name = join '-', @_;    my $name = join '-', @_;
228      #### warn "WARNING: Suspect use of \$_ in method create_index. name[$name]_[$_]";
229    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
230      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;      WAIT::Index->new(
231                         file => $self->path.'/'.$name,
232                         subname => $name,
233                         env  => $self->{env},
234                         maindbfile => $self->maindbfile,
235                         tablename => $self->tablename,
236                         attr => $_,
237                        );
238  }  }
239    
240  =head2 Creating an inverted index  =head2 Creating an inverted index
# Line 284  sub create_inverted_index { Line 295  sub create_inverted_index {
295    }    }
296    
297    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
298    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = WAIT::InvertedIndex->new(file   => $self->path.'/'.$name,
299                                      filter => [@{$parm{pipeline}}], # clone                                       subname=> $name,
300                                      name   => $name,                                       env    => $self->{env},
301                                      attr   => $parm{attribute},                                       maindbfile => $self->maindbfile,
302                                      %opt, # backward compatibility stuff                                       tablename => $self->tablename,
303                                     );                                       filter => [@{$parm{pipeline}}], # clone
304                                         name   => $name,
305                                         attr   => $parm{attribute},
306                                         %opt, # backward compatibility stuff
307                                        );
308    # We will have to use $parm{predicate} here    # We will have to use $parm{predicate} here
309    push @{$self->{inverted}->{$parm{attribute}}}, $idx;    push @{$self->{inverted}->{$parm{attribute}}}, $idx;
310  }  }
311    
312  sub dir {  sub dir {
313    $_[0]->{file};    $_[0]->path;
314  }  }
315    
316  =head2 C<$tb-E<gt>layout>  =head2 C<$tb-E<gt>layout>
# Line 323  Must be called via C<WAIT::Database::dro Line 338  Must be called via C<WAIT::Database::dro
338    
339  sub drop {  sub drop {
340    my $self = shift;    my $self = shift;
341    
342    if ((caller)[0] eq 'WAIT::Database') { # database knows about this    if ((caller)[0] eq 'WAIT::Database') { # database knows about this
343      $self->close;               # just make sure      $self->close;               # just make sure
344      my $file = $self->{file};  
345        my $path = $self->path;
346    
347      for (values %{$self->{indexes}}) {      for (values %{$self->{indexes}}) {
348        $_->drop;        $_->drop;
349      }      }
350      unlink "$file/records";      unlink "$path/records";
351      # $self->unlock;      rmdir "$path/read" or warn "Could not rmdir '$path/read'";
352      ! (!-e $file or rmdir $file);  
353    } else {    } else {
354      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
355    }    }
# Line 346  sub mrequire ($) { Line 363  sub mrequire ($) {
363    require $module;    require $module;
364  }  }
365    
366    sub path {
367      my($self) = @_;
368      return $self->{path} if $self->{path};
369      require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
370      require Carp;
371      Carp::confess("NO path attr");
372    }
373    
374  sub open {  sub open {
375    my $self = shift;    my $self = shift;
376    my $file = $self->{file} . '/records';    my $path = $self->path . '/records';
377    
378    mrequire ref($self);           # that's tricky eh?    mrequire ref($self);           # that's tricky eh?
379    if (defined $self->{'layout'}) {    if (defined $self->{'layout'}) {
# Line 359  sub open { Line 384  sub open {
384    }    }
385    if (exists $self->{indexes}) {    if (exists $self->{indexes}) {
386      require WAIT::Index;      require WAIT::Index;
387      for (values %{$self->{indexes}}) {      for my $Ind (values %{$self->{indexes}}) {
388        $_->{mode} = $self->{mode};        for my $x (qw(mode env maindbfile)) {
389            $Ind->{$x} = $self->{$x};
390          }
391      }      }
392    }    }
393    if (exists $self->{inverted}) {    if (exists $self->{inverted}) {
394      my ($att, $idx);      my ($att, $idx);
395      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
396        for $idx (@{$self->{inverted}->{$att}}) {        for $idx (@{$self->{inverted}->{$att}}) {
397          $idx->{mode} = $self->{mode};          for my $x (qw(mode env maindbfile)) {
398              $idx->{$x} = $self->{$x};
399            }
400        }        }
401      }      }
402      require WAIT::InvertedIndex;      require WAIT::InvertedIndex;
403    }    }
   unless (defined $self->{dbh}) {  
     if ($USE_RECNO) {  
       $self->{dbh} = tie(@{$self->{db}}, 'DB_File', $file,  
                          $self->{mode}, 0664, $DB_RECNO);  
     } else {  
       $self->{dbh} =  
         tie(%{$self->{db}}, 'DB_File', $file,  
                          $self->{mode}, 0664, $DB_BTREE);  
     }  
   }  
   
   # Locking  
   #  
   # We allow multiple readers to coexists.  But write access excludes  
   # all read access vice versa.  In practice read access on tables  
   # open for writing will mostly work ;-)  
   
   my $lockmgr = LockFile::Simple->make(-autoclean => 1);  
   
   # aquire a write lock. We might hold one acquired in create() already  
   $self->{write_lock} ||= $lockmgr->lock($self->{file} . '/write')  
     or die "Can't lock '$self->{file}/write'";  
404    
405    my $lockdir = $self->{file} . '/read';    # CONFUSION: WAIT knows two *modes*: read-only or read-write.
406    unless (-d $lockdir) {    # BerkeleyDB means file permissions when talking about Mode.
407      mkdir $lockdir, 0755 or die "Could not mkdir $lockdir: $!";    # BerkeleyDB has the "Flags" attribute to specify
408    }    # read/write/lock/etc subsystems.
409    
410      my $flags;
411    if ($self->{mode} & O_RDWR) {    if ($self->{mode} & O_RDWR) {
412      # this is a hack.  We do not check for reopening ...      $flags = DB_CREATE; # | DB_INIT_MPOOL | DB_PRIVATE | DB_INIT_CDB;
413      return $self if $self->{write_lock};      #warn "DEBUG: Flags on table $path set to 'writing'";
       
     # If we actually want to write we must check if there are any readers  
     opendir DIR, $lockdir or  
       die "Could not opendir '$lockdir': $!";  
     for my $lockfile (grep { -f "$lockdir/$_" } readdir DIR) {  
       # check if the locks are still valid.  
       # Since we are protected by a write lock, we could use a pline file.  
       # But we want to use the stale testing from LockFile::Simple.  
       if (my $lck = $lockmgr->trylock("$lockdir/$lockfile")) {  
         warn "Removing stale lockfile '$lockdir/$lockfile'";  
         $lck->release;  
       } else {  
         $self->{write_lock}->release;  
         die "Cannot write table '$file' while it's in use";  
       }  
     }  
414    } else {    } else {
415      # this is a hack.  We do not check for reopening ...      $flags = DB_RDONLY;
416      return $self if $self->{read_lock};      #warn "DEBUG: Flags on table $path set to 'readonly'";
417          }
418      # We are a reader. So we release the write lock    unless (defined $self->{dbh}) {
419      my $id = time;      my $subname = $self->tablename . "/records";
420      while (-f "$lockdir/$id.lock") { # here assume ".lock" format!      $self->{dbh} =
421        $id++;          tie(%{$self->{db}}, 'BerkeleyDB::Btree',
422      }              $self->{env} ? (Env => $self->{env}) : (),
423      $self->{read_lock} = $lockmgr->lock("$lockdir/$id");              # Filename => $file,
424      $self->{write_lock}->release;              Filename => $self->maindbfile,
425      delete $self->{write_lock};              Subname => $subname,
426                Mode => 0664,
427                Flags => $flags,
428                $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
429                $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
430               )
431                or die "Cannot tie: $BerkeleyDB::Error;
432     DEBUG: Filename[$self->{maindbfile}]subname[$subname]Mode[0664]Flags[$flags]";
433    }    }
   
434    $self;    $self;
435  }  }
436    
# Line 510  sub insert { Line 508  sub insert {
508    unless ($gotkey) {    unless ($gotkey) {
509      $key = $self->{nextk}++;      $key = $self->{nextk}++;
510    }    }
511    if ($USE_RECNO) {    $self->{db}->{$key} = $tuple;
     $self->{db}->[$key] = $tuple;  
   } else {  
     $self->{db}->{$key} = $tuple;  
   }  
512    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
513      unless ($_->insert($key, %parm)) {      unless ($_->insert($key, %parm)) {
514        # duplicate key, undo changes        # duplicate key, undo changes
# Line 565  sub fetch { Line 559  sub fetch {
559    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
560    
561    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
562    if ($USE_RECNO) {    $self->unpack($self->{db}->{$key});
     $self->unpack($self->{db}->[$key]);  
   } else {  
     $self->unpack($self->{db}->{$key});  
   }  
563  }  }
564    
565  sub delete_by_key {  sub delete_by_key {
# Line 577  sub delete_by_key { Line 567  sub delete_by_key {
567    my $key   = shift;    my $key   = shift;
568    
569    unless ($key) {    unless ($key) {
570      Carp::cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";      cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
571      return;      return;
572    }    }
573    
# Line 609  sub delete { Line 599  sub delete {
599  }  }
600    
601  sub unpack {  sub unpack {
602    my $self = shift;    my($self, $tuple) = @_;
603    my $tuple = shift;  
604    return unless defined $tuple;    unless (defined $tuple){
605        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
606        warn("Debug: somebody called unpack without argument tuple!");
607        return;
608      }
609    
610    my $att;    my $att;
611    my @result;    my @result;
# Line 625  sub unpack { Line 619  sub unpack {
619    
620  sub set {  sub set {
621    my ($self, $iattr, $value) = @_;    my ($self, $iattr, $value) = @_;
622        # in the rare case that they haven't written a single record yet, we
623    unless ($self->{write_lock}) {    # make sure, the inverted inherits our $self->{mode}:
624      die "Cannot set attribute $iattr without having a write lock. Nothing done";    defined $self->{db} or $self->open;
625    }  
626    for my $att (keys %{$self->{inverted}}) {    for my $att (keys %{$self->{inverted}}) {
627      if ($] > 5.003) {         # avoid bug in perl up to 5.003_05      if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
628        my $idx;        my $idx;
# Line 646  sub set { Line 640  sub set {
640  sub close {  sub close {
641    my $self = shift;    my $self = shift;
642    
643      #cluck("DEBUG: Closing A Table");
644    
645    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
646      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
647    }    }
648    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
649      require WAIT::Index;      for (values %{$self->{indexes}}) {
650      $_->close();        $_->close();
651        }
652    }    }
653    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
654      require WAIT::InvertedIndex;      # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
655        # if WAIT::InvertedIndex has not been loaded, they cannot have
656        # been altered so far
657      my $att;      my $att;
658      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
659        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
# Line 669  sub close { Line 668  sub close {
668    }    }
669    if ($self->{dbh}) {    if ($self->{dbh}) {
670      delete $self->{dbh};      delete $self->{dbh};
671      }
672      if ($USE_RECNO) {    untie %{$self->{db}};
673        untie @{$self->{db}};    for my $att (qw(env db path maindbfile)) {
674      } else {      delete $self->{$att};
675        untie %{$self->{db}};      #cluck "DEBUG: Deleted att $att";
     }  
     delete $self->{db};  
676    }    }
677    
   $self->unlock;  
     
678    1;    1;
679  }  }
680    
681  sub unlock {  sub DESTROY {
682    my $self = shift;    my $self = shift;
683    
684    # Either we have a read or a write lock (or we close the table already)    delete $self->{env};
   # unless ($self->{read_lock} || $self->{write_lock}) {  
   #   warn "WAIT::Table::unlock: Table aparently hold's no lock"  
   # }  
   if ($self->{write_lock}) {  
     $self->{write_lock}->release();  
     delete $self->{write_lock};  
   }  
   if ($self->{read_lock}) {  
     $self->{read_lock}->release();  
     delete $self->{read_lock};  
   }  
685    
686  }    # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
687    
 sub DESTROY {  
   my $self = shift;  
   
   warn "Table handle destroyed without closing it first"  
     if $self->{write_lock} || $self->{read_lock};  
688  }  }
689    
690  sub open_scan {  sub open_scan {
# Line 762  sub intervall { Line 741  sub intervall {
741    bless \%result, 'WAIT::Query::Raw';    bless \%result, 'WAIT::Query::Raw';
742  }  }
743    
744  sub search {  sub search_ref {
745    my $self  = shift;    my $self  = shift;
746    my ($query, $attr, $cont, $raw);    my ($query, $attr, $cont, $raw);
747    if (ref $_[0]) {    if (ref $_[0]) {
748      $query = shift;      $query = shift;
749          # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$query],[qw()])->Indent(1)->Useqq(1)->Dump; # XXX
750    
751      $attr = $query->{attr};      $attr = $query->{attr};
752      $cont = $query->{cont};      $cont = $query->{cont};
753      $raw  = $query->{raw};      $raw  = $query->{raw};
754    } else {    } else {
755      require Carp;      cluck("Using three argument search interface is deprecated, use hashref interface instead");
     Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");  
756      $attr = shift;      $attr = shift;
757      $cont = shift;      $cont = shift;
758      $raw  = shift;      $raw  = shift;
# Line 807  sub search { Line 786  sub search {
786    }    }
787    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
788      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
789        my %r = $_->search($query, $cont);        my $r = $_->search_ref($query, $cont);
790        my ($key, $val);        my ($key, $val);
791        while (($key, $val) = each %r) {        while (($key, $val) = each %$r) {
792          if (exists $result{$key}) {          if (exists $result{$key}) {
793            $result{$key} += $val;            $result{$key} += $val;
794          } else {          } else {
# Line 823  sub search { Line 802  sub search {
802    for (keys %result) {    for (keys %result) {
803      delete $result{$_} if $self->{deleted}->{$_}      delete $result{$_} if $self->{deleted}->{$_}
804    }    }
805    %result;    \%result;
806    }
807    
808    sub parse_query {
809      my($self, $attr, $query) = @_;
810      return unless defined $query && length $query;
811      my %qt;
812      for (@{$self->{inverted}->{$attr}}) {
813        grep $qt{$_}++, $_->parse($query);
814      }
815      [keys %qt];
816  }  }
817    
818  sub hilight_positions {  sub hilight_positions {
Legend:
Removed from v.24  
changed lines
  Added in v.113
  ViewVC Help
Powered by ViewVC 1.1.26