/[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 113 by dpavlin, Tue Jul 13 20:28:45 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      my $env = BerkeleyDB::Env->new(
102                                    -Home => $self->path,
103                                    -Flags => DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB|DB_PRIVATE,
104                                    # Cachesize => 1024*1024*8,
105                                    # Pagesize => 8*1024, # environment doesn't understand Pagesize parameter!
106                                    -Verbose => 1,
107                                    -ErrFile => $self->path."/error.log",
108                                    );
109      unless ($env) {
110        confess("Could not create environment: $BerkeleyDB::Error");
111      }
112    
113      $self->{env} = $env;
114    
115      # apperently (! learned from trial and error) while the Env doesn't
116      # understand Pagesize, the very first table needs to set it up if we
117      # want to deviate from the default. And all tables need to follow
118      # this lead. I'm doing so explicitly, it looks prettier to me
119      $self->{_attr} = BerkeleyDB::Btree->new(
120                                              -Filename => $self->maindbfile,
121                                              -Subname  => "_attr",
122                                              -Flags    => DB_CREATE,
123                                              -Mode     => 0664,
124                                              -Env      => $env,
125                                              $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
126                                              $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
127                                             );
128    
129      unless (defined($self->{_attr})) {
130        die("Cannot open [".$self->maindbfile."] _attr: $BerkeleyDB::Error");
131      }
132    
133    
134      # Use of BerkeleyDB::Env->new here could maybe some day be a way to
135      # introduce a smart locking mechanism? Whatever... it is currently
136      # kein Thema: remember, that the database has a $self->path which
137      # is a *directory* and there are no berkeley tables in this
138      # directory, but there is one subdirectory in this directory for
139      # *each* *table* object.
140    
141    $self->{uniqueatt} = $parm{uniqueatt};    $self->{uniqueatt} = $parm{uniqueatt};
142    $self->{mode}      = O_CREAT;    $self->{mode}      = O_RDWR;
143    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;  
144  }  }
145    
146    
# Line 130  sub open { Line 160  sub open {
160    my %parm    = @_;    my %parm    = @_;
161    my $dir     = $parm{directory} || '.';    my $dir     = $parm{directory} || '.';
162    my $name    = $parm{name} or croak "No name specified";    my $name    = $parm{name} or croak "No name specified";
163    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;  
164    
165      $self = do $meta;    my $mode = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);
166      unless (defined $self) {    $self->{dir}  = $dir; # will be overwritten by the thaw below, but we need it now
167        warn "do '$meta' did not work. Mysterious! Reverting to eval `cat $meta`";    $self->{name} = $name;
168        sleep(4);  
169        $self = eval `cat $meta`;    my $env;
170    
171      return if (! -d $self->path);
172    
173      if ($mode & O_RDWR) {
174        my $flags = DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB;
175        #warn "setting flags for envorinment 'writing'";
176        $env = BerkeleyDB::Env->new(
177                                    -Home => $self->path,
178                                    -Flags => $flags,
179                                   );
180        unless ($env) {
181          confess("Could not create environment in [".$self->path."]: $BerkeleyDB::Error");
182      }      }
183    }    } else {
184        # in der Datei neo-lieferung.pl habe ich in Punkt 2.6 darueber
185        # lamentiert, dass der Readonly-User kein Environment bekommt.
186        # Es muesste ein Klacks sein, dafuer einen Schalter
187        # bereitzustellen. Kostet mich aber zu viel Denkzeit.
188        # warn "DEBUG: setting env to NIL";
189        $env = "";
190      }
191    
192      #warn "DEBUG: trying to open the database for _attr";
193      my $maindbfile = $self->maindbfile;
194      my $attr = BerkeleyDB::Btree->new(
195                                        -Filename => $maindbfile,
196                                        -Subname  => "_attr",
197                                        $env ? (-Env => $env) : (-Flags => DB_RDONLY),
198                                       );
199      unless (defined($attr)) {
200          croak "Cannot open [$maindbfile] _attr: $BerkeleyDB::Error; mdbf[$maindbfile] env[$env]";
201      }
202    
203      #warn "DEBUG: opened the database for _attr";
204      $attr->db_get(0, my $dat);
205      #warn sprintf "DEBUG: got _attr record. time[%.6f] length(dat)[%d]", Time::HiRes::time(), length $dat;
206      $self = thaw $dat;
207      #warn sprintf "DEBUG: thawed _attr rec. time[%.6f]", Time::HiRes::time();
208      $self->{_attr} = $attr;
209    
210    return unless defined $self;    return unless defined $self;
   $self->{mode} = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);  
211    
212    if ($self->{mode} & O_RDWR) {    $self->{mode} = $mode;
213      # Locking: We do not care about read access since write is atomic.    $self->{env}  = $env;
214      my $lockmgr = LockFile::Simple->make(-autoclean => 1, -stale => 1);    $self->{dir}  = $dir; # yes, again
215          $self->{name} = $name;
216      # aquire a write lock    $self->walkncomplete;
     $self->{write_lock} = $lockmgr->lock("$dir/$name/write")  
       or die "Can't lock '$dir/$name/write'";  
   }  
217    
218    $self;    $self;
219  }  }
220    
221    sub walkncomplete {
222  =head2 C<$db-E<gt>dispose;>    my $self = shift;
223      $self->maindbfile;
224  Dispose a database. Remove all associated files. This may fail if the    $self->path;
225  database or one of its tables is still open. Failure will be indicated    for my $t (values %{$self->{tables} || {}}) {
226  by a false return value.      $t->{file} ||= $self->{file};
227        $t->{maindbfile} ||= $self->{maindbfile};
228  =cut      $t->{mode} = $self->{mode};
229        for my $ind (values %{$t->{indexes}}) {
230  sub dispose {        $ind->{file} ||= $self->{file};
231    my $dir;        $ind->{maindbfile} ||= $self->{maindbfile};
232          $ind->{mode} = $self->{mode};
233    if (ref $_[0]) {               # called with instance      }
234      croak "Database readonly" unless $_[0]->{mode} & (O_CREAT | O_RDWR);      for my $inv (values %{$t->{inverted}}) {
235      $dir = $_[0]->{file};        for my $ind (@$inv) {
236      $_[0]->close;          $ind->{file} ||= $self->{file};
237    } else {          $ind->{maindbfile} ||= $self->{maindbfile};
238      my $type = shift;          $ind->{mode} = $self->{mode};
239      my %parm = @_;        }
240      my $base = $parm{directory} || '.';      }
     my $name = $parm{name}       || croak "No name specified";  
     $dir = "$base/$name";  
241    }    }
   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;  
242  }  }
243    
244    
245  =head2 C<$db-E<gt>close;>  =head2 close
246    
247  Close a database saving all meta data after closing all associated tables.  Close a database saving all meta data after closing all associated tables.
248    
249     $db->close;
250    
251  =cut  =cut
252    
253  sub close {  sub close {
254      # my $self = shift would increase refcount!
255    my $self = $_[0];    my $self = $_[0];
   my $file = $self->{file};  
   my $table;  
   my $did_save;  
256        
257    for $table (values %{$self->{tables}}) {    for my $table (values %{$self->{tables}}) {
258      $table->close if ref($table);      $table->close if ref($table);
259    }    }
260    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);
261    
262    my $lock = delete $self->{write_lock}; # Do not store lock objects    my $env = $self->{env};
263    
264    if ($HAVE_DATA_DUMPER) {    for my $att (qw(path maindbfile name env)) {
265      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;  
     }  
266    }    }
267    
268    if ($HAVE_STORABLE) {    my $db = $self->{_attr};
269      if (!eval {Storable::store($self, "$file/catalog.$$")}) {    delete $self->{_attr} || confess "can't delete _attr";
270        unlink "$file/catalog.$$";  
271        croak "Could not open '$file/catalog.$$' for writing: $!";    my $dat = nfreeze $self;
272        # never reached: return unless $did_save;    $db->db_put(0, $dat);
273      } else {  
274        $did_save = rename "$file/catalog.$$", "$file/catalog";    undef $db;
275      }  
276    }    #warn "DEBUG: Removing env[$env] before closing database";
277      undef $env;
278      #warn "DEBUG: Removed it.";
279    
   $lock->release;  
     
280    undef $_[0];    undef $_[0];
281    $did_save;    return 1;
282    }
283    
284    
285    =head2 dispose
286    
287    Dispose a database. Remove all associated files. This may fail if the
288    database or one of its tables is still open. Failure will be indicated
289    by a false return value.
290    
291     $db->dispose;
292    
293     WAIT::Database->dispose(name=>'name', directory=>'/dir/to/db/');
294    
295    =cut
296    
297    sub dispose {
298      # my $self = shift would increase refcount!
299    
300      my $path;
301    
302      if (ref $_[0]) {               # called with instance
303        croak "no mode" unless defined($_[0]->{mode});
304        croak "Database readonly" unless $_[0]->{mode} & (O_CREAT | O_RDWR);
305        $path = $_[0]->path;
306        $_[0]->close;
307      } else {
308        shift;
309        my %parm = @_;
310        my $base = $parm{directory} || '.';
311        my $name = $parm{name}      || croak "No name specified";
312        $path = "$base/$name";
313      }
314      croak "No such database '$path'" unless -e "$path";
315    
316      #warn "DEBUG: removing $path";
317      my $ret = rmtree($path, 0, 1);
318    
319      return $ret;
320  }  }
321    
322    
# Line 259  sub create_table { Line 334  sub create_table {
334    my %parm = @_;    my %parm = @_;
335    my $name = $parm{name} or croak "create_table: No name specified";    my $name = $parm{name} or croak "create_table: No name specified";
336    my $attr = $parm{attr} or croak "create_table: No attributes specified";    my $attr = $parm{attr} or croak "create_table: No attributes specified";
337    my $file = $self->{file};    my $path = $self->path;
338    
339    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);
340    
# Line 274  sub create_table { Line 349  sub create_table {
349        }        }
350      }      }
351    }    }
352    $self->{tables}->{$name} = WAIT::Table->new(file     => "$file/$name",    $self->{tables}->{$name} = WAIT::Table->new(path     => "$path/$name",
353                                                database => $self,                                                database => $self,
354                                                  env      => $self->{env},
355                                                  maindbfile  => $self->maindbfile,
356                                                  tablename   => $name,
357                                                %parm);                                                %parm);
358    unless (defined $self->{tables}->{$name}) {# fail gracefully    unless (defined $self->{tables}->{$name}) {# fail gracefully
359      delete $self->{tables}->{$name};      delete $self->{tables}->{$name};
# Line 289  sub create_table { Line 367  sub create_table {
367    WAIT::Table::Handle->new($self, $name);    WAIT::Table::Handle->new($self, $name);
368  }  }
369    
370    =head2 maindbfile
371    
372    Name of BerekelyDB database (without path)
373    
374     my $bdb = $db->maindbfile;
375    
376    =cut
377    
378    sub maindbfile {
379      my($self,$path) = @_;
380      return $self->{maindbfile} if $self->{maindbfile};
381      $path ||= $self->path;
382      confess "no path argument or attribute" unless $path;
383      $self->{maindbfile} = "etat";
384    }
385    
386    =head2 path
387    
388    Path to database
389    
390     my $db_path = $db->path;
391    
392    =cut
393    
394    sub path {
395      my $self = shift;
396      return $self->{path} if $self->{path};
397      confess("no attribut dir?") unless $self->{dir};
398      confess("no attribut name?") unless $self->{name};
399      $self->{path} = "$self->{dir}/$self->{name}";
400    }
401    
402  =head2 C<$db-E<gt>table(name =E<gt>> I<tname>C<);>  =head2 C<$db-E<gt>table(name =E<gt>> I<tname>C<);>
403    
# Line 318  sub table { Line 427  sub table {
427      }      }
428      WAIT::Table::Handle->new($self,$name);      WAIT::Table::Handle->new($self,$name);
429    } else {    } else {
430      print STDERR "No such table '$name'\n";      croak "No such table '$name'";
     return;  
431    }    }
432  }  }
433    
Legend:
Removed from v.86  
changed lines
  Added in v.113
  ViewVC Help
Powered by ViewVC 1.1.26