/[wait]/trunk/lib/WAIT/Table.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WAIT/Table.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

cvs-head/lib/WAIT/Table.pm revision 10 by ulpfr, Fri Apr 28 15:40:52 2000 UTC trunk/lib/WAIT/Table.pm revision 113 by dpavlin, Tue Jul 13 20:28:45 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: Wed Jan 23 14:15:15 2002
8  # Language        : CPerl  # Language        : CPerl
9  # Update Count    : 51  # Update Count    : 152
10  # Status          : Unknown, Use with caution!  # Status          : Unknown, Use with caution!
11  #  #
12  # Copyright (c) 1996-1997, Ulrich Pfeifer  # Copyright (c) 1996-1997, Ulrich Pfeifer
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    our $VERSION = "2.000";
29    
30    use WAIT::Table::Handle ();
31  require WAIT::Parse::Base;  require WAIT::Parse::Base;
32    
33  use strict;  use strict;
34  use Carp;  use Carp qw(cluck croak);
35  use DB_File;  # use autouse Carp => qw( croak($) );
36    use BerkeleyDB;
37  use Fcntl;  use Fcntl;
38    
 my $USE_RECNO = 0;  
   
39  =head2 Creating a Table.  =head2 Creating a Table.
40    
41  The constructor WAIT::Table-<gt>new is normally called via the  The constructor WAIT::Table-E<gt>new is normally called via the
42  create_table method of a database handle. This is not enforced, but  create_table method of a database handle. This is not enforced, but
43  creating a table doesn not make any sense unless the table is  creating a table does not make any sense unless the table is
44  registered by the database because the latter implements persistence  registered by the database because the latter implements persistence
45  of the meta data. Registering is done automatically by letting the  of the meta data. Registering is done automatically by letting the
46  database handle create a table.  database handle the creation of a table.
47    
48    my $db = create WAIT::Database name => 'sample';    my $db = WAIT::Database->create(name => 'sample');
49    my $tb = $db->create_table (name     => 'test',    my $tb = $db->create_table(name     => 'test',
50                                attr     => ['docid', 'headline'],                               access   => $access,
51                                layout   => $layout,                               layout   => $layout,
52                                access   => $access,                               attr     => ['docid', 'headline'],
53                               );                              );
54    
55  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
56  table module, to prevent direct access if called via Table.  table module, to prevent direct access if called via Table.
57    
58  =over 10  =over 10
59    
60  =item C<access> => I<accesobj>  =item C<access> => I<accessobj>
61    
62  A reference to a acces object for the external parts (attributes) of  A reference to an access object for the external parts (attributes) of
63  tuples. As you may remember, the WAIT System does not enforce that  tuples. As you may remember, the WAIT System does not enforce that
64  objects are completely stored inside the system to avoid duplication.  objects are completely stored inside the system to avoid duplication.
65  There is no (strong) point in storing all you HTML-Documents inside  There is no (strong) point in storing all your HTML documents inside
66  the system when indexing your WWW-Server.  the system when indexing your WWW-Server.
67    
68    The access object is designed to work like as a tied hash. You pass
69    the refernce to the object, not the tied hash though. An example
70    implementation of an access class that works for manpages is
71    WAIT::Document::Nroff.
72    
73    The implementation needs to take into account that WAIT will keep this
74    object in a Data::Dumper or Storable database and re-use it when sman
75    is run. So it is not good enough if we can produce the index with it
76    now, when we create or actively access the table, WAIT also must be
77    able to retrieve documents on its own, when we are in a different
78    context. This happens specifically in a retrieval. To get this working
79    seemlessly, the access-defining class must implement a close method.
80    This method will be called before the Data::Dumper dump takes place.
81    In that moment the access-defining class must get rid of all data
82    structures that cannot be reconstructed via the Data::Dumper dump,
83    such as database handles or C pointers.
84    
85  =item C<file> => I<fname>  =item C<file> => I<fname>
86    
87  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>
88  as prefix. I<Mandatory>  as prefix. I<Mandatory>, but usually taken care of by the
89    WAIT::Database handle when the constructor is called via
90    WAIT::Database::create_table().
91    
92  =item C<name> => I<name>  =item C<name> => I<name>
93    
# Line 73  The name of this table. I<Mandatory> Line 95  The name of this table. I<Mandatory>
95    
96  =item C<attr> => [ I<attr> ... ]  =item C<attr> => [ I<attr> ... ]
97    
98  A reference to an array of attribute names. I<Mandatory>  A reference to an array of attribute names. WAIT will keep the
99    contents of these attributes in its table. I<Mandatory>
100    
101  =item C<djk> => [ I<attr> ... ]  =item C<djk> => [ I<attr> ... ]
102    
103  A reference to an array of attribute names which make up the  A reference to an array of attribute names which make up the
104  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;
105    
106  =item C<layout> => I<layoutobj>  =item C<layout> => I<layoutobj>
107    
108  A reference to an external parser object. Defaults to anew instance of  A reference to an external parser object. Defaults to a new instance
109  C<WAIT::Parse::Base>  of C<WAIT::Parse::Base>. For an example implementation see
110    WAIT::Parse::Nroff. A layout class can be implemented as a singleton
111    class if you so like.
112    
113  =item C<access> => I<accesobj>  =item C<keyset> => I<keyset>
114    
115  A reference to a acces object for the external parts of tuples.  The set of attributes needed to identify a record. Defaults to all
116    attributes.
117    
118    =item C<invindex> => I<inverted index>
119    
120    A reference to an anon array defining attributes of each record that
121    need to be indexed. See the source of smakewhatis for how to set this
122    up.
123    
124  =back  =back
125    
# Line 98  sub new { Line 130  sub new {
130    my %parm = @_;    my %parm = @_;
131    my $self = {};    my $self = {};
132    
133      # Check for mandatory attrs early
134      for my $x (qw(name attr env maindbfile tablename)) {
135        $self->{$x}     = $parm{$x}     or croak "No $x specified";
136      }
137    
138    # Do that before we eventually add '_weight' to attributes.    # Do that before we eventually add '_weight' to attributes.
139    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];    $self->{keyset}   = $parm{keyset}   || [[@{$parm{attr}}]];
140    
141    $self->{mode}     = O_CREAT | O_RDWR;    $self->{mode}     = O_CREAT | O_RDWR;
142    
143    # Determine and set up subclass    # Determine and set up subclass
144    $type = ref($type) || $type;    $type = ref($type) || $type;
145    if (defined $parm{djk}) {    if (defined $parm{djk}) {
# Line 118  sub new { Line 157  sub new {
157      unshift @{$parm{attr}}, '_weight' unless $attr{'_weight'};      unshift @{$parm{attr}}, '_weight' unless $attr{'_weight'};
158    }    }
159    
160    $self->{file}     = $parm{file}     or croak "No file specified";    $self->{path}     = $parm{path}     or croak "No path specified";
161    if (-d  $self->{file} or !mkdir($self->{file}, 0775)) {    bless $self, $type;
162      croak "Could not 'mkdir $self->{file}': $!\n";  
   }  
   $self->{name}     = $parm{name}     or croak "No name specified";  
   $self->{attr}     = $parm{attr}     or croak "No attributes specified";  
