/[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 20 by cvs2svn, Tue May 9 11:29:45 2000 UTC trunk/lib/WAIT/Table.pm revision 108 by dpavlin, Tue Jul 13 17:41:12 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: Mon May  8 20:20:58 2000  # Last Modified On: Wed Jan 23 14:15:15 2002
8  # Language        : CPerl  # Language        : CPerl
9  # Update Count    : 131  # 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;
# Line 32  require WAIT::Parse::Base; Line 33  require WAIT::Parse::Base;
33  use strict;  use strict;
34  use Carp;  use Carp;
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');
# Line 222  sub create_index { Line 226  sub create_index {
226    require WAIT::Index;    require WAIT::Index;
227    
228    my $name = join '-', @_;    my $name = join '-', @_;
229      #### warn "WARNING: Suspect use of \$_ in method create_index. name[$name]_[$_]";
230    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
231      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;      WAIT::Index->new(
232                         file => $self->file.'/'.$name,
233                         subname => $name,
234                         env  => $self->{env},
235                         maindbfile => $self->maindbfile,
236                         tablename => $self->tablename,
237                         attr => $_,
238                        );
239  }  }
240    
241  =head2 Creating an inverted index  =head2 Creating an inverted index
# Line 284  sub create_inverted_index { Line 296  sub create_inverted_index {
296    }    }
297    
298    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
299    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = WAIT::InvertedIndex->new(file   => $self->file.'/'.$name,
300                                      filter => [@{$parm{pipeline}}], # clone                                       subname=> $name,
301                                      name   => $name,                                       env    => $self->{env},
302                                      attr   => $parm{attribute},                                       maindbfile => $self->maindbfile,
303                                      %opt, # backward compatibility stuff                                       tablename => $self->tablename,
304                                     );                                       filter => [@{$parm{pipeline}}], # clone
305                                         name   => $name,
306                                         attr   => $parm{attribute},
307                                         %opt, # backward compatibility stuff
308                                        );
309    # We will have to use $parm{predicate} here    # We will have to use $parm{predicate} here
310    push @{$self->{inverted}->{$parm{attribute}}}, $idx;    push @{$self->{inverted}->{$parm{attribute}}}, $idx;
311  }  }
312    
313  sub dir {  sub dir {
314    $_[0]->{file};    $_[0]->file;
315  }  }
316    
317  =head2 C<$tb-E<gt>layout>  =head2 C<$tb-E<gt>layout>
# Line 323  Must be called via C<WAIT::Database::dro Line 339  Must be called via C<WAIT::Database::dro
339    
340  sub drop {  sub drop {
341    my $self = shift;    my $self = shift;
342    
343    if ((caller)[0] eq 'WAIT::Database') { # database knows about this    if ((caller)[0] eq 'WAIT::Database') { # database knows about this
344      $self->close;               # just make sure      $self->close;               # just make sure
345      my $file = $self->{file};  
346        my $file = $self->file;
347    
348      for (values %{$self->{indexes}}) {      for (values %{$self->{indexes}}) {
349        $_->drop;        $_->drop;
350      }      }
351      unlink "$file/records";      unlink "$file/records";
352      # $self->unlock;      rmdir "$file/read" or warn "Could not rmdir '$file/read'";
353      ! (!-e $file or rmdir $file);  
354    } else {    } else {
355      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
356    }    }
# Line 346  sub mrequire ($) { Line 364  sub mrequire ($) {
364    require $module;    require $module;
365  }  }
366    
367    sub path {
368      my($self) = @_;
369      return $self->{path} if $self->{path};
370      require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
371      require Carp;
372      Carp::confess("NO file attr");
373    }
374    
375  sub open {  sub open {
376    my $self = shift;    my $self = shift;
377    my $file = $self->{file} . '/records';    my $file = $self->file . '/records';
378    
379    mrequire ref($self);           # that's tricky eh?    mrequire ref($self);           # that's tricky eh?
380    if (defined $self->{'layout'}) {    if (defined $self->{'layout'}) {
# Line 359  sub open { Line 385  sub open {
385    }    }
386    if (exists $self->{indexes}) {    if (exists $self->{indexes}) {
387      require WAIT::Index;      require WAIT::Index;
388      for (values %{$self->{indexes}}) {      for my $Ind (values %{$self->{indexes}}) {
389        $_->{mode} = $self->{mode};        for my $x (qw(mode env maindbfile)) {
390            $Ind->{$x} = $self->{$x};
391          }
392      }      }
393    }    }
394    if (exists $self->{inverted}) {    if (exists $self->{inverted}) {
395      my ($att, $idx);      my ($att, $idx);
396      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
397        for $idx (@{$self->{inverted}->{$att}}) {        for $idx (@{$self->{inverted}->{$att}}) {
398          $idx->{mode} = $self->{mode};          for my $x (qw(mode env maindbfile)) {
399              $idx->{$x} = $self->{$x};
400            }
401        }        }
402      }      }
403      require WAIT::InvertedIndex;      require WAIT::InvertedIndex;
404    }    }
   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 ;-)  
