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

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

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

branches/CPAN/lib/WAIT/Table.pm revision 11 by unknown, Fri Apr 28 15:41:10 2000 UTC trunk/lib/WAIT/Table.pm revision 116 by dpavlin, Wed Jul 14 09:48:26 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 confess);
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  =item C<file> => I<fname>  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  The filename of the records file. Files for indexes will have I<fname>  implementation of an access class that works for manpages is
71  as prefix. I<Mandatory>  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<path> => I<dir>
86    
87    The path to database. Files for indexes will have I<path>
88    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 confess "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 confess "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"    confess "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                         path => $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 220  sub create_inverted_index { Line 278  sub create_inverted_index {
278    my $self  = shift;    my $self  = shift;
279    my %parm  = @_;    my %parm  = @_;
280    
281    croak "No attribute specified" unless $parm{attribute};    confess "No attribute specified" unless $parm{attribute};
282    croak "No pipeline specified"  unless $parm{pipeline};    confess "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"    confess "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(path   => $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";      confess ref($self)."::drop called directly";
355    }    }
356  }  }
357    
# 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      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 confess "Cannot tie: $BerkeleyDB::Error\nDEBUG: Filename[$self->{maindbfile}]subname[$subname]Mode[0664]Flags[$flags]";
432    }    }
433    $self;    $self;
434  }  }
# Line 340  sub open { Line 436  sub open {
436  sub fetch_extern {  sub fetch_extern {
437    my $self  = shift;    my $self  = shift;
438    
439    print "#@_", $self->{'access'}->{Mode}, "\n";    # print "#@_", $self->{'access'}->{Mode}, "\n"; # DEBUGGING?
440    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
441      mrequire ref($self->{'access'});      mrequire ref($self->{'access'});
442      $self->{'access'}->FETCH(@_);      $self->{'access'}->FETCH(@_);
# Line 358  sub _find_index { Line 454  sub _find_index {
454    my (@att) = @_;    my (@att) = @_;
455    my %att;    my %att;
456    my $name;    my $name;
457      
458    @att{@att} = @att;    @att{@att} = @att;
459    
460    KEY: for $name (keys %{$self->{indexes}}) {    KEY: for $name (keys %{$self->{indexes}}) {
# Line 375  sub have { Line 471  sub have {
471    my $self  = shift;    my $self  = shift;
472    my %parm  = @_;    my %parm  = @_;
473    
474    my $index = $self->_find_index(keys %parm);    my $index = $self->_find_index(keys %parm) or return; # no index-no have
475    croak "No index found" unless $index;  
476    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
477    return $index->have(@_);    return $index->have(@_);
478  }  }
# Line 387  sub insert { Line 483  sub insert {
483    
484    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
485    
486      # We should move all writing methods to a subclass to check only once
487      $self->{mode} & O_RDWR or confess "Cannot insert into table opened in RD_ONLY mode";
488    
489    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
490    my $key;    my $key;
491    my @deleted = keys %{$self->{deleted}};    my @deleted = keys %{$self->{deleted}};
492      my $gotkey = 0;
493    
494    if (@deleted) {    if (@deleted) {
495      $key = pop @deleted;      $key = pop @deleted;
496      delete $self->{deleted}->{$key};      delete $self->{deleted}->{$key};
497        # Sanity check
498        if ($key && $key>0) {
499          $gotkey=1;
500    } else {    } else {
501      $key = $self->{nextk}++;        warn(sprintf("WAIT database inconsistency during insert ".
502                       "key[%s]: Please rebuild index\n",
503                       $key
504                      ));
505        }
506    }    }
507    if ($USE_RECNO) {    unless ($gotkey) {
508      $self->{db}->[$key] = $tuple;      $key = $self->{nextk}++;
   } else {  
     $self->{db}->{$key} = $tuple;  
509    }    }
510      $self->{db}->{$key} = $tuple;
511    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
512      unless ($_->insert($key, %parm)) {      unless ($_->insert($key, %parm)) {
513        # duplicate key, undo changes        # duplicate key, undo changes
514        if ($key == $self->{nextk}-1) {        if ($key == $self->{nextk}-1) {
515          $self->{nextk}--;          $self->{nextk}--;
516        } else {        } else {
517            # warn "setting key[$key] deleted during insert";
518          $self->{deleted}->{$key}=1;          $self->{deleted}->{$key}=1;
519        }        }
520        my $idx;        my $idx;
# Line 416  sub insert { Line 523  sub insert {
523          $idx->remove($key, %parm);          $idx->remove($key, %parm);
524        }        }
525        return undef;        return undef;
526      }      }
527    }    }
528    if (defined $self->{inverted}) {    if (defined $self->{inverted}) {
529      my $att;      my $att;
# Line 432  sub insert { Line 539  sub insert {
539    
540  sub sync {  sub sync {
541    my $self  = shift;    my $self  = shift;
542      
543    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
544      map $_->sync, $_;      map $_->sync, $_;
545    }    }
# Line 449  sub fetch { Line 556  sub fetch {
556    my $key   = shift;    my $key   = shift;
557    
558    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
559      
560    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
561    if ($USE_RECNO) {    $self->unpack($self->{db}->{$key});
     $self->unpack($self->{db}->[$key]);  
   } else {  
     $self->unpack($self->{db}->{$key});  
   }  
562  }  }
563    
564  sub delete_by_key {  sub delete_by_key {
565    my $self  = shift;    my $self  = shift;
566    my $key   = shift;    my $key   = shift;
567    
568      unless ($key) {
569        cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
570        return;
571      }
572    
573    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
574    my %tuple = $self->fetch($key);    my %tuple = $self->fetch($key);
575    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
# Line 478  sub delete_by_key { Line 586  sub delete_by_key {
586        }        }
587      }      }
588    }    }
589      # warn "setting key[$key] deleted during delete_by_key";
590    ++$self->{deleted}->{$key};    ++$self->{deleted}->{$key};
591  }  }
592    
593  sub delete {  sub delete {
594    my $self  = shift;    my $self  = shift;
595    my $tkey = $self->have(@_);    my $tkey = $self->have(@_);
596      # warn "tkey[$tkey]\@_[@_]";
597    defined $tkey && $self->delete_by_key($tkey, @_);    defined $tkey && $self->delete_by_key($tkey, @_);
598  }  }
599    
600  sub unpack {  sub unpack {
601    my $self = shift;    my($self, $tuple) = @_;
602    my $tuple = shift;  
603      unless (defined $tuple){
604        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
605        warn("Debug: somebody called unpack without argument tuple!");
606        return;
607      }
608    
609    my $att;    my $att;
610    my @result;    my @result;
# Line 502  sub unpack { Line 616  sub unpack {
616    @result;    @result;
617  }  }
618    
619    sub set {
620      my ($self, $iattr, $value) = @_;
621      # in the rare case that they haven't written a single record yet, we
622      # make sure, the inverted inherits our $self->{mode}:
623      defined $self->{db} or $self->open;
624    
625      for my $att (keys %{$self->{inverted}}) {
626        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
627          my $idx;
628          for $idx (@{$self->{inverted}->{$att}}) {
629            $idx->set($iattr, $value);
630          }
631        } else {
632          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
633        }
634      }
635    
636      1;
637    }
638    
639  sub close {  sub close {
640    my $self = shift;    my $self = shift;
641    
642      #cluck("DEBUG: Closing A Table");
643    
644    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
645      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
646    }    }
647    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
648      $_->close();      for (values %{$self->{indexes}}) {
649          $_->close();
650        }
651    }    }
652    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
653        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
654        # if WAIT::InvertedIndex has not been loaded, they cannot have
655        # been altered so far
656      my $att;      my $att;
657      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
658        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 667  sub close {
667    }    }
668    if ($self->{dbh}) {    if ($self->{dbh}) {
669      delete $self->{dbh};      delete $self->{dbh};
670      }
671      if ($USE_RECNO) {    untie %{$self->{db}};
672        untie @{$self->{db}};    for my $att (qw(env db path maindbfile)) {
673      } else {      delete $self->{$att};
674        untie %{$self->{db}};      #cluck "DEBUG: Deleted att $att";
     }  
     delete $self->{db};  
675    }    }
676    
677    1;    1;
678  }  }
679    
680    sub DESTROY {
681      my $self = shift;
682    
683      delete $self->{env};
684    
685      # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
686    
687    }
688    
689  sub open_scan {  sub open_scan {
690    my $self = shift;    my $self = shift;
691    my $code = shift;    my $code = shift;
# Line 556  sub open_index_scan { Line 704  sub open_index_scan {
704    if (defined $self->{indexes}->{$name}) {    if (defined $self->{indexes}->{$name}) {
705      $self->{indexes}->{$name}->open_scan($code);      $self->{indexes}->{$name}->open_scan($code);
706    } else {    } else {
707      croak "No such index '$name'";      confess "No such index '$name'";
708    }    }
709  }  }
710    
# Line 592  sub intervall { Line 740  sub intervall {
740    bless \%result, 'WAIT::Query::Raw';    bless \%result, 'WAIT::Query::Raw';
741  }  }
742    
743  sub search {  sub search_ref {
744    my $self = shift;    my $self  = shift;
745    my $attr = shift;    my ($query, $attr, $cont, $raw);
746    my $cont = shift;    if (ref $_[0]) {
747    my $raw  = shift;      $query = shift;
748        # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$query],[qw()])->Indent(1)->Useqq(1)->Dump; # XXX
749    
750        $attr = $query->{attr};
751        $cont = $query->{cont};
752        $raw  = $query->{raw};
753      } else {
754        cluck("Using three argument search interface is deprecated, use hashref interface instead");
755        $attr = shift;
756        $cont = shift;
757        $raw  = shift;
758        $query = {
759                  attr => $attr,
760                  cont => $cont,
761                  raw  => $raw,
762                 };
763      }
764    
765    my %result;    my %result;
766    
767    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 771  sub search {
771        my $name = $_->name;        my $name = $_->name;
772        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
773          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
774          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
775          my ($key, $val);          my ($key, $val);
776          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
777            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 785  sub search {
785    }    }
786    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
787      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
788        my %r = $_->search($cont);        my $r = $_->search_ref($query, $cont);
789        my ($key, $val);        my ($key, $val);
790        while (($key, $val) = each %r) {        while (($key, $val) = each %$r) {
791          if (exists $result{$key}) {          if (exists $result{$key}) {
792            $result{$key} += $val;            $result{$key} += $val;
793          } else {          } else {
# Line 636  sub search { Line 801  sub search {
801    for (keys %result) {    for (keys %result) {
802      delete $result{$_} if $self->{deleted}->{$_}      delete $result{$_} if $self->{deleted}->{$_}
803    }    }
804    %result;    \%result;
805    }
806    
807    sub parse_query {
808      my($self, $attr, $query) = @_;
809      return unless defined $query && length $query;
810      my %qt;
811      for (@{$self->{inverted}->{$attr}}) {
812        grep $qt{$_}++, $_->parse($query);
813      }
814      [keys %qt];
815  }  }
816    
817  sub hilight_positions {  sub hilight_positions {
# Line 644  sub hilight_positions { Line 819  sub hilight_positions {
819    my %pos;    my %pos;
820    
821    if (defined $raw) {    if (defined $raw) {
822      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
823                                              # WAIT::InvertedIndex for
824                                              # this index field $attr
825        my $name = $_->name;        my $name = $_->name;
826        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
827          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 855  sub hilight_positions {
855  }  }
856    
857  sub hilight {  sub hilight {
858    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
859    my $type = $tb->layout();    my $layout = $tb->layout();
860    
861    my @result;    my @result;
862    
863    $query ||= {};    $qplain ||= {};
864    $raw   ||= {};    $qraw   ||= {};
865    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
866    while (@ttxt) {    while (@ttxt) {
867      no strict 'refs';      no strict 'refs';
868      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 870  sub hilight {
870      my $fld;      my $fld;
871    
872      my %hl;      my %hl;
873      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
874        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
875                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
876        for (keys %$hp) {        for (keys %$hp) {
877          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
878            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 898  sub hilight {
898  }  }
899    
900  1;  1;
   
Legend:
Removed from v.11  
changed lines
  Added in v.116
  ViewVC Help
Powered by ViewVC 1.1.26