[libcatmandu-perl] 19/30: Adding pod
Jonas Smedegaard
dr at jones.dk
Tue Dec 19 11:10:13 UTC 2017
This is an automated email from the git hooks/post-receive script.
js pushed a commit to annotated tag debian/1.0700-1
in repository libcatmandu-perl.
commit dcd43119f3303967a38e0d1d62e2085fbc63f809
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Mon Oct 23 14:36:01 2017 +0200
Adding pod
---
lib/Catmandu/Cmd/stream.pm | 10 +++--
lib/Catmandu/FileBag.pm | 5 ++-
lib/Catmandu/FileStore.pm | 2 +-
lib/Catmandu/Plugin/Readonly.pm | 85 +++++++++++++++++++++++++-----------
lib/Catmandu/Store/File/Multi/Bag.pm | 4 +-
t/Catmandu-FileStore.t | 2 +-
t/Catmandu-Plugin-Readonly.t | 36 +++++----------
t/Catmandu-Store-File-Memory.t | 2 +-
t/Catmandu-Store-File-Simple.t | 2 +-
t/Catmandu-Store-Hash.t | 4 --
10 files changed, 87 insertions(+), 65 deletions(-)
diff --git a/lib/Catmandu/Cmd/stream.pm b/lib/Catmandu/Cmd/stream.pm
index 8215663..e83f3ed 100644
--- a/lib/Catmandu/Cmd/stream.pm
+++ b/lib/Catmandu/Cmd/stream.pm
@@ -62,11 +62,13 @@ sub upload_file {
my ($self, $store, $bag_name, $id_name, $filename) = @_;
unless ($store->bag->exists($bag_name)) {
- $store->bag->add({_id => $bag_name});
+ $store->bag->add({_id => $bag_name}) // return undef;
}
my $bag = $store->bag->files($bag_name);
+ return undef unless $bag;
+
my $io;
if (!defined($filename) || $filename eq '-') {
@@ -86,15 +88,17 @@ sub download_file {
my ($self, $store, $bag_name, $id_name, $filename) = @_;
unless ($store->bag->exists($bag_name)) {
- carp "No such bag `$bag_name`";
+ croak "No such bag `$bag_name`";
}
my $bag = $store->bag->files($bag_name);
+ return undef unless $bag;
+
my $file = $bag->get($id_name);
unless ($file) {
- carp "No such file `$id_name` in `$bag_name`";
+ croak "No such file `$id_name` in `$bag_name`";
}
my $io;
diff --git a/lib/Catmandu/FileBag.pm b/lib/Catmandu/FileBag.pm
index fd6b161..fab1a7b 100644
--- a/lib/Catmandu/FileBag.pm
+++ b/lib/Catmandu/FileBag.pm
@@ -4,7 +4,7 @@ our $VERSION = '1.0606';
use Catmandu::Sane;
use IO::String;
-use Catmandu::Util qw(:check);
+use Catmandu::Util qw(:is :check);
use Moo::Role;
use namespace::clean;
@@ -38,7 +38,8 @@ sub upload {
my ($self, $io, $id) = @_;
check_string($id);
check_invocant($io);
- $self->add({_id => $id, _stream => $io});
+
+ is_hash_ref $self->add({_id => $id, _stream => $io});
}
1;
diff --git a/lib/Catmandu/FileStore.pm b/lib/Catmandu/FileStore.pm
index 0671880..6c039f2 100644
--- a/lib/Catmandu/FileStore.pm
+++ b/lib/Catmandu/FileStore.pm
@@ -75,7 +75,7 @@ sub bag {
$pkg->new(%$opts);
}
else {
- Catmandu::Error->throw("no bag `$name` exists");
+ return undef;
}
}
diff --git a/lib/Catmandu/Plugin/Readonly.pm b/lib/Catmandu/Plugin/Readonly.pm
index 87480a1..5f85aa9 100644
--- a/lib/Catmandu/Plugin/Readonly.pm
+++ b/lib/Catmandu/Plugin/Readonly.pm
@@ -5,59 +5,92 @@ use MooX::Aliases;
use Package::Stash;
use namespace::clean;
-has readonly_throw_error => (is => 'ro' , default => sub { 0 });
-
sub BUILD {
my ($self) = @_;
my $name = ref($self->store);
- # Overwrite the drop method of the Catmandu::Store implementation
- my $stash = Package::Stash->new($name);
- $stash->add_symbol(
- '&drop' => sub {
- $self->log->warn("trying to drop a readonly store");
- Catmandu::NotImplemented->throw("$name is readonly")
- if $self->readonly_throw_error;
- 1;
- });
-}
+ if ($self->store->does('Catmandu::Droppable')) {
+ # Overwrite the drop method of the Catmandu::Store implementation
+ my $stash = Package::Stash->new($name);
+ $stash->add_symbol(
+ '&drop' => sub {
+ $self->log->warn("trying to drop a readonly store");
+ my $err = Catmandu::NotImplemented->new("$name is readonly");
+ return undef, $err;
+ });
+ }
+};
around add => sub {
my ($orig,$self,$data) = @_;
my $name = ref($self);
$self->log->warn("trying to add to readonly store");
- Catmandu::NotImplemented->throw("$name is readonly")
- if $self->readonly_throw_error;
- $data
+ my $err = Catmandu::NotImplemented->new("$name is readonly");
+ return undef, $err;
};
around delete => sub {
my ($orig,$self) = @_;
my $name = ref($self);
$self->log->warn("trying to delete from readonly store");
- Catmandu::NotImplemented->throw("$name is readonly")
- if $self->readonly_throw_error;
-
- 1;
+ my $err = Catmandu::NotImplemented->new("$name is readonly");
+ return undef, $err;
};
around delete_all => sub {
my ($orig,$self) = @_;
my $name = ref($self);
$self->log->warn("trying to delete_all on readonly store");
- Catmandu::NotImplemented->throw("$name is readonly")
- if $self->readonly_throw_error;
- 1;
+ my $err = Catmandu::NotImplemented->new("$name is readonly");
+ return undef, $err;
};
around drop => sub {
my ($orig,$self) = @_;
my $name = ref($self);
$self->log->warn("trying to drop a readonly store");
- Catmandu::NotImplemented->throw("$name is readonly")
- if $self->readonly_throw_error;
-
- 1;
+ my $err = Catmandu::NotImplemented->new("$name is readonly");
+ return undef, $err;
};
1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Catmandu::Plugin::Readonly - Make stores or bags read-only
+
+=head1 SYNOPSIS
+
+ $ cat catmandu.yml
+ ---
+ store:
+ test:
+ package: File::Simple
+ options:
+ default_plugins: [ 'Readonly']
+ root: t/data
+
+ # This will fail, no files can be added to the 'test' store
+ $ catmandu stream myfile.txt to test --bag 1 -id myfile.txt
+
+ # This command will succeed only if the 'test' database contains
+ # the 'sample.txt' file
+ # catmandu stream test --bag 3 --id sample.txt
+
+=head1 DESCRIPTION
+
+The Catmandu::Plugin::Readonly will transform a Catmandu::Store or a Catmandu::Bag
+in read-only mode: all writes, deletes and drops will be ignored.
+
+This command will work on L<Catmandu::Store> and L<Catmandu::FileStore>
+implementations.
+
+=head1 SEE ALSO
+
+L<Catmandu::Store>, L<Catmandu::Bag>
+
+=cut
diff --git a/lib/Catmandu/Store/File/Multi/Bag.pm b/lib/Catmandu/Store/File/Multi/Bag.pm
index 0071093..6c883df 100644
--- a/lib/Catmandu/Store/File/Multi/Bag.pm
+++ b/lib/Catmandu/Store/File/Multi/Bag.pm
@@ -24,7 +24,6 @@ sub upload {
my $bag = $store->bag($self->name);
next unless $bag;
if ($rewind) {
-
# Rewind the stream after first use...
Catmandu::BadVal->throw("IO stream needs to seekable")
unless $io->isa('IO::Seekable');
@@ -35,7 +34,8 @@ sub upload {
}
else {
my $bag = $store->bag($self->name);
- $bag->add({_id => $id}) if $bag;
+ next unless $bag;
+ $bag->add({_id => $id});
}
}
diff --git a/t/Catmandu-FileStore.t b/t/Catmandu-FileStore.t
index 0b1232a..39e4a00 100644
--- a/t/Catmandu-FileStore.t
+++ b/t/Catmandu-FileStore.t
@@ -73,7 +73,7 @@ is $s->bag, $b;
is $b->store, $s;
is $b->name, 'index';
-throws_ok { $s->bag('foo') } 'Catmandu::Error';
+ok ! $s->bag('foo') , 'unkown bag';
note("options");
$s = T::Store->new(
diff --git a/t/Catmandu-Plugin-Readonly.t b/t/Catmandu-Plugin-Readonly.t
index e70ca66..8ad13ed 100644
--- a/t/Catmandu-Plugin-Readonly.t
+++ b/t/Catmandu-Plugin-Readonly.t
@@ -22,36 +22,24 @@ my $store = Catmandu::Store::Hash->new(
ok $store->does('Catmandu::Store'),
'create Catmandu-Store with Readonly plugin';
-ok $store->bag->add({_id => '001', name => 'Penguin'}), 'store something';
+my ($ret,$err) = $store->bag->add({_id => '001', name => 'Penguin'});
-ok ! $store->bag->get('001'), 'didn\'t store anything';
+ok !defined($ret) , 'add returned undef';
+isa_ok $err, 'Catmandu::NotImplemented';
-ok $store->bag->delete('001'), 'delete something';
+($ret,$err) = $store->bag->get('001');
-ok $store->drop , 'drop database';
+ok !defined($ret) , 'get returned undef';
+ok !defined($err) , 'no error thrown';
-note("throw errors");
+($ret,$err) = $store->bag->delete('001');
-$store = Catmandu::Store::Hash->new(
- default_plugins => [qw(Readonly)] ,
- default_options => { readonly_throw_error => 1 }
-);
+ok !defined($ret) , 'delete returned undef';
+isa_ok $err, 'Catmandu::NotImplemented';
-ok $store->does('Catmandu::Store'),
- 'create Catmandu-Store with Readonly plugin';
-
-throws_ok {
- $store->bag->add({_id => '001', name => 'Penguin'})
-} 'Catmandu::NotImplemented' , 'store something';
-
-ok ! $store->bag->get('001');
-
-throws_ok {
- $store->bag->delete('001')
-} 'Catmandu::NotImplemented' , 'delete something';
+($ret,$err) = $store->drop;
-throws_ok {
- $store->drop
-} 'Catmandu::NotImplemented' , 'drop database';
+ok !defined($ret) , 'drop returned undef';
+isa_ok $err, 'Catmandu::NotImplemented';
done_testing;
diff --git a/t/Catmandu-Store-File-Memory.t b/t/Catmandu-Store-File-Memory.t
index 21cc64c..da5a78c 100644
--- a/t/Catmandu-Store-File-Memory.t
+++ b/t/Catmandu-Store-File-Memory.t
@@ -27,7 +27,7 @@ ok $bags , 'create memory store';
ok $bags->add({_id => '1234'}), 'adding `1234` bag';
-throws_ok {$store->bag('1235')} 'Catmandu::Error', 'bag(1235) doesnt exist';
+ok ! $store->bag('1235') , 'bag(1235) doesnt exist';
lives_ok {$store->bag('1234')} 'bag(1234) exists';
diff --git a/t/Catmandu-Store-File-Simple.t b/t/Catmandu-Store-File-Simple.t
index 69b6088..8929f0d 100644
--- a/t/Catmandu-Store-File-Simple.t
+++ b/t/Catmandu-Store-File-Simple.t
@@ -32,7 +32,7 @@ is $store->path_string('0001234'), 't/data2/000/001/234',
ok !$store->path_string('00000001234'), 'path_string(00000001234) fails';
-throws_ok {$store->bag('1235')} 'Catmandu::Error', 'bag(1235) doesnt exist';
+ok !$store->bag('1235'), 'bag(1235) doesnt exist';
lives_ok {$store->bag('1')} 'bag(1) exists';
diff --git a/t/Catmandu-Store-Hash.t b/t/Catmandu-Store-Hash.t
index aa7afd4..21cbb1d 100644
--- a/t/Catmandu-Store-Hash.t
+++ b/t/Catmandu-Store-Hash.t
@@ -69,8 +69,4 @@ is $bag2->count, 1, "Bags stay alive";
my $bag3 = $store->bag('foo');
ok !$bag3->get('123'), "foo doesnt have 123";
-ok $store->drop;
-
-use Data::Dumper;
-warn Dumper($store);
done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-perl.git
More information about the Pkg-perl-cvs-commits
mailing list