/[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

cvs-head/lib/WAIT/Database.pm revision 86 by dpavlin, Mon May 24 13:41:28 2004 UTC trunk/lib/WAIT/Database.pm revision 110 by dpavlin, Tue Jul 13 19:05:31 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
5  # Created On      : Thu Aug  8 09:44:13 1996  # Created On      : Thu Aug  8 09:44:13 1996
6  # Last Modified By: Ulrich Pfeifer  # Last Modified By: Ulrich Pfeifer
7  # Last Modified On: Sat Apr 27 16:48:24 2002  # Last Modified On: Sat Apr 15 16:15:29 2000
8  # Language        : CPerl  # Language        : CPerl
9  #  #
10  # (C) Copyright 1996-2000, Ulrich Pfeifer  # (C) Copyright 1996-2000, 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    
86    unless ($name) {    croak("No name specified") unless ($name);
     croak("No name specified");  
   }  
87    
88    unless (-d $dir){    croak("Directory '$dir' does not exits: $!") unless (-d $dir);
     croak("Directory '$dir' does not exits: $!");  
   }  
89    
90    if (-d "$dir/$name") {    if (-d "$dir/$name") {
91      warn "Warning: Directory '$dir/$name' already exists";      warn "Warning: Directory '$dir/$name' already exists";
# Line 102  sub create { Line 95  sub create {
95      }      }
96    }    }
97    
98      $self->{dir}       = $dir;
99    $self->{name}      = $name;    $self->{name}      = $name;
100    $self->{file}      = "$dir/$name";  
101      print STDERR "## dir: $dir name: $name\n";
102    
103      my $env = BerkeleyDB::Env->new(
104                                    -Home => $self->path,
105                                    -Flags => DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB|DB_PRIVATE,
106                                    # Cachesize => 1024*1024*8,
107                                    # Pagesize => 8*1024, # environment doesn't understand Pagesize parameter!
108                                    -Verbose => 1,
109                                    -ErrFile => $self->path."/error.log",
110                                    );
111      unless ($env) {
112        confess("Could not create environment: $BerkeleyDB::Error");
113      }
114    
115      $self->{env} = $env;
116    
117      # apperently (! learned from trial and error) while the Env doesn't
118      # understand Pagesize, the very first table needs to set it up if we
119      # want to deviate from the default. And all tables need to follow
120      # this lead. I'm doing so explicitly, it looks prettier to me
121      $self->{_attr} = BerkeleyDB::Btree->new(
122                                              -Filename => $self->maindbfile,
123                                              -Subname  => "_attr",
124                                              -Flags    => DB_CREATE,
125                                              -Mode     => 0664,
126                                              -Env      => $env,
127                                              $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
128                                              $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
129                                             );
130    
131    print STDERR "### created ",$self->maindbfile,"\n";
132    
133      unless (defined($self->{_attr})) {
134        die("Cannot open [".$self->maindbfile."] _attr: $BerkeleyDB::Error");
135      }
136    
137    
138      # Use of BerkeleyDB::Env->new here could maybe some day be a way to
139      # introduce a smart locking mechanism? Whatever... it is currently
140      # kein Thema: remember, that the database has a $self->path which
141      # is a *directory* and there are no berkeley tables in this
142      # directory, but there is one subdirectory in this directory for
143      # *each* *table* object.
144    
145    $self->{uniqueatt} = $parm{uniqueatt};    $self->{uniqueatt} = $parm{uniqueatt};
146    $self->{mode}      = O_CREAT;    $self->{mode}      = O_RDWR;
147    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;  
148  }  }
149    
150    
# Line 130  sub open { Line 164  sub open {
164    my %parm    = @_;    my %parm    = @_;
165    my $dir     = $parm{directory} || '.';    my $dir     = $parm{directory} || '.';
166    my $name    = $parm{name} or croak "No name specified";    my $name    = $parm{name} or croak "No name specified";
167    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;  
168    
169      $self = do $meta;    my $mode = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);
170      unless (defined $self) {    $self->{dir}  = $dir; # will be overwritten by the thaw below, but we need it now
171        warn "do '$meta' did not work. Mysterious! Reverting to eval `cat $meta`";    $self->{name} = $name;
172        sleep(4);  
173        $self = eval `cat $meta`;    my $env;
174    
175      if ($mode & O_RDWR) {
176        my $flags = DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB;
177        #warn "setting flags for envorinment 'writing'";
178        $env = BerkeleyDB::Env->new(
179                                    -Home => $self->path,
180                                    -Flags => $flags,
181                                   );
182        unless ($env) {
183          confess("Could not create environment in [".$self->path."]: $BerkeleyDB::Error");
184      }      }
185    }    } else {
186        # in der Datei neo-lieferung.pl habe ich in Punkt 2.6 darueber
187        # lamentiert, dass der Readonly-User kein Environment bekommt.
188        # Es muesste ein Klacks sein, dafuer einen Schalter
189        # bereitzustellen. Kostet mich aber zu viel Denkzeit.
190        # warn "DEBUG: setting env to NIL";
191        $env = "";
192      }
193    
194      warn "DEBUG: trying to open the database for _attr";
195      my $maindbfile = $self->maindbfile;
196      my $attr = BerkeleyDB::Btree->new(
197                                        -Filename => $maindbfile,
198                                        -Subname  => "_attr",
199                                        $env ? (-Env => $env) : (-Flags => DB_RDONLY),
200                                       );
201      unless (defined($attr)) {
202          croak "Cannot open [$maindbfile] _attr: $BerkeleyDB::Error; mdbf[$maindbfile] env[$env]";
203      }
204    
205      #warn "DEBUG: opened the database for _attr";
206      $attr->db_get(0, my $dat);
207      #warn sprintf "DEBUG: got _attr record. time[%.6f] length(dat)[%d]", Time::HiRes::time(), length $dat;
208      $self = thaw $dat;
209      #warn sprintf "DEBUG: thawed _attr rec. time[%.6f]", Time::HiRes::time();
210      $self->{_attr} = $attr;
211    
212    return unless defined $self;    return unless defined $self;
   $self->{mode} = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);  
