diff options
author | Sergey Poznyakoff <gray@gnu.org> | 2018-12-13 11:52:57 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org> | 2018-12-13 11:52:57 +0200 |
commit | 820419c1cc238a86caf4e1955446700895201ac1 (patch) | |
tree | 399a3ead15804f392c34e60c3cc72003e9a36f6d | |
parent | f584673e3882ea30d0e36a2273c0733b96ee7317 (diff) | |
download | glacier-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.pm | 10 | ||||
-rw-r--r-- | lib/App/Glacier/DB.pm | 59 | ||||
-rw-r--r-- | lib/App/Glacier/DB/GDBM.pm | 21 | ||||
-rw-r--r-- | lib/App/Glacier/Directory.pm | 9 |
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; |