aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org>2018-12-13 11:52:57 +0200
committerSergey Poznyakoff <gray@gnu.org>2018-12-13 11:52:57 +0200
commit820419c1cc238a86caf4e1955446700895201ac1 (patch)
tree399a3ead15804f392c34e60c3cc72003e9a36f6d
parentf584673e3882ea30d0e36a2273c0733b96ee7317 (diff)
downloadglacier-820419c1cc238a86caf4e1955446700895201ac1.tar.gz
glacier-820419c1cc238a86caf4e1955446700895201ac1.tar.bz2
Rewrite Glacier::DB
* lib/App/Glacier/Command.pm (jobdb, directory): Change agruments to constructors. * lib/App/Glacier/DB.pm: Rewrite as a facade * lib/App/Glacier/DB/GDBM.pm: Rewrite as a backend for Glacier::DB * lib/App/Glacier/Directory.pm: Inherit from Glacier::DB
-rw-r--r--lib/App/Glacier/Command.pm10
-rw-r--r--lib/App/Glacier/DB.pm59
-rw-r--r--lib/App/Glacier/DB/GDBM.pm21
-rw-r--r--lib/App/Glacier/Directory.pm9
4 files changed, 66 insertions, 33 deletions
diff --git a/lib/App/Glacier/Command.pm b/lib/App/Glacier/Command.pm
index 5dd9eb8..0888b4b 100644
--- a/lib/App/Glacier/Command.pm
+++ b/lib/App/Glacier/Command.pm
@@ -11,7 +11,7 @@ use App::Glacier::EclatCreds;
use App::Glacier::Config;
use Net::Amazon::Glacier;
use App::Glacier::HttpCatch;
-use App::Glacier::DB::GDBM;
+use App::Glacier::DB;
use App::Glacier::Timestamp;
use App::Glacier::Directory;
@@ -187,8 +187,9 @@ sub jobdb {
unless ($self->{_jobdb}) {
my $file = $self->cfget(qw(database job file));
$self->touchdir(dirname($file));
- $self->{_jobdb} = new App::Glacier::DB::GDBM(
- $file,
+ $self->{_jobdb} = new App::Glacier::DB(
+ 'GDBM',
+ filename => $file,
encoding => 'json',
mode => $self->cfget(qw(database job mode))
);
@@ -227,7 +228,8 @@ sub directory {
$self->touchdir($self->cfget(qw(database inv directory)));
$self->{_dir}{$vault_name} =
new App::Glacier::Directory(
- $file,
+ 'GDBM',
+ filename => $file,
encoding => 'json',
mode => $self->cfget(qw(database inv mode)),
ttl => $self->cfget(qw(database inv ttl))
diff --git a/lib/App/Glacier/DB.pm b/lib/App/Glacier/DB.pm
index 3f16280..536ef81 100644
--- a/lib/App/Glacier/DB.pm
+++ b/lib/App/Glacier/DB.pm
@@ -1,12 +1,10 @@
package App::Glacier::DB;
use strict;
use warnings;
-require Exporter;
-use parent 'Exporter';
use JSON;
-use Storable;
use Carp;
use App::Glacier::Timestamp;
+use parent 'Exporter';
use constant {
ENCODE => 0,
@@ -32,28 +30,41 @@ my %transcode = (
);
sub new {
- my $class = shift;
- local %_ = @_;
+ my ($class, $backend, %opts) = @_;
my $v;
my $self = bless { }, $class;
- if ($v = delete $_{encoding}) {
+ if ($v = delete $opts{encoding}) {
croak "unsupported encoding $v"
unless exists $transcode{$v};
$self->{_encode} = $transcode{$v}[ENCODE];
$self->{_decode} = $transcode{$v}[DECODE];
}
- if (keys(%_)) {
- croak "unrecognized parameters: ".join(', ', keys(%_));
+ my $modname = __PACKAGE__ . '::' . $backend;
+ my $modpath = $modname;
+ $modpath =~ s{::}{/}g;
+ $modpath .= '.pm';
+
+ eval {
+ require $modpath;
+ $self->{_backend} = $modname->new(%opts);
+ };
+ if ($@) {
+ if ($@ =~ /Can't locate $modpath/) {
+ croak "unknown backend: $backend";
+ }
+ croak $@;
}
return $self;
}
+sub backend { shift->{_backend} }
+
sub decode {
my ($self, $val) = @_;
- return $val unless defined($self->{_decode});
+ return $val unless $val && defined($self->{_decode});
# This extra assignment is necessary to avoid the
# "attempt to copy freed scalar" panic (reported at least for Perl
# 5.18.2), which is apparently due to context mismatch.
@@ -67,6 +78,32 @@ sub encode {
return &{$self->{_encode}}($val);
}
-1;
+sub retrieve {
+ my ($self, $key) = @_;
+ return $self->decode($self->backend->retrieve($key));
+}
+
+sub store {
+ my ($self, $key, $val) = @_;
+ return $self->backend->store($key, $self->encode($val));
+}
-
+sub foreach {
+ my ($self, $code) = @_;
+ croak "argument must be a CODE" unless ref($code) eq 'CODE';
+ $self->backend->foreach(sub {
+ my ($key, $val) = @_;
+ &{$code}($key, $self->decode($val));
+ });
+}
+
+our $AUTOLOAD;
+
+sub AUTOLOAD {
+ my $self = shift;
+ (my $meth = $AUTOLOAD) =~ s/.*:://;
+
+ $self->backend->${\$meth}(@_);
+}
+
+1;
diff --git a/lib/App/Glacier/DB/GDBM.pm b/lib/App/Glacier/DB/GDBM.pm
index 24a4057..d485ce3 100644
--- a/lib/App/Glacier/DB/GDBM.pm
+++ b/lib/App/Glacier/DB/GDBM.pm
@@ -1,22 +1,17 @@
package App::Glacier::DB::GDBM;
-require App::Glacier::DB;
use strict;
use warnings;
-use parent qw(App::Glacier::DB);
use GDBM_File;
use Carp;
sub new {
my $class = shift;
- my $filename = shift;
local %_ = @_;
- my $mode = delete $_{mode} || 0644;
- my $retries = delete $_{retries} || 10;
- my $self = $class->SUPER::new(%_);
- $self->{_filename} = $filename;
- $self->{_mode} = $mode;
+ my $self = bless {}, $class;
+ $self->{_filename} = delete $_{filename} // croak "filename is required";
+ $self->{_mode} = delete $_{mode} || 0644;
+ $self->{_retries} = delete $_{retries} || 10;
$self->{_nref} = 0;
- $self->{_retries} = $retries;
$self->{_deleted} = [];
return $self;
}
@@ -61,15 +56,13 @@ sub retrieve {
my ($self, $key) = @_;
return $self->_tied(sub {
return undef unless exists $self->{_map}{$key};
- return $self->decode($self->{_map}{$key});
+ return $self->{_map}{$key};
});
}
sub store {
my ($self, $key, $val) = @_;
- return $self->_tied(sub {
- $self->{_map}{$key} = $self->encode($val);
- });
+ return $self->_tied(sub { $self->{_map}{$key} = $val });
}
sub delete {
@@ -87,7 +80,7 @@ sub foreach {
$self->_tied(sub {
push @{$self->{_deleted}}, [];
while (my ($key, $val) = each %{$self->{_map}}) {
- &{$code}($key, $self->decode($val));
+ &{$code}($key, $val);
}
foreach my $key (@{pop @{$self->{_deleted}}}) {
diff --git a/lib/App/Glacier/Directory.pm b/lib/App/Glacier/Directory.pm
index 7076814..03b9847 100644
--- a/lib/App/Glacier/Directory.pm
+++ b/lib/App/Glacier/Directory.pm
@@ -1,8 +1,7 @@
package App::Glacier::Directory;
use strict;
use warnings;
-require App::Glacier::DB::GDBM;
-use parent 'App::Glacier::DB::GDBM';
+use parent 'App::Glacier::DB';
use Carp;
our @EXPORT_OK = qw(DIR_UPTODATE DIR_PENDING DIR_OUTDATED);
@@ -11,9 +10,9 @@ our %EXPORT_TAGS = ( status => [ qw(DIR_UPTODATE DIR_PENDING DIR_OUTDATED) ] );
use constant DB_INFO_KEY => ';00INFO';
sub new {
- my ($class, $file, %opts) = @_;
+ my ($class, $backend, %opts) = @_;
my $ttl = delete $opts{ttl};
- my $self = $class->SUPER::new($file, %opts);
+ my $self = $class->SUPER::new($backend, %opts);
$self->{_ttl} = $ttl;
return $self;
}
@@ -152,3 +151,5 @@ sub status {
}
return DIR_UPTODATE;
}
+
+1;

Return to:

Send suggestions and report system problems to the System administrator.