213    
214    if ($self->{mode} & O_RDWR) {    $self->{mode} = $mode;
215      # Locking: We do not care about read access since write is atomic.    $self->{env}  = $env;
216      my $lockmgr = LockFile::Simple->make(-autoclean => 1, -stale => 1);    $self->{dir}  = $dir; # yes, again
217          $self->{name} = $name;
218      # aquire a write lock    $self->walkncomplete;
     $self->{write_lock} = $lockmgr->lock("$dir/$name/write")  
       or die "Can't lock '$dir/$name/write'";  
   }  
219    
220    $self;    $self;
221  }  }
222    
223    sub walkncomplete {
224  =head2 C<$db-E<gt>dispose;>    my $self = shift;
225      $self->maindbfile;
226  Dispose a database. Remove all associated files. This may fail if the    $self->path;
227  database or one of its tables is still open. Failure will be indicated    for my $t (values %{$self->{tables} || {}}) {
228  by a false return value.      $t->{file} ||= $self->{file};
229        $t->{maindbfile} ||= $self->{maindbfile};
230  =cut      $t->{mode} = $self->{mode};
231        for my $ind (values %{$t->{indexes}}) {
232  sub dispose {        $ind->{file} ||= $self->{file};
233    my $dir;        $ind->{maindbfile} ||= $self->{maindbfile};
234          $ind->{mode} = $self->{mode};
235    if (ref $_[0]) {               # called with instance      }
236      croak "Database readonly" unless $_[0]->{mode} & (O_CREAT | O_RDWR);      for my $inv (values %{$t->{inverted}}) {
237      $dir = $_[0]->{file};        for my $ind (@$inv) {
238      $_[0]->close;          $ind->{file} ||= $self->{file};
239    } else {          $ind->{maindbfile} ||= $self->{maindbfile};
240      my $type = shift;          $ind->{mode} = $self->{mode};
241      my %parm = @_;        }
242      my $base = $parm{directory} || '.';      }
     my $name = $parm{name}       || croak "No name specified";  
     $dir = "$base/$name";  
243    }    }
   croak "No such database '$dir'" unless -e "$dir/meta";  
   
   #warn "Running rmtree on dir[$dir]";  
   my $ret = rmtree($dir, 0, 1);  
   #warn "rmtree returned[$ret]";  
   $ret;  
244  }  }
245    
246    
247  =head2 C<$db-E<gt>close;>  =head2 close
248    
249  Close a database saving all meta data after closing all associated tables.  Close a database saving all meta data after closing all associated tables.
250    
251     $db->close;
252    
253  =cut  =cut
254    
255  sub close {  sub close {
256    my $self = $_[0];    my $self = shift;
   my $file = $self->{file};  
   my $table;  
   my $did_save;  
257        
258    for $table (values %{$self->{tables}}) {    for my $table (values %{$self->{tables}}) {
259      $table->close if ref($table);      $table->close if ref($table);
260    }    }
261    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);
262    
263    my $lock = delete $self->{write_lock}; # Do not store lock objects    my $env = $self->{env};
264    
265    if ($HAVE_DATA_DUMPER) {    for my $att (qw(path maindbfile name env)) {
266      my $fh   = new FileHandle "> $file/meta.$$";      delete $self->{$att} || confess "can't delete '$att'";
     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;  
     }  
267    }    }
268    
269    if ($HAVE_STORABLE) {    my $db = $self->{_attr};
270      if (!eval {Storable::store($self, "$file/catalog.$$")}) {    delete $self->{_attr} || confess "can't delete _attr";
271        unlink "$file/catalog.$$";  
272        croak "Could not open '$file/catalog.$$' for writing: $!";    my $dat = nfreeze $self;
273        # never reached: return unless $did_save;    $db->db_put(0, $dat);
274      } else {  
275        $did_save = rename "$file/catalog.$$", "$file/catalog";    #warn "DEBUG: Removing env[$env] before closing database";
276      }    undef $env;
277    }    #warn "DEBUG: Removed it.";
278    
   $lock->release;  
     
279    undef $_[0];    undef $_[0];
280    $did_save;    return 1;
281    }
282    
283    
284    =head2 dispose
285    
286    Dispose a database. Remove all associated files. This may fail if the
287    database or one of its tables is still open. Failure will be indicated
288    by a false return value.
289    
290     $db->dispose;
291    
292     WAIT::Database->dispose(name=>'name', directory=>'/dir/to/db/');
293    
294    =cut
295    
296    sub dispose {
297      my $self = shift;
298    
299      my $path;
300    
301      if ($self && ref $self) {               # called with instance
302        croak "no mode" unless defined($self->{mode});
303        croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);
304        $path = $self->path;
305        $self->close;
306      } else {
307        my %parm = @_;
308        my $base = $parm{directory} || '.';
309        my $name = $parm{name}      || croak "No name specified";
310        $path = "$base/$name";
311      }
312      croak "No such database '$path'" unless -e "$path";
313    
314      my $ret = rmtree($path, 0, 1);
315    
316      return $ret;
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 "no path argument or 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.86  
changed lines
  Added in v.110
  ViewVC Help
Powered by ViewVC 1.1.26