/[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 11 by unknown, Fri Apr 28 15:41:10 2000 UTC revision 19 by ulpfr, Tue May 9 11:29:45 2000 UTC
# Line 1  Line 1 
1  #                              -*- Mode: Perl -*-  #                              -*- Mode: Perl -*-
2  # Database --  # $Basename: Database.pm $
3  # ITIID           : $ITI$ $Header $__Header$  # $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: Sun Nov 22 18:44:48 1998  # Last Modified On: Sat Apr 15 16:15:29 2000
8  # Language        : CPerl  # Language        : CPerl
 # Update Count    : 249  
 # Status          : Unknown, Use with caution!  
9  #  #
10  # Copyright (c) 1996-1997, Ulrich Pfeifer  # (C) Copyright 1996-2000, Ulrich Pfeifer
11  #  #
12    
13  =head1 NAME  =head1 NAME
# Line 34  use FileHandle (); Line 32  use FileHandle ();
32  use File::Path qw(rmtree);  use File::Path qw(rmtree);
33  use WAIT::Table ();  use WAIT::Table ();
34  use Fcntl;  use Fcntl;
35  use Carp;  use Carp; # will use autouse later
36    use LockFile::Simple ();
37    
38    # use autouse Carp => qw( croak($) );
39  my ($HAVE_DATA_DUMPER, $HAVE_STORABLE);  my ($HAVE_DATA_DUMPER, $HAVE_STORABLE);
40    
41  BEGIN {  BEGIN {
# Line 48  BEGIN { Line 49  BEGIN {
49  }  }
50    
51    
52  =head2 C<$db = create WAIT::Database name =>E<gt> I<name> C<directory =E<gt>> I<dir>C<;>  =head2 Constructor create
53    
54      $db = WAIT::Database->create(
55                                   name      => <name>,
56                                   directory => <dir>
57                                  );
58    
59    Create a new database.
60    
61  =over 10  =over 10
62    
# Line 65  directory). Line 73  directory).
73    
74  If given, the database will require unique attributes over all tables.  If given, the database will require unique attributes over all tables.
75    
76  The function will return undef and set C<$@> on failure.  The method will croak on failure.
77    
78    =back
79    
80  =cut  =cut
81    
# Line 74  sub create { Line 84  sub create {
84    my %parm = @_;    my %parm = @_;
85    my $self = {};    my $self = {};
86    my $dir  = $parm{directory} || '.';    my $dir  = $parm{directory} || '.';
87    my $name = $parm{name}      or croak "No name specified";    my $name = $parm{name};
88    
89      unless ($name) {
90        croak("No name specified");
91      }
92    
93      unless (-d $dir){
94        croak("Directory '$dir' does not exits: $!");
95      }
96    
97    croak "Directory '$dir' does not exits: $!" unless -d $dir;    if (-d "$dir/$name") {
98    croak "Directory '$name' already exists"    if -d "$dir/$name";      warn "Warning: Directory '$dir/$name' already exists";
99    mkdir "$dir/$name", 0775 or croak "Could not mkdir '$dir/$name': $!";    } else {
100        unless (mkdir "$dir/$name", 0775) {
101          croak("Could not mkdir '$dir/$name': $!");
102        }
103      }
104    
105    $self->{name}      = $name;    $self->{name}      = $name;
106    $self->{file}      = "$dir/$name";    $self->{file}      = "$dir/$name";
107    $self->{uniqueatt} = $parm{uniqueatt};    $self->{uniqueatt} = $parm{uniqueatt};
108    $self->{mode}      = O_CREAT;    $self->{mode}      = O_CREAT;
109      my $lockmgr = LockFile::Simple->make(-autoclean => 1);
110      # aquire a write lock
111      $self->{write_lock} = $lockmgr->lock("$dir/$name/write")
112        or die "Can't lock '$dir/$name/write'";
113    bless $self => ref($type) || $type;    bless $self => ref($type) || $type;
114  }  }
115    
116    
117  =head2 C<$db = open WAIT::Database name =E<gt>> I<name> C<directory =E<gt>> I<dir>C<;>  =head2 Constructor open
118    
119      $db = WAIT::Database->open(
120                                 name => "foo",
121                                 directory => "bar"
122                                );
123    
124  Open an existing database I<foo> in directory I<bar>.  Open an existing database I<foo> in directory I<bar>.
125    
# Line 102  sub open { Line 133  sub open {
133    my $catalog = "$dir/$name/catalog";    my $catalog = "$dir/$name/catalog";
134    my $meta    = "$dir/$name/meta";    my $meta    = "$dir/$name/meta";
135    my $self;    my $self;
136      
137    if ($HAVE_STORABLE and -e $catalog    if ($HAVE_STORABLE and -e $catalog
138        and (!-e $meta or -M $meta >= -M $catalog)) {        and (!-e $meta or -M $meta >= -M $catalog)) {
139      $self = Storable::retrieve($catalog);      $self = Storable::retrieve($catalog);
# Line 111  sub open { Line 142  sub open {
142    
143      $self = do $meta;      $self = do $meta;
144      unless (defined $self) {      unless (defined $self) {
145        warn "\ado '$meta' did not work. Mysterious! Reverting to eval `cat $meta`\n";        warn "do '$meta' did not work. Mysterious! Reverting to eval `cat $meta`";
146        sleep(4);        sleep(4);
147        $self = eval `cat $meta`;        $self = eval `cat $meta`;
148      }      }
149    }    }
150    
151    return $self unless defined $self;    return unless defined $self;
152    $self->{mode} = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);    $self->{mode} = (exists $parm{mode})?$parm{mode}:(O_CREAT | O_RDWR);
153    
154      if ($self->{mode} & O_RDWR) {
155        # Locking: We do not care about read access since write is atomic.
156        my $lockmgr = LockFile::Simple->make(-autoclean => 1);
157        
158        # aquire a write lock
159        $self->{write_lock} = $lockmgr->lock("$dir/$name/write")
160          or die "Can't lock '$dir/$name/write'";
161      }
162    
163    $self;    $self;
164  }  }
165    
# Line 147  sub dispose { Line 188  sub dispose {
188    }    }
189    croak "No such database '$dir'" unless -e "$dir/meta";    croak "No such database '$dir'" unless -e "$dir/meta";
190    
191    rmtree($dir, 0, 1);    #warn "Running rmtree on dir[$dir]";
192      my $ret = rmtree($dir, 0, 1);
193      #warn "rmtree returned[$ret]";
194      $ret;
195  }  }
196    
197    
# Line 162  sub close { Line 206  sub close {
206    my $file = $self->{file};    my $file = $self->{file};
207    my $table;    my $table;
208    my $did_save;    my $did_save;
209      
210    for $table (values %{$self->{tables}}) {    for $table (values %{$self->{tables}}) {
211      $table->close if ref($table);      $table->close if ref($table);
212    }    }
213    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);    return 1 unless $self->{mode} & (O_RDWR | O_CREAT);
214    
215      my $lock = delete $self->{write_lock}; # Do not store lock objects
216    
217    if ($HAVE_DATA_DUMPER) {    if ($HAVE_DATA_DUMPER) {
218      my $fh   = new FileHandle "> $file/meta";      my $fh   = new FileHandle "> $file/meta.$$";
219      if ($fh) {      if ($fh) {
220        my $dumper = new Data::Dumper [$self],['self'];        my $dumper = new Data::Dumper [$self],['self'];
221        $fh->print('my ');        $fh->print('my ');
222        $fh->print($dumper->Dumpxs);        $fh->print($dumper->Dumpxs);
223        $fh->close;        $fh->close;
224        $did_save = 1;        $did_save = rename "$file/meta.$$", "$file/meta";
225      } else {      } else {
226        croak "Could not open '$file/meta' for writing: $!";        croak "Could not open '$file/meta' for writing: $!";
227        return unless $HAVE_STORABLE;        # never reached: return unless $HAVE_STORABLE;
228      }      }
229    }    }
230    
231    if ($HAVE_STORABLE) {    if ($HAVE_STORABLE) {
232      if (!eval {Storable::store($self, "$file/catalog")}) {      if (!eval {Storable::store($self, "$file/catalog.$$")}) {
233        fail ("Could not open '$file/catalog' for writing: $!");        unlink "$file/catalog.$$";
234        return unless $did_save;        croak "Could not open '$file/catalog.$$' for writing: $!";
235          # never reached: return unless $did_save;
236      } else {      } else {
237        $did_save++;        $did_save = rename "$file/catalog.$$", "$file/catalog";
238      }      }
239    }    }
240    
241      $lock->release;
242      
243    undef $_[0];    undef $_[0];
244    $did_save;    $did_save;
245  }  }
246    
247    
248  =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<);>
249    
250  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
251  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
252  returns a table handle (C<WAIT::Table::Handle>).  L<WAIT::Table> for which attributes are required. The method returns a
253    table handle (C<WAIT::Table::Handle>).
254    
255  =cut  =cut
256    
257  sub create_table {  sub create_table {
258    my $self = shift;    my $self = shift;
259    my %parm = @_;    my %parm = @_;
260    my $name = $parm{name} || return fail("No name specified");    my $name = $parm{name} or croak "create_table: No name specified";
261      my $attr = $parm{attr} or croak "create_table: No attributes specified";
262    my $file = $self->{file};    my $file = $self->{file};
263    
264    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);    croak "Database readonly" unless $self->{mode} & (O_CREAT | O_RDWR);
# Line 216  sub create_table { Line 268  sub create_table {
268    }    }
269    
270    if ($self->{uniqueatt}) {    if ($self->{uniqueatt}) {
271      for (@{$parm{attr}}) {      # attribute names must be uniqe      for (@$attr) {      # attribute names must be uniqe
272        if ($self->{attr}->{$_}) {        if ($self->{attr}->{$_}) {
273          return fail ("Attribute '$_' is not unique")          croak("Attribute '$_' is not unique")
274        }        }
275      }      }
276    }    }
# Line 232  sub create_table { Line 284  sub create_table {
284    
285    if ($self->{uniqueatt}) {    if ($self->{uniqueatt}) {
286      # remember table name for each attribute      # remember table name for each attribute
287      map ($self->{attr}->{$_} = $name, @{$parm{attr}});      map ($self->{attr}->{$_} = $name, @$attr);
288    }    }
289    WAIT::Table::Handle->new($self, $name);    WAIT::Table::Handle->new($self, $name);
290  }  }
291    
292    
293  =head2 <$db-E<gt>table name =E<gt>> I<tname>C<;>  =head2 C<$db-E<gt>table(name =E<gt>> I<tname>C<);>
294    
295  Open a new table with name I<tname>. The function  Open a new table with name I<tname>. The method
296  returns a table handle (C<WAIT::Table::Handle).  returns a table handle (C<WAIT::Table::Handle>).
297    
298  =cut  =cut
299    
# Line 271  sub table { Line 323  sub table {
323  }  }
324    
325    
326  =head2 C<$db-E<gt>drop  name =E<gt>> I<tname>C<;>  =head2 C<$db-E<gt>drop(name =E<gt>> I<tname>C<);>
327    
328  Drop the table named I<tname>. The table should be closed before  Drop the table named I<tname>. The table should be closed before
329  calling B<drop>.  calling B<drop>.
# Line 300  sub drop_table { Line 352  sub drop_table {
352  }  }
353    
354    
 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];  
       1;  
     } 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");  
   }  
 }  
   
   
355  1;  1;
356    
357    
Legend:
Removed from v.11  
changed lines
  Added in v.19
  ViewVC Help
Powered by ViewVC 1.1.26