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

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

Parent Directory | Revision Log | View Patch Patch

-branches/CPAN/lib/WAIT/Database.pm
revision 11 by unknown,
Fri Apr 28 15:41:10 2000 UTC
+trunk/lib/WAIT/Database.pm
revision 108 by dpavlin,
Tue Jul 13 17:41:12 2004 UTC
 Line 1
- #                              -*- Mode: Perl -*-
+ #                              -*- Mode: cperl -*-
- # Database --
+ # $Basename: Database.pm $
- # ITIID           : $ITI$ $Header $__Header$
+ # $Revision: 1.14 $
  # Author          : Ulrich Pfeifer
  # Created On      : Thu Aug  8 09:44:13 1996
  # Last Modified By: Ulrich Pfeifer
- # Last Modified On: Sun Nov 22 18:44:48 1998
+ # Last Modified On: Sat Apr 15 16:15:29 2000
  # Language        : CPerl
- # Update Count    : 249
- # Status          : Unknown, Use with caution!
  #
- # Copyright (c) 1996-1997, Ulrich Pfeifer
+ # (C) Copyright 1996-2000, Ulrich Pfeifer
  #
  =head1 NAME
-Line 33 
 use strict;
+Line 31 
 use strict;
  use FileHandle ();
  use File::Path qw(rmtree);
  use WAIT::Table ();
+ use BerkeleyDB;
  use Fcntl;
- use Carp;
+ use Carp; # will use autouse later
- my ($HAVE_DATA_DUMPER, $HAVE_STORABLE);
+ use Storable qw(nfreeze thaw);
+ use vars qw($VERSION);
+ use Data::Dumper;
- BEGIN {
+ $VERSION = "2.000";
-   eval { require Data::Dumper };
-   $HAVE_DATA_DUMPER = 1 if $@ eq '';
+ #$WAIT::Database::Pagesize = 1*1024;
-   eval { require Storable };
+ #$WAIT::Database::Cachesize = 4*1024*1024;
-   $HAVE_STORABLE    = 1 if $@ eq '';
-   $HAVE_DATA_DUMPER || $HAVE_STORABLE ||
+ # use autouse Carp => qw( croak($) );
-     die "Could not find Data::Dumper nor Storable";
-   $Storable::forgive_me = 1;
- }
+ =head2 Constructor create
- =head2 C<$db = create WAIT::Database name =>E<gt> I<name> C<directory =E<gt>> I<dir>C<;>
+   $db = WAIT::Database->create(
+                                directory => '/dir/to/database/'
+                                name      => 'name',
+                               );
+ Create a new database.
  =over 10
  =item B<name> I<name>
- mandatory
+ Mandatory name of database
  =item B<directory> I<directory>
-Line 65 
 directory).
+Line 69 
 directory).
  If given, the database will require unique attributes over all tables.
- The function will return undef and set C<$@> on failure.
+ The method will croak on failure.
+ =back
  =cut