163    $self->{djk}      = $parm{djk}      if defined $parm{djk};    $self->{djk}      = $parm{djk}      if defined $parm{djk};
164    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;    $self->{layout}   = $parm{layout} || new WAIT::Parse::Base;
165    $self->{access}   = $parm{access} if defined $parm{access};    $self->{access}   = $parm{access} if defined $parm{access};
# Line 131  sub new { Line 167  sub new {
167    $self->{deleted}  = {};       # no deleted records yet    $self->{deleted}  = {};       # no deleted records yet
168    $self->{indexes}  = {};    $self->{indexes}  = {};
169    
170    bless $self, $type;    # Checking for readers is not necessary, but let's go with the
171      # generic method.
172      
173    # Call create_index() and create_index() for compatibility    # Call create_index() and create_index() for compatibility
174    for (@{$self->{keyset}||[]}) {    for (@{$self->{keyset}||[]}) {
175      #carp "Specification of indexes at table create time is deprecated";      #carp "Specification of indexes at table create time is deprecated";
# Line 141  sub new { Line 179  sub new {
179      # carp "Specification of inverted indexes at table create time is deprecated";      # carp "Specification of inverted indexes at table create time is deprecated";
180      my $att  = shift @{$parm{invindex}};      my $att  = shift @{$parm{invindex}};
181      my @spec = @{shift @{$parm{invindex}}};      my @spec = @{shift @{$parm{invindex}}};
182      my @opt;      my @opt  = ();
183        
184      if (ref($spec[0])) {      if (ref($spec[0])) {
185        carp "Secondary pipelines are deprecated\n";        warn "Secondary pipelines are deprecated";
186        @opt = %{shift @spec};        @opt = %{shift @spec};
187      }      }
188      $self->create_inverted_index(attribute => $att, pipeline  => \@spec, @opt);      $self->create_inverted_index(attribute => $att,
189                                     pipeline  => \@spec,
190                                     @opt);
191    }    }
192    
193    $self;    $self;
194    # end of backwarn compatibility stuff    # end of backwarn compatibility stuff
195  }  }
196    
197    for my $accessor (qw(maindbfile tablename)) {
198      no strict 'refs';
199      *{$accessor} = sub {
200        my($self) = @_;
201        return $self->{$accessor} if $self->{$accessor};
202        require Carp;
203        Carp::confess("accessor $accessor not there");
204      }
205    }
206    
207  =head2 Creating an index  =head2 Creating an index
208    
209    $tb->create_index('docid');    $tb->create_index('docid');
210    
211  =item C<create_index>  C<create_index>
   