405    
406    my $lockmgr = LockFile::Simple->make(-autoclean => 1);    # CONFUSION: WAIT knows two *modes*: read-only or read-write.
407      # BerkeleyDB means file permissions when talking about Mode.
408    # aquire a write lock. We might hold one acquired in create() already    # BerkeleyDB has the "Flags" attribute to specify
409    $self->{write_lock} ||= $lockmgr->lock($self->{file} . '/write')    # read/write/lock/etc subsystems.
     or die "Can't lock '$self->{file}/write'";  
   
   my $lockdir = $self->{file} . '/read';  
   unless (-d $lockdir) {  
     mkdir $lockdir, 0755 or die "Could not mkdir $lockdir: $!";  
   }  
410    
411      my $flags;
412    if ($self->{mode} & O_RDWR) {    if ($self->{mode} & O_RDWR) {
413      # this is a hack.  We do not check for reopening ...      $flags = DB_CREATE; # | DB_INIT_MPOOL | DB_PRIVATE | DB_INIT_CDB;
414      return $self if $self->{write_lock};      warn "Flags on table $file 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";  
       }  
     }  
415    } else {    } else {
416      # this is a hack.  We do not check for reopening ...      $flags = DB_RDONLY;
417      return $self if $self->{read_lock};      # warn "Flags on table $file set to 'readonly'";
418          }
419      # We are a reader. So we release the write lock    unless (defined $self->{dbh}) {
420      my $id = time;      my $subname = $self->tablename . "/records";
421      while (-f "$lockdir/$id.lock") { # here assume ".lock" format!      $self->{dbh} =
422        $id++;          tie(%{$self->{db}}, 'BerkeleyDB::Btree',
423      }              $self->{env} ? (Env => $self->{env}) : (),
424      $self->{read_lock} = $lockmgr->lock("$lockdir/$id");              # Filename => $file,
425      $self->{write_lock}->release;              Filename => $self->maindbfile,
426      delete $self->{write_lock};              Subname => $subname,
427                Mode => 0664,
428                Flags => $flags,
429                $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
430                $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
431               )
432                or die "Cannot tie: $BerkeleyDB::Error;
433     DEBUG: Filename[$self->{maindbfile}]subname[$subname]Mode[0664]Flags[$flags]";
434    }    }
   
435    $self;    $self;
436  }  }
437    
# Line 510  sub insert { Line 509  sub insert {
509    unless ($gotkey) {    unless ($gotkey) {
510      $key = $self->{nextk}++;      $key = $self->{nextk}++;
511    }    }
512    if ($USE_RECNO) {    $self->{db}->{$key} = $tuple;
     $self->{db}->[$key] = $tuple;  
   } else {  
     $self->{db}->{$key} = $tuple;  
   }  
