/[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 108 by dpavlin, Tue Jul 13 17:41:12 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;
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');
# Line 168  table! Line 219  table!
219    
220  sub create_index {  sub create_index {
221    my $self= shift;    my $self= shift;
222      
223    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
224      if $self->{nextk} > 1;      if $self->{nextk} > 1;
225      
226    require WAIT::Index;    require WAIT::Index;
227      
228    my $name = join '-', @_;    my $name = join '-', @_;
229      #### warn "WARNING: Suspect use of \$_ in method create_index. name[$name]_[$_]";
230    $self->{indexes}->{$name} =    $self->{indexes}->{$name} =
231      new WAIT::Index file => $self->{file}.'/'.$name, attr => $_;      WAIT::Index->new(
232                         file => $self->file.'/'.$name,
233                         subname => $name,
234                         env  => $self->{env},
235                         maindbfile => $self->maindbfile,
236                         tablename => $self->tablename,
237                         attr => $_,
238                        );
239  }  }
240    
241  =head2 Creating an inverted index  =head2 Creating an inverted index
# Line 196  set attributes specified when the table Line 255  set attributes specified when the table
255    
256  =item C<pipeline>  =item C<pipeline>
257    
258  A piplines specification is a reference to and array of method names  A piplines specification is a reference to an array of method names
259  (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
260  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
261  attribute list.  the attribute list.
262    
263  =item C<predicate>  =item C<predicate>
264    
265  An indication which predicate the index implements. This may be  An indication which predicate the index implements. This may be
266  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for  e.g. 'plain', 'stemming' or 'soundex'. The indicator will be used for
267  query processing. Currently there is no standard set of predicate  query processing. Currently there is no standard set of predicate
268  names. The predicate defaults to the last member of the ppline if  names. The predicate defaults to the last member of the pipeline if
269  omitted.  omitted.
270    
271  =back  =back
# Line 224  sub create_inverted_index { Line 283  sub create_inverted_index {
283    croak "No pipeline specified"  unless $parm{pipeline};    croak "No pipeline specified"  unless $parm{pipeline};
284    
285    $parm{predicate} ||= $parm{pipeline}->[-1];    $parm{predicate} ||= $parm{pipeline}->[-1];
286      
287    croak "Cannot create index for table aready populated"    croak "Cannot create index for table aready populated"
288      if $self->{nextk} > 1;      if $self->{nextk} > 1;
289      
290    require WAIT::InvertedIndex;    require WAIT::InvertedIndex;
291    
292    # backward compatibility stuff    # backward compatibility stuff
# Line 235  sub create_inverted_index { Line 294  sub create_inverted_index {
294    for (qw(attribute pipeline predicate)) {    for (qw(attribute pipeline predicate)) {
295      delete $opt{$_};      delete $opt{$_};
296    }    }
297      
298    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});    my $name = join '_', ($parm{attribute}, @{$parm{pipeline}});
299    my $idx = new WAIT::InvertedIndex(file   => $self->{file}.'/'.$name,    my $idx = WAIT::InvertedIndex->new(file   => $self->file.'/'.$name,
300                                      filter => [@{$parm{pipeline}}], # clone                                       subname=> $name,
301                                      name   => $name,                                       env    => $self->{env},
302                                      attr   => $parm{attribute},                                       maindbfile => $self->maindbfile,
303                                      %opt, # backward compatibility stuff                                       tablename => $self->tablename,
304                                     );                                       filter => [@{$parm{pipeline}}], # clone
305                                         name   => $name,
306                                         attr   => $parm{attribute},
307                                         %opt, # backward compatibility stuff
308                                        );
309    # We will have to use $parm{predicate} here    # We will have to use $parm{predicate} here
310    push @{$self->{inverted}->{$parm{attribute}}}, $idx;    push @{$self->{inverted}->{$parm{attribute}}}, $idx;
311  }  }
312    
313  sub dir {  sub dir {
314    $_[0]->{file};    $_[0]->file;
315  }  }
316    
317  =head2 C<$tb-E<gt>layout>  =head2 C<$tb-E<gt>layout>
# Line 276  Must be called via C<WAIT::Database::dro Line 339  Must be called via C<WAIT::Database::dro
339    
340  sub drop {  sub drop {
341    my $self = shift;    my $self = shift;
342    
343    if ((caller)[0] eq 'WAIT::Database') { # database knows about this    if ((caller)[0] eq 'WAIT::Database') { # database knows about this
344      $self->close;               # just make sure      $self->close;               # just make sure
345      my $file = $self->{file};  
346        my $file = $self->file;
347    
348      for (values %{$self->{indexes}}) {      for (values %{$self->{indexes}}) {
349        $_->drop;        $_->drop;
350      }      }
351      unlink "$file/records";      unlink "$file/records";
352      ! (!-e $file or rmdir $file);      rmdir "$file/read" or warn "Could not rmdir '$file/read'";
353    
354    } else {    } else {
355      croak ref($self)."::drop called directly";      croak ref($self)."::drop called directly";
356    }    }
# Line 298  sub mrequire ($) { Line 364  sub mrequire ($) {
364    require $module;    require $module;
365  }  }
366    
367    sub path {
368      my($self) = @_;
369      return $self->{path} if $self->{path};
370      require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
371      require Carp;
372      Carp::confess("NO file attr");
373    }
374    
375  sub open {  sub open {
376    my $self = shift;    my $self = shift;
377    my $file = $self->{file} . '/records';    my $file = $self->file . '/records';
378    
379    mrequire ref($self);           # that's tricky eh?    mrequire ref($self);           # that's tricky eh?
380    if (defined $self->{'layout'}) {    if (defined $self->{'layout'}) {
# Line 311  sub open { Line 385  sub open {
385    }    }
386    if (exists $self->{indexes}) {    if (exists $self->{indexes}) {
387      require WAIT::Index;      require WAIT::Index;
388      for (values %{$self->{indexes}}) {      for my $Ind (values %{$self->{indexes}}) {
389        $_->{mode} = $self->{mode};        for my $x (qw(mode env maindbfile)) {
390            $Ind->{$x} = $self->{$x};
391          }
392      }      }
393    }    }
394    if (exists $self->{inverted}) {    if (exists $self->{inverted}) {
395      my ($att, $idx);      my ($att, $idx);
396      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
397        for $idx (@{$self->{inverted}->{$att}}) {        for $idx (@{$self->{inverted}->{$att}}) {
398          $idx->{mode} = $self->{mode};          for my $x (qw(mode env maindbfile)) {
399              $idx->{$x} = $self->{$x};
400            }
401        }        }
402      }      }
403      require WAIT::InvertedIndex;      require WAIT::InvertedIndex;
404    }    }
405    
406      # CONFUSION: WAIT knows two *modes*: read-only or read-write.
407      # BerkeleyDB means file permissions when talking about Mode.
408      # BerkeleyDB has the "Flags" attribute to specify
409      # read/write/lock/etc subsystems.
410    
411      my $flags;
412      if ($self->{mode} & O_RDWR) {
413        $flags = DB_CREATE; # | DB_INIT_MPOOL | DB_PRIVATE | DB_INIT_CDB;
414        warn "Flags on table $file set to 'writing'";
415      } else {
416        $flags = DB_RDONLY;
417        # warn "Flags on table $file set to 'readonly'";
418      }
419    unless (defined $self->{dbh}) {    unless (defined $self->{dbh}) {
420      if ($USE_RECNO) {      my $subname = $self->tablename . "/records";
421        $self->{dbh} = tie(@{$self->{db}}, 'DB_File', $file,      $self->{dbh} =
422                           $self->{mode}, 0664, $DB_RECNO);          tie(%{$self->{db}}, 'BerkeleyDB::Btree',
423      } else {              $self->{env} ? (Env => $self->{env}) : (),
424        $self->{dbh} =              # Filename => $file,
425          tie(%{$self->{db}}, 'DB_File', $file,              Filename => $self->maindbfile,
426                           $self->{mode}, 0664, $DB_BTREE);              Subname => $subname,
427      }              Mode => 0664,
428                Flags => $flags,
429                $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
430                $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
431               )
432                or die "Cannot tie: $BerkeleyDB::Error;
433     DEBUG: Filename[$self->{maindbfile}]subname[$subname]Mode[0664]Flags[$flags]";
434    }    }
435    $self;    $self;
436  }  }
# Line 340  sub open { Line 438  sub open {
438  sub fetch_extern {  sub fetch_extern {
439    my $self  = shift;    my $self  = shift;
440    
441    print "#@_", $self->{'access'}->{Mode}, "\n";    # print "#@_", $self->{'access'}->{Mode}, "\n"; # DEBUGGING?
442    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
443      mrequire ref($self->{'access'});      mrequire ref($self->{'access'});
444      $self->{'access'}->FETCH(@_);      $self->{'access'}->FETCH(@_);
# Line 358  sub _find_index { Line 456  sub _find_index {
456    my (@att) = @_;    my (@att) = @_;
457    my %att;    my %att;
458    my $name;    my $name;
459      
460    @att{@att} = @att;    @att{@att} = @att;
461    
462    KEY: for $name (keys %{$self->{indexes}}) {    KEY: for $name (keys %{$self->{indexes}}) {
# Line 375  sub have { Line 473  sub have {
473    my $self  = shift;    my $self  = shift;
474    my %parm  = @_;    my %parm  = @_;
475    
476    my $index = $self->_find_index(keys %parm);    my $index = $self->_find_index(keys %parm) or return; # no index-no have
477    croak "No index found" unless $index;  
478    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
479    return $index->have(@_);    return $index->have(@_);
480  }  }
# Line 387  sub insert { Line 485  sub insert {
485    
486    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
487    
488      # We should move all writing methods to a subclass to check only once
489      $self->{mode} & O_RDWR or croak "Cannot insert into table opened in RD_ONLY mode";
490    
491    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));    my $tuple = join($;, map($parm{$_} || '', @{$self->{attr}}));
492    my $key;    my $key;
493    my @deleted = keys %{$self->{deleted}};    my @deleted = keys %{$self->{deleted}};
494      my $gotkey = 0;
495    
496    if (@deleted) {    if (@deleted) {
497      $key = pop @deleted;      $key = pop @deleted;
498      delete $self->{deleted}->{$key};      delete $self->{deleted}->{$key};
499        # Sanity check
500        if ($key && $key>0) {
501          $gotkey=1;
502    } else {    } else {
503      $key = $self->{nextk}++;        warn(sprintf("WAIT database inconsistency during insert ".
504                       "key[%s]: Please rebuild index\n",
505                       $key
506                      ));
507        }
508    }    }
509    if ($USE_RECNO) {    unless ($gotkey) {
510      $self->{db}->[$key] = $tuple;      $key = $self->{nextk}++;
   } else {  
     $self->{db}->{$key} = $tuple;  
511    }    }
512      $self->{db}->{$key} = $tuple;
513    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
514      unless ($_->insert($key, %parm)) {      unless ($_->insert($key, %parm)) {
515        # duplicate key, undo changes        # duplicate key, undo changes
516        if ($key == $self->{nextk}-1) {        if ($key == $self->{nextk}-1) {
517          $self->{nextk}--;          $self->{nextk}--;
518        } else {        } else {
519            # warn "setting key[$key] deleted during insert";
520          $self->{deleted}->{$key}=1;          $self->{deleted}->{$key}=1;
521        }        }
522        my $idx;        my $idx;
# Line 416  sub insert { Line 525  sub insert {
525          $idx->remove($key, %parm);          $idx->remove($key, %parm);
526        }        }
527        return undef;        return undef;
528      }      }
529    }    }
530    if (defined $self->{inverted}) {    if (defined $self->{inverted}) {
531      my $att;      my $att;
# Line 432  sub insert { Line 541  sub insert {
541    
542  sub sync {  sub sync {
543    my $self  = shift;    my $self  = shift;
544      
545    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
546      map $_->sync, $_;      map $_->sync, $_;
547    }    }
# Line 449  sub fetch { Line 558  sub fetch {
558    my $key   = shift;    my $key   = shift;
559    
560    return () if exists $self->{deleted}->{$key};    return () if exists $self->{deleted}->{$key};
561      
562    defined $self->{db} or $self->open;    defined $self->{db} or $self->open;
563    if ($USE_RECNO) {    $self->unpack($self->{db}->{$key});
     $self->unpack($self->{db}->[$key]);  
   } else {  
     $self->unpack($self->{db}->{$key});  
   }  
564  }  }
565    
566  sub delete_by_key {  sub delete_by_key {
567    my $self  = shift;    my $self  = shift;
568    my $key   = shift;    my $key   = shift;
569    
570      unless ($key) {
571        Carp::cluck "Warning: delete_by_key called without key. Looks like a bug in WAIT?";
572        return;
573      }
574    
575    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};    return $self->{deleted}->{$key} if defined $self->{deleted}->{$key};
576    my %tuple = $self->fetch($key);    my %tuple = $self->fetch($key);
577    for (values %{$self->{indexes}}) {    for (values %{$self->{indexes}}) {
# Line 478  sub delete_by_key { Line 588  sub delete_by_key {
588        }        }
589      }      }
590    }    }
591      # warn "setting key[$key] deleted during delete_by_key";
592    ++$self->{deleted}->{$key};    ++$self->{deleted}->{$key};
593  }  }
594    
595  sub delete {  sub delete {
596    my $self  = shift;    my $self  = shift;
597    my $tkey = $self->have(@_);    my $tkey = $self->have(@_);
598      # warn "tkey[$tkey]\@_[@_]";
599    defined $tkey && $self->delete_by_key($tkey, @_);    defined $tkey && $self->delete_by_key($tkey, @_);
600  }  }
601    
602  sub unpack {  sub unpack {
603    my $self = shift;    my($self, $tuple) = @_;
604    my $tuple = shift;  
605      unless (defined $tuple){
606        # require Carp; # unfortunately gives us "bizarre copy...." :-(((((
607        warn("Debug: somebody called unpack without argument tuple!");
608        return;
609      }
610    
611    my $att;    my $att;
612    my @result;    my @result;
# Line 502  sub unpack { Line 618  sub unpack {
618    @result;    @result;
619  }  }
620    
621    sub set {
622      my ($self, $iattr, $value) = @_;
623      # in the rare case that they haven't written a single record yet, we
624      # make sure, the inverted inherits our $self->{mode}:
625      defined $self->{db} or $self->open;
626    
627      for my $att (keys %{$self->{inverted}}) {
628        if ($] > 5.003) {         # avoid bug in perl up to 5.003_05
629          my $idx;
630          for $idx (@{$self->{inverted}->{$att}}) {
631            $idx->set($iattr, $value);
632          }
633        } else {
634          map $_->set($iattr, $value), @{$self->{inverted}->{$att}};
635        }
636      }
637    
638      1;
639    }
640    
641  sub close {  sub close {
642    my $self = shift;    my $self = shift;
643    
644      require Carp; Carp::cluck("------->Closing A Table<-------");
645    
646    if (exists $self->{'access'}) {    if (exists $self->{'access'}) {
647      eval {$self->{'access'}->close}; # dont bother if not opened      eval {$self->{'access'}->close}; # dont bother if not opened
648    }    }
649    for (values %{$self->{indexes}}) {    if ($WAIT::Index::VERSION) {
650      $_->close();      for (values %{$self->{indexes}}) {
651          $_->close();
652        }
653    }    }
654    if (defined $self->{inverted}) {    if (defined $self->{inverted} && $WAIT::InvertedIndex::VERSION) {
655        # require WAIT::InvertedIndex; Uli: we can avoid closing indexes:
656        # if WAIT::InvertedIndex has not been loaded, they cannot have
657        # been altered so far
658      my $att;      my $att;
659      for $att (keys %{$self->{inverted}}) {      for $att (keys %{$self->{inverted}}) {
660        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 669  sub close {
669    }    }
670    if ($self->{dbh}) {    if ($self->{dbh}) {
671      delete $self->{dbh};      delete $self->{dbh};
672      }
673      if ($USE_RECNO) {    untie %{$self->{db}};
674        untie @{$self->{db}};    for my $att (qw(env db file maindbfile)) {
675      } else {      delete $self->{$att};
676        untie %{$self->{db}};      warn "----->Deleted att $att<-----";
     }  
     delete $self->{db};  
677    }    }
678    
679    1;    1;
680  }  }
681    
682    sub DESTROY {
683      my $self = shift;
684    
685      delete $self->{env};
686    
687      # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$self],[qw(self)])->Indent(1)->Useqq(1)->Dump; # XXX
688    
689    }
690    
691  sub open_scan {  sub open_scan {
692    my $self = shift;    my $self = shift;
693    my $code = shift;    my $code = shift;
# Line 592  sub intervall { Line 742  sub intervall {
742    bless \%result, 'WAIT::Query::Raw';    bless \%result, 'WAIT::Query::Raw';
743  }  }
744    
745  sub search {  sub search_ref {
746    my $self = shift;    my $self  = shift;
747    my $attr = shift;    my ($query, $attr, $cont, $raw);
748    my $cont = shift;    if (ref $_[0]) {
749    my $raw  = shift;      $query = shift;
750        # require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$query],[qw()])->Indent(1)->Useqq(1)->Dump; # XXX
751    
752        $attr = $query->{attr};
753        $cont = $query->{cont};
754        $raw  = $query->{raw};
755      } else {
756        require Carp;
757        Carp::cluck("Using three argument search interface is deprecated, use hashref interface instead");
758        $attr = shift;
759        $cont = shift;
760        $raw  = shift;
761        $query = {
762                  attr => $attr,
763                  cont => $cont,
764                  raw  => $raw,
765                 };
766      }
767    
768    my %result;    my %result;
769    
770    defined $self->{db} or $self->open; # require layout    defined $self->{db} or $self->open; # require layout
# Line 606  sub search { Line 774  sub search {
774        my $name = $_->name;        my $name = $_->name;
775        if (exists $raw->{$name} and @{$raw->{$name}}) {        if (exists $raw->{$name} and @{$raw->{$name}}) {
776          my $scale = 1/scalar(@{$raw->{$name}});          my $scale = 1/scalar(@{$raw->{$name}});
777          my %r = $_->search_raw(@{$raw->{$name}});          my %r = $_->search_raw($query, @{$raw->{$name}});
778          my ($key, $val);          my ($key, $val);
779          while (($key, $val) = each %r) {          while (($key, $val) = each %r) {
780            if (exists $result{$key}) {            if (exists $result{$key}) {
# Line 620  sub search { Line 788  sub search {
788    }    }
789    if (defined $cont and $cont ne '') {    if (defined $cont and $cont ne '') {
790      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) {
791        my %r = $_->search($cont);        my $r = $_->search_ref($query, $cont);
792        my ($key, $val);        my ($key, $val);
793        while (($key, $val) = each %r) {        while (($key, $val) = each %$r) {
794          if (exists $result{$key}) {          if (exists $result{$key}) {
795            $result{$key} += $val;            $result{$key} += $val;
796          } else {          } else {
# Line 636  sub search { Line 804  sub search {
804    for (keys %result) {    for (keys %result) {
805      delete $result{$_} if $self->{deleted}->{$_}      delete $result{$_} if $self->{deleted}->{$_}
806    }    }
807    %result;    \%result;
808    }
809    
810    sub parse_query {
811      my($self, $attr, $query) = @_;
812      return unless defined $query && length $query;
813      my %qt;
814      for (@{$self->{inverted}->{$attr}}) {
815        grep $qt{$_}++, $_->parse($query);
816      }
817      [keys %qt];
818  }  }
819    
820  sub hilight_positions {  sub hilight_positions {
# Line 644  sub hilight_positions { Line 822  sub hilight_positions {
822    my %pos;    my %pos;
823    
824    if (defined $raw) {    if (defined $raw) {
825      for (@{$self->{inverted}->{$attr}}) {      for (@{$self->{inverted}->{$attr}}) { # objects of type
826                                              # WAIT::InvertedIndex for
827                                              # this index field $attr
828        my $name = $_->name;        my $name = $_->name;
829        if (exists $raw->{$name}) {        if (exists $raw->{$name}) {
830          my %qt;          my %qt;
# Line 678  sub hilight_positions { Line 858  sub hilight_positions {
858  }  }
859    
860  sub hilight {  sub hilight {
861    my ($tb, $text, $query, $raw) = @_;    my ($tb, $buf, $qplain, $qraw) = @_;
862    my $type = $tb->layout();    my $layout = $tb->layout();
863    
864    my @result;    my @result;
865    
866    $query ||= {};    $qplain ||= {};
867    $raw   ||= {};    $qraw   ||= {};
868    my @ttxt = $type->tag($text);    my @ttxt = $layout->tag($buf);
869    while (@ttxt) {    while (@ttxt) {
870      no strict 'refs';      no strict 'refs';
871      my %tag = %{shift @ttxt};      my %tag = %{shift @ttxt};
# Line 692  sub hilight { Line 873  sub hilight {
873      my $fld;      my $fld;
874    
875      my %hl;      my %hl;
876      for $fld (grep defined $tag{$_}, keys %$query, keys %$raw) {      for $fld (grep defined $tag{$_}, keys %$qplain, keys %$qraw) {
877        my $hp = $tb->hilight_positions($fld, $txt,        my $hp = $tb->hilight_positions($fld, $txt,
878                                        $query->{$fld}, $raw->{$fld});                                        $qplain->{$fld}, $qraw->{$fld});
879        for (keys %$hp) {        for (keys %$hp) {
880          if (exists $hl{$_}) {   # -w ;-(          if (exists $hl{$_}) {   # -w ;-(
881            $hl{$_} = max($hl{$_}, $hp->{$_});            $hl{$_} = max($hl{$_}, $hp->{$_});
# Line 720  sub hilight { Line 901  sub hilight {
901  }  }
902    
903  1;  1;
   
Legend:
Removed from v.11  
changed lines
  Added in v.108
  ViewVC Help
Powered by ViewVC 1.1.26