212  must be called with a list of attributes. This must be a subset of the  must be called with a list of attributes. This must be a subset of the
213  attributes specified when the table was created. Currently this  attributes specified when the table was created. Currently this
214  method must be called before the first tuple is inserted in the  method must be called before the first tuple is inserted in the
# Line 168  table! Line 218  table!
218    
219  sub create_index {  sub create_index {
220    my $self= shift;    my $self= shift;
221      
222    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
223      if $self->{nextk} > 1;      if $self->{nextk} > 1;
224      
225    require WAIT::Index;    require WAIT::Index;
226      
227    my $name = join '-', @_;    my $name = join '-', @_;
228      #### warn "WARNING: Suspect use of \$_ in method create_index. name[$name]_[$_]";
229    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
230      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;      WAIT::Index->new(
231                         file => $self->path.'/'.$name,
232                         subname => $name,
233                         env  => $self->{env},
234                         maindbfile => $self->maindbfile,
235                         tablename => $self->tablename,
236                         attr => $_,
237                        );
238  }  }
239    
240  =head2 Creating an inverted index  =head2 Creating an inverted index
# Line 196  set attributes specified when the table Line 254  set attributes specified when the table
254    
255  =item C<pipeline>  =item C<pipeline>
256    
257  A piplines specification is a reference to and array of method names  A piplines specification is a reference to an array of method names
258  (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
259  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
260  attribute list.  the attribute list.
261    
262  =item C<predicate>  =item C<predicate>
263    
264  An indication which predicate the index implements. This may be  An indication which predicate the index implements. This may be
265  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for
266  query processing. Currently there is no standard set of predicate  query processing. Currently there is no standard set of predicate
267  names. The predicate defaults to the last member of the ppline if  names. The predicate defaults to the last member of the pipeline if
268  omitted.  omitted.
269    
270  =back  =back
# Line 224  sub create_inverted_index { Line 282  sub create_inverted_index {
282    croak "No pipeline specified"  unless $parm{pipeline};    croak "No pipeline specified"  unless $parm{pipeline};
283    
284    $parm{predicate} ||= $parm{pipeline}->[-1];    $parm{predicate} ||= $parm{pipeline}->[-1];
285      
286    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
287      if $self->{nextk} > 1;      if $self->{nextk} > 1;
288      
289    require WAIT::InvertedIndex;    require WAIT::InvertedIndex;
290    
291    # backward compatibility stuff    # backward compatibility stuff
# Line 235  sub create_inverted_index { Line 293  sub create_inverted_index {
293    for (qw(attribute pipeline predicate)) {    for (qw(attribute pipeline predicate)) {
294      delete $opt{$_};      delete $opt{$_};
295    }    }
296      
297    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
298    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = WAIT::InvertedIndex->new(file   => $self->path.'/'.$name,
299                                      filter => [@{$parm{pipeline}}], # clone                                       subname=> $name,
300                                      name   => $name,                                       env    => $self->{env},
301                                      attr   => $parm{attribute},                                       maindbfile => $self->maindbfile,
302                                      %opt, # backward compatibility stuff                                       tablename => $self->tablename,
303                                     );                                       filter => [@{$parm{pipeline}}], # clone
304                                         name   => $name,
305                                         attr   => $parm{attribute},
306                                         %opt, # backward compatibility stuff
307                                        );
308    # We will have to use $parm{predicate} here    # We will have to use $parm{predicate} here
309    push @{$self->{inverted}->{$parm{attribute}}}, $idx;    push @{$self->{inverted}->{$parm{attribute}}}, $idx;
310  }  }
311    
312  sub dir {  sub dir {
313    $_[0]->{file};    $_[0]->path;
314  }  }
315    
316  =head2 C<$tb-E<gt>layout>  =head2 C<$tb-E<gt>layout>
# Line 276  Must be called via C<WAIT::Database::dro Line 338  Must be called via C<WAIT::Database::dro
338    
339  sub drop {  sub drop {
340    my $self = shift;    my $self = shift;
341    
342    if ((caller)[0] eq 'WAIT::Database') { # database knows about this    if ((caller)[0] eq 'WAIT::Database') { # database knows about this
343      $self->close;               # just make sure      $self->close;               # just make sure
344      my $file = $self->{file};  
345        my $path = $self->path;
346    
347      for (values %{$self->{indexes}}) {      for (values %{$self->{indexes}}) {
348        $_->drop;        $_->drop;
349      }      }
350      unlink "$file/records";      unlink "$path/records";
351      ! (!-e $file or rmdir $file);      rmdir "$path/read" or warn "Could not rmdir '$path/read'";
352    
353    } else {    } else {
354      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
355    }    }
# Line 298  sub mrequire ($) { Line 363  sub mrequire ($) {
363    require $module;    require $module;
364  }  }
365    
366    sub path {
367      my($self) = @_;
368      return $self->{path} if $self->{path};
369      require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
370      require Carp;
371      Carp::confess("NO path attr");
372    }
373    
374  sub open {  sub open {
375    my $self = shift;    my $self = shift;
376    my $file = $self->{file} . '/records';    my $path = $self->path . '/records';
377    
378    mrequire ref($self);           # that's tricky eh?    mrequire ref($self);           # that's tricky eh?
379    if (defined $self->{'layout'}) {    if (defined $self->{'layout'}) {
# Line 311  sub open { Line 384  sub open {
384    }    }
385    if (exists $self->{indexes}) {    if (exists $self->{indexes}) {
386      require WAIT::Index;      require WAIT::Index;
387      for (values %{$self->{indexes}}) {      for my $Ind (values %{$self->{indexes}}) {
388        $_->{mode} = $self->{mode};        for my $x (qw(mode env maindbfile)) {
389            $Ind->{$x} = $self->{$x};
390          }
391      }      }
392    }    }
393    if (exists $self->{inverted}) {    if (exists $self->{inverted}) {
394      my ($att, $idx);      my ($att, $idx);
395      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
396        for $idx (@{$self->{inverted}->{$att}}) {        for $idx (@{$self->{inverted}->{$att}}) {
397          $idx->{mode} = $self->{mode};          for my $x (qw(mode env maindbfile)) {
398              $idx->{$x} = $self->{$x};
399            }
400        }        }
401      }      }
402      require WAIT::InvertedIndex;      require WAIT::InvertedIndex;
403    }    }
404    
405      # CONFUSION: WAIT knows two *modes*: read-only or read-write.
406      # BerkeleyDB means file permissions when talking about Mode.
407      # BerkeleyDB has the "Flags" attribute to specify
408      # read/write/lock/etc subsystems.
409    
410      my $flags;
411      if ($self->{mode} & O_RDWR) {
412        $flags = DB_CREATE; # | DB_INIT_MPOOL | DB_PRIVATE | DB_INIT_CDB;
413        #warn "DEBUG: Flags on table $path set to 'writing'";
414      } else {
415        $flags = DB_RDONLY;
416        #warn "DEBUG: Flags on table $path set to 'readonly'";
417      }
418    unless (defined $self->{dbh}) {    unless (defined $self->{dbh}) {
419      if ($USE_RECNO) {      my $subname = $self->tablename . "/records";
420        $self->{dbh} = tie(@{$self->{db}}, 'DB_File', $file,      $self->{dbh} =
421                           $self->{mode}, 0664, $DB_RECNO);          tie(%{$self->{db}}, 'BerkeleyDB::Btree',
422      } else {              $self->{env} ? (Env => $self->{env}) : (),
423        $self->{dbh} =              # Filename => $file,
424          tie(%{$self->{db}}, 'DB_File', $file,              Filename => $self->maindbfile,
425                           $self->{mode}, 0664, $DB_BTREE);              Subname => $subname,
426      }              Mode => 0664,
427                Flags => $flags,
428                $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
429                $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
430               )
431                or die "Cannot tie: $BerkeleyDB::Error;
432     DEBUG: Filename[$self->{maindbfile}]subname[$subname]Mode[0664]Flags[$flags]";
433    }    }
434    $self;    $self;
435  }  }
# Line 340  sub open { Line 437  sub open {
437  sub fetch_extern {  sub fetch_extern {
438    my $self  = shift;    my $self  = shift;
439    
440    print "#@_", $self->{'access'}->{Mode}, "\n";    # print "#@_", $self->{'access'}->{Mode}, "\n"; # DEBUGGING?
441    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
442      mrequire ref($self->{'access'});      mrequire ref($self->{'access'});
443      $self->{'access'}->FETCH(@_);      $self->{'access'}->FETCH(@_);
# Line 358  sub _find_index { Line 455  sub _find_index {
455    my (@att) = @_;    my (@att) = @_;
456    my %att;    my %att;
457    my $name;    my $name;
458      
459    @att{@att} = @att;    @att{@att} = @att;
460    
461    KEY: for $name (keys %{$self->{indexes}}) {    KEY: for $name (keys %{$self->{indexes}}) {
# Line 375  sub have { Line 472  sub have {
472    my $self  = shift;    my $self  = shift;
473    my %parm  = @_;    my %parm  = @_;
474    
475    my $index = $self->_find_index(keys %parm);    my $index = $self->_find_index(keys %parm) or return; # no index-no have
476    croak "No index found" unless $index;  
477    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
478    return $index->have(@_);    return $index->have(@_);
479  }  }
# Line 387  sub insert { Line 484  sub insert {
484    
485    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
486    
487      # We should move all writing methods to a subclass to check only once
488      $self->{mode} & O_RDWR or croak "Cannot insert into table opened in RD_ONLY mode";
489    
490    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
491    my $key;    my $key;
492    my @deleted = keys %{$self->{deleted}};    my @deleted = keys %{$self->{deleted}};
493      my $gotkey = 0;
494    
495    if (@deleted) {    if (@deleted) {
496      $key = pop @deleted;      $key = pop @deleted;
497      delete $self->{deleted}->{$key};      delete $self->{deleted}->{$key};
498        # Sanity check
499        if ($key && $key>0) {
500          $gotkey=1;
501    } else {    } else {
502      $key = $self->{nextk}++;        warn(sprintf("WAIT database inconsistency during insert ".
503                       "key[%s]: Please rebuild index\n",
504                       $key
505                      ));
506        }
507    }    }
508    if ($USE_RECNO) {    unless ($gotkey) {
509      $self->{db}->[$key] = $tuple;      $key = $self->{nextk}++;
   } else {  
     $self->{db}->{$key} = $tuple;  
510    }    }
511      $self->{db}->{$key} = $tuple;
512    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
513      unless ($_->insert($key, %parm)) {      unless ($_->insert($key, %parm)) {
514        # duplicate key, undo changes        # duplicate key, undo changes
515        if ($key == $self->{nextk}-1) {        if ($key == $self->{nextk}-1) {
516          $self->{nextk}--;          $self->{nextk}--;
517        } else {        } else {
518            # warn "setting key[$key] deleted during insert";
519          $self->{deleted}->{$key}=1;          $self->{deleted}->{$key}=1;
520        }        }
521        my $idx;        my $idx;
# Line 416  sub insert { Line 524  sub insert {
524          $idx->remove($key, %parm);          $idx->remove($key, %parm);
525        }        }
526        return undef;        return undef;
527      }      }
528    }    }
529    if (defined $self->{inverted}) {    if (defined $self->{inverted}) {
530      my $att;      my $att;
# Line 432  sub insert { Line 540  sub insert {
540    
541  sub sync {  sub sync {
542    my $self  = shift;    my $self  = shift;
543      
544    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
545      map $_->sync, $_;      map $_->sync, $_;
546    }    }
# Line 449  sub fetch { Line 557  sub fetch {
557    my $key   = shift;    my $key   = shift;
558    
559    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
560      
561    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
562    if ($USE_RECNO) {    $self->unpack($self->{db}->{$key});
     $self->unpack($self->{db}->[$key]);  
   } else {  
     $self->unpack($self->{db}->{$key});  
   }  
563  }  }
564    
565  sub delete_by_key {  sub delete_by_key {
566    my $self  = shift;    my $self  = shift;
567    my $key   = shift;    my $key   = shift;
568    
569      unless ($key) {
570        cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
571        return;
572      }
573    
574    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
575    my %tuple = $self->fetch($key);    my %tuple = $self->fetch($key);
576    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
# Line 478  sub delete_by_key { Line 587  sub delete_by_key {
587        }        }
588      }      }
589    }    }
590      # warn "setting key[$key] deleted during delete_by_key";
591    ++$self->{deleted}->{$key};    ++$self->{deleted}->{$key};
592  }  }
593    
594  sub delete {  sub delete {
595    my $self  = shift;    my $self  = shift;
596    my $tkey = $self->have(@_);    my $tkey = $self->have(@_);
597      # warn "tkey[$tkey]\@_[@_]";
598    defined $tkey && $self->delete_by_key($tkey, @_);    defined $tkey && $self->delete_by_key($tkey, @_);
599  }  }
600    
601  sub unpack {  sub unpack {
602    my $self = shift;    my($self, $tuple) = @_;
603    my $tuple = shift;  
604      unless (defined $tuple){
605        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
606        warn("Debug: somebody called unpack without argument tuple!");
607        return;
608      }
609    
610    my $att;    my $att;
611    my @result;    my @result;
# Line 502  sub unpack { Line 617  sub unpack {
617    @result;    @result;
618  }  }
619    
620    sub set {
621      my ($self, $iattr, $value) = @_;
622      # in the rare case that they haven't written a single record yet, we
623      # make sure, the inverted inherits our $self->{mode}:
624      defined $self->{db} or $self->open;
625    
626      for my $att (keys %{$self->{inverted}}) {
627        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
628          my $idx;
629          for $idx (@{$self->{inverted}->{$att}}) {
630            $idx->set($iattr, $value);
631          }
632        } else {
633          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
634        }
635      }
636    
637      1;
638    }
639    
640  sub close {  sub close {
641    my $self = shift;    my $self = shift;
642    
643      #cluck("DEBUG: Closing A Table");
644    
645    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
646      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
647    }    }
648    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
649      $_->close();      for (values %{$self->{indexes}}) {
650          $_->close();
651        }
652    }    }
653    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
654        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
655        # if WAIT::InvertedIndex has not been loaded, they cannot have
656        # been altered so far
657      my $att;      my $att;
658      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
659        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 526  sub close { Line 668  sub close {
668    }    }
669    if ($self->{dbh}) {    if ($self->{dbh}) {
670      delete $self->{dbh};      delete $self->{dbh};
671      }
672      if ($USE_RECNO) {    untie %{$self->{db}};
673        untie @{$self->{db}};    for my $att (qw(env db path maindbfile)) {
674      } else {      delete $self->{$att};
675        untie %{$self->{db}};      #cluck "DEBUG: Deleted att $att";
     }  
     delete $self->{db};  
676    }    }
677    
678    1;    1;
679  }  }
680    
681    sub DESTROY {
682      my $self = shift;
683    
684      delete $self->{env};
685    
686      # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
687    
688    }
689    
690  sub open_scan {  sub open_scan {
691    my $self = shift;    my $self = shift;
692    my $code = shift;    my $code = shift;
# Line 592  sub intervall { Line 741  sub intervall {
741    bless \%result, 'WAIT::Query::Raw';    bless \%result, 'WAIT::Query::Raw';
742  }  }
743    
744  sub search {  sub search_ref {
745    my $self = shift;    my $self  = shift;
746    my $attr = shift;    my ($query, $attr, $cont, $raw);
747    my $cont = shift;    if (ref $_[0]) {
748    my $raw  = shift;      $query = shift;
749        # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$query],[qw()])->Indent(1)->Useqq(1)->Dump; # XXX
750    
751        $attr = $query->{attr};
752        $cont = $query->{cont};
753        $raw  = $query->{raw};
754      } else {
755        cluck("Using three argument search interface is deprecated, use hashref interface instead");
756        $attr = shift;
757        $cont = shift;
758        $raw  = shift;
759        $query = {
760                  attr => $attr,
761                  cont => $cont,
762                  raw  => $raw,
763                 };
764      }
765    
766    my %result;    my %result;
767    
768    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 772  sub search {
772        my $name = $_->name;        my $name = $_->name;
773        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
774          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
775          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
776          my ($key, $val);          my ($key, $val);
777          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
778            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 786  sub search {
786    }    }
787    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
788      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
789        my %r = $_->search($cont);        my $r = $_->search_ref($query, $cont);
790        my ($key, $val);        my ($key, $val);
791        while (($key, $val) = each %r) {        while (($key, $val) = each %$r) {
792          if (exists $result{$key}) {          if (exists $result{$key}) {
793            $result{$key} += $val;            $result{$key} += $val;
794          } else {          } else {
# Line 636  sub search { Line 802  sub search {
802    for (keys %result) {    for (keys %result) {
803      delete $result{$_} if $self->{deleted}->{$_}      delete $result{$_} if $self->{deleted}->{$_}
804    }    }
805    %result;    \%result;
806    }
807    
808    sub parse_query {
809      my($self, $attr, $query) = @_;
810      return unless defined $query && length $query;
811      my %qt;
812      for (@{$self->{inverted}->{$attr}}) {
813        grep $qt{$_}++, $_->parse($query);
814      }
815      [keys %qt];
816  }  }
817    
818  sub hilight_positions {  sub hilight_positions {
# Line 644  sub hilight_positions { Line 820  sub hilight_positions {
820    my %pos;    my %pos;
821    
822    if (defined $raw) {    if (defined $raw) {
823      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
824                                              # WAIT::InvertedIndex for
825                                              # this index field $attr
826        my $name = $_->name;        my $name = $_->name;
827        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
828          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 856  sub hilight_positions {
856  }  }
857    
858  sub hilight {  sub hilight {
859    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
860    my $type = $tb->layout();    my $layout = $tb->layout();
861    
862    my @result;    my @result;
863    
864    $query ||= {};    $qplain ||= {};
865    $raw   ||= {};    $qraw   ||= {};
866    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
867    while (@ttxt) {    while (@ttxt) {
868      no strict 'refs';      no strict 'refs';
869      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 871  sub hilight {
871      my $fld;      my $fld;
872    
873      my %hl;      my %hl;
874      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
875        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
876                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
877        for (keys %$hp) {        for (keys %$hp) {
878          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
879            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 899  sub hilight {
899  }  }
900    
901  1;  1;
   
Legend:
Removed from v.10  
changed lines
  Added in v.113
  ViewVC Help
Powered by ViewVC 1.1.26