[libcatmandu-perl] 16/30: Adding default_options and tests for FileStore
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 621f4768441288c3ef50301ef19ef639d015d60d
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Mon Oct 23 10:53:04 2017 +0200
Adding default_options and tests for FileStore
---
Build.PL | 2 +-
lib/Catmandu/FileStore.pm | 50 ++++++++++++-----------
t/Catmandu-FileStore.t | 102 ++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 130 insertions(+), 24 deletions(-)
diff --git a/Build.PL b/Build.PL
index 8828940..51a90ef 100644
--- a/Build.PL
+++ b/Build.PL
@@ -15,7 +15,7 @@ my %module_build_args = (
},
"dist_abstract" => "a data toolkit",
"dist_author" => [
- "Nicolas Steenlant, C<< <nicolas.steenlant at ugent.be> >>"
+ "Nicolas Steenlant <nicolas.steenlant\@ugent.be>"
],
"dist_name" => "Catmandu",
"dist_version" => "1.0606",
diff --git a/lib/Catmandu/FileStore.pm b/lib/Catmandu/FileStore.pm
index 128aa15..0671880 100644
--- a/lib/Catmandu/FileStore.pm
+++ b/lib/Catmandu/FileStore.pm
@@ -19,25 +19,26 @@ sub _build_default_bag {
sub _build_index {
my ($self) = @_;
-
+ my $name = $self->index_bag;
my $inst;
try {
+ my $opts = { store => $self , name => $name };
+ my $default_opts = $self->default_options;
+ my $bag_opts = $self->bag_options->{$name} //= {};
+ $opts = {%$default_opts, %$bag_opts, %$opts};
+
my $pkg = Catmandu::Util::require_package($self->index_class);
my $index_name = $self->index_bag;
- if (my $options = $self->bag_options->{$index_name}) {
- $options = {%$options};
-
- if (my $plugins = delete $options->{plugins}) {
- $pkg = $pkg->with_plugins($plugins);
- }
+ my $default_plugins = $self->default_plugins;
+ my $plugins = delete($opts->{plugins}) // [];
- $inst = $pkg->new(%$options, store => $self, name => $index_name);
- }
- else {
- $inst = $pkg->new(store => $self, name => $index_name);
+ if (@$default_plugins || @$plugins) {
+ $pkg = $pkg->with_plugins(@$default_plugins, @$plugins);
}
+
+ $inst = $pkg->new(%$opts);
}
catch {
$self->log->warn(
@@ -50,25 +51,28 @@ sub _build_index {
sub bag {
my $self = shift;
my $name = shift // $self->index_bag;
- my $pkg = $self->index_class;
my $index_name = $self->index_bag;
+ # Return the index when requested
if ($name eq $index_name) {
$self->index;
}
+ # Otherwise load the container for files
elsif ($self->index->exists($name)) {
- $pkg = Catmandu::Util::require_package($self->bag_class);
-
- if (my $options = $self->bag_options->{$name}) {
- $options = {%$options};
- if (my $plugins = delete $options->{plugins}) {
- $pkg = $pkg->with_plugins($plugins);
- }
- $pkg->new(%$options, store => $self, name => $name);
- }
- else {
- $pkg->new(store => $self, name => $name);
+ my $opts = { store => $self , name => $name };
+ my $default_opts = $self->default_options;
+ my $bag_opts = $self->bag_options->{$name} //= {};
+ $opts = {%$default_opts, %$bag_opts, %$opts};
+ my $pkg = Catmandu::Util::require_package(delete($opts->{class}) // $self->bag_class);
+
+ my $default_plugins = $self->default_plugins;
+ my $plugins = delete($opts->{plugins}) // [];
+
+ if (@$default_plugins || @$plugins) {
+ $pkg = $pkg->with_plugins(@$default_plugins, @$plugins);
}
+
+ $pkg->new(%$opts);
}
else {
Catmandu::Error->throw("no bag `$name` exists");
diff --git a/t/Catmandu-FileStore.t b/t/Catmandu-FileStore.t
index 5286570..0b1232a 100644
--- a/t/Catmandu-FileStore.t
+++ b/t/Catmandu-FileStore.t
@@ -13,4 +13,106 @@ BEGIN {
require_ok $pkg;
+{
+ package T::Store;
+ use Moo;
+ with $pkg;
+
+ package T::Store::Index;
+ use Moo;
+ with 'Catmandu::Bag';
+ with 'Catmandu::FileBag';
+
+ sub generator { }
+ sub add { }
+ sub get { }
+ sub delete { }
+ sub delete_all { }
+
+ package T::Store::Bag;
+ use Moo;
+ with 'Catmandu::Bag';
+ with 'Catmandu::FileBag';
+
+ sub generator { }
+ sub add { }
+ sub get { }
+ sub delete { }
+ sub delete_all { }
+
+ package T::CustomIndexClass;
+ use Moo;
+ extends 'T::Store::Index';
+
+ has prop => (is => 'ro');
+
+ package T::CustomBagClass;
+ use Moo;
+ extends 'T::Store::Bag';
+
+ has prop => (is => 'ro');
+}
+
+note("create a new store");
+my $s = T::Store->new;
+can_ok $s, 'bag_class';
+can_ok $s, 'default_bag';
+can_ok $s, 'bag';
+can_ok $s, 'index';
+is $s->bag_class, 'T::Store::Bag';
+is $s->default_bag, 'index';
+
+note("create a custom store");
+$s = T::Store->new(bag_class => 'T::CustomBagClass', index_class => 'T::CustomIndexClass');
+is $s->bag_class, 'T::CustomBagClass';
+is $s->index_class, 'T::CustomIndexClass';
+
+my $b = $s->bag;
+isa_ok $b, $s->index_class;
+is $s->bag, $b;
+is $b->store, $s;
+is $b->name, 'index';
+
+throws_ok { $s->bag('foo') } 'Catmandu::Error';
+
+note("options");
+$s = T::Store->new(
+ index_class => 'T::CustomIndexClass' ,
+ bags => {index => {prop => 'val', store => 'junk', name => 'junk'}}
+);
+is $s->index->prop, 'val', "options are passed to bag";
+isnt $s->index->store, 'junk', "store can't be overriden";
+isnt $s->index->name, 'junk', "name can't be overriden";
+
+note("default options");
+$s = T::Store->new(
+ index_class => 'T::CustomIndexClass' ,
+ default_options => {prop => 'bar'},
+ bags => {index => {store => 'junk', name => 'junk'}}
+);
+is $s->index->prop, 'bar';
+
+$s = T::Store->new(
+ index_class => 'T::CustomIndexClass' ,
+ default_options => {prop => 'bar'},
+ bags => {index => {prop => 'baz', store => 'junk', name => 'junk'}}
+);
+is $s->index->prop, 'baz';
+
+note("plugins");
+$b = T::Store->new(bags => {index => {plugins => [qw(Datestamps)]}})
+ ->index;
+ok $b->does('Catmandu::Plugin::Datestamps'), 'apply plugins';
+
+$b = T::Store->new(default_plugins => [qw(Datestamps)])->index;
+ok $b->does('Catmandu::Plugin::Datestamps'), 'apply default plugins';
+
+$b = T::Store->new(
+ default_plugins => [qw(Datestamps)],
+ bags => {index => {plugins => [qw(Versioning)]}}
+)->index;
+ok $b->does('Catmandu::Plugin::Datestamps')
+ && $b->does('Catmandu::Plugin::Versioning'), 'prepend default plugins';
+
+
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