[libcatmandu-perl] 17/30: Adding readonly plugin

[Jonas Smedegaard]

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 85688af9b02e2bd35c2dac79d75ccbaea6e616de
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date:   Mon Oct 23 12:07:02 2017 +0200

    Adding readonly plugin
---
 lib/Catmandu/Plugin/Readonly.pm | 63 +++++++++++++++++++++++++++++++++++++++++
 t/Catmandu-Plugin-Readonly.t    | 57 +++++++++++++++++++++++++++++++++++++
 t/Catmandu-Store-Hash.t         |  4 +++
 3 files changed, 124 insertions(+)

diff --git a/lib/Catmandu/Plugin/Readonly.pm b/lib/Catmandu/Plugin/Readonly.pm
new file mode 100644
index 0000000..87480a1
--- /dev/null
+++ b/lib/Catmandu/Plugin/Readonly.pm
@@ -0,0 +1,63 @@
+package Catmandu::Plugin::Readonly;
+
+use Moo::Role;
+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;
+        });
+}
+
+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
+};
+
+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;
+};
+
+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;
+};
+
+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;
+};
+
+1;
diff --git a/t/Catmandu-Plugin-Readonly.t b/t/Catmandu-Plugin-Readonly.t
new file mode 100644
index 0000000..e70ca66
--- /dev/null
+++ b/t/Catmandu-Plugin-Readonly.t
@@ -0,0 +1,57 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Catmandu::Store::Hash;
+
+my $pkg;
+
+BEGIN {
+    $pkg = 'Catmandu::Plugin::Readonly';
+    use_ok $pkg;
+}
+require_ok $pkg;
+
+note("stores");
+
+my $store = Catmandu::Store::Hash->new(
+    bags => {data => {plugins => [qw(Readonly)]}});
+
+ok $store->does('Catmandu::Store'),
+    'create Catmandu-Store with Readonly plugin';
+
+ok $store->bag->add({_id => '001', name => 'Penguin'}), 'store something';
+
+ok ! $store->bag->get('001'), 'didn\'t store anything';
+
+ok $store->bag->delete('001'), 'delete something';
+
+ok $store->drop , 'drop database';
+
+note("throw errors");
+
+$store = Catmandu::Store::Hash->new(
+    default_plugins => [qw(Readonly)] ,
+    default_options => { readonly_throw_error => 1 }
+);
+
+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';
+
+throws_ok {
+    $store->drop
+} 'Catmandu::NotImplemented' , 'drop database';
+
+done_testing;
diff --git a/t/Catmandu-Store-Hash.t b/t/Catmandu-Store-Hash.t
index 21cbb1d..aa7afd4 100644
--- a/t/Catmandu-Store-Hash.t
+++ b/t/Catmandu-Store-Hash.t
@@ -69,4 +69,8 @@ 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