From: octo Date: Tue, 12 Apr 2005 15:33:29 +0000 (+0000) Subject: Gdbm renamed to Dbm X-Git-Tag: Release-0.8.0~20^2~13 X-Git-Url: https://git.verplant.org/?a=commitdiff_plain;h=8aeddb3f4c112523a7215da8cacdf9af83576ecf;p=onis.git Gdbm renamed to Dbm --- diff --git a/lib/Onis/Data/Persistent/Dbm.pm b/lib/Onis/Data/Persistent/Dbm.pm new file mode 100644 index 0000000..ba3cb76 --- /dev/null +++ b/lib/Onis/Data/Persistent/Dbm.pm @@ -0,0 +1,250 @@ +package Onis::Data::Persistent::Dbm; + +use strict; +use warnings; + +use Carp qw(carp confess); +use AnyDBM_File; + +use Onis::Config (qw(get_config)); + +=head1 NAME + +Onis::Data::Persistent::Dbm - Storage backend using AnyDBM_File. + +=head1 DESCRIPTION + +Storage backend that uses DBM files for storing data permanently. + +=head1 CONFIGURATION OPTIONS + +=over 4 + +=item B: IdirE> + +Directory in which the GDBM-files are kept. + +=back + +=cut + +our $DBMDirectory = get_config ('gdbm_directory') || 'var'; +$DBMDirectory =~ s#/$##g; + +if (!$DBMDirectory or !-d $DBMDirectory) +{ + print STDERR <{'data'} = tie (%hash, 'AnyDBM_File', $filename, O_CREAT|O_RDWR, 0664); + $obj->{'key'} = $key; + $obj->{'fields'} = [@fields]; + $obj->{'num_fields'} = scalar (@fields); + $obj->{'field_index'} = {map { $_ => $i++ } (@fields)}; + $obj->{'id'} = $id; + $obj->{'cache'} = {}; + + if ($::DEBUG & 0x0200) + { + my $prefix = __FILE__ . ': '; + my $dbg = Data::Dumper->Dump ([$obj], ['obj']); + $dbg =~ s/^/$prefix/mg; chomp ($dbg); + print STDOUT $/, $dbg; + } + + return (bless ($obj, $pkg)); +} + +sub put +{ + my $obj = shift; + my $key = shift; + my @fields = @_; + my $db = $obj->{'data'}; + + if ($obj->{'num_fields'} != scalar (@fields)) + { + my $id = $obj->{'id'}; + carp ("Number of fields do not match ($id)."); + return; + } + + if ($::DEBUG & 0x0200) + { + print STDOUT $/, __FILE__, ': PUT(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @fields) . ')'; + } + + $obj->{'cache'}{$key} = [@fields]; +} + +sub get +{ + my $obj = shift; + my $key = shift; + my $val; + my @ret; + my $db = $obj->{'data'}; + + if (!exists ($obj->{'cache'}{$key})) + { + if ($db->get ($key, $val)) + { + $obj->{'cache'}{$key} = undef; + } + else + { + $obj->{'cache'}{$key} = [split ($Alarm, $val)]; + } + } + + if (!defined ($obj->{'cache'}{$key})) + { + return (qw()); + } + else + { + @ret = @{$obj->{'cache'}{$key}}; + } + + if ($::DEBUG & 0x0200) + { + print STDOUT $/, __FILE__, ': GET(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @ret) . ')'; + } + + return (@ret); +} + +sub keys +{ + my $obj = shift; + my @fields = @_; + my @field_indizes = (); + my $db = $obj->{'data'}; + my $key; + my $val; + + for ($db->seq ($key, $val, R_FIRST); $db->seq ($key, $val, R_NEXT) == 0;) + { + next if (defined ($obj->{'cache'}{$key})); + $obj->{'cache'}{$key} = [split ($Alarm, $val)]; + } + + if (!@fields) + { + return (keys %{$obj->{'cache'}}); + } + + for (@fields) + { + my $field = $_; + if (!defined ($obj->{'field_index'}{$field})) + { + my $id = $obj->{'id'}; + print STDERR $/, __FILE__, ": $field is not a valid field ($id)."; + next; + } + push (@field_indizes, $obj->{'field_index'}{$field}); + } + + return (sort + sub { + for (@field_indizes) + { + my $d = $obj->{'cache'}{$a}[$_] cmp $obj->{'cache'}{$b}[$_]; + return ($d) if ($d); + } + }, @keys); +} + +sub del +{ + my $obj = shift; + my $key = shift; + my $db = $obj->{'data'}; + + if (exists ($obj->{'cache'}{$key})) + { + if (defined ($obj->{'cache'}{$key})) + { + $db->del ($key); + $obj->{'cache'}{$key} = undef; + } + # It's known that the key doesn't exist.. + } + else + { + $db->del ($key); + $obj->{'cache'}{$key} = undef; + } +} + +sub sync +{ + my $obj = shift; + my $db = $obj->{'data'}; + + for (keys %{$obj->{'cache'}}) + { + my $key = $_; + my $val = join ($Alarm, @{$obj->{'cache'}{$key}}); + + $db->put ($key, $val); + delete ($obj->{'cache'}{$key}); + } + + $db->sync (); +} + +END +{ + for (keys (%Objects)) + { + my $obj = $_; + $obj->sync (); + } +} + +=head1 AUTHOR + +Florian octo Forster, L + +=cut diff --git a/lib/Onis/Data/Persistent/Gdbm.pm b/lib/Onis/Data/Persistent/Gdbm.pm deleted file mode 100644 index ba3cb76..0000000 --- a/lib/Onis/Data/Persistent/Gdbm.pm +++ /dev/null @@ -1,250 +0,0 @@ -package Onis::Data::Persistent::Dbm; - -use strict; -use warnings; - -use Carp qw(carp confess); -use AnyDBM_File; - -use Onis::Config (qw(get_config)); - -=head1 NAME - -Onis::Data::Persistent::Dbm - Storage backend using AnyDBM_File. - -=head1 DESCRIPTION - -Storage backend that uses DBM files for storing data permanently. - -=head1 CONFIGURATION OPTIONS - -=over 4 - -=item B: IdirE> - -Directory in which the GDBM-files are kept. - -=back - -=cut - -our $DBMDirectory = get_config ('gdbm_directory') || 'var'; -$DBMDirectory =~ s#/$##g; - -if (!$DBMDirectory or !-d $DBMDirectory) -{ - print STDERR <{'data'} = tie (%hash, 'AnyDBM_File', $filename, O_CREAT|O_RDWR, 0664); - $obj->{'key'} = $key; - $obj->{'fields'} = [@fields]; - $obj->{'num_fields'} = scalar (@fields); - $obj->{'field_index'} = {map { $_ => $i++ } (@fields)}; - $obj->{'id'} = $id; - $obj->{'cache'} = {}; - - if ($::DEBUG & 0x0200) - { - my $prefix = __FILE__ . ': '; - my $dbg = Data::Dumper->Dump ([$obj], ['obj']); - $dbg =~ s/^/$prefix/mg; chomp ($dbg); - print STDOUT $/, $dbg; - } - - return (bless ($obj, $pkg)); -} - -sub put -{ - my $obj = shift; - my $key = shift; - my @fields = @_; - my $db = $obj->{'data'}; - - if ($obj->{'num_fields'} != scalar (@fields)) - { - my $id = $obj->{'id'}; - carp ("Number of fields do not match ($id)."); - return; - } - - if ($::DEBUG & 0x0200) - { - print STDOUT $/, __FILE__, ': PUT(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @fields) . ')'; - } - - $obj->{'cache'}{$key} = [@fields]; -} - -sub get -{ - my $obj = shift; - my $key = shift; - my $val; - my @ret; - my $db = $obj->{'data'}; - - if (!exists ($obj->{'cache'}{$key})) - { - if ($db->get ($key, $val)) - { - $obj->{'cache'}{$key} = undef; - } - else - { - $obj->{'cache'}{$key} = [split ($Alarm, $val)]; - } - } - - if (!defined ($obj->{'cache'}{$key})) - { - return (qw()); - } - else - { - @ret = @{$obj->{'cache'}{$key}}; - } - - if ($::DEBUG & 0x0200) - { - print STDOUT $/, __FILE__, ': GET(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @ret) . ')'; - } - - return (@ret); -} - -sub keys -{ - my $obj = shift; - my @fields = @_; - my @field_indizes = (); - my $db = $obj->{'data'}; - my $key; - my $val; - - for ($db->seq ($key, $val, R_FIRST); $db->seq ($key, $val, R_NEXT) == 0;) - { - next if (defined ($obj->{'cache'}{$key})); - $obj->{'cache'}{$key} = [split ($Alarm, $val)]; - } - - if (!@fields) - { - return (keys %{$obj->{'cache'}}); - } - - for (@fields) - { - my $field = $_; - if (!defined ($obj->{'field_index'}{$field})) - { - my $id = $obj->{'id'}; - print STDERR $/, __FILE__, ": $field is not a valid field ($id)."; - next; - } - push (@field_indizes, $obj->{'field_index'}{$field}); - } - - return (sort - sub { - for (@field_indizes) - { - my $d = $obj->{'cache'}{$a}[$_] cmp $obj->{'cache'}{$b}[$_]; - return ($d) if ($d); - } - }, @keys); -} - -sub del -{ - my $obj = shift; - my $key = shift; - my $db = $obj->{'data'}; - - if (exists ($obj->{'cache'}{$key})) - { - if (defined ($obj->{'cache'}{$key})) - { - $db->del ($key); - $obj->{'cache'}{$key} = undef; - } - # It's known that the key doesn't exist.. - } - else - { - $db->del ($key); - $obj->{'cache'}{$key} = undef; - } -} - -sub sync -{ - my $obj = shift; - my $db = $obj->{'data'}; - - for (keys %{$obj->{'cache'}}) - { - my $key = $_; - my $val = join ($Alarm, @{$obj->{'cache'}{$key}}); - - $db->put ($key, $val); - delete ($obj->{'cache'}{$key}); - } - - $db->sync (); -} - -END -{ - for (keys (%Objects)) - { - my $obj = $_; - $obj->sync (); - } -} - -=head1 AUTHOR - -Florian octo Forster, L - -=cut