/[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

revision 10 by ulpfr, Fri Apr 28 15:40:52 2000 UTC revision 85 by ulpfr, Fri May 3 16:16:10 2002 UTC
# Line 1  Line 1 
1  #                              -*- Mode: Perl -*-  #                              -*- Mode: Cperl -*-
2  # Table.pm --  # Table.pm --
3  # ITIID           : $ITI$ $Header $__Header$  # ITIID           : $ITI$ $Header $__Header$
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: Sun Nov 22 18:44:37 1998  # Last Modified On: Sat Apr 27 17:20:31 2002
8  # Language        : CPerl  # Language        : CPerl
9  # Update Count    : 51  # Update Count    : 172
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
13  #  #
14    
15  =head1 NAME  =head1 NAME
16    
# 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    
29    use WAIT::Table::Handle ();
30  require WAIT::Parse::Base;  require WAIT::Parse::Base;
31    
32  use strict;  use strict;
33  use Carp;  use Carp;
34  use DB_File;  # use autouse Carp => qw( croak($) );
35    use BerkeleyDB;
36  use Fcntl;  use Fcntl;
37    use LockFile::Simple ();
38    
39  my $USE_RECNO = 0;  my $USE_RECNO = 0;
40    
41  =head2 Creating a Table.  =head2 Creating a Table.
42    
43  The constructor WAIT::Table-<gt>new is normally called via the  The constructor WAIT::Table-E<gt>new is normally called via the
44  create_table method of a database handle. This is not enforced, but  create_table method of a database handle. This is not enforced, but
45  creating a table doesn not make any sense unless the table is  creating a table does not make any sense unless the table is
46  registered by the database because the latter implements persistence  registered by the database because the latter implements persistence
47  of the meta data. Registering is done automatically by letting the  of the meta data. Registering is done automatically by letting the
48  database handle create a table.  database handle the creation of a table.
49    
50    my $db = create WAIT::Database name => 'sample';    my $db = WAIT::Database->create(name => 'sample');
51    my $tb = $db->create_table (name     => 'test',    my $tb = $db->create_table(name     => 'test',
52                                attr     => ['docid', 'headline'],                               access   => $access,
53                                layout   => $layout,                               layout   => $layout,
54                                access   => $access,                               attr     => ['docid', 'headline'],
55                               );                              );
56    
57  The constructor returns a handle for the table. This handle is hidden by the  The constructor returns a handle for the table. This handle is hidden by the
58  table module, to prevent direct access if called via Table.  table module, to prevent direct access if called via Table.
59    
60  =over 10  =over 10
61    
62  =item C<access> => I<accesobj>  =item C<access> => I<accessobj>
63    
64  A reference to a acces object for the external parts (attributes) of  A reference to an access object for the external parts (attributes) of
65  tuples. As you may remember, the WAIT System does not enforce that  tuples. As you may remember, the WAIT System does not enforce that
66  objects are completely stored inside the system to avoid duplication.  objects are completely stored inside the system to avoid duplication.
67  There is no (strong) point in storing all you HTML-Documents inside  There is no (strong) point in storing all your HTML documents inside
68  the system when indexing your WWW-Server.  the system when indexing your WWW-Server.
69    
70    The access object is designed to work like as a tied hash. You pass
71    the refernce to the object, not the tied hash though. An example
72    implementation of an access class that works for manpages is
73    WAIT::Document::Nroff.
74    
75    The implementation needs to take into account that WAIT will keep this
76    object in a Data::Dumper or Storable database and re-use it when sman
77    is run. So it is not good enough if we can produce the index with it
78    now, when we create or actively access the table, WAIT also must be
79    able to retrieve documents on its own, when we are in a different
80    context. This happens specifically in a retrieval. To get this working
81    seemlessly, the access-defining class must implement a close method.
82    This method will be called before the Data::Dumper dump takes place.
83    In that moment the access-defining class must get rid of all data
84    structures that cannot be reconstructed via the Data::Dumper dump,
85    such as database handles or C pointers.
86    
87  =item C<file> => I<fname>  =item C<file> => I<fname>
88    
89  The filename of the records file. Files for indexes will have I<fname>  The filename of the records file. Files for indexes will have I<fname>
90  as prefix. I<Mandatory>  as prefix. I<Mandatory>, but usually taken care of by the
91    WAIT::Database handle when the constructor is called via
92    WAIT::Database::create_table().
93    
94  =item C<name> => I<name>  =item C<name> => I<name>
95    
# Line 73  The name of this table. I<Mandatory> Line 97  The name of this table. I<Mandatory>
97    
98  =item C<attr> => [ I<attr> ... ]  =item C<attr> => [ I<attr> ... ]
99    
100  A reference to an array of attribute names. I<Mandatory>  A reference to an array of attribute names. WAIT will keep the
101    contents of these attributes in its table. I<Mandatory>
102    
103  =item C<djk> => [ I<attr> ... ]  =item C<djk> => [ I<attr> ... ]
104    
105  A reference to an array of attribute names which make up the  A reference to an array of attribute names which make up the
106  I<disjointness key>. Don't think about it - i's of no use yet;  I<disjointness key>. Don't think about it - it's of no use yet;
107    
108  =item C<layout> => I<layoutobj>  =item C<layout> => I<layoutobj>
109    
110  A reference to an external parser object. Defaults to anew instance of  A reference to an external parser object. Defaults to a new instance
111  C<WAIT::Parse::Base>  of C<WAIT::Parse::Base>. For an example implementation see
112    WAIT::Parse::Nroff. A layout class can be implemented as a singleton
113    class if you so like.
114    
115    =item C<keyset> => I<keyset>
116    
117  =item C<access> => I<accesobj>  The set of attributes needed to identify a record. Defaults to all
118    attributes.
119    
120  A reference to a acces object for the external parts of tuples.  =item C<invindex> => I<inverted index>
121    
122    A reference to an anon array defining attributes of each record that
123    need to be indexed. See the source of smakewhatis for how to set this
124    up.
125    
126  =back  =back
127    
# Line 98  sub new { Line 132  sub new {
132    my %parm = @_;    my %parm = @_;
133    my $self = {};    my $self = {};
134    
135      # Check for mandatory attrs early
136      $self->{name}     = $parm{name}     or croak "No name specified";
137      $self->{attr}     = $parm{attr}     or croak "No attributes specified";
138    
139    # Do that before we eventually add '_weight' to attributes.    # Do that before we eventually add '_weight' to attributes.
140    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];
141    
142    $self->{mode}     = O_CREAT | O_RDWR;    $self->{mode}     = O_CREAT | O_RDWR;
143    
144    # Determine and set up subclass    # Determine and set up subclass
145    $type = ref($type) || $type;    $type = ref($type) || $type;
146    if (defined $parm{djk}) {    if (defined $parm{djk}) {
# Line 119  sub new { Line 159  sub new {
159    }    }
160    
161    $self->{file}     = $parm{file}     or croak "No file specified";    $self->{file}     = $parm{file}     or croak "No file specified";
162    if (-d  $self->{file} or !mkdir($self->{file}, 0775)) {    if (-e  $self->{file}){
163      croak "Could not 'mkdir $self->{file}': $!\n";      warn "Warning: file '$self->{file}' already exists\n";
164    }    }
165    $self->{name}     = $parm{name}     or croak "No name specified";  
   $self->{attr}     = $parm{attr}     or croak "No attributes specified";  
166    $self->{djk}      = $parm{djk}      if defined $parm{djk};    $self->{djk}      = $parm{djk}      if defined $parm{djk};
167    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;
168    $self->{access}   = $parm{access} if defined $parm{access};    $self->{access}   = $parm{access} if defined $parm{access};
# Line 132  sub new { Line 171  sub new {
171    $self->{indexes}  = {};    $self->{indexes}  = {};
172    
173    bless $self, $type;    bless $self, $type;
174    
175      # Checking for readers is not necessary, but let's go with the
176      # generic method.
177      $self->getlock(O_RDWR|O_CREAT); # dies when failing
178      
179    # Call create_index() and create_index() for compatibility    # Call create_index() and create_index() for compatibility
180    for (@{$self->{keyset}||[]}) {    for (@{$self->{keyset}||[]}) {
181      #carp "Specification of indexes at table create time is deprecated";      #carp "Specification of indexes at table create time is deprecated";
# Line 142  sub new { Line 186  sub new {
186      my $att  = shift @{$parm{invindex}};      my $att  = shift @{$parm{invindex}};
187      my @spec = @{shift @{$parm{invindex}}};      my @spec = @{shift @{$parm{invindex}}};
188      my @opt;      my @opt;
189        
190      if (ref($spec[0])) {      if (ref($spec[0])) {
191        carp "Secondary pipelines are deprecated\n";        carp "Secondary pipelines are deprecated\n";
192        @opt = %{shift @spec};        @opt = %{shift @spec};
193      }      }
194      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);
195    }    }
196    
197    $self;    $self;
198    # end of backwarn compatibility stuff    # end of backwarn compatibility stuff
199  }  }
# Line 168  table! Line 213  table!
213    
214  sub create_index {  sub create_index {
215    my $self= shift;    my $self= shift;
216      
217    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
218      if $self->{nextk} > 1;      if $self->{nextk} > 1;
219      
220    require WAIT::Index;    require WAIT::Index;
221      
222    my $name = join '-', @_;    my $name = join '-', @_;
223    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
224      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;      new WAIT::Index file => $self->{file}, name => $name, attr => $_;
225  }  }
226    
227  =head2 Creating an inverted index  =head2 Creating an inverted index
# Line 196  set attributes specified when the table Line 241  set attributes specified when the table
241    
242  =item C<pipeline>  =item C<pipeline>
243    
244  A piplines specification is a reference to and array of method names  A piplines specification is a reference to an array of method names
245  (from package C<WAIT::Filter>) which are to applied in sequence to the  (from package C<WAIT::Filter>) which are to be applied in sequence to
246  contents of the named attribute. The attribute name may not be in the  the contents of the named attribute. The attribute name may not be in
247  attribute list.  the attribute list.
248    
249  =item C<predicate>  =item C<predicate>
250    
251  An indication which predicate the index implements. This may be  An indication which predicate the index implements. This may be
252  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for
253  query processing. Currently there is no standard set of predicate  query processing. Currently there is no standard set of predicate
254  names. The predicate defaults to the last member of the ppline if  names. The predicate defaults to the last member of the pipeline if
255  omitted.  omitted.
256    
257  =back  =back
# Line 224  sub create_inverted_index { Line 269  sub create_inverted_index {
269    croak "No pipeline specified"  unless $parm{pipeline};    croak "No pipeline specified"  unless $parm{pipeline};
270    
271    $parm{predicate} ||= $parm{pipeline}->[-1];    $parm{predicate} ||= $parm{pipeline}->[-1];
272      
273    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
274      if $self->{nextk} > 1;      if $self->{nextk} > 1;
275      
276    require WAIT::InvertedIndex;    require WAIT::InvertedIndex;
277    
278    # backward compatibility stuff    # backward compatibility stuff
# Line 235  sub create_inverted_index { Line 280  sub create_inverted_index {
280    for (qw(attribute pipeline predicate)) {    for (qw(attribute pipeline predicate)) {
281      delete $opt{$_};      delete $opt{$_};
282    }    }
283      
284    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
285    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,
286                                      filter => [@{$parm{pipeline}}], # clone                                      filter => [@{$parm{pipeline}}], # clone
# Line 276  Must be called via C<WAIT::Database::dro Line 321  Must be called via C<WAIT::Database::dro
321    
322  sub drop {  sub drop {
323    my $self = shift;    my $self = shift;
324    
325      unless ($self->{write_lock}){
326        warn "Cannot drop table without write lock. Nothing done";
327        return;
328      }
329      
330    if ((caller)[0] eq 'WAIT::Database') { # database knows about this    if ((caller)[0] eq 'WAIT::Database') { # database knows about this
331      $self->close;               # just make sure      $self->close;               # just make sure
332    
333      my $file = $self->{file};      my $file = $self->{file};
334    
335      for (values %{$self->{indexes}}) {      for (values %{$self->{indexes}}) {
336        $_->drop;        $_->drop;
337      }      }
338      unlink "$file/records";      rmdir "$file.read" or warn "Could not rmdir '$file/read'";
339      ! (!-e $file or rmdir $file);      unlink "$file";
340        
341    } else {    } else {
342      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
343    }    }
# Line 324  sub open { Line 377  sub open {
377      }      }
378      require WAIT::InvertedIndex;      require WAIT::InvertedIndex;
379    }    }
380    
381      $self->getlock($self->{mode});
382    
383      my $dbmode = ($self->{mode} & O_CREAT) ? DB_CREATE : 0;
384    unless (defined $self->{dbh}) {    unless (defined $self->{dbh}) {
385      if ($USE_RECNO) {      if ($USE_RECNO) {
386        $self->{dbh} = tie(@{$self->{db}}, 'DB_File', $file,        tie(%{$self->{db}}, 'BerkeleyDB::Recno',
387                           $self->{mode}, 0664, $DB_RECNO);            -Filename => $self->{file},
388              -Subname  => 'records',
389              -Flags    => $dbmode);
390      } else {      } else {
391        $self->{dbh} =        $self->{dbh} =
392          tie(%{$self->{db}}, 'DB_File', $file,          tie(%{$self->{db}}, 'BerkeleyDB::Btree',
393                           $self->{mode}, 0664, $DB_BTREE);              -Filename => $self->{file},
394                -Subname  => 'records',
395                -Mode     => 0664,
396                -Flags    => $dbmode);
397      }      }
398    }    }
399      
400      
401    $self;    $self;
402  }  }
403    
404  sub fetch_extern {  sub fetch_extern {
405    my $self  = shift;    my $self  = shift;
406    
407    print "#@_", $self->{'access'}->{Mode}, "\n";    # print "#@_", $self->{'access'}->{Mode}, "\n"; # DEBUGGING?
408    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
409      mrequire ref($self->{'access'});      mrequire ref($self->{'access'});
410      $self->{'access'}->FETCH(@_);      $self->{'access'}->FETCH(@_);
# Line 358  sub _find_index { Line 422  sub _find_index {
422    my (@att) = @_;    my (@att) = @_;
423    my %att;    my %att;
424    my $name;    my $name;
425      
426    @att{@att} = @att;    @att{@att} = @att;
427    
428    KEY: for $name (keys %{$self->{indexes}}) {    KEY: for $name (keys %{$self->{indexes}}) {
# Line 375  sub have { Line 439  sub have {
439    my $self  = shift;    my $self  = shift;
440    my %parm  = @_;    my %parm  = @_;
441    
442    my $index = $self->_find_index(keys %parm);    my $index = $self->_find_index(keys %parm) or return; # no index-no have
443    croak "No index found" unless $index;  
444    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
445    return $index->have(@_);    return $index->have(@_);
446  }  }
# Line 387  sub insert { Line 451  sub insert {
451    
452    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
453    
454      # We should move all writing methods to a subclass to check only once
455      $self->{mode} & O_RDWR or croak "Cannot insert into table opened in RD_ONLY mode";
456    
457    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
458    my $key;    my $key;
459    my @deleted = keys %{$self->{deleted}};    my @deleted = keys %{$self->{deleted}};
460      my $gotkey = 0;
461    
462    if (@deleted) {    if (@deleted) {
463      $key = pop @deleted;      $key = pop @deleted;
464      delete $self->{deleted}->{$key};      delete $self->{deleted}->{$key};
465        # Sanity check
466        if ($key && $key>0) {
467          $gotkey=1;
468    } else {    } else {
469          warn(sprintf("WAIT database inconsistency during insert ".
470                       "key[%s]: Please rebuild index\n",
471                       $key
472                      ));
473        }
474      }
475      unless ($gotkey) {
476      $key = $self->{nextk}++;      $key = $self->{nextk}++;
477    }    }
478    if ($USE_RECNO) {    if ($USE_RECNO) {
# Line 408  sub insert { Line 486  sub insert {
486        if ($key == $self->{nextk}-1) {        if ($key == $self->{nextk}-1) {
487          $self->{nextk}--;          $self->{nextk}--;
488        } else {        } else {
489            # warn "setting key[$key] deleted during insert";
490          $self->{deleted}->{$key}=1;          $self->{deleted}->{$key}=1;
491        }        }
492        my $idx;        my $idx;
# Line 416  sub insert { Line 495  sub insert {
495          $idx->remove($key, %parm);          $idx->remove($key, %parm);
496        }        }
497        return undef;        return undef;
498      }      }
499    }    }
500    if (defined $self->{inverted}) {    if (defined $self->{inverted}) {
501      my $att;      my $att;
# Line 432  sub insert { Line 511  sub insert {
511    
512  sub sync {  sub sync {
513    my $self  = shift;    my $self  = shift;
514      
515    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
516      map $_->sync, $_;      map $_->sync, $_;
517    }    }
# Line 449  sub fetch { Line 528  sub fetch {
528    my $key   = shift;    my $key   = shift;
529    
530    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
531      
532    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
533    if ($USE_RECNO) {    if ($USE_RECNO) {
534      $self->unpack($self->{db}->[$key]);      $self->unpack($self->{db}->[$key]);
# Line 462  sub delete_by_key { Line 541  sub delete_by_key {
541    my $self  = shift;    my $self  = shift;
542    my $key   = shift;    my $key   = shift;
543    
544      unless ($key) {
545        Carp::cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
546        return;
547      }
548    
549    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
550    my %tuple = $self->fetch($key);    my %tuple = $self->fetch($key);
551    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
# Line 478  sub delete_by_key { Line 562  sub delete_by_key {
562        }        }
563      }      }
564    }    }
565      # warn "setting key[$key] deleted during delete_by_key";
566    ++$self->{deleted}->{$key};    ++$self->{deleted}->{$key};
567  }  }
568    
569  sub delete {  sub delete {
570    my $self  = shift;    my $self  = shift;
571    my $tkey = $self->have(@_);    my $tkey = $self->have(@_);
572      # warn "tkey[$tkey]\@_[@_]";
573    defined $tkey && $self->delete_by_key($tkey, @_);    defined $tkey && $self->delete_by_key($tkey, @_);
574  }  }
575    
576  sub unpack {  sub unpack {
577    my $self = shift;    my($self, $tuple) = @_;
578    my $tuple = shift;  
579      unless (defined $tuple){
580        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
581        warn("Debug: somebody called unpack without argument tuple!");
582        return;
583      }
584    
585    my $att;    my $att;
586    my @result;    my @result;
# Line 502  sub unpack { Line 592  sub unpack {
592    @result;    @result;
593  }  }
594    
595    sub set {
596      my ($self, $iattr, $value) = @_;
597      
598      unless ($self->{write_lock}){
599        warn "Cannot set iattr[$iattr] without write lock. Nothing done";
600        return;
601      }
602    
603      # in the rare case that they haven't written a single record yet, we
604      # make sure, the inverted inherits our $self->{mode}:
605      defined $self->{db} or $self->open;
606    
607      for my $att (keys %{$self->{inverted}}) {
608        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
609          my $idx;
610          for $idx (@{$self->{inverted}->{$att}}) {
611            $idx->set($iattr, $value);
612          }
613        } else {
614          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
615        }
616      }
617    
618      1;
619    }
620    
621  sub close {  sub close {
622    my $self = shift;    my $self = shift;
623    
624    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
625      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
626    }    }
627    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
628      $_->close();      for (values %{$self->{indexes}}) {
629          $_->close();
630        }
631    }    }
632    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
633        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
634        # if WAIT::InvertedIndex has not been loaded, they cannot have
635        # been altered so far
636      my $att;      my $att;
637      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
638        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 535  sub close { Line 656  sub close {
656      delete $self->{db};      delete $self->{db};
657    }    }
658    
659      $self->unlock;
660      
661    1;    1;
662  }  }
663    
664    # Locking
665    #
666    # We allow multiple readers to coexists.  But write access excludes
667    # all read access and vice versa.  In practice read access on tables
668    # open for writing will mostly work ;-)
669    
670    # If a "write" lock is requested, an existing "read" lock will be
671    # released.  If a "read" lock ist requested, an existing "write" lock
672    # will be released.  Requiring a lock already hold has no effect.
673    
674    sub getlock {
675      my ($self, $mode) = @_;
676    
677      # autoclean cleans on DESTROY, stale sends SIGZERO to the owner
678      #
679      my $lockmgr = LockFile::Simple->make(-autoclean => 1, -stale => 1);
680      my $file    = $self->{file};
681      my $lockdir = $self->{file} . '.read';
682    
683      unless (-d $lockdir) {
684        mkdir $lockdir, 0755 or die "Could not mkdir $lockdir: $!";
685      }
686      
687      if ($mode & O_RDWR) {         # Get a write lock.  Release it again
688                                    # and die if there is any valid
689                                    # readers.
690        
691        # Have a write lock already
692        return $self if $self->{write_lock};
693    
694        if ($self->{read_lock}) {   # We are a becoming a writer now. So
695                                    # we release the read lock to avoid
696                                    # blocking ourselves.
697          $self->{read_lock}->release;
698          delete $self->{read_lock};
699        }
700    
701        # Get the preliminary write lock
702        $self->{write_lock} = $lockmgr->lock($self->{file} . '.write')
703          or die "Can't lock '$self->{file}.write'";
704        
705        # If we actually want to write we must check if there are any
706        # readers.  The write lock is confirmed if wen cannot find any
707        # valid readers.
708        
709        local *DIR;
710        opendir DIR, $lockdir or
711          die "Could not opendir '$lockdir': $!";
712        for my $lockfile (grep { -f "$lockdir/$_" } readdir DIR) {
713          # Check if the locks are still valid.  Since we are protected by
714          # a write lock, we could use a plain file.  But we want to use
715          # the stale testing from LockFile::Simple.
716          if (my $lck = $lockmgr->trylock("$lockdir/$lockfile")) {
717            warn "Removing stale lockfile '$lockdir/$lockfile'";
718            $lck->release;
719          } else {                  # Found an active reader, rats!
720            $self->{write_lock}->release;
721            die "Cannot write table '$file' while it's in use";
722          }
723        }
724        closedir DIR;
725      } else {
726        # Have a read lock already
727        return $self if $self->{read_lock};
728    
729        # Get the preliminary write lock to protect the directory
730        # operations.
731    
732        my $write_lock = $lockmgr->lock($self->{file} . '.read/write')
733          or die "Can't lock '$self->{file}.read/write'";
734    
735        # Find a new read slot.  Maybe the plain file would be better?
736        my $id = time;
737        while (-f "$lockdir/$id.lock") { # here assume ".lock" format!
738          $id++;
739        }
740    
741        $self->{read_lock} = $lockmgr->lock("$lockdir/$id")
742          or die "Can't lock '$lockdir/$id'";
743    
744        # We are a reader now. So we release the write lock
745        $write_lock->release;
746      }
747      return $self;
748    }
749    
750    sub unlock {
751      my $self = shift;
752    
753      # Either we have a read or a write lock (or we close the table already)
754      # unless ($self->{read_lock} || $self->{write_lock}) {
755      #   warn "WAIT::Table::unlock: Table aparently hold's no lock"
756      # }
757      if ($self->{write_lock}) {
758        $self->{write_lock}->release();
759        delete $self->{write_lock};
760      }
761      if ($self->{read_lock}) {
762        $self->{read_lock}->release();
763        delete $self->{read_lock};
764      }
765    
766    }
767    
768    sub DESTROY {
769      my $self = shift;
770    
771      if ($self->{write_lock} || $self->{read_lock}) {
772        warn "Table handle destroyed without closing it first";
773        $self->unlock;
774      }
775    }
776    
777  sub open_scan {  sub open_scan {
778    my $self = shift;    my $self = shift;
779    my $code = shift;    my $code = shift;
# Line 593  sub intervall { Line 829  sub intervall {
829  }  }
830    
831  sub search {  sub search {
832    my $self = shift;    my $self  = shift;
833    my $attr = shift;    my ($query, $attr, $cont, $raw);
834    my $cont = shift;    if (ref $_[0]) {
835    my $raw  = shift;      $query = shift;
836      
837        $attr = $query->{attr};
838        $cont = $query->{cont};
839        $raw  = $query->{raw};
840      } else {
841        require Carp;
842        Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");
843        $attr = shift;
844        $cont = shift;
845        $raw  = shift;
846        $query = {
847                  attr => $attr,
848                  cont => $cont,
849                  raw  => $raw,
850                 };
851      }
852    
853    my %result;    my %result;
854    
855    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 859  sub search {
859        my $name = $_->name;        my $name = $_->name;
860        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
861          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
862          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
863          my ($key, $val);          my ($key, $val);
864          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
865            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 873  sub search {
873    }    }
874    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
875      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
876        my %r = $_->search($cont);        my %r = $_->search($query, $cont);
877        my ($key, $val);        my ($key, $val);
878        while (($key, $val) = each %r) {        while (($key, $val) = each %r) {
879          if (exists $result{$key}) {          if (exists $result{$key}) {
# Line 644  sub hilight_positions { Line 897  sub hilight_positions {
897    my %pos;    my %pos;
898    
899    if (defined $raw) {    if (defined $raw) {
900      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
901                                              # WAIT::InvertedIndex for
902                                              # this index field $attr
903        my $name = $_->name;        my $name = $_->name;
904        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
905          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 933  sub hilight_positions {
933  }  }
934    
935  sub hilight {  sub hilight {
936    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
937    my $type = $tb->layout();    my $layout = $tb->layout();
938    
939    my @result;    my @result;
940    
941    $query ||= {};    $qplain ||= {};
942    $raw   ||= {};    $qraw   ||= {};
943    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
944    while (@ttxt) {    while (@ttxt) {
945      no strict 'refs';      no strict 'refs';
946      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 948  sub hilight {
948      my $fld;      my $fld;
949    
950      my %hl;      my %hl;
951      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
952        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
953                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
954        for (keys %$hp) {        for (keys %$hp) {
955          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
956            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 976  sub hilight {
976  }  }
977    
978  1;  1;
   
Legend:
Removed from v.10  
changed lines
  Added in v.85
  ViewVC Help
Powered by ViewVC 1.1.26