513    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
514      unless ($_->insert($key, %parm)) {      unless ($_->insert($key, %parm)) {
515        # duplicate key, undo changes        # duplicate key, undo changes
# Line 565  sub fetch { Line 560  sub fetch {
560    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
561    
562    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
563    if ($USE_RECNO) {    $self->unpack($self->{db}->{$key});
     $self->unpack($self->{db}->[$key]);  
   } else {  
     $self->unpack($self->{db}->{$key});  
   }  
564  }  }
565    
566  sub delete_by_key {  sub delete_by_key {
# Line 609  sub delete { Line 600  sub delete {
600  }  }
601    
602  sub unpack {  sub unpack {
603    my $self = shift;    my($self, $tuple) = @_;
604    my $tuple = shift;  
605    return unless defined $tuple;    unless (defined $tuple){
606        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
607        warn("Debug: somebody called unpack without argument tuple!");
608        return;
609      }
610    
611    my $att;    my $att;
612    my @result;    my @result;
# Line 625  sub unpack { Line 620  sub unpack {
620    
621  sub set {  sub set {
622    my ($self, $iattr, $value) = @_;    my ($self, $iattr, $value) = @_;
623        # in the rare case that they haven't written a single record yet, we
624    return unless $self->{write_lock};    # make sure, the inverted inherits our $self->{mode}:
625      defined $self->{db} or $self->open;
626    
627    for my $att (keys %{$self->{inverted}}) {    for my $att (keys %{$self->{inverted}}) {
628      if ($] > 5.003) {         # avoid bug in perl up to 5.003_05      if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
629        my $idx;        my $idx;
# Line 644  sub set { Line 641  sub set {
641  sub close {  sub close {
642    my $self = shift;    my $self = shift;
643    
644      require Carp; Carp::cluck("------->Closing A Table<-------");
645    
646    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
647      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
648    }    }
649    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
650      require WAIT::Index;      for (values %{$self->{indexes}}) {
651      $_->close();        $_->close();
652        }
653    }    }
654    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
655        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
656        # if WAIT::InvertedIndex has not been loaded, they cannot have
657        # been altered so far
658      my $att;      my $att;
659      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
660        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 666  sub close { Line 669  sub close {
669    }    }
670    if ($self->{dbh}) {    if ($self->{dbh}) {
671      delete $self->{dbh};      delete $self->{dbh};
672      }
673      if ($USE_RECNO) {    untie %{$self->{db}};
674        untie @{$self->{db}};    for my $att (qw(env db file maindbfile)) {
675      } else {      delete $self->{$att};
676        untie %{$self->{db}};      warn "----->Deleted att $att<-----";
     }  
     delete $self->{db};  
677    }    }
678    
   $self->unlock;  
     
679    1;    1;
680  }  }
681    
682  sub unlock {  sub DESTROY {
683    my $self = shift;    my $self = shift;
684    
685    # 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};  
   }  
   
 }  
686    
687  sub DESTROY {    # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
   my $self = shift;  
688    
   warn "Table handle destroyed without closing it first"  
     if $self->{write_lock} || $self->{read_lock};  
689  }  }
690    
691  sub open_scan {  sub open_scan {
# Line 759  sub intervall { Line 742  sub intervall {
742    bless \%result, 'WAIT::Query::Raw';    bless \%result, 'WAIT::Query::Raw';
743  }  }
744    
745  sub search {  sub search_ref {
746    my $self  = shift;    my $self  = shift;
747    my ($query, $attr, $cont, $raw);    my ($query, $attr, $cont, $raw);
748    if (ref $_[0]) {    if (ref $_[0]) {
749      $query = shift;      $query = shift;
750          # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$query],[qw()])->Indent(1)->Useqq(1)->Dump; # XXX
751    
752      $attr = $query->{attr};      $attr = $query->{attr};
753      $cont = $query->{cont};      $cont = $query->{cont};
754      $raw  = $query->{raw};      $raw  = $query->{raw};
# Line 804  sub search { Line 788  sub search {
788    }    }
789    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
790      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
791        my %r = $_->search($query, $cont);        my $r = $_->search_ref($query, $cont);
792        my ($key, $val);        my ($key, $val);
793        while (($key, $val) = each %r) {        while (($key, $val) = each %$r) {
794          if (exists $result{$key}) {          if (exists $result{$key}) {
795            $result{$key} += $val;            $result{$key} += $val;
796          } else {          } else {
# Line 820  sub search { Line 804  sub search {
804    for (keys %result) {    for (keys %result) {
805      delete $result{$_} if $self->{deleted}->{$_}      delete $result{$_} if $self->{deleted}->{$_}
806    }    }
807    %result;    \%result;
808    }
809    
810    sub parse_query {
811      my($self, $attr, $query) = @_;
812      return unless defined $query && length $query;
813      my %qt;
814      for (@{$self->{inverted}->{$attr}}) {
815        grep $qt{$_}++, $_->parse($query);
816      }
817      [keys %qt];
818  }  }
819    
820  sub hilight_positions {  sub hilight_positions {
Legend:
Removed from v.20  
changed lines
  Added in v.108
  ViewVC Help
Powered by ViewVC 1.1.26