/[wait]/trunk/lib/WAIT/Database.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/Database.pm

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

revision 107 by dpavlin, Mon May 24 20:57:08 2004 UTC revision 108 by dpavlin, Tue Jul 13 17:41:12 2004 UTC
# Line 1  Line 1 
1  #                              -*- Mode: Perl -*-  #                              -*- Mode: cperl -*-
2  # $Basename: Database.pm $  # $Basename: Database.pm $
3  # $Revision: 1.14 $  # $Revision: 1.14 $
4  # Author          : Ulrich Pfeifer  # Author          : Ulrich Pfeifer
# Line 31  use strict; Line 31  use strict;
31  use FileHandle ();  use FileHandle ();
32  use File::Path qw(rmtree);  use File::Path qw(rmtree);
33  use WAIT::Table ();  use WAIT::Table ();
34    use BerkeleyDB;
35  use Fcntl;  use Fcntl;
36  use Carp; # will use autouse later  use Carp; # will use autouse later
37  use LockFile::Simple ();  use Storable qw(nfreeze thaw);
38    use vars qw($VERSION);
39    use Data::Dumper;
40    
41  # use autouse Carp => qw( croak($) );  $VERSION = "2.000";
 my ($HAVE_DATA_DUMPER, $HAVE_STORABLE);  
42    
43  BEGIN {  #$WAIT::Database::Pagesize = 1*1024;
44    eval { require Data::Dumper };  #$WAIT::Database::Cachesize = 4*1024*1024;
   $HAVE_DATA_DUMPER = 1 if $@ eq '';  
   eval { require Storable };  
   $HAVE_STORABLE    = 1 if $@ eq '';  
   $HAVE_DATA_DUMPER || $HAVE_STORABLE ||  
     die "Could not find Data::Dumper nor Storable";  
   $Storable::forgive_me = 1;  
 }  
45    
46    # use autouse Carp => qw( croak($) );
47    
48  =head2 Constructor create  =head2 Constructor create
49    
50    $db = WAIT::Database->create(    $db = WAIT::Database->create(
51                                 name      => <name>,                                 directory => '/dir/to/database/'
52                                 directory => <dir>                                 name      => 'name',
53                                );                                );
54    
55  Create a new database.  Create a new database.
# Line 62  Create a new database. Line 58  Create a new database.
58    
59  =item B<name> I<name>  =item B<name> I<name>
60    
61  mandatory  Mandatory name of database
62    
63  =item B<directory> I<directory>  =item B<directory> I<directory>
64    
# Line 83  sub create { Line 79  sub create {
79    my $type = shift;    my $type = shift;
80    my %parm = @_;    my %parm = @_;
81    my $self = {};    my $self = {};
82      bless $self => ref($type) || $type;
83    my $dir  = $parm{directory} || '.';    my $dir  = $parm{directory} || '.';
84    my $name = $parm{name};    my $name = $parm{name};
85    
# Line 102  sub create { Line 99  sub create {
99      }      }
100    }    }
101    
102      $self->{dir}       = $dir;
103    $self->{name}      = $name;    $self->{name}      = $name;
104    $self->{file}      = "$dir/$name";  
105    use Data::Dumper;
106    print Dumper($self);
107    
108      print STDERR "## dir: $dir name: $name path: ",$self->file,"\n";
109    
110      my $env= BerkeleyDB::Env->new(
111                                    -Home => $self->path,
112                                    -Flags => DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB|DB_PRIVATE,
113                                    # Cachesize => 1024*1024*8,
114                                    # Pagesize => 8*1024, # environment doesn't understand Pagesize parameter!
115                                    -Verbose => 1,
116                                    -ErrFile => $self->path."/error.log",
117                                    );
118      unless ($env) {
119        confess("Could not create environment: $BerkeleyDB::Error");
120      }
121    
122      $self->{env} = $env;
123    
124      # apperently (! learned from trial and error) while the Env doesn't
125      # understand Pagesize, the very first table needs to set it up if we
126      # want to deviate from the default. And all tables need to follow
127      # this lead. I'm doing so explicitly, it looks prettier to me
128      $self->{_attr} = BerkeleyDB::Btree->new(
129                                              -Filename => $self->maindbfile,
130                                              -Subname  => "_attr",
131                                              -Flags    => DB_CREATE,
132                                              -Mode     => 0664,
133                                              -Env      => $env,
134                                              $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
135                                              $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
136                                             );
137    
138    print STDERR "### created ",$self->maindbfile,"\n";
139    
140      unless (defined($self->{_attr})) {
141        die("Cannot open [".$self->maindbfile."] _attr: $BerkeleyDB::Error");
142      }
143    
144    
145      # Use of BerkeleyDB::Env->new here could maybe some day be a way to
146      # introduce a smart locking mechanism? Whatever... it is currently
147      # kein Thema: remember, that the database has a $self->path which
148      # is a *directory* and there are no berkeley tables in this
149      # directory, but there is one subdirectory in this directory for
150      # *each* *table* object.
151    
152    $self->{uniqueatt} = $parm{uniqueatt};    $self->{uniqueatt} = $parm{uniqueatt};
153    $self->{mode}      = O_CREAT;    $self->{mode}      = O_RDWR;
154    my $lockmgr = LockFile::Simple->make(-autoclean => 1, -stale => 1);    $self;
   # aquire a write lock  
   $self->{write_lock} = $lockmgr->lock("$dir/$name/write")  
     or die "Can't lock '$dir/$name/write'";  
   bless $self => ref($type) || $type;  
155  }  }
156    
157    
# Line 130  sub open { Line 171  sub open {
171    my %parm    = @_;    my %parm    = @_;
172    my $dir     = $parm{directory} || '.';    my $dir     = $parm{directory} || '.';
173    my $name    = $parm{name} or croak "No name specified";    my $name    = $parm{name} or croak "No name specified";
174    my $catalog = "$dir/$name/catalog";    my $self = bless {}, ref($type) || $type;
   my $meta    = "$dir/$name/meta";  
   my $self;  
   
   if ($HAVE_STORABLE and -e $catalog  
       and (!-e $meta or -M $meta >= -M $catalog)) {  
     $self = Storable::retrieve($catalog);  
   } else {  
     return undef unless -f $meta;  
175    
176      $self = do $meta;    my $mode = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);
177      unless (defined $self) {    $self->{dir}  = $dir; # will be overwritten by the thaw below, but we need it now
178        warn "do '$meta' did not work. Mysterious! Reverting to eval `cat $meta`";    $self->{name} = $name;
179        sleep(4);  
180        $self = eval `cat $meta`;    my $env;
181    
182      if ($mode & O_RDWR) {
183        my $flags = DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB;
184        warn "setting flags for envorinment 'writing'";
185        $env = BerkeleyDB::Env->new(
186                                    -Home => $self->path,
187                                    -Flags => $flags,
188                                   );
189        unless ($env) {
190          confess("Could not create environment in [".$self->path."]: $BerkeleyDB::Error");
191      }      }
192    }    } else {
193        # in der Datei neo-lieferung.pl habe ich in Punkt 2.6 darueber
194        # lamentiert, dass der Readonly-User kein Environment bekommt.
195        # Es muesste ein Klacks sein, dafuer einen Schalter
196        # bereitzustellen. Kostet mich aber zu viel Denkzeit.
197        # warn "DEBUG: setting env to NIL";
198        $env = "";
199      }
200      # warn "DEBUG: trying to open the database for _attr";
201      my $maindbfile = $self->maindbfile;
202      my $attr = BerkeleyDB::Btree->new(
203                                        -Filename => $maindbfile,
204                                        -Subname  => "_attr",
205                                        $env ? (-Env => $env) : (-Flags => DB_RDONLY, -Home => $self->path),
206                                       );
207      unless (defined($attr)) {
208          use Data::Dumper;
209          print Dumper($attr);
210          croak "Cannot open [$maindbfile] _attr: $BerkeleyDB::Error; mdbf[$maindbfile] env[$env]";
211      }
212      # warn "DEBUG: opened the database for _attr";
213      $attr->db_get(0, my $dat);
214      # warn sprintf "DEBUG: got _attr record. time[%.6f] length(dat)[%d]", Time::HiRes::time(), length $dat;
215      $self = thaw $dat;
216      # warn sprintf "DEBUG: thawed _attr rec. time[%.6f]", Time::HiRes::time();
217      $self->{_attr} = $attr;
218    
219    return unless defined $self;    return unless defined $self;
   $self->{mode} = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);  
220    
221    if ($self->{mode} & O_RDWR) {    $self->{mode} = $mode;
222      # Locking: We do not care about read access since write is atomic.    $self->{env}  = $env;
223      my $lockmgr = LockFile::Simple->make(-autoclean => 1, -stale => 1);    $self->{dir}  = $dir; # yes, again
224          $self->{name} = $name;
225      # aquire a write lock    $self->walkncomplete;
     $self->{write_lock} = $lockmgr->lock("$dir/$name/write")  
       or die "Can't lock '$dir/$name/write'";  
   }  
226    
227    $self;    $self;
228  }  }
229    
230    sub walkncomplete {
231      my $self = shift;
232      $self->maindbfile;
233      $self->path;
234      for my $t (values %{$self->{tables} || {}}) {
235        $t->{file} ||= $self->{file};
236        $t->{maindbfile} ||= $self->{maindbfile};
237        $t->{mode} = $self->{mode};
238        for my $ind (values %{$t->{indexes}}) {
239          $ind->{file} ||= $self->{file};
240          $ind->{maindbfile} ||= $self->{maindbfile};
241          $ind->{mode} = $self->{mode};
242        }
243        for my $inv (values %{$t->{inverted}}) {
244          for my $ind (@$inv) {
245            $ind->{file} ||= $self->{file};
246            $ind->{maindbfile} ||= $self->{maindbfile};
247            $ind->{mode} = $self->{mode};
248          }
249        }
250      }
251    }
252    
253  =head2 C<$db-E<gt>dispose;>  =head2 dispose
254    
255  Dispose a database. Remove all associated files. This may fail if the  Dispose a database. Remove all associated files. This may fail if the
256  database or one of its tables is still open. Failure will be indicated  database or one of its tables is still open. Failure will be indicated
257  by a false return value.  by a false return value.
258    
259     $db->dispose;
260    
261     WAIT::Database->dispose(name=>'name', directory=>'/dir/to/db/');
262    
263  =cut  =cut
264    
265  sub dispose {  sub dispose {
266    my $dir;    my $path;
267    
268    if (ref $_[0]) {               # called with instance    if (ref $_[0]) {               # called with instance
269      croak "Database readonly" unless $_[0]->{mode} & (O_CREAT | O_RDWR);      croak "Database readonly" unless $_[0]->{mode} & (O_CREAT | O_RDWR);
270      $dir = $_[0]->{file};      $path = $_[0]->path;
271      $_[0]->close;      $_[0]->close;
272    } else {    } else {
273      my $type = shift;      my $type = shift;
274      my %parm = @_;      my %parm = @_;
275      my $base = $parm{directory} || '.';      my $base = $parm{directory} || '.';
276      my $name = $parm{name}       || croak "No name specified";      my $name = $parm{name}      || croak "No name specified";
277      $dir = "$base/$name";      $path = "$base/$name";
278    }    }
279    croak "No such database '$dir'" unless -e "$dir/meta";    croak "No such database '$path'" unless -e "$path";
280    
281      my $ret = rmtree($path, 0, 1);
282    
   #warn "Running rmtree on dir[$dir]";  
   my $ret = rmtree($dir, 0, 1);  
   #warn "rmtree returned[$ret]";  
283    $ret;    $ret;
284  }  }
285    
# Line 203  Close a database saving all meta data af Line 292  Close a database saving all meta data af
292    
293  sub close {  sub close {
294    my $self = $_[0];    my $self = $_[0];
   my $file = $self->{file};  
   my $table;  
   my $did_save;  
295        
296    for $table (values %{$self->{tables}}) {    for my $table (values %{$self->{tables}}) {
297      $table->close if ref($table);      $table->close if ref($table);
298    }    }
299    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);
300    
301    my $lock = delete $self->{write_lock}; # Do not store lock objects    for my $att (qw(file maindbfile name env)) {
302        delete $self->{$att} || confess "can't delete '$att'";
   if ($HAVE_DATA_DUMPER) {  
     my $fh   = new FileHandle "> $file/meta.$$";  
     if ($fh) {  
       my $dumper = new Data::Dumper [$self],['self'];  
       $fh->print('my ');  
       $fh->print($dumper->Dumpxs);  
       $fh->close;  
       $did_save = rename "$file/meta.$$", "$file/meta";  
     } else {  
       croak "Could not open '$file/meta' for writing: $!";  
       # never reached: return unless $HAVE_STORABLE;  
     }  
303    }    }
304    
305    if ($HAVE_STORABLE) {    my $db = $self->{_attr};
306      if (!eval {Storable::store($self, "$file/catalog.$$")}) {    delete $self->{_attr} || confess "can't delete _attr";
307        unlink "$file/catalog.$$";  
308        croak "Could not open '$file/catalog.$$' for writing: $!";    my $dat = nfreeze $self;
309        # never reached: return unless $did_save;    $db->db_put(0, $dat);
310      } else {  
311        $did_save = rename "$file/catalog.$$", "$file/catalog";    #warn "DEBUG: Removing env[$env] before closing database";
312      }    undef $env;
313    }    #warn "DEBUG: Removed it.";
314    
   $lock->release;  
     
315    undef $_[0];    undef $_[0];
316    $did_save;    return 1;
317  }  }
318    
319    
# Line 259  sub create_table { Line 331  sub create_table {
331    my %parm = @_;    my %parm = @_;
332    my $name = $parm{name} or croak "create_table: No name specified";    my $name = $parm{name} or croak "create_table: No name specified";
333    my $attr = $parm{attr} or croak "create_table: No attributes specified";    my $attr = $parm{attr} or croak "create_table: No attributes specified";
334    my $file = $self->{file};    my $path = $self->path;
335    
336    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);
337    
# Line 274  sub create_table { Line 346  sub create_table {
346        }        }
347      }      }
348    }    }
349    $self->{tables}->{$name} = WAIT::Table->new(file     => "$file/$name",    $self->{tables}->{$name} = WAIT::Table->new(file     => "$path/$name",
350                                                database => $self,                                                database => $self,
351                                                  env      => $self->{env},
352                                                  maindbfile  => $self->maindbfile,
353                                                  tablename   => $name,
354                                                %parm);                                                %parm);
355    unless (defined $self->{tables}->{$name}) {# fail gracefully    unless (defined $self->{tables}->{$name}) {# fail gracefully
356      delete $self->{tables}->{$name};      delete $self->{tables}->{$name};
# Line 289  sub create_table { Line 364  sub create_table {
364    WAIT::Table::Handle->new($self, $name);    WAIT::Table::Handle->new($self, $name);
365  }  }
366    
367    =head2 maindbfile
368    
369    Name of BerekelyDB database (without path)
370    
371     my $bdb = $db->maindbfile;
372    
373    =cut
374    
375    sub maindbfile {
376      my($self,$path) = @_;
377      return $self->{maindbfile} if $self->{maindbfile};
378      $path ||= $self->path;
379      confess "ALERT: no file argument, no file attribute???" unless $path;
380      $self->{maindbfile} = "etat";
381    }
382    
383    =head2 path
384    
385    Path to database
386    
387     my $db_path = $db->path;
388    
389    =cut
390    
391    sub path {
392      my $self = shift;
393      return $self->{path} if $self->{path};
394      confess("no attribut dir?") unless $self->{dir};
395      confess("no attribut name?") unless $self->{name};
396      $self->{path} = "$self->{dir}/$self->{name}";
397    }
398    
399  =head2 C<$db-E<gt>table(name =E<gt>> I<tname>C<);>  =head2 C<$db-E<gt>table(name =E<gt>> I<tname>C<);>
400    
# Line 318  sub table { Line 424  sub table {
424      }      }
425      WAIT::Table::Handle->new($self,$name);      WAIT::Table::Handle->new($self,$name);
426    } else {    } else {
427      print STDERR "No such table '$name'\n";      croak "No such table '$name'";
     return;  
428    }    }
429  }  }
430    
Legend:
Removed from v.107  
changed lines
  Added in v.108
  ViewVC Help
Powered by ViewVC 1.1.26