[libcatmandu-perl] 22/30: Making File::Store add() method behaving more like Store add()
Jonas Smedegaard
dr at jones.dk
Tue Dec 19 11:10:14 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 79f92140e21a173030df45b90f1d614d6787693c
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Mon Nov 6 14:06:50 2017 +0100
Making File::Store add() method behaving more like Store add()
---
lib/Catmandu/FileBag.pm | 15 ++++-
lib/Catmandu/Store/File/Memory/Bag.pm | 33 +++++-----
lib/Catmandu/Store/File/Multi/Bag.pm | 72 ++++++++++++++++++----
lib/Catmandu/Store/File/Simple/Bag.pm | 4 ++
lib/Catmandu/Store/Multi/Bag.pm | 10 +++
t/Catmandu-Store-File-Memory-Bag.t | 20 +++++-
t/Catmandu-Store-File-Multi-Bag.t | 111 ++++++++++++++++++++++++++++++++++
t/Catmandu-Store-File-Multi-Index.t | 81 +++++++++++++++++++++++++
t/Catmandu-Store-File-Simple-Bag.t | 27 +++++++--
9 files changed, 333 insertions(+), 40 deletions(-)
diff --git a/lib/Catmandu/FileBag.pm b/lib/Catmandu/FileBag.pm
index e32857e..3bead5f 100644
--- a/lib/Catmandu/FileBag.pm
+++ b/lib/Catmandu/FileBag.pm
@@ -39,9 +39,20 @@ sub upload {
check_string($id);
check_invocant($io);
- $self->add({_id => $id, _stream => $io});
+ my $file = {_id => $id, _stream => $io};
- my $file = $self->get($id);
+ $self->add($file);
+
+ # The add() method of FileBags should inline data the passed $file with
+ # file metadata. Use a get($id) when this inline update wasn't implemented
+ # by the Bag.
+ if (exists $file->{size}) {
+ # all ok
+ }
+ else {
+ $self->log->warn("$self doesn't inline update \$data in add(\$data) method");
+ $file = $self->get($id);
+ }
if (!defined($file)) {
return 0;
diff --git a/lib/Catmandu/Store/File/Memory/Bag.pm b/lib/Catmandu/Store/File/Memory/Bag.pm
index 13af184..a94fff6 100644
--- a/lib/Catmandu/Store/File/Memory/Bag.pm
+++ b/lib/Catmandu/Store/File/Memory/Bag.pm
@@ -4,8 +4,10 @@ our $VERSION = '1.0606';
use Catmandu::Sane;
use Moo;
+use Clone 'clone';
use Catmandu::Util qw(content_type);
use namespace::clean;
+require bytes;
with 'Catmandu::Bag';
with 'Catmandu::FileBag';
@@ -58,24 +60,23 @@ sub add {
my $str = Catmandu::Util::read_io($io);
- $self->store->_files->{$name}->{$id} = {
- _id => $id,
- size => length $str,
- md5 => '',
- content_type => content_type($id),
- created => time,
- modified => time,
- _stream => sub {
- my $io = $_[0];
-
- Catmandu::Error->throw("no io defined or not writable")
- unless defined($io);
-
- $io->write($str);
- },
- %$data
+ $data->{_id} = $id;
+ $data->{size} = bytes::length($str);
+ $data->{md5} = '';
+ $data->{content_type} = content_type($id);
+ $data->{created} = time;
+ $data->{modified} = time;
+ $data->{_stream} = sub {
+ my $io = $_[0];
+
+ Catmandu::Error->throw("no io defined or not writable")
+ unless defined($io);
+
+ $io->write($str);
};
+ $self->store->_files->{$name}->{$id} = clone($data);
+
1;
}
diff --git a/lib/Catmandu/Store/File/Multi/Bag.pm b/lib/Catmandu/Store/File/Multi/Bag.pm
index f71dcba..75b0d1e 100644
--- a/lib/Catmandu/Store/File/Multi/Bag.pm
+++ b/lib/Catmandu/Store/File/Multi/Bag.pm
@@ -13,6 +13,61 @@ extends 'Catmandu::Store::Multi::Bag';
with 'Catmandu::FileBag';
+sub add {
+ my ($self, $data) = @_;
+
+ # Overwrite the Multi::Bag add an store each stream in the backend store
+
+ my $rewind = 0;
+ my $id = $data->{_id};
+ my $stream = $data->{_stream};
+
+ my $new_data = {};
+
+ # By default try to add the data to all the stores
+ for my $store (@{$self->store->stores}) {
+ 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 $stream->isa('IO::Seekable');
+ $stream->seek(0, 0);
+ }
+
+ my $file = {_id => $id , _stream => $stream};
+ $bag->add($file);
+
+ for (keys %$file) {
+ $new_data->{$_} = $file->{$_} unless exists $new_data->{$_};
+ }
+
+ $rewind = 1;
+ }
+
+ # Check if the returned record contains the minimum required fields
+ # (otherwise we have a File::Store implementation that doesn't inline
+ # update the passed $data in add($data))
+ if (exists $new_data->{size} && exists $new_data->{created} &&
+ exists $new_data->{modified}) {
+ # all is ok
+ }
+ else {
+ $self->log->warn("$self doesn't inline update \$data in add(\$data) method");
+ $new_data = $self->get($id);
+ }
+
+ if ($new_data) {
+ $data->{$_} = $new_data->{$_} for keys %$new_data;
+ }
+ else {
+ $self->log->error("can't find $id in $self!");
+ }
+
+ 1;
+}
+
sub upload {
my ($self, $io, $id) = @_;
@@ -21,6 +76,8 @@ sub upload {
my $rewind;
+ my $bytes = 0;
+
for my $store (@{$self->store->stores}) {
if ($store->does('Catmandu::FileStore')) {
my $bag = $store->bag($self->name);
@@ -31,7 +88,7 @@ sub upload {
unless $io->isa('IO::Seekable');
$io->seek(0, 0);
}
- $store->bag($self->name)->upload($io, $id) ||
+ $bytes = $store->bag($self->name)->upload($io, $id) ||
$self->log->error("failed to upload $id to " . $self->name);
$rewind = 1;
}
@@ -42,18 +99,7 @@ sub upload {
}
}
- my $file = $self->get($id);
-
- if (!defined($file)) {
- return 0;
- }
- elsif (is_hash_ref($file)) {
- return $file->{size};
- }
- else {
- $self->log->error("expecting a HASH but got `$file'");
- return 0;
- }
+ return $bytes;
}
1;
diff --git a/lib/Catmandu/Store/File/Simple/Bag.pm b/lib/Catmandu/Store/File/Simple/Bag.pm
index d04151a..8cb4650 100644
--- a/lib/Catmandu/Store/File/Simple/Bag.pm
+++ b/lib/Catmandu/Store/File/Simple/Bag.pm
@@ -125,6 +125,10 @@ sub add {
Catmandu::Util::write_file($file, $io) || Catmandu::Error->throw("failed to write file : $!");
}
+ my $new_data = $self->get($id);
+
+ $data->{$_} = $new_data->{$_} for keys %$new_data;
+
1;
}
diff --git a/lib/Catmandu/Store/Multi/Bag.pm b/lib/Catmandu/Store/Multi/Bag.pm
index 2ec49a8..300a65c 100644
--- a/lib/Catmandu/Store/Multi/Bag.pm
+++ b/lib/Catmandu/Store/Multi/Bag.pm
@@ -61,6 +61,8 @@ sub add {
my $bag = $store->bag($self->name);
$bag->add($data) if $bag;
}
+
+ 1;
}
sub delete {
@@ -72,6 +74,8 @@ sub delete {
my $bag = $store->bag($self->name);
$bag->delete($id) if $bag;
}
+
+ 1;
}
sub delete_all {
@@ -83,6 +87,8 @@ sub delete_all {
my $bag = $store->bag($self->name);
$bag->delete_all if $bag;
}
+
+ 1;
}
sub drop {
@@ -94,6 +100,8 @@ sub drop {
my $bag = $store->bag($self->name);
$bag->drop if $bag && $bag->does('Catmandu::Droppable');
}
+
+ 1;
}
sub commit {
@@ -105,6 +113,8 @@ sub commit {
my $bag = $store->bag($self->name);
$bag->commit if $bag;
}
+
+ 1;
}
1;
diff --git a/t/Catmandu-Store-File-Memory-Bag.t b/t/Catmandu-Store-File-Memory-Bag.t
index 3778af4..0551268 100644
--- a/t/Catmandu-Store-File-Memory-Bag.t
+++ b/t/Catmandu-Store-File-Memory-Bag.t
@@ -31,9 +31,23 @@ ok $bag , 'got bag(1234)';
note("add");
{
- ok $bag->upload(io('t/data2/000/000/001/test.txt'), 'test1.txt');
- ok $bag->upload(io('t/data2/000/000/002/test.txt'), 'test2.txt');
- ok $bag->upload(io('t/data2/000/000/003/test.txt'), 'test3.txt');
+ my $n1 = $bag->upload(io('t/data2/000/000/001/test.txt'), 'test1.txt');
+
+ ok $n1 , 'upload test1.txt';
+
+ is $n1 , 16 , '16 bytes';
+
+ my $n2 = $bag->upload(io('t/data2/000/000/002/test.txt'), 'test2.txt');
+
+ ok $n2 , 'upload test2.txt';
+
+ is $n2 , 6 , '6 bytes';
+
+ my $n3 = $bag->upload(io('t/data2/000/000/003/test.txt'), 'test3.txt');
+
+ ok $n3 , 'upload test3.txt';
+
+ is $n3 , 6 , '6 bytes';
}
note("list");
diff --git a/t/Catmandu-Store-File-Multi-Bag.t b/t/Catmandu-Store-File-Multi-Bag.t
index 4518af1..0ef7a41 100644
--- a/t/Catmandu-Store-File-Multi-Bag.t
+++ b/t/Catmandu-Store-File-Multi-Bag.t
@@ -3,6 +3,9 @@ use strict;
use warnings;
use Test::More;
use Test::Exception;
+use Catmandu::Store::File::Simple;
+use Catmandu::Store::File::Multi;
+use utf8;
my $pkg;
@@ -13,4 +16,112 @@ BEGIN {
require_ok $pkg;
+my $stores = [
+ Catmandu::Store::File::Simple->new(root => 't/data', keysize => 9),
+ Catmandu::Store::File::Simple->new(root => 't/data3', keysize => 9),
+];
+
+my $store = Catmandu::Store::File::Multi->new(stores => $stores);
+my $index = $store->index;
+
+ok $store , 'got a store';
+ok $index , 'got an index';
+
+ok $index->add({_id => 1234}), 'adding bag `1234`';
+
+my $bag = $store->bag('1234');
+
+ok $bag , 'got bag(1234)';
+
+note("add");
+{
+ my $n1 = $bag->upload(IO::File->new('t/data2/000/000/001/test.txt'),'test1.txt');
+
+ ok $n1 , 'upload test1.txt';
+
+ is $n1 , 16 , '16 bytes';
+
+ ok -f 't/data/000/001/234/test1.txt', 'test1.txt exists';
+
+ ok -f 't/data3/000/001/234/test1.txt', 'test1.txt exists';
+
+ my $n2 = $bag->upload(IO::File->new('t/data2/000/000/002/test.txt'), 'test2.txt');
+
+ ok $n2 , 'upload test2.txt';
+
+ is $n2 , 6 , '6 bytes';
+
+ ok -f 't/data/000/001/234/test2.txt', 'test2.txt exists';
+
+ ok -f 't/data3/000/001/234/test2.txt', 'test1.txt exists';
+
+ my $n3 = $bag->upload(IO::File->new('t/data2/000/000/003/test.txt'),'test3.txt');
+
+ ok $n3 , 'upload test3.txt';
+
+ is $n3 , 6 , '6 bytes';
+
+ ok -f 't/data/000/001/234/test3.txt', 'test3.txt exists';
+
+ ok -f 't/data3/000/001/234/test3.txt', 'test1.txt exists';
+
+ my $data = { _id => 'test4.txt' , _stream => IO::File->new('t/data2/000/000/003/test.txt') };
+
+ ok $bag->add($data) , 'add({ ..test4.. })';
+
+ is $data->{size} , 6 , '$data->{size}';
+}
+
+note("list");
+{
+ my $array = [sort @{$bag->map(sub {shift->{_id}})->to_array}];
+
+ ok $array , 'list got a response';
+
+ is_deeply $array , [qw(test1.txt test2.txt test3.txt test4.txt)],
+ 'got correct response';
+}
+
+note("exists");
+{
+ for (1 .. 4) {
+ ok $bag->exists("test" . $_ . ".txt"), "exists(test" . $_ . ".txt)";
+ }
+}
+
+note("get");
+{
+ for (1 .. 3) {
+ ok $bag->get("test" . $_ . ".txt"), "get(test" . $_ . ".txt)";
+ }
+
+ my $file = $bag->get("test1.txt");
+
+ my $str = $bag->as_string_utf8($file);
+
+ ok $str , 'can stream the data';
+
+ is $str , "钱唐湖春行\n", 'got the correct data';
+}
+
+note("delete");
+{
+ ok $bag->delete('test1.txt'), 'delete(test1.txt)';
+
+ my $array = [sort @{$bag->map(sub {shift->{_id}})->to_array}];
+
+ ok $array , 'list got a response';
+
+ is_deeply $array , [qw(test2.txt test3.txt test4.txt)], 'got correct response';
+}
+
+note("...delete_all (index)");
+{
+ lives_ok {$index->delete_all()} 'delete_all';
+
+ my $array = $index->to_array;
+
+ is_deeply $array , [], 'got correct response';
+}
+
done_testing();
diff --git a/t/Catmandu-Store-File-Multi-Index.t b/t/Catmandu-Store-File-Multi-Index.t
index bb8b033..abce12d 100644
--- a/t/Catmandu-Store-File-Multi-Index.t
+++ b/t/Catmandu-Store-File-Multi-Index.t
@@ -3,6 +3,8 @@ use strict;
use warnings;
use Test::More;
use Test::Exception;
+use Catmandu::Store::File::Simple;
+use Catmandu::Store::File::Multi;
my $pkg;
@@ -13,4 +15,83 @@ BEGIN {
require_ok $pkg;
+my $stores = [
+ Catmandu::Store::File::Simple->new(root => 't/data2', keysize => 9),
+];
+
+my $store = Catmandu::Store::File::Multi->new(stores => $stores);
+my $index;
+
+note("index");
+{
+ $index = $store->index();
+
+ ok $index , 'got the index bag';
+}
+
+note("list");
+{
+ my $array = $index->to_array;
+
+ ok $array , 'list got a response';
+
+ # Order is not important in a list
+ is_deeply [sort({$a->{_id} cmp $b->{_id}} @$array)],
+ [{_id => 1}, {_id => 2}, {_id => 3},], 'got correct response';
+}
+
+note("exists");
+{
+ for (1 .. 3) {
+ ok $index->exists($_), "exists($_)";
+ my $zero_key = ("0" x $_) . $_;
+ ok $index->exists($zero_key), "exists($zero_key)";
+ }
+}
+
+note("get");
+{
+ for (1 .. 3) {
+ ok $index->get($_), "get($_)";
+ my $zero_key = ("0" x $_) . $_;
+ ok $index->get($zero_key), "get($zero_key)";
+ }
+}
+
+$stores = [
+ Catmandu::Store::File::Simple->new(root => 't/data', keysize => 9),
+ Catmandu::Store::File::Simple->new(root => 't/data3', keysize => 9),
+];
+
+$store = Catmandu::Store::File::Multi->new(stores => $stores);
+$index = $store->index();
+
+note("add");
+{
+ throws_ok {$index->add({_id => 'abcd'})} 'Catmandu::BadArg',
+ 'failed to add(abcd)';
+ throws_ok {$index->add({_id => '1234567890'})} 'Catmandu::BadArg',
+ 'failed to add(1234567890)';
+ throws_ok {$index->add({_id => '00000000001234'})} 'Catmandu::BadArg',
+ 'failed to add(00000000001234)';
+
+ my $c = $index->add({_id => '1234'});
+
+ ok $c , 'add(1234)';
+
+ ok -d "t/data/000/001/234", 'found a container on disk';
+}
+
+note("delete");
+{
+ ok $index->delete('1234'), 'delete(1234)';
+
+ ok !-d "t/data/000/001/234", 'container on disk was deleted';
+}
+
+note("delete_all");
+{
+ lives_ok {$index->delete_all()} 'delete_all';
+}
+
done_testing();
diff --git a/t/Catmandu-Store-File-Simple-Bag.t b/t/Catmandu-Store-File-Simple-Bag.t
index 652a46b..14a91aa 100644
--- a/t/Catmandu-Store-File-Simple-Bag.t
+++ b/t/Catmandu-Store-File-Simple-Bag.t
@@ -31,20 +31,35 @@ ok $bag , 'got bag(1234)';
note("add");
{
- ok $bag->upload(IO::File->new('t/data2/000/000/001/test.txt'),
- 'test1.txt');
+ my $n1 = $bag->upload(IO::File->new('t/data2/000/000/001/test.txt'),'test1.txt');
+
+ ok $n1 , 'upload test1.txt';
+
+ is $n1 , 16 , '16 bytes';
ok -f 't/data/000/001/234/test1.txt', 'test1.txt exists';
- ok $bag->upload(IO::File->new('t/data2/000/000/002/test.txt'),
- 'test2.txt');
+ my $n2 = $bag->upload(IO::File->new('t/data2/000/000/002/test.txt'), 'test2.txt');
+
+ ok $n2 , 'upload test2.txt';
+
+ is $n2 , 6 , '6 bytes';
ok -f 't/data/000/001/234/test2.txt', 'test2.txt exists';
- ok $bag->upload(IO::File->new('t/data2/000/000/003/test.txt'),
- 'test3.txt');
+ my $n3 = $bag->upload(IO::File->new('t/data2/000/000/003/test.txt'),'test3.txt');
+
+ ok $n3 , 'upload test3.txt';
+
+ is $n3 , 6 , '6 bytes';
ok -f 't/data/000/001/234/test3.txt', 'test3.txt exists';
+
+ my $data = { _id => 'test3.txt' , _stream => IO::File->new('t/data2/000/000/003/test.txt') };
+
+ ok $bag->add($data) , 'add({ ..test3.. })';
+
+ is $data->{size} , 6 , '$data->{size}';
}
note("list");
--
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