/[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 34 by ulpfr, Sun Nov 12 14:22:40 2000 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: Sun Nov 12 15:21:19 2000
8  # Language        : CPerl  # Language        : CPerl
9  # Update Count    : 51  # Update Count    : 135
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 autouse Carp => qw( croak($) );
35  use DB_File;  use DB_File;
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 (-d  $self->{file}){
163        warn "Warning: Directory '$self->{file}' already exists\n";
164      } elsif (!mkdir($self->{file}, 0775)) {
165      croak "Could not 'mkdir $self->{file}': $!\n";      croak "Could not 'mkdir $self->{file}': $!\n";
166    }    }
167    $self->{name}     = $parm{name}     or croak "No name specified";  
168    $self->{attr}     = $parm{attr}     or croak "No attributes specified";    my $lockmgr = LockFile::Simple->make(-autoclean => 1);
169      # Aquire a write lock, since we are creating the table, no readers
170      # could possibly be active.
171      $self->{write_lock} = $lockmgr->lock($self->{file} . '/write')
172        or die "Can't lock '$self->{file}/write'";
173    
174    $self->{djk}      = $parm{djk}      if defined $parm{djk};    $self->{djk}      = $parm{djk}      if defined $parm{djk};
175    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;
176    $self->{access}   = $parm{access} if defined $parm{access};    $self->{access}   = $parm{access} if defined $parm{access};
# Line 142  sub new { Line 189  sub new {
189      my $att  = shift @{$parm{invindex}};      my $att  = shift @{$parm{invindex}};
190      my @spec = @{shift @{$parm{invindex}}};      my @spec = @{shift @{$parm{invindex}}};
191      my @opt;      my @opt;
192        
193      if (ref($spec[0])) {      if (ref($spec[0])) {
194        carp "Secondary pipelines are deprecated\n";        carp "Secondary pipelines are deprecated\n";
195        @opt = %{shift @spec};        @opt = %{shift @spec};
196      }      }
197      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);
198    }    }
199    
200    $self;    $self;
201    # end of backwarn compatibility stuff    # end of backwarn compatibility stuff
202  }  }
# Line 168  table! Line 216  table!
216    
217  sub create_index {  sub create_index {
218    my $self= shift;    my $self= shift;
219      
220    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
221      if $self->{nextk} > 1;      if $self->{nextk} > 1;
222      
223    require WAIT::Index;    require WAIT::Index;
224      
225    my $name = join '-', @_;    my $name = join '-', @_;
226    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
227      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;
# Line 196  set attributes specified when the table Line 244  set attributes specified when the table
244    
245  =item C<pipeline>  =item C<pipeline>
246    
247  A piplines specification is a reference to and array of method names  A piplines specification is a reference to an array of method names
248  (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
249  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
250  attribute list.  the attribute list.
251    
252  =item C<predicate>  =item C<predicate>
253    
254  An indication which predicate the index implements. This may be  An indication which predicate the index implements. This may be
255  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for
256  query processing. Currently there is no standard set of predicate  query processing. Currently there is no standard set of predicate
257  names. The predicate defaults to the last member of the ppline if  names. The predicate defaults to the last member of the pipeline if
258  omitted.  omitted.
259    
260  =back  =back
# Line 224  sub create_inverted_index { Line 272  sub create_inverted_index {
272    croak "No pipeline specified"  unless $parm{pipeline};    croak "No pipeline specified"  unless $parm{pipeline};
273    
274    $parm{predicate} ||= $parm{pipeline}->[-1];    $parm{predicate} ||= $parm{pipeline}->[-1];
275      
276    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
277      if $self->{nextk} > 1;      if $self->{nextk} > 1;
278      
279    require WAIT::InvertedIndex;    require WAIT::InvertedIndex;
280    
281    # backward compatibility stuff    # backward compatibility stuff
# Line 235  sub create_inverted_index { Line 283  sub create_inverted_index {
283    for (qw(attribute pipeline predicate)) {    for (qw(attribute pipeline predicate)) {
284      delete $opt{$_};      delete $opt{$_};
285    }    }
286      
287    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
288    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,
289                                      filter => [@{$parm{pipeline}}], # clone                                      filter => [@{$parm{pipeline}}], # clone
# Line 284  sub drop { Line 332  sub drop {
332        $_->drop;        $_->drop;
333      }      }
334      unlink "$file/records";      unlink "$file/records";
335        # $self->unlock;
336      ! (!-e $file or rmdir $file);      ! (!-e $file or rmdir $file);
337    } else {    } else {
338      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
# Line 334  sub open { Line 383  sub open {
383                           $self->{mode}, 0664, $DB_BTREE);                           $self->{mode}, 0664, $DB_BTREE);
384      }      }
385    }    }
386    
387      # Locking
388      #
389      # We allow multiple readers to coexists.  But write access excludes
390      # all read access and vice versa.  In practice read access on tables
391      # open for writing will mostly work ;-)
392    
393      my $lockmgr = LockFile::Simple->make(-autoclean => 1);
394    
395      my $lockdir = $self->{file} . '/read';
396      unless (-d $lockdir) {
397        mkdir $lockdir, 0755 or die "Could not mkdir $lockdir: $!";
398      }
399    
400      if ($self->{mode} & O_RDWR) {
401        # Get a write lock.  Release it again and die if there is any
402        # valid reader.
403        
404        # this is a hack.  We do not check for reopening ...
405        return $self if $self->{write_lock};
406    
407        if ($self->{read_lock}) {
408          # We are a becoming a writer now. So we release the read lock to
409          # avoid blocking ourselves.
410          $self->{read_lock}->release;
411          delete $self->{read_lock};
412        }
413    
414        # Get the preliminary write lock
415        $self->{write_lock} = $lockmgr->lock($self->{file} . '/write')
416          or die "Can't lock '$self->{file}/write'";
417        
418        # If we actually want to write we must check if there are any
419        # readers.  The write lock is confirmed if wen cannot find any
420        # valid readers.
421        
422        local *DIR;
423        opendir DIR, $lockdir or
424          die "Could not opendir '$lockdir': $!";
425        for my $lockfile (grep { -f "$lockdir/$_" } readdir DIR) {
426          # check if the locks are still valid.
427          # Since we are protected by a write lock, we could use a plain file.
428          # But we want to use the stale testing from LockFile::Simple.
429          if (my $lck = $lockmgr->trylock("$lockdir/$lockfile")) {
430            warn "Removing stale lockfile '$lockdir/$lockfile'";
431            $lck->release;
432          } else {
433            $self->{write_lock}->release;
434            die "Cannot write table '$file' while it's in use";
435          }
436        }
437        closedir DIR;
438      } else {
439        # this is a hack.  We do not check for reopening ...
440        return $self if $self->{read_lock};
441    
442        # Get the preliminary write lock to protect the directory
443        # operations.
444        
445        $self->{write_lock} ||= $lockmgr->lock($self->{file} . '/write')
446          or die "Can't lock '$self->{file}/write'";
447        
448        # find a new read slot
449        my $id = time;
450        while (-f "$lockdir/$id.lock") { # here assume ".lock" format!
451          $id++;
452        }
453    
454        $self->{read_lock} = $lockmgr->lock("$lockdir/$id")
455          or die "Can't lock '$lockdir/$id'";
456    
457        # We are a reader now. So we release the write lock
458        $self->{write_lock}->release;
459        delete $self->{write_lock};
460      }
461    
462    $self;    $self;
463  }  }
464    
465  sub fetch_extern {  sub fetch_extern {
466    my $self  = shift;    my $self  = shift;
467    
468    print "#@_", $self->{'access'}->{Mode}, "\n";    # print "#@_", $self->{'access'}->{Mode}, "\n"; # DEBUGGING?
469    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
470      mrequire ref($self->{'access'});      mrequire ref($self->{'access'});
471      $self->{'access'}->FETCH(@_);      $self->{'access'}->FETCH(@_);
# Line 358  sub _find_index { Line 483  sub _find_index {
483    my (@att) = @_;    my (@att) = @_;
484    my %att;    my %att;
485    my $name;    my $name;
486      
487    @att{@att} = @att;    @att{@att} = @att;
488    
489    KEY: for $name (keys %{$self->{indexes}}) {    KEY: for $name (keys %{$self->{indexes}}) {
# Line 375  sub have { Line 500  sub have {
500    my $self  = shift;    my $self  = shift;
501    my %parm  = @_;    my %parm  = @_;
502    
503    my $index = $self->_find_index(keys %parm);    my $index = $self->_find_index(keys %parm) or return; # no index-no have
504    croak "No index found" unless $index;  
505    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
506    return $index->have(@_);    return $index->have(@_);
507  }  }
# Line 387  sub insert { Line 512  sub insert {
512    
513    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
514    
515      # We should move all writing methods to a subclass to check only once
516      $self->{mode} & O_RDWR or croak "Cannot insert into table opened in RD_ONLY mode";
517    
518    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
519    my $key;    my $key;
520    my @deleted = keys %{$self->{deleted}};    my @deleted = keys %{$self->{deleted}};
521      my $gotkey = 0;
522    
523    if (@deleted) {    if (@deleted) {
524      $key = pop @deleted;      $key = pop @deleted;
525      delete $self->{deleted}->{$key};      delete $self->{deleted}->{$key};
526        # Sanity check
527        if ($key && $key>0) {
528          $gotkey=1;
529    } else {    } else {
530          warn(sprintf("WAIT database inconsistency during insert ".
531                       "key[%s]: Please rebuild index\n",
532                       $key
533                      ));
534        }
535      }
536      unless ($gotkey) {
537      $key = $self->{nextk}++;      $key = $self->{nextk}++;
538    }    }
539    if ($USE_RECNO) {    if ($USE_RECNO) {
# Line 408  sub insert { Line 547  sub insert {
547        if ($key == $self->{nextk}-1) {        if ($key == $self->{nextk}-1) {
548          $self->{nextk}--;          $self->{nextk}--;
549        } else {        } else {
550            # warn "setting key[$key] deleted during insert";
551          $self->{deleted}->{$key}=1;          $self->{deleted}->{$key}=1;
552        }        }
553        my $idx;        my $idx;
# Line 416  sub insert { Line 556  sub insert {
556          $idx->remove($key, %parm);          $idx->remove($key, %parm);
557        }        }
558        return undef;        return undef;
559      }      }
560    }    }
561    if (defined $self->{inverted}) {    if (defined $self->{inverted}) {
562      my $att;      my $att;
# Line 432  sub insert { Line 572  sub insert {
572    
573  sub sync {  sub sync {
574    my $self  = shift;    my $self  = shift;
575      
576    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
577      map $_->sync, $_;      map $_->sync, $_;
578    }    }
# Line 449  sub fetch { Line 589  sub fetch {
589    my $key   = shift;    my $key   = shift;
590    
591    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
592      
593    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
594    if ($USE_RECNO) {    if ($USE_RECNO) {
595      $self->unpack($self->{db}->[$key]);      $self->unpack($self->{db}->[$key]);
# Line 462  sub delete_by_key { Line 602  sub delete_by_key {
602    my $self  = shift;    my $self  = shift;
603    my $key   = shift;    my $key   = shift;
604    
605      unless ($key) {
606        Carp::cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
607        return;
608      }
609    
610    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
611    my %tuple = $self->fetch($key);    my %tuple = $self->fetch($key);
612    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
# Line 478  sub delete_by_key { Line 623  sub delete_by_key {
623        }        }
624      }      }
625    }    }
626      # warn "setting key[$key] deleted during delete_by_key";
627    ++$self->{deleted}->{$key};    ++$self->{deleted}->{$key};
628  }  }
629    
630  sub delete {  sub delete {
631    my $self  = shift;    my $self  = shift;
632    my $tkey = $self->have(@_);    my $tkey = $self->have(@_);
633      # warn "tkey[$tkey]\@_[@_]";
634    defined $tkey && $self->delete_by_key($tkey, @_);    defined $tkey && $self->delete_by_key($tkey, @_);
635  }  }
636    
637  sub unpack {  sub unpack {
638    my $self = shift;    my($self, $tuple) = @_;
639    my $tuple = shift;  
640      unless (defined $tuple){
641        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
642        warn("Debug: somebody called unpack without argument tuple!");
643        return;
644      }
645    
646    my $att;    my $att;
647    my @result;    my @result;
# Line 502  sub unpack { Line 653  sub unpack {
653    @result;    @result;
654  }  }
655    
656    sub set {
657      my ($self, $iattr, $value) = @_;
658      
659      unless ($self->{write_lock}){
660        warn "Cannot set iattr[$iattr] without write lock. Nothing done";
661        return;
662      }
663      for my $att (keys %{$self->{inverted}}) {
664        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
665          my $idx;
666          for $idx (@{$self->{inverted}->{$att}}) {
667            $idx->set($iattr, $value);
668          }
669        } else {
670          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
671        }
672      }
673    
674      1;
675    }
676    
677  sub close {  sub close {
678    my $self = shift;    my $self = shift;
679    
680    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
681      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
682    }    }
683    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
684      $_->close();      for (values %{$self->{indexes}}) {
685          $_->close();
686        }
687    }    }
688    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
689        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
690        # if WAIT::InvertedIndex has not been loaded, they cannot have
691        # been altered so far
692      my $att;      my $att;
693      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
694        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 712  sub close {
712      delete $self->{db};      delete $self->{db};
713    }    }
714    
715      $self->unlock;
716      
717    1;    1;
718  }  }
719    
720    sub unlock {
721      my $self = shift;
722    
723      # Either we have a read or a write lock (or we close the table already)
724      # unless ($self->{read_lock} || $self->{write_lock}) {
725      #   warn "WAIT::Table::unlock: Table aparently hold's no lock"
726      # }
727      if ($self->{write_lock}) {
728        $self->{write_lock}->release();
729        delete $self->{write_lock};
730      }
731      if ($self->{read_lock}) {
732        $self->{read_lock}->release();
733        delete $self->{read_lock};
734      }
735    
736    }
737    
738    sub DESTROY {
739      my $self = shift;
740    
741      warn "Table handle destroyed without closing it first"
742        if $self->{write_lock} || $self->{read_lock};
743    }
744    
745  sub open_scan {  sub open_scan {
746    my $self = shift;    my $self = shift;
747    my $code = shift;    my $code = shift;
# Line 593  sub intervall { Line 797  sub intervall {
797  }  }
798    
799  sub search {  sub search {
800    my $self = shift;    my $self  = shift;
801    my $attr = shift;    my ($query, $attr, $cont, $raw);
802    my $cont = shift;    if (ref $_[0]) {
803    my $raw  = shift;      $query = shift;
804      
805        $attr = $query->{attr};
806        $cont = $query->{cont};
807        $raw  = $query->{raw};
808      } else {
809        require Carp;
810        Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");
811        $attr = shift;
812        $cont = shift;
813        $raw  = shift;
814        $query = {
815                  attr => $attr,
816                  cont => $cont,
817                  raw  => $raw,
818                 };
819      }
820    
821    my %result;    my %result;
822    
823    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 827  sub search {
827        my $name = $_->name;        my $name = $_->name;
828        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
829          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
830          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
831          my ($key, $val);          my ($key, $val);
832          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
833            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 841  sub search {
841    }    }
842    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
843      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
844        my %r = $_->search($cont);        my %r = $_->search($query, $cont);
845        my ($key, $val);        my ($key, $val);
846        while (($key, $val) = each %r) {        while (($key, $val) = each %r) {
847          if (exists $result{$key}) {          if (exists $result{$key}) {
# Line 644  sub hilight_positions { Line 865  sub hilight_positions {
865    my %pos;    my %pos;
866    
867    if (defined $raw) {    if (defined $raw) {
868      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
869                                              # WAIT::InvertedIndex for
870                                              # this index field $attr
871        my $name = $_->name;        my $name = $_->name;
872        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
873          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 901  sub hilight_positions {
901  }  }
902    
903  sub hilight {  sub hilight {
904    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
905    my $type = $tb->layout();    my $layout = $tb->layout();
906    
907    my @result;    my @result;
908    
909    $query ||= {};    $qplain ||= {};
910    $raw   ||= {};    $qraw   ||= {};
911    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
912    while (@ttxt) {    while (@ttxt) {
913      no strict 'refs';      no strict 'refs';
914      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 916  sub hilight {
916      my $fld;      my $fld;
917    
918      my %hl;      my %hl;
919      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
920        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
921                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
922        for (keys %$hp) {        for (keys %$hp) {
923          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
924            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 944  sub hilight {
944  }  }
945    
946  1;  1;
   
Legend:
Removed from v.10  
changed lines
  Added in v.34
  ViewVC Help
Powered by ViewVC 1.1.26