-Line 73 
 sub create {
+Line 79 
 sub create {
    my $type = shift;
    my %parm = @_;
    my $self = {};
+   bless $self => ref($type) || $type;
    my $dir  = $parm{directory} || '.';
-   my $name = $parm{name}      or croak "No name specified";
+   my $name = $parm{name};
+   unless ($name) {
+     croak("No name specified");
+   }
+   unless (-d $dir){
+     croak("Directory '$dir' does not exits: $!");
+   }
-   croak "Directory '$dir' does not exits: $!" unless -d $dir;
+   if (-d "$dir/$name") {
-   croak "Directory '$name' already exists"    if -d "$dir/$name";
+     warn "Warning: Directory '$dir/$name' already exists";
-   mkdir "$dir/$name", 0775 or croak "Could not mkdir '$dir/$name': $!";
+   } else {
+     unless (mkdir "$dir/$name", 0775) {
+       croak("Could not mkdir '$dir/$name': $!");
+     }
+   }
+   $self->{dir}       = $dir;
    $self->{name}      = $name;
-   $self->{file}      = "$dir/$name";
+ use Data::Dumper;
+ print Dumper($self);
+   print STDERR "## dir: $dir name: $name path: ",$self->file,"\n";
+   my $env= BerkeleyDB::Env->new(
+                                 -Home => $self->path,
+                                 -Flags => DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB|DB_PRIVATE,
+                                 # Cachesize => 1024*1024*8,
+                                 # Pagesize => 8*1024, # environment doesn't understand Pagesize parameter!
+                                 -Verbose => 1,
+                                 -ErrFile => $self->path."/error.log",
+                                 );
+   unless ($env) {
+     confess("Could not create environment: $BerkeleyDB::Error");
+   }
+   $self->{env} = $env;
+   # apperently (! learned from trial and error) while the Env doesn't
+   # understand Pagesize, the very first table needs to set it up if we
+   # want to deviate from the default. And all tables need to follow
+   # this lead. I'm doing so explicitly, it looks prettier to me
+   $self->{_attr} = BerkeleyDB::Btree->new(
+                                           -Filename => $self->maindbfile,
+                                           -Subname  => "_attr",
+                                           -Flags    => DB_CREATE,
+                                           -Mode     => 0664,
+                                           -Env      => $env,
+                                           $WAIT::Database::Cachesize?(Cachesize => $WAIT::Database::Cachesize):(),
+                                           $WAIT::Database::Pagesize?(Pagesize => $WAIT::Database::Pagesize):(),
+                                          );
+ print STDERR "### created ",$self->maindbfile,"\n";
+   unless (defined($self->{_attr})) {
+     die("Cannot open [".$self->maindbfile."] _attr: $BerkeleyDB::Error");
+   }
+   # Use of BerkeleyDB::Env->new here could maybe some day be a way to
+   # introduce a smart locking mechanism? Whatever... it is currently
+   # kein Thema: remember, that the database has a $self->path which
+   # is a *directory* and there are no berkeley tables in this
+   # directory, but there is one subdirectory in this directory for
+   # *each* *table* object.
    $self->{uniqueatt} = $parm{uniqueatt};
-   $self->{mode}      = O_CREAT;
+   $self->{mode}      = O_RDWR;
-   bless $self => ref($type) || $type;
+   $self;
  }
- =head2 C<$db = open WAIT::Database name =E<gt>> I<name> C<directory =E<gt>> I<dir>C<;>
+ =head2 Constructor open
+   $db = WAIT::Database->open(
+                              name => "foo",
+                              directory => "bar"
+                             );
  Open an existing database I<foo> in directory I<bar>.
-Line 99 
 sub open {
+Line 171 
 sub open {
    my %parm    = @_;
    my $dir     = $parm{directory} || '.';
    my $name    = $parm{name} or croak "No name specified";
-   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;
-     $self = do $meta;
+   my $mode = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);
-     unless (defined $self) {
+   $self->{dir}  = $dir; # will be overwritten by the thaw below, but we need it now
-       warn "\ado '$meta' did not work. Mysterious! Reverting to eval `cat $meta`\n";
+   $self->{name} = $name;
-       sleep(4);
-       $self = eval `cat $meta`;
+   my $env;
+   if ($mode & O_RDWR) {
+     my $flags = DB_CREATE|DB_INIT_MPOOL|DB_INIT_CDB;
+     warn "setting flags for envorinment 'writing'";
+     $env = BerkeleyDB::Env->new(
+                                 -Home => $self->path,
+                                 -Flags => $flags,
+                                );
+     unless ($env) {
+       confess("Could not create environment in [".$self->path."]: $BerkeleyDB::Error");
      }
-   }
+   } else {
+     # in der Datei neo-lieferung.pl habe ich in Punkt 2.6 darueber
+     # lamentiert, dass der Readonly-User kein Environment bekommt.
+     # Es muesste ein Klacks sein, dafuer einen Schalter
+     # bereitzustellen. Kostet mich aber zu viel Denkzeit.
+     # warn "DEBUG: setting env to NIL";
+     $env = "";
+   }
+   # warn "DEBUG: trying to open the database for _attr";
+   my $maindbfile = $self->maindbfile;
+   my $attr = BerkeleyDB::Btree->new(
+                                     -Filename => $maindbfile,
+                                     -Subname  => "_attr",
+                                     $env ? (-Env => $env) : (-Flags => DB_RDONLY, -Home => $self->path),
+                                    );
+   unless (defined($attr)) {
+       use Data::Dumper;
+       print Dumper($attr);
+       croak "Cannot open [$maindbfile] _attr: $BerkeleyDB::Error; mdbf[$maindbfile] env[$env]";
+   }
+   # warn "DEBUG: opened the database for _attr";
+   $attr->db_get(0, my $dat);
+   # warn sprintf "DEBUG: got _attr record. time[%.6f] length(dat)[%d]", Time::HiRes::time(), length $dat;
+   $self = thaw $dat;
+   # warn sprintf "DEBUG: thawed _attr rec. time[%.6f]", Time::HiRes::time();
+   $self->{_attr} = $attr;
+   return unless defined $self;
+   $self->{mode} = $mode;
+   $self->{env}  = $env;
+   $self->{dir}  = $dir; # yes, again
+   $self->{name} = $name;
+   $self->walkncomplete;
-   return $self unless defined $self;
-   $self->{mode} = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);
    $self;
  }
+ sub walkncomplete {
+   my $self = shift;
+   $self->maindbfile;
+   $self->path;
+   for my $t (values %{$self->{tables} || {}}) {
+     $t->{file} ||= $self->{file};
+     $t->{maindbfile} ||= $self->{maindbfile};
+     $t->{mode} = $self->{mode};
+     for my $ind (values %{$t->{indexes}}) {
+       $ind->{file} ||= $self->{file};
+       $ind->{maindbfile} ||= $self->{maindbfile};
+       $ind->{mode} = $self->{mode};
+     }
+     for my $inv (values %{$t->{inverted}}) {
+       for my $ind (@$inv) {
+         $ind->{file} ||= $self->{file};
+         $ind->{maindbfile} ||= $self->{maindbfile};
+         $ind->{mode} = $self->{mode};
+       }
+     }
+   }
+ }
- =head2 C<$db-E<gt>dispose;>
+ =head2 dispose
  Dispose a database. Remove all associated files. This may fail if the
  database or one of its tables is still open. Failure will be indicated
  by a false return value.
+  $db->dispose;
+  WAIT::Database->dispose(name=>'name', directory=>'/dir/to/db/');
  =cut
  sub dispose {
-   my $dir;
+   my $path;
    if (ref $_[0]) {               # called with instance
      croak "Database readonly" unless $_[0]->{mode} & (O_CREAT | O_RDWR);
-     $dir = $_[0]->{file};
+     $path = $_[0]->path;
      $_[0]->close;
    } else {
      my $type = shift;
      my %parm = @_;
      my $base = $parm{directory} || '.';
-     my $name = $parm{name}       || croak "No name specified";
+     my $name = $parm{name}      || croak "No name specified";
-     $dir = "$base/$name";
+     $path = "$base/$name";
    }
-   croak "No such database '$dir'" unless -e "$dir/meta";
+   croak "No such database '$path'" unless -e "$path";
-   rmtree($dir, 0, 1);
+   my $ret = rmtree($path, 0, 1);
+   $ret;
  }
-Line 159 
 Close a database saving all meta data af
+Line 292 
 Close a database saving all meta data af
  sub close {
    my $self = $_[0];
-   my $file = $self->{file};
-   my $table;
+   for my $table (values %{$self->{tables}}) {
-   my $did_save;
-   for $table (values %{$self->{tables}}) {
      $table->close if ref($table);
    }
    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);
-   if ($HAVE_DATA_DUMPER) {
+   for my $att (qw(file maindbfile name env)) {
-     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 = 1;
-     } else {
-       croak "Could not open '$file/meta' for writing: $!";
-       return unless $HAVE_STORABLE;
-     }
    }
-   if ($HAVE_STORABLE) {
+   my $db = $self->{_attr};
-     if (!eval {Storable::store($self, "$file/catalog")}) {
+   delete $self->{_attr} || confess "can't delete _attr";
-       fail ("Could not open '$file/catalog' for writing: $!");
-       return unless $did_save;
+   my $dat = nfreeze $self;
-     } else {
+   $db->db_put(0, $dat);
-       $did_save++;
-     }
+   #warn "DEBUG: Removing env[$env] before closing database";
-   }
+   undef $env;
+   #warn "DEBUG: Removed it.";
    undef $_[0];
-   $did_save;
+   return 1;
  }
- =head2 C<$db-E<gt>create_table name =E<gt>> I<tname> ... C<;>
+ =head2 C<$db-E<gt>create_table(name =E<gt>> I<tname>, ... C<);>
- Create a new table with name I<tname>. All paraeters are passed to
+ Create a new table with name I<tname>. All parameters are passed to
- C<WAIT::Table::new> together with a filename to use. The function
+ C<WAIT::Table-E<gt>new> together with a filename to use. See
- returns a table handle (C<WAIT::Table::Handle>).
+ L<WAIT::Table> for which attributes are required. The method returns a
+ table handle (C<WAIT::Table::Handle>).
  =cut
  sub create_table {
    my $self = shift;
    my %parm = @_;
-   my $name = $parm{name} || return fail("No name specified");
+   my $name = $parm{name} or croak "create_table: No name specified";
-   my $file = $self->{file};
+   my $attr = $parm{attr} or croak "create_table: No attributes specified";
+   my $path = $self->path;
    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);
-Line 216 
 sub create_table {
+Line 340 
 sub create_table {
    }
    if ($self->{uniqueatt}) {
-     for (@{$parm{attr}}) {      # attribute names must be uniqe
+     for (@$attr) {      # attribute names must be uniqe
        if ($self->{attr}->{$_}) {
-         return fail ("Attribute '$_' is not unique")
+         croak("Attribute '$_' is not unique")
        }
      }
    }
-   $self->{tables}->{$name} = WAIT::Table->new(file     => "$file/$name",
+   $self->{tables}->{$name} = WAIT::Table->new(file     => "$path/$name",
                                                database => $self,
+                                               env      => $self->{env},
+                                               maindbfile  => $self->maindbfile,
+                                               tablename   => $name,
                                                %parm);
    unless (defined $self->{tables}->{$name}) {# fail gracefully
      delete $self->{tables}->{$name};
-Line 232 
 sub create_table {
+Line 359 
 sub create_table {
    if ($self->{uniqueatt}) {
      # remember table name for each attribute
-     map ($self->{attr}->{$_} = $name, @{$parm{attr}});
+     map ($self->{attr}->{$_} = $name, @$attr);
    }
    WAIT::Table::Handle->new($self, $name);
  }
+ =head2 maindbfile
+ Name of BerekelyDB database (without path)
+  my $bdb = $db->maindbfile;
+ =cut
+ sub maindbfile {
+   my($self,$path) = @_;
+   return $self->{maindbfile} if $self->{maindbfile};
+   $path ||= $self->path;
+   confess "ALERT: no file argument, no file attribute???" unless $path;
+   $self->{maindbfile} = "etat";
+ }
+ =head2 path
+ Path to database
+  my $db_path = $db->path;
+ =cut
+ sub path {
+   my $self = shift;
+   return $self->{path} if $self->{path};
+   confess("no attribut dir?") unless $self->{dir};
+   confess("no attribut name?") unless $self->{name};
+   $self->{path} = "$self->{dir}/$self->{name}";
+ }
- =head2 <$db-E<gt>table name =E<gt>> I<tname>C<;>
+ =head2 C<$db-E<gt>table(name =E<gt>> I<tname>C<);>
- Open a new table with name I<tname>. The function
+ Open a new table with name I<tname>. The method
- returns a table handle (C<WAIT::Table::Handle).
+ returns a table handle (C<WAIT::Table::Handle>).
  =cut
-Line 271 
 sub table {
+Line 429 
 sub table {
  }
- =head2 C<$db-E<gt>drop  name =E<gt>> I<tname>C<;>
+ =head2 C<$db-E<gt>drop(name =E<gt>> I<tname>C<);>
  Drop the table named I<tname>. The table should be closed before
  calling B<drop>.
-Line 300 
 sub drop_table {
+Line 458 
 sub drop_table {
  }
- package WAIT::Table::Handle;
- use Carp;
- sub new {
-   my ($type, $database, $name) = @_;
-   bless [$database, $name], $type;
- }
- sub AUTOLOAD {
-   my $func = $WAIT::Table::Handle::AUTOLOAD; $func =~ s/.*:://;
-   my $self = $_[0];
-   my ($database, $name) = @{$self};
-   if (defined $database->{tables}->{$name}) {
-     if ($func eq 'drop') {
-       $database->drop_table(name => $name);
-       undef $_[0];
-;
-     } elsif ($func ne 'DESTROY') {
-       shift @_;
-       if ($func eq 'open') {
-         $database->{tables}->{$name}->$func(mode => $database->{mode}, @_);
-       } else {
-         $database->{tables}->{$name}->$func(@_);
-       }
-     }
-   } else {
-     return fail("Invalid handle\n");
-   }
- }
 ;

 Legend:



Removed from v.11
 


changed lines


 
Added in v.108
 Legend:



Removed from v.11
 


changed lines


 
Added in v.108
-Removed from v.11
+Added in v.108

	ViewVC Help
Powered by ViewVC 1.1.26