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

branches/CPAN/lib/WAIT/Table.pm revision 11 by unknown, Fri Apr 28 15:41:10 2000 UTC cvs-head/lib/WAIT/Table.pm revision 86 by dpavlin, Mon May 24 13:41:28 2004 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        require WAIT::InvertedIndex;
609        if ($^V gt v5.003) {         # avoid bug in perl up to 5.003_05
610          my $idx;
611          for $idx (@{$self->{inverted}->{$att}}) {
612            $idx->set($iattr, $value);
613          }
614        } else {
615          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
616        }
617      }
618    
619      1;
620    }
621    
622  sub close {  sub close {
623    my $self = shift;    my $self = shift;
624    
625    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
626      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
627    }    }
628    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
629      $_->close();      for (values %{$self->{indexes}}) {
630          $_->close();
631        }
632    }    }
633    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
634        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
635        # if WAIT::InvertedIndex has not been loaded, they cannot have
636        # been altered so far
637      my $att;      my $att;
638      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
639        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 657  sub close {
657      delete $self->{db};      delete $self->{db};
658    }    }
659    
660      $self->unlock;
661      
662    1;    1;
663  }  }
664    
665    # Locking
666    #
667    # We allow multiple readers to coexists.  But write access excludes
668    # all read access and vice versa.  In practice read access on tables
669    # open for writing will mostly work ;-)
670    
671    # If a "write" lock is requested, an existing "read" lock will be
672    # released.  If a "read" lock ist requested, an existing "write" lock
673    # will be released.  Requiring a lock already hold has no effect.
674    
675    sub getlock {
676      my ($self, $mode) = @_;
677    
678      # autoclean cleans on DESTROY, stale sends SIGZERO to the owner
679      #
680      my $lockmgr = LockFile::Simple->make(-autoclean => 1, -stale => 1);
681      my $file    = $self->{file};
682      my $lockdir = $self->{file} . '.read';
683    
684      unless (-d $lockdir) {
685        mkdir $lockdir, 0755 or die "Could not mkdir $lockdir: $!";
686      }
687      
688      if ($mode & O_RDWR) {         # Get a write lock.  Release it again
689                                    # and die if there is any valid
690                                    # readers.
691        
692        # Have a write lock already
693        return $self if $self->{write_lock};
694    
695        if ($self->{read_lock}) {   # We are a becoming a writer now. So
696                                    # we release the read lock to avoid
697                                    # blocking ourselves.
698          $self->{read_lock}->release;
699          delete $self->{read_lock};
700        }
701    
702        # Get the preliminary write lock
703        $self->{write_lock} = $lockmgr->lock($self->{file} . '.write')
704          or die "Can't lock '$self->{file}.write'";
705        
706        # If we actually want to write we must check if there are any
707        # readers.  The write lock is confirmed if wen cannot find any
708        # valid readers.
709        
710        local *DIR;
711        opendir DIR, $lockdir or
712          die "Could not opendir '$lockdir': $!";
713        for my $lockfile (grep { -f "$lockdir/$_" } readdir DIR) {
714          # Check if the locks are still valid.  Since we are protected by
715          # a write lock, we could use a plain file.  But we want to use
716          # the stale testing from LockFile::Simple.
717          if (my $lck = $lockmgr->trylock("$lockdir/$lockfile")) {
718            warn "Removing stale lockfile '$lockdir/$lockfile'";
719            $lck->release;
720          } else {                  # Found an active reader, rats!
721            $self->{write_lock}->release;
722            die "Cannot write table '$file' while it's in use";
723          }
724        }
725        closedir DIR;
726      } else {
727        # Have a read lock already
728        return $self if $self->{read_lock};
729    
730        # Get the preliminary write lock to protect the directory
731        # operations.
732    
733        my $write_lock = $lockmgr->lock($self->{file} . '.read/write')
734          or die "Can't lock '$self->{file}.read/write'";
735    
736        # Find a new read slot.  Maybe the plain file would be better?
737        my $id = time;
738        while (-f "$lockdir/$id.lock") { # here assume ".lock" format!
739          $id++;
740        }
741    
742        $self->{read_lock} = $lockmgr->lock("$lockdir/$id")
743          or die "Can't lock '$lockdir/$id'";
744    
745        # We are a reader now. So we release the write lock
746        $write_lock->release;
747      }
748      return $self;
749    }
750    
751    sub unlock {
752      my $self = shift;
753    
754      # Either we have a read or a write lock (or we close the table already)
755      # unless ($self->{read_lock} || $self->{write_lock}) {
756      #   warn "WAIT::Table::unlock: Table aparently hold's no lock"
757      # }
758      if ($self->{write_lock}) {
759        $self->{write_lock}->release();
760        delete $self->{write_lock};
761      }
762      if ($self->{read_lock}) {
763        $self->{read_lock}->release();
764        delete $self->{read_lock};
765      }
766    
767    }
768    
769    sub DESTROY {
770      my $self = shift;
771    
772      if ($self->{write_lock} || $self->{read_lock}) {
773        warn "Table handle destroyed without closing it first";
774        $self->unlock;
775      }
776    }
777    
778  sub open_scan {  sub open_scan {
779    my $self = shift;    my $self = shift;
780    my $code = shift;    my $code = shift;
# Line 593  sub intervall { Line 830  sub intervall {
830  }  }
831    
832  sub search {  sub search {
833    my $self = shift;    my $self  = shift;
834    my $attr = shift;    my ($query, $attr, $cont, $raw);
835    my $cont = shift;    if (ref $_[0]) {
836    my $raw  = shift;      $query = shift;
837      
838        $attr = $query->{attr};
839        $cont = $query->{cont};
840        $raw  = $query->{raw};
841      } else {
842        require Carp;
843        Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");
844        $attr = shift;
845        $cont = shift;
846        $raw  = shift;
847        $query = {
848                  attr => $attr,
849                  cont => $cont,
850                  raw  => $raw,
851                 };
852      }
853    
854    my %result;    my %result;
855    
856    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 860  sub search {
860        my $name = $_->name;        my $name = $_->name;
861        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
862          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
863          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
864          my ($key, $val);          my ($key, $val);
865          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
866            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 874  sub search {
874    }    }
875    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
876      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
877        my %r = $_->search($cont);        my %r = $_->search($query, $cont);
878        my ($key, $val);        my ($key, $val);
879        while (($key, $val) = each %r) {        while (($key, $val) = each %r) {
880          if (exists $result{$key}) {          if (exists $result{$key}) {
# Line 644  sub hilight_positions { Line 898  sub hilight_positions {
898    my %pos;    my %pos;
899    
900    if (defined $raw) {    if (defined $raw) {
901      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
902                                              # WAIT::InvertedIndex for
903                                              # this index field $attr
904        my $name = $_->name;        my $name = $_->name;
905        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
906          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 934  sub hilight_positions {
934  }  }
935    
936  sub hilight {  sub hilight {
937    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
938    my $type = $tb->layout();    my $layout = $tb->layout();
939    
940    my @result;    my @result;
941    
942    $query ||= {};    $qplain ||= {};
943    $raw   ||= {};    $qraw   ||= {};
944    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
945    while (@ttxt) {    while (@ttxt) {
946      no strict 'refs';      no strict 'refs';
947      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 949  sub hilight {
949      my $fld;      my $fld;
950    
951      my %hl;      my %hl;
952      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
953        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
954                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
955        for (keys %$hp) {        for (keys %$hp) {
956          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
957            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 977  sub hilight {
977  }  }
978    
979  1;  1;
   
Legend:
Removed from v.11  
changed lines
  Added in v.86
  ViewVC Help
Powered by ViewVC 1.1.26