/[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 31 by laperla, Sun Nov 12 01:26:10 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: Fri May 19 14:51:14 2000
8  # Language        : CPerl  # Language        : CPerl
9  # Update Count    : 51  # Update Count    : 133
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<access> => I<accesobj>  =item C<keyset> => I<keyset>
116    
117  A reference to a acces object for the external parts of tuples.  The set of attributes needed to identify a record. Defaults to all
118    attributes.
119    
120    =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
170      $self->{write_lock} = $lockmgr->lock($self->{file} . '/write')
171        or die "Can't lock '$self->{file}/write'";
172    
173    $self->{djk}      = $parm{djk}      if defined $parm{djk};    $self->{djk}      = $parm{djk}      if defined $parm{djk};
174    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;
175    $self->{access}   = $parm{access} if defined $parm{access};    $self->{access}   = $parm{access} if defined $parm{access};
# Line 142  sub new { Line 188  sub new {
188      my $att  = shift @{$parm{invindex}};      my $att  = shift @{$parm{invindex}};
189      my @spec = @{shift @{$parm{invindex}}};      my @spec = @{shift @{$parm{invindex}}};
190      my @opt;      my @opt;
191        
192      if (ref($spec[0])) {      if (ref($spec[0])) {
193        carp "Secondary pipelines are deprecated\n";        carp "Secondary pipelines are deprecated\n";
194        @opt = %{shift @spec};        @opt = %{shift @spec};
195      }      }
196      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);
197    }    }
198    
199    $self;    $self;
200    # end of backwarn compatibility stuff    # end of backwarn compatibility stuff
201  }  }
# Line 168  table! Line 215  table!
215    
216  sub create_index {  sub create_index {
217    my $self= shift;    my $self= shift;
218      
219    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
220      if $self->{nextk} > 1;      if $self->{nextk} > 1;
221      
222    require WAIT::Index;    require WAIT::Index;
223      
224    my $name = join '-', @_;    my $name = join '-', @_;
225    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
226      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 243  set attributes specified when the table
243    
244  =item C<pipeline>  =item C<pipeline>
245    
246  A piplines specification is a reference to and array of method names  A piplines specification is a reference to an array of method names
247  (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
248  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
249  attribute list.  the attribute list.
250    
251  =item C<predicate>  =item C<predicate>
252    
253  An indication which predicate the index implements. This may be  An indication which predicate the index implements. This may be
254  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for
255  query processing. Currently there is no standard set of predicate  query processing. Currently there is no standard set of predicate
256  names. The predicate defaults to the last member of the ppline if  names. The predicate defaults to the last member of the pipeline if
257  omitted.  omitted.
258    
259  =back  =back
# Line 224  sub create_inverted_index { Line 271  sub create_inverted_index {
271    croak "No pipeline specified"  unless $parm{pipeline};    croak "No pipeline specified"  unless $parm{pipeline};
272    
273    $parm{predicate} ||= $parm{pipeline}->[-1];    $parm{predicate} ||= $parm{pipeline}->[-1];
274      
275    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
276      if $self->{nextk} > 1;      if $self->{nextk} > 1;
277      
278    require WAIT::InvertedIndex;    require WAIT::InvertedIndex;
279    
280    # backward compatibility stuff    # backward compatibility stuff
# Line 235  sub create_inverted_index { Line 282  sub create_inverted_index {
282    for (qw(attribute pipeline predicate)) {    for (qw(attribute pipeline predicate)) {
283      delete $opt{$_};      delete $opt{$_};
284    }    }
285      
286    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
287    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,
288                                      filter => [@{$parm{pipeline}}], # clone                                      filter => [@{$parm{pipeline}}], # clone
# Line 284  sub drop { Line 331  sub drop {
331        $_->drop;        $_->drop;
332      }      }
333      unlink "$file/records";      unlink "$file/records";
334        # $self->unlock;
335      ! (!-e $file or rmdir $file);      ! (!-e $file or rmdir $file);
336    } else {    } else {
337      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
# Line 334  sub open { Line 382  sub open {
382                           $self->{mode}, 0664, $DB_BTREE);                           $self->{mode}, 0664, $DB_BTREE);
383      }      }
384    }    }
385    
386      # Locking
387      #
388      # We allow multiple readers to coexists.  But write access excludes
389      # all read access vice versa.  In practice read access on tables
390      # open for writing will mostly work ;-)
391    
392      my $lockmgr = LockFile::Simple->make(-autoclean => 1);
393    
394      # aquire a write lock. We might hold one acquired in create() already
395      $self->{write_lock} ||= $lockmgr->lock($self->{file} . '/write')
396        or die "Can't lock '$self->{file}/write'";
397    
398      my $lockdir = $self->{file} . '/read';
399      unless (-d $lockdir) {
400        mkdir $lockdir, 0755 or die "Could not mkdir $lockdir: $!";
401      }
402    
403      if ($self->{mode} & O_RDWR) {
404        # this is a hack.  We do not check for reopening ...
405        return $self if $self->{write_lock};
406        
407        # If we actually want to write we must check if there are any readers
408        local *DIR;
409        opendir DIR, $lockdir or
410          die "Could not opendir '$lockdir': $!";
411        for my $lockfile (grep { -f "$lockdir/$_" } readdir DIR) {
412          # check if the locks are still valid.
413          # Since we are protected by a write lock, we could use a pline file.
414          # But we want to use the stale testing from LockFile::Simple.
415          if (my $lck = $lockmgr->trylock("$lockdir/$lockfile")) {
416            warn "Removing stale lockfile '$lockdir/$lockfile'";
417            $lck->release;
418          } else {
419            $self->{write_lock}->release;
420            die "Cannot write table '$file' while it's in use";
421          }
422        }
423        closedir DIR;
424      } else {
425        # this is a hack.  We do not check for reopening ...
426        return $self if $self->{read_lock};
427        
428        # We are a reader. So we release the write lock
429        my $id = time;
430        while (-f "$lockdir/$id.lock") { # here assume ".lock" format!
431          $id++;
432        }
433        $self->{read_lock} = $lockmgr->lock("$lockdir/$id");
434        $self->{write_lock}->release;
435        delete $self->{write_lock};
436      }
437    
438    $self;    $self;
439  }  }
440    
441  sub fetch_extern {  sub fetch_extern {
442    my $self  = shift;    my $self  = shift;
443    
444    print "#@_", $self->{'access'}->{Mode}, "\n";    # print "#@_", $self->{'access'}->{Mode}, "\n"; # DEBUGGING?
445    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
446      mrequire ref($self->{'access'});      mrequire ref($self->{'access'});
447      $self->{'access'}->FETCH(@_);      $self->{'access'}->FETCH(@_);
# Line 358  sub _find_index { Line 459  sub _find_index {
459    my (@att) = @_;    my (@att) = @_;
460    my %att;    my %att;
461    my $name;    my $name;
462      
463    @att{@att} = @att;    @att{@att} = @att;
464    
465    KEY: for $name (keys %{$self->{indexes}}) {    KEY: for $name (keys %{$self->{indexes}}) {
# Line 375  sub have { Line 476  sub have {
476    my $self  = shift;    my $self  = shift;
477    my %parm  = @_;    my %parm  = @_;
478    
479    my $index = $self->_find_index(keys %parm);    my $index = $self->_find_index(keys %parm) or return; # no index-no have
480    croak "No index found" unless $index;  
481    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
482    return $index->have(@_);    return $index->have(@_);
483  }  }
# Line 387  sub insert { Line 488  sub insert {
488    
489    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
490    
491      # We should move all writing methods to a subclass to check only once
492      $self->{mode} & O_RDWR or croak "Cannot insert into table opened in RD_ONLY mode";
493    
494    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
495    my $key;    my $key;
496    my @deleted = keys %{$self->{deleted}};    my @deleted = keys %{$self->{deleted}};
497      my $gotkey = 0;
498    
499    if (@deleted) {    if (@deleted) {
500      $key = pop @deleted;      $key = pop @deleted;
501      delete $self->{deleted}->{$key};      delete $self->{deleted}->{$key};
502        # Sanity check
503        if ($key && $key>0) {
504          $gotkey=1;
505    } else {    } else {
506          warn(sprintf("WAIT database inconsistency during insert ".
507                       "key[%s]: Please rebuild index\n",
508                       $key
509                      ));
510        }
511      }
512      unless ($gotkey) {
513      $key = $self->{nextk}++;      $key = $self->{nextk}++;
514    }    }
515    if ($USE_RECNO) {    if ($USE_RECNO) {
# Line 408  sub insert { Line 523  sub insert {
523        if ($key == $self->{nextk}-1) {        if ($key == $self->{nextk}-1) {
524          $self->{nextk}--;          $self->{nextk}--;
525        } else {        } else {
526            # warn "setting key[$key] deleted during insert";
527          $self->{deleted}->{$key}=1;          $self->{deleted}->{$key}=1;
528        }        }
529        my $idx;        my $idx;
# Line 416  sub insert { Line 532  sub insert {
532          $idx->remove($key, %parm);          $idx->remove($key, %parm);
533        }        }
534        return undef;        return undef;
535      }      }
536    }    }
537    if (defined $self->{inverted}) {    if (defined $self->{inverted}) {
538      my $att;      my $att;
# Line 432  sub insert { Line 548  sub insert {
548    
549  sub sync {  sub sync {
550    my $self  = shift;    my $self  = shift;
551      
552    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
553      map $_->sync, $_;      map $_->sync, $_;
554    }    }
# Line 449  sub fetch { Line 565  sub fetch {
565    my $key   = shift;    my $key   = shift;
566    
567    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
568      
569    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
570    if ($USE_RECNO) {    if ($USE_RECNO) {
571      $self->unpack($self->{db}->[$key]);      $self->unpack($self->{db}->[$key]);
# Line 462  sub delete_by_key { Line 578  sub delete_by_key {
578    my $self  = shift;    my $self  = shift;
579    my $key   = shift;    my $key   = shift;
580    
581      unless ($key) {
582        Carp::cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
583        return;
584      }
585    
586    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
587    my %tuple = $self->fetch($key);    my %tuple = $self->fetch($key);
588    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
# Line 478  sub delete_by_key { Line 599  sub delete_by_key {
599        }        }
600      }      }
601    }    }
602      # warn "setting key[$key] deleted during delete_by_key";
603    ++$self->{deleted}->{$key};    ++$self->{deleted}->{$key};
604  }  }
605    
606  sub delete {  sub delete {
607    my $self  = shift;    my $self  = shift;
608    my $tkey = $self->have(@_);    my $tkey = $self->have(@_);
609      # warn "tkey[$tkey]\@_[@_]";
610    defined $tkey && $self->delete_by_key($tkey, @_);    defined $tkey && $self->delete_by_key($tkey, @_);
611  }  }
612    
613  sub unpack {  sub unpack {
614    my $self = shift;    my($self, $tuple) = @_;
615    my $tuple = shift;  
616      unless (defined $tuple){
617        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
618        warn("Debug: somebody called unpack without argument tuple!");
619        return;
620      }
621    
622    my $att;    my $att;
623    my @result;    my @result;
# Line 502  sub unpack { Line 629  sub unpack {
629    @result;    @result;
630  }  }
631    
632    sub set {
633      my ($self, $iattr, $value) = @_;
634      
635      unless ($self->{write_lock}){
636        warn "Cannot set iattr[$iattr] without write lock. Nothing done";
637        return;
638      }
639      for my $att (keys %{$self->{inverted}}) {
640        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
641          my $idx;
642          for $idx (@{$self->{inverted}->{$att}}) {
643            $idx->set($iattr, $value);
644          }
645        } else {
646          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
647        }
648      }
649    
650      1;
651    }
652    
653  sub close {  sub close {
654    my $self = shift;    my $self = shift;
655    
656    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
657      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
658    }    }
659    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
660      $_->close();      for (values %{$self->{indexes}}) {
661          $_->close();
662        }
663    }    }
664    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
665        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
666        # if WAIT::InvertedIndex has not been loaded, they cannot have
667        # been altered so far
668      my $att;      my $att;
669      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
670        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 688  sub close {
688      delete $self->{db};      delete $self->{db};
689    }    }
690    
691      $self->unlock;
692      
693    1;    1;
694  }  }
695    
696    sub unlock {
697      my $self = shift;
698    
699      # Either we have a read or a write lock (or we close the table already)
700      # unless ($self->{read_lock} || $self->{write_lock}) {
701      #   warn "WAIT::Table::unlock: Table aparently hold's no lock"
702      # }
703      if ($self->{write_lock}) {
704        $self->{write_lock}->release();
705        delete $self->{write_lock};
706      }
707      if ($self->{read_lock}) {
708        $self->{read_lock}->release();
709        delete $self->{read_lock};
710      }
711    
712    }
713    
714    sub DESTROY {
715      my $self = shift;
716    
717      warn "Table handle destroyed without closing it first"
718        if $self->{write_lock} || $self->{read_lock};
719    }
720    
721  sub open_scan {  sub open_scan {
722    my $self = shift;    my $self = shift;
723    my $code = shift;    my $code = shift;
# Line 593  sub intervall { Line 773  sub intervall {
773  }  }
774    
775  sub search {  sub search {
776    my $self = shift;    my $self  = shift;
777    my $attr = shift;    my ($query, $attr, $cont, $raw);
778    my $cont = shift;    if (ref $_[0]) {
779    my $raw  = shift;      $query = shift;
780      
781        $attr = $query->{attr};
782        $cont = $query->{cont};
783        $raw  = $query->{raw};
784      } else {
785        require Carp;
786        Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");
787        $attr = shift;
788        $cont = shift;
789        $raw  = shift;
790        $query = {
791                  attr => $attr,
792                  cont => $cont,
793                  raw  => $raw,
794                 };
795      }
796    
797    my %result;    my %result;
798    
799    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 803  sub search {
803        my $name = $_->name;        my $name = $_->name;
804        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
805          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
806          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
807          my ($key, $val);          my ($key, $val);
808          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
809            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 817  sub search {
817    }    }
818    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
819      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
820        my %r = $_->search($cont);        my %r = $_->search($query, $cont);
821        my ($key, $val);        my ($key, $val);
822        while (($key, $val) = each %r) {        while (($key, $val) = each %r) {
823          if (exists $result{$key}) {          if (exists $result{$key}) {
# Line 644  sub hilight_positions { Line 841  sub hilight_positions {
841    my %pos;    my %pos;
842    
843    if (defined $raw) {    if (defined $raw) {
844      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
845                                              # WAIT::InvertedIndex for
846                                              # this index field $attr
847        my $name = $_->name;        my $name = $_->name;
848        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
849          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 877  sub hilight_positions {
877  }  }
878    
879  sub hilight {  sub hilight {
880    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
881    my $type = $tb->layout();    my $layout = $tb->layout();
882    
883    my @result;    my @result;
884    
885    $query ||= {};    $qplain ||= {};
886    $raw   ||= {};    $qraw   ||= {};
887    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
888    while (@ttxt) {    while (@ttxt) {
889      no strict 'refs';      no strict 'refs';
890      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 892  sub hilight {
892      my $fld;      my $fld;
893    
894      my %hl;      my %hl;
895      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
896        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
897                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
898        for (keys %$hp) {        for (keys %$hp) {
899          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
900            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 920  sub hilight {
920  }  }
921    
922  1;  1;
   
Legend:
Removed from v.10  
changed lines
  Added in v.31
  ViewVC Help
Powered by ViewVC 1.1.26