├── t ├── csv_test.json ├── small.json ├── small.yaml ├── run.fix ├── planets.csv ├── myfixes.fix ├── planets.tab ├── fix-level-2.txt ├── lib │ └── Catmandu │ │ ├── Fix │ │ └── undef_error.pm │ │ ├── Serializer │ │ └── dumper.pm │ │ └── Importer │ │ └── Values.pm ├── fix-level-1.txt ├── fix-level-3.txt ├── script.pl ├── Catmandu-Sane.t ├── Catmandu-Fixable.t ├── Catmandu-Fix-Bind.t ├── russian.txt ├── Catmandu-Fix-flatten.t ├── Catmandu-Fix-log.t ├── Catmandu-Fix-nothing.t ├── Catmandu-Fix-uniq.t ├── Catmandu-Iterator.t ├── Catmandu-Fix-sleep.t ├── Catmandu-Fix-array.t ├── Catmandu-Fix-hash.t ├── Catmandu-IdGenerator.t ├── Catmandu-Fix-clone.t ├── Catmandu-Fix-reject.t ├── Catmandu-IdGenerator-UUID.t ├── Catmandu-Fix-retain_field.t ├── Catmandu-Fix-reverse.t ├── Catmandu-Importer-Mock.t ├── Catmandu-Cmd-copy.t ├── Catmandu-Fix-filter.t ├── Catmandu-Fix-replace_all.t ├── Catmandu-Fix-add_to_exporter.t ├── Catmandu-Fix-upcase.t ├── Catmandu-Cmd-import.t ├── Catmandu-Fix-add_to_store.t ├── Catmandu-Fix-downcase.t ├── Catmandu-Fix-capitalize.t ├── Catmandu-Fix-append.t ├── Catmandu-Exporter-Null.t ├── Catmandu-Cmd-count.t ├── Catmandu-Cmd-delete.t ├── Catmandu-Fix-prepend.t ├── Catmandu-MultiIterator.t ├── Catmandu-Fix-collapse.t ├── Catmandu-Fix-to_json.t ├── Catmandu-Fix-remove_field.t ├── Catmandu-Fix-from_json.t ├── Catmandu-Fix-expand_date.t ├── Catmandu-Fix-perlcode.t ├── log4perl.conf ├── Catmandu-Fix-Condition-exists.t ├── Catmandu-Importer-Multi.t ├── Catmandu-Fix-retain.t ├── Catmandu-Fix-include.t ├── Catmandu-Fix-count.t ├── Catmandu-Fix-uri_encode.t ├── Catmandu-Fix-uri_decode.t ├── Catmandu-Cmd-run.t ├── catmandu.yml ├── Catmandu-Fix-format.t ├── Catmandu-Counter.t ├── Catmandu-Exporter-Mock.t ├── Catmandu-Fix-code.t ├── Catmandu-Exporter-YAML.t ├── Catmandu-Validator-Simple.t ├── Catmandu-Fix-split_field.t ├── Catmandu-Fix-parse_text.t ├── Catmandu-Fix-uri_encode_decode.t ├── Catmandu-Serializer.t ├── Catmandu-Fix-expand.t ├── Catmandu-Fix-paste.t ├── Catmandu-Fix-assoc.t ├── Catmandu-Fix-sum.t ├── Catmandu-Pluggable.t ├── Catmandu-Exporter.t ├── Catmandu-Fix-copy_field.t ├── Catmandu-Fix-substring.t ├── Catmandu-Fix-vacuum.t ├── Catmandu-Cmd-help.t ├── Catmandu-Error.t ├── Catmandu-Cmd-config.t ├── Catmandu-Exporter-JSON.t ├── Catmandu-Fix-Base.t ├── Catmandu-Fix-move_field.t ├── Catmandu-Cmd-export.t ├── Catmandu-Importer-YAML.t ├── Catmandu-Env.t ├── Catmandu-Cmd-convert.t ├── Catmandu-Fix-set_array.t ├── Catmandu-Fix-set_hash.t ├── Catmandu-Importer-JSON.t ├── Catmandu-ArrayIterator.t ├── Catmandu-Importer-TSV.t ├── Catmandu-Fix-add_field.t ├── Catmandu-Fix-set_field.t ├── Catmandu-Fix-Bind-importer.t ├── Catmandu-Exporter-Multi.t ├── Catmandu-Searchable.t ├── Catmandu-Fix-join_field.t ├── Catmandu-Importer-CSV.t ├── Catmandu-Buffer.t ├── Catmandu-Cmd-info.t ├── Catmandu-Fix-Condition-all_equal.t ├── Catmandu-Fix-Condition-any_equal.t ├── Catmandu-Importer-Modules.t ├── Catmandu-Fix-Condition-less_than.t ├── Catmandu-Fix-Condition-greater_than.t ├── Catmandu-Fix-Condition-is_true.t ├── Catmandu-IdGenerator-Mock.t ├── Catmandu-Fix-Condition-is_false.t ├── Catmandu-Fix-lookup_in_store.t ├── Catmandu-Fix-Condition-all_match.t ├── Catmandu-Fix-lookup.t ├── Catmandu-Store.t ├── Catmandu-Exporter-Text.t ├── Catmandu-Plugin-Datestamps.t ├── Catmandu-Store-Multi.t ├── Catmandu-Fix-trim.t ├── Catmandu-Fix-Condition-any_match.t ├── Catmandu-Store-Hash.t ├── Catmandu-Hits.t ├── Catmandu-Addable.t ├── Catmandu-Cmd.t ├── Catmandu-Exporter-CSV.t └── Catmandu-Exporter-TSV.t ├── lib └── Catmandu │ ├── Expander.pm │ ├── Fix │ ├── nothing.pm │ ├── clone.pm │ ├── downcase.pm │ ├── upcase.pm │ ├── capitalize.pm │ ├── sum.pm │ ├── Condition │ │ ├── is_true.pm │ │ ├── is_false.pm │ │ ├── any_match.pm │ │ ├── all_match.pm │ │ ├── less_than.pm │ │ ├── greater_than.pm │ │ ├── all_equal.pm │ │ ├── any_equal.pm │ │ └── exists.pm │ ├── append.pm │ ├── prepend.pm │ ├── count.pm │ ├── from_json.pm │ ├── flatten.pm │ ├── remove_field.pm │ ├── uniq.pm │ ├── Bind │ │ └── identity.pm │ ├── filter.pm │ ├── split_field.pm │ ├── array.pm │ ├── to_json.pm │ ├── reverse.pm │ ├── uri_encode.pm │ ├── code.pm │ ├── join_field.pm │ ├── uri_decode.pm │ ├── retain_field.pm │ ├── replace_all.pm │ ├── hash.pm │ ├── reject.pm │ ├── Condition.pm │ ├── collapse.pm │ ├── expand.pm │ ├── add_field.pm │ ├── log.pm │ ├── set_field.pm │ ├── set_hash.pm │ ├── substring.pm │ ├── set_array.pm │ ├── sleep.pm │ ├── trim.pm │ ├── vacuum.pm │ ├── Base.pm │ ├── copy_field.pm │ ├── parse_text.pm │ ├── format.pm │ ├── retain.pm │ ├── move_field.pm │ └── expand_date.pm │ ├── Droppable.pm │ ├── Exporter │ ├── Null.pm │ ├── Multi.pm │ └── Mock.pm │ ├── IdGenerator │ ├── UUID.pm │ └── Mock.pm │ ├── IdGenerator.pm │ ├── Fixable.pm │ ├── Store │ ├── Multi.pm │ └── Multi │ │ └── Bag.pm │ ├── Serializer │ └── json.pm │ ├── Transactional.pm │ ├── Cmd │ ├── drop.pm │ ├── count.pm │ ├── convert.pm │ ├── run.pm │ ├── delete.pm │ ├── config.pm │ └── import.pm │ ├── MultiIterator.pm │ ├── Importer │ ├── Null.pm │ ├── Mock.pm │ └── Multi.pm │ ├── Iterator.pm │ ├── Counter.pm │ └── Sane.pm ├── .gitignore ├── dist.ini ├── .travis.yml ├── .mailmap ├── benchmark └── clone.pl └── cpanfile /t/csv_test.json: -------------------------------------------------------------------------------- 1 | {"ok":1,"foo":"bar"} 2 | {"fob":"test"} 3 | -------------------------------------------------------------------------------- /t/small.json: -------------------------------------------------------------------------------- 1 | {"hello":"ვეპხის ტყაოსანი შოთა რუსთაველი"} 2 | -------------------------------------------------------------------------------- /t/small.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | hello: ვეპხის ტყაოსანი შოთა რუსთაველი 3 | 4 | -------------------------------------------------------------------------------- /t/run.fix: -------------------------------------------------------------------------------- 1 | add_field(hello, world) 2 | add_to_exporter(., JSON, line_delimited: 1) 3 | -------------------------------------------------------------------------------- /t/planets.csv: -------------------------------------------------------------------------------- 1 | english,latin 2 | Sun,Sol 3 | Mercury,Mercurius 4 | Moon,Luna 5 | Earth,Terra 6 | -------------------------------------------------------------------------------- /t/myfixes.fix: -------------------------------------------------------------------------------- 1 | # For use in t/Catmandu-Fix.t 2 | add_field(utf8_name,'ვეპხის ტყაოსანი შოთა რუსთაველი') -------------------------------------------------------------------------------- /t/planets.tab: -------------------------------------------------------------------------------- 1 | english latin 2 | Sun Sol 3 | Mercury Mercurius 4 | Moon Luna 5 | Earth Terra 6 | 7 | -------------------------------------------------------------------------------- /t/fix-level-2.txt: -------------------------------------------------------------------------------- 1 | add_field('working_place','University Library of Ghent') 2 | include('fix-level-3.txt') 3 | -------------------------------------------------------------------------------- /t/lib/Catmandu/Fix/undef_error.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::undef_error; 2 | 3 | use Moo; 4 | 5 | sub fix { 6 | undef; 7 | } 8 | 9 | 1; -------------------------------------------------------------------------------- /t/fix-level-1.txt: -------------------------------------------------------------------------------- 1 | #fixes-level-1 2 | add_field('name','Franck') 3 | add_field('first_name','Nicolas') 4 | 5 | include('fix-level-2.txt') 6 | -------------------------------------------------------------------------------- /t/fix-level-3.txt: -------------------------------------------------------------------------------- 1 | add_field('hobbies.$append','cooking') 2 | add_field('hobbies.$append','art') 3 | add_field('hobbies.$append','hiking') 4 | -------------------------------------------------------------------------------- /lib/Catmandu/Expander.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Expander; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'CGI::Expand'; 8 | 9 | sub max_array { 1000000 } 10 | 11 | 1; 12 | 13 | -------------------------------------------------------------------------------- /t/script.pl: -------------------------------------------------------------------------------- 1 | use Catmandu::Fix; 2 | 3 | sub { 4 | my ($data, $reject) = @_; 5 | if ($data->{answer} == 2) { 6 | return $reject; 7 | } else { 8 | $data->{answer} ||= 42; 9 | return $data; 10 | } 11 | } 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | !.gitignore 2 | .DS_Store 3 | *.swp 4 | .build 5 | _build 6 | blib 7 | Build 8 | cover_db 9 | LICENSE 10 | Makefile.PL 11 | MANIFEST* 12 | META.json 13 | MYMETA.* 14 | Catmandu-* 15 | !*.t 16 | .perl-version 17 | local 18 | cpanfile.snapshot 19 | -------------------------------------------------------------------------------- /t/lib/Catmandu/Serializer/dumper.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Serializer::dumper; 2 | 3 | use Catmandu::Sane; 4 | use Data::Dumper; 5 | use Moo; 6 | 7 | sub serialize { 8 | Dumper($_[1]); 9 | } 10 | 11 | sub deserialize { 12 | eval($_[1]); 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /t/Catmandu-Sane.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Sane'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | done_testing 2; 16 | 17 | -------------------------------------------------------------------------------- /t/Catmandu-Fixable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fixable'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | done_testing 2; 16 | 17 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Bind.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Exception; 6 | use Catmandu::Util qw(:is); 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::Bind'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | done_testing 2; -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Catmandu 2 | author = Nicolas Steenlant 3 | [@Milla] 4 | installer = ModuleBuild 5 | [ExecDir] 6 | dir = bin 7 | [ReadmeAnyFromPod / ReadmePodInRoot] 8 | type = markdown 9 | filename = README.md 10 | location = root 11 | source_filename = lib/Catmandu/Introduction.pod 12 | -------------------------------------------------------------------------------- /t/russian.txt: -------------------------------------------------------------------------------- 1 | На берегу пустынных волн 2 | Стоял он, дум великих полн, 3 | И вдаль глядел. Пред ним широко 4 | Река неслася; бедный чёлн 5 | По ней стремился одиноко. 6 | По мшистым, топким берегам 7 | Чернели избы здесь и там, 8 | Приют убогого чухонца; 9 | И лес, неведомый лучам 10 | В тумане спрятанного солнца, 11 | Кругом шумел. -------------------------------------------------------------------------------- /t/Catmandu-Fix-flatten.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::flatten'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('deep')->fix({deep => [1,[2,3],[[4,5],6],7]}), 16 | {deep => [1 .. 7]}; 17 | 18 | done_testing; 19 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-log.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::log'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $data = {foo => 'bar'}; 15 | 16 | is $data, $pkg->new('test')->fix($data), "fixed data is the same object"; 17 | 18 | done_testing 2; 19 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-nothing.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::nothing'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $data = {foo => 'bar'}; 15 | 16 | is $data, $pkg->new->fix($data), "fixed data is the same object"; 17 | 18 | done_testing 2; 19 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-uniq.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::uniq'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('tags')->fix({tags => ["foo","bar","bar","foo"]}), 16 | {tags => ["foo","bar"]}; 17 | 18 | done_testing; 19 | -------------------------------------------------------------------------------- /t/Catmandu-Iterator.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Iterator'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $g = sub { sub {} }; 16 | 17 | my $i = $pkg->new($g); 18 | ok $i->does('Catmandu::Iterable'); 19 | 20 | done_testing 3; 21 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-sleep.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::sleep'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('1','MILLISECOND')->fix({name => 'Joe'}), 16 | {name => "Joe"}, 17 | "slept didn't change the data"; 18 | 19 | done_testing 2; 20 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-array.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::array'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('tags')->fix({tags => {name => 'Peter'}}), 16 | {tags => ['name', 'Peter']}, 17 | "hash to array"; 18 | 19 | done_testing 2; 20 | 21 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-hash.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::hash'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('tags')->fix({tags => ["name", "Peter", "age", 13]}), 16 | {tags => {name => 'Peter', age => 13}}, 17 | "array to hash"; 18 | 19 | done_testing 2; 20 | 21 | -------------------------------------------------------------------------------- /t/Catmandu-IdGenerator.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Store::Hash; 8 | 9 | my $bag = Catmandu::Store::Hash->new(bags => {data => {id_generator => 'Mock'}})->bag; 10 | isa_ok $bag->id_generator, 'Catmandu::IdGenerator::Mock'; 11 | $bag->add_many([{},{},{}]); 12 | is_deeply $bag->pluck('_id')->to_array, [0,1,2]; 13 | 14 | done_testing; 15 | 16 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-clone.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::clone'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $data = {foo => 'bar'}; 15 | my $cloned = $pkg->new->fix($data); 16 | 17 | is_deeply $data, $cloned, "cloned data is equal"; 18 | isnt $data, $cloned, "cloned data is another object"; 19 | 20 | done_testing 3; 21 | -------------------------------------------------------------------------------- /t/lib/Catmandu/Importer/Values.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Importer::Values; 2 | 3 | use Catmandu::Sane; 4 | use Moo; 5 | use namespace::clean; 6 | 7 | with 'Catmandu::Importer'; 8 | 9 | has values => (is => 'ro', default => sub { '' }); 10 | 11 | sub generator { 12 | my ($self) = @_; 13 | sub { 14 | state $values = [ split /;/, $self->values ]; 15 | return @$values ? { value => shift(@$values) } : undef; 16 | }; 17 | } 18 | 19 | 1; 20 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-reject.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::ArrayIterator; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::reject'; 12 | use_ok $pkg; 13 | } 14 | 15 | my $fix = $pkg->new; 16 | 17 | is $fix->fix({}), undef; 18 | is_deeply $fix->fix([{}]), []; 19 | is_deeply $fix->fix(Catmandu::ArrayIterator->new([{}]))->to_array, []; 20 | 21 | done_testing 4; 22 | 23 | -------------------------------------------------------------------------------- /t/Catmandu-IdGenerator-UUID.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::IdGenerator::UUID'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $id_generator = $pkg->new; 16 | isa_ok $id_generator, $pkg; 17 | ok $id_generator->does("Catmandu::IdGenerator"), 18 | "An object of class '$pkg' does 'Catmandu::Id::Generator'"; 19 | 20 | done_testing; 21 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-retain_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::retain_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('keep')->fix({remove => 'me', also => 'me', keep => 'me'}), 16 | {keep => 'me'}; 17 | 18 | is_deeply 19 | $pkg->new('unknown')->fix({remove => 'me', also => 'me'}), 20 | {}; 21 | 22 | done_testing 3; 23 | 24 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-reverse.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::reverse'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name')->fix({name => 'joe'}), 16 | {name => "eoj"}, 17 | "reverse string"; 18 | 19 | is_deeply 20 | $pkg->new('numbers')->fix({numbers => [1,2,3,4]}), 21 | {numbers => [4,3,2,1]}, 22 | "reverse array"; 23 | 24 | done_testing 3; -------------------------------------------------------------------------------- /t/Catmandu-Importer-Mock.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Importer::Mock'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $data = [ 16 | {n => 0}, 17 | {n => 1}, 18 | {n => 2}, 19 | ]; 20 | 21 | my $importer = $pkg->new(size => 3); 22 | 23 | isa_ok $importer, $pkg; 24 | 25 | is_deeply $importer->to_array, $data, "Data structure ok"; 26 | 27 | done_testing 4; 28 | 29 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.20" 4 | - "5.18" 5 | - "5.16" 6 | - "5.14" 7 | - "5.12" 8 | - "5.10" 9 | install: 10 | - cpanm --quiet --installdeps --notest --force --skip-satisfied . 11 | - cpanm --quiet --notest --skip-satisfied Devel::Cover 12 | script: 13 | - perl Build.PL && ./Build build && cover -test 14 | after_success: 15 | - cpanm --quiet --notest --skip-satisfied Devel::Cover::Report::Coveralls 16 | - cover -report coveralls 17 | env: RELEASE_TESTING=1 AUTOMATED_TESTING=1 18 | sudo: false -------------------------------------------------------------------------------- /t/Catmandu-Cmd-copy.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd::copy'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | my $result = test_app(qq|Catmandu::CLI| => [ qw(copy -v test to Hash) ]); 19 | 20 | like $result->stderr, qr/copied 4 objects/, 'copied 4 objects' ; 21 | is $result->error, undef, 'threw no exceptions' ; 22 | 23 | done_testing; 24 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-filter.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::filter'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('words', 'Pa')->fix({words => [qw(Patrick Nicolas Paul Frank)]}), 16 | {words => [qw(Patrick Paul)]}; 17 | 18 | is_deeply 19 | $pkg->new('words', 'Przewalski')->fix({words => [qw(Patrick Nicolas Paul Frank)]}), 20 | {words => [qw()]}; 21 | 22 | done_testing 3; 23 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-replace_all.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::replace_all'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('date', '\d{2}', '01')->fix({date => "July 23"}), 16 | {date => "July 01"}; 17 | 18 | is_deeply 19 | $pkg->new('date', '(\d{2})', '${1}th')->fix({date => "July 23"}), 20 | {date => "July 23th"}, 21 | "interpolation works"; 22 | 23 | done_testing 3; 24 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/nothing.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::nothing; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Fix::Base'; 11 | 12 | sub emit { 13 | my ($self, $fixer, $label) = @_; 14 | "last ${label};"; 15 | } 16 | 17 | 1; 18 | 19 | __END__ 20 | 21 | =pod 22 | 23 | =head1 NAME 24 | 25 | Catmandu::Fix::nothing - does nothing (for testing) 26 | 27 | =head1 SYNOPSIS 28 | 29 | nothing() 30 | 31 | =head1 SEE ALSO 32 | 33 | L 34 | 35 | =cut 36 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-add_to_exporter.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Capture::Tiny ':all'; 8 | use Catmandu; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Fix::add_to_exporter'; 13 | use_ok $pkg; 14 | } 15 | 16 | my ($stdout, $stderr, $exit) = capture { 17 | my $fixer = Catmandu->fixer('add_to_exporter(.,JSON,array:1)'); 18 | 19 | $fixer->fix({hello => 'world'}); 20 | }; 21 | 22 | is $stdout, qq|[{"hello":"world"}]\n| , 'fixed ok'; 23 | 24 | done_testing 2; -------------------------------------------------------------------------------- /t/Catmandu-Fix-upcase.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::upcase'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name')->fix({name => 'joe'}), 16 | {name => "JOE"}, 17 | "upcase value"; 18 | 19 | is_deeply 20 | $pkg->new('names.*.name')->fix({names => [{name => 'joe'}, {name => 'rick'}]}), 21 | {names => [{name => 'JOE'}, {name => 'RICK'}]}, 22 | "upcase wildcard values"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-import.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester::CaptureExternal; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd::import'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | my $result = test_app(qq|Catmandu::CLI| => [ qw(import CSV -v --file t/planets.csv to Hash) ]); 19 | 20 | like $result->stderr, qr/imported 4 objects/, 'imported 4 objects' ; 21 | is $result->error, undef, 'threw no exceptions' ; 22 | 23 | done_testing 4; -------------------------------------------------------------------------------- /t/Catmandu-Fix-add_to_store.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::add_to_store'; 12 | use_ok $pkg; 13 | } 14 | 15 | Catmandu->config->{store}{test} = { 16 | package => "Hash", 17 | }; 18 | 19 | my $bag = Catmandu->store('test')->bag('test'); 20 | 21 | my $rec = {add => {_id => 1}}; 22 | 23 | $pkg->new('add', 'test', '-bag', 'test')->fix($rec); 24 | 25 | is_deeply $rec->{add}, $bag->get(1); 26 | 27 | done_testing 2; 28 | 29 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-downcase.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::downcase'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name')->fix({name => 'JOE'}), 16 | {name => "joe"}, 17 | "downcase value"; 18 | 19 | is_deeply 20 | $pkg->new('names.*.name')->fix({names => [{name => 'JOE'}, {name => 'RICK'}]}), 21 | {names => [{name => 'joe'}, {name => 'rick'}]}, 22 | "downcase wildcard values"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-capitalize.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::capitalize'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name')->fix({name => 'joe'}), 16 | {name => "Joe"}, 17 | "capitalize value"; 18 | 19 | is_deeply 20 | $pkg->new('names.*.name')->fix({names => [{name => 'joe'}, {name => 'rick'}]}), 21 | {names => [{name => 'Joe'}, {name => 'Rick'}]}, 22 | "capitalize wildcard values"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-append.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::append'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name', 'y')->fix({name => 'joe'}), 16 | {name => "joey"}, 17 | "append to value"; 18 | 19 | is_deeply 20 | $pkg->new('names.*.name', 'y')->fix({names => [{name => 'joe'}, {name => 'rick'}]}), 21 | {names => [{name => 'joey'}, {name => 'ricky'}]}, 22 | "append to wildcard values"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /lib/Catmandu/Droppable.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Droppable; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo::Role; 8 | use namespace::clean; 9 | 10 | requires 'drop'; 11 | 12 | 1; 13 | 14 | __END__ 15 | 16 | =pod 17 | 18 | =head1 NAME 19 | 20 | Catmandu::Droppable - Optional role for droppable stores or bags 21 | 22 | =head1 SYNOPSIS 23 | 24 | # delete a store 25 | $store->drop; 26 | # delete a single bag 27 | $store->bag('sessions')->drop; 28 | 29 | =head1 METHODS 30 | 31 | =head2 drop 32 | 33 | Drop the store or bag. 34 | 35 | =cut 36 | 37 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-Null.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Exception; 5 | 6 | my $pkg; 7 | BEGIN { 8 | $pkg = 'Catmandu::Exporter::Null'; 9 | use_ok $pkg; 10 | } 11 | require_ok $pkg; 12 | 13 | my $data = [{'a' => 'moose', b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}]; 14 | my $out = ""; 15 | 16 | my $exporter = $pkg->new(file => \$out); 17 | isa_ok $exporter, $pkg; 18 | 19 | $exporter->add($_) for @$data; 20 | $exporter->commit; 21 | 22 | is $out,'', "Null is empty ok"; 23 | is $exporter->count,3, "Count ok"; 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-count.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd::count'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | my $result = test_app(qq|Catmandu::CLI| => [ qw(count test) ]); 19 | 20 | is $result->stdout, "4\n" , 'got data'; 21 | is $result->error, undef, 'threw no exceptions' ; 22 | ## Next test can fail on buggy Perl installations 23 | #is $result->stderr, '', 'nothing sent to sderr' ; 24 | 25 | done_testing 4; 26 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-delete.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd::delete'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | my $result = test_app(qq|Catmandu::CLI| => [ qw(delete test) ]); 19 | 20 | is $result->stdout, "" , 'got data'; 21 | is $result->error, undef, 'threw no exceptions' ; 22 | ## Next test can fail buggy perl installations 23 | #is $result->stderr, '', 'nothing sent to sderr' ; 24 | 25 | done_testing 4; 26 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-prepend.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::prepend'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name', 'mr. ')->fix({name => 'smith'}), 16 | {name => "mr. smith"}, 17 | "prepend to value"; 18 | 19 | is_deeply 20 | $pkg->new('names.*.name', 'mr. ')->fix({names => [{name => 'smith'}, {name => 'jones'}]}), 21 | {names => [{name => 'mr. smith'}, {name => 'mr. jones'}]}, 22 | "prepend to wildcard values"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /t/Catmandu-MultiIterator.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::ArrayIterator; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::MultiIterator'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $data = [ 17 | {n => 0}, 18 | {n => 1}, 19 | {n => 2}, 20 | ]; 21 | 22 | my $it = $pkg->new( 23 | Catmandu::ArrayIterator->new([@$data]), 24 | Catmandu::ArrayIterator->new([@$data]), 25 | ); 26 | 27 | isa_ok $it, $pkg; 28 | 29 | is_deeply $it->to_array, [@$data, @$data]; 30 | 31 | done_testing; 32 | 33 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-collapse.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::collapse'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new()->fix({names => [{name => 'joe'}, {name => 'rick'}]}), 16 | {'names.0.name' => "joe", 'names.1.name' => "rick"}, 17 | "data is flattened"; 18 | 19 | is_deeply 20 | $pkg->new('sep','-')->fix({names => [{name => 'joe'}, {name => 'rick'}]}), 21 | {'names-0-name' => "joe", 'names-1-name' => "rick"}, 22 | "data is flattened"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-to_json.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use JSON::XS (); 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::to_json'; 12 | use_ok $pkg; 13 | } 14 | 15 | my $json = JSON::XS->new->utf8(0)->allow_nonref(1); 16 | 17 | is_deeply 18 | $pkg->new('name')->fix({name => ["Joe"]}), 19 | {name => $json->encode(["Joe"])}; 20 | 21 | is_deeply 22 | $pkg->new('names.*')->fix({names => [{name => 'Joe'}, {name => 'Rick'}]}), 23 | {names => [$json->encode({name => 'Joe'}), $json->encode({name => 'Rick'})]}; 24 | 25 | done_testing 3; 26 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-remove_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::remove_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('remove')->fix({remove => 'me', keep => 'me'}), 16 | {keep => 'me'}, 17 | "remove field at root"; 18 | 19 | is_deeply 20 | $pkg->new('many.*.remove')->fix({many => [{remove => 'me', keep => 'me'}, {remove => 'me', keep => 'me'}]}), 21 | {many => [{keep => 'me'}, {keep => 'me'}]}, 22 | "remove nested field with wildcard"; 23 | 24 | done_testing 3; 25 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-from_json.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use JSON::XS (); 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::from_json'; 12 | use_ok $pkg; 13 | } 14 | 15 | my $json = JSON::XS->new->utf8(0)->allow_nonref(1); 16 | 17 | is_deeply 18 | $pkg->new('name')->fix({name => $json->encode(["Joe"])}), 19 | {name => ["Joe"]}; 20 | 21 | is_deeply 22 | $pkg->new('names.*')->fix({names => [$json->encode({name => 'Joe'}), $json->encode({name => 'Rick'})]}), 23 | {names => [{name => 'Joe'}, {name => 'Rick'}]}; 24 | 25 | done_testing 3; 26 | 27 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-expand_date.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | my $pkg; 8 | BEGIN { 9 | $pkg = 'Catmandu::Fix::expand_date'; 10 | use_ok $pkg; 11 | } 12 | 13 | sub test_expand { 14 | my $expect = pop; 15 | my $data = pop; 16 | is_deeply $pkg->new(@_)->fix($data), $expect; 17 | } 18 | 19 | test_expand 20 | { date => '2001-11-09' } 21 | => { date => '2001-11-09', year => 2001, month => 11, day => 9 }; 22 | 23 | test_expand 'date_created', 24 | { date_created => '2001:11' } 25 | => { date_created => '2001:11', year => 2001, month => 11 }; 26 | 27 | done_testing 3; 28 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-perlcode.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Catmandu::Fix; 5 | use Catmandu::Fix::perlcode; 6 | 7 | foreach my $i (1..2) { # also tests caching 8 | my $fixer = Catmandu::Fix->new( fixes => ['perlcode(t/script.pl)'] ); 9 | my $data = { }; 10 | $fixer->fix($data); 11 | is_deeply $data, { answer => 42 }, 'perlcode fix'; 12 | } 13 | 14 | { 15 | my $fixer = Catmandu::Fix->new( fixes => ['perlcode(t/script.pl)'] ); 16 | is_deeply $fixer->fix([ 17 | map { +{ answer => $_ } } 1..3 18 | ]), [ { answer => 1 }, { answer => 3 } ], 'perlcode fix with reject'; 19 | } 20 | 21 | done_testing; 22 | -------------------------------------------------------------------------------- /t/log4perl.conf: -------------------------------------------------------------------------------- 1 | log4perl.category.Catmandu=DEBUG,STDERR 2 | log4perl.categoty.Catmandu::Fix::log=TRACE,STDERR 3 | 4 | log4perl.appender.STDOUT=Log::Log4perl::Appender::Screen 5 | log4perl.appender.STDOUT.stderr=0 6 | log4perl.appender.STDOUT.utf8=1 7 | 8 | log4perl.appender.STDOUT.layout=PatternLayout 9 | log4perl.appender.STDOUT.layout.ConversionPattern=%d [%P] - %p %l %M time=%r : %m%n 10 | 11 | log4perl.appender.STDERR=Log::Log4perl::Appender::Screen 12 | log4perl.appender.STDERR.stderr=1 13 | log4perl.appender.STDERR.utf8=1 14 | 15 | log4perl.appender.STDERR.layout=PatternLayout 16 | log4perl.appender.STDERR.layout.ConversionPattern=%d [%P] - %l : %m%n -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-exists.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Fix::set_field; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::Condition::exists'; 12 | use_ok $pkg; 13 | } 14 | 15 | my $cond = $pkg->new('foo'); 16 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 17 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 18 | 19 | is_deeply 20 | $cond->fix({foo => undef}), 21 | {foo => undef, test => 'pass'}; 22 | 23 | is_deeply 24 | $cond->fix({}), 25 | {test => 'fail'}; 26 | 27 | done_testing 3; 28 | -------------------------------------------------------------------------------- /t/Catmandu-Importer-Multi.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Importer::Mock; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Importer::Multi'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $data = [ 17 | {n => 0}, 18 | {n => 1}, 19 | {n => 2}, 20 | ]; 21 | 22 | my $importer = $pkg->new(importers => [ 23 | Catmandu::Importer::Mock->new(size => 3), 24 | Catmandu::Importer::Mock->new(size => 3), 25 | ]); 26 | 27 | isa_ok $importer, $pkg; 28 | 29 | is_deeply $importer->to_array, [@$data, @$data]; 30 | 31 | done_testing; 32 | 33 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-retain.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::retain'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('keep')->fix({remove => 'me', also => 'me', keep => 'me'}), 16 | {keep => 'me'}; 17 | 18 | is_deeply 19 | $pkg->new('unknown')->fix({remove => 'me', also => 'me'}), 20 | {}; 21 | is_deeply 22 | $pkg->new('keep', 'maybe.keep')->fix({remove => 'me', keep => 'me', maybe => {keep => 'me', remove => 'me'}}), 23 | {keep => 'me', maybe => {keep => 'me'}}; 24 | 25 | done_testing 4; 26 | 27 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-include.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::include'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $object = {}; 15 | my $intended_object = { 16 | name => "Franck", 17 | first_name => "Nicolas", 18 | working_place => "University Library of Ghent" , 19 | hobbies => [ 'cooking' , 'art' , 'hiking'] 20 | }; 21 | my $fix_file = "fix-level-1.txt"; 22 | 23 | is_deeply( 24 | $pkg->new($fix_file)->fix($object), 25 | $intended_object, 26 | "include fix at multiple levels" 27 | ); 28 | 29 | done_testing 2; 30 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/clone.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::clone; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Fix::Base'; 11 | 12 | sub emit { 13 | my ($self, $fixer) = @_; 14 | $fixer->emit_clone($fixer->var); 15 | } 16 | 17 | 1; 18 | 19 | __END__ 20 | 21 | =pod 22 | 23 | =head1 NAME 24 | 25 | Catmandu::Fix::clone - create a clone of the data object 26 | 27 | =head1 SYNOPSIS 28 | 29 | # Create a clone of the data object 30 | clone() 31 | 32 | # Now do all the changes on the clone 33 | add_field(foo, 2) 34 | 35 | =head1 SEE ALSO 36 | 37 | L 38 | 39 | =cut 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-count.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::count'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply $pkg->new('tags')->fix({tags => [qw(smelly stinky malodorous)]}), {tags => 3}; 15 | is_deeply $pkg->new('authors.*')->fix( 16 | {authors => [{firstname => "Mark", lastname => "Twain"}, {name => "Virgil"}]}), 17 | {authors => [2, 1]}; 18 | is_deeply $pkg->new('name')->fix({name => "Huckleberry Finn"}), {name => "Huckleberry Finn"}; 19 | is_deeply $pkg->new('name')->fix({name => undef}), {name => undef}; 20 | 21 | done_testing 5; 22 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-uri_encode.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use utf8; 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::uri_encode'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name')->fix({name => 'café'}), 16 | {name => "caf%C3%A9"}, 17 | "escape utf8 string from French"; 18 | 19 | is_deeply 20 | $pkg->new('name')->fix({name => 'ὁ τῶν Πέρσων βασιλεύς'}), 21 | {name => "%E1%BD%81%20%CF%84%E1%BF%B6%CE%BD%20%CE%A0%CE%AD%CF%81%CF%83%CF%89%CE%BD%20%CE%B2%CE%B1%CF%83%CE%B9%CE%BB%CE%B5%CF%8D%CF%82"}, 22 | "escape utf8 string from Greek"; 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-uri_decode.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use utf8; 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::uri_decode'; 12 | use_ok $pkg; 13 | } 14 | 15 | is_deeply 16 | $pkg->new('name')->fix({name => 'caf%C3%A9'}), 17 | {name => "café"}, 18 | "unescape utf8 string from French"; 19 | 20 | is_deeply 21 | $pkg->new('name')->fix({name => '%E1%BD%81%20%CF%84%E1%BF%B6%CE%BD%20%CE%A0%CE%AD%CF%81%CF%83%CF%89%CE%BD%20%CE%B2%CE%B1%CF%83%CE%B9%CE%BB%CE%B5%CF%8D%CF%82'}), 22 | {name => "ὁ τῶν Πέρσων βασιλεύς"}, 23 | "unescape utf8 string from Greek"; 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-run.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester::CaptureExternal; 8 | use JSON::XS; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Cmd::run'; 13 | use_ok $pkg; 14 | } 15 | require_ok $pkg; 16 | 17 | use Catmandu::CLI; 18 | 19 | my $result = test_app(qq|Catmandu::CLI| => [ qw(run t/run.fix) ]); 20 | 21 | my $perl = decode_json($result->stdout); 22 | 23 | ok $perl, 'got JSON'; 24 | is $perl->{hello} , 'world' , 'got data'; 25 | is $result->error, undef, 'threw no exceptions' ; 26 | # Next test can fail on buggy Perl installations 27 | ##is $result->stderr, '', 'nothing sent to sderr' ; 28 | 29 | done_testing 5; -------------------------------------------------------------------------------- /t/catmandu.yml: -------------------------------------------------------------------------------- 1 | --- 2 | test: ok 3 | importer: 4 | default: 5 | package: YAML 6 | mock: 7 | package: Mock 8 | exporter: 9 | default: 10 | package: YAML 11 | csv: 12 | package: CSV 13 | store: 14 | default: 15 | package: Hash 16 | hash: 17 | package: Hash 18 | test: 19 | package: Hash 20 | options: 21 | init_data: 22 | - _id: Sun 23 | value: Sol 24 | - _id: Mercury 25 | value: Mercurius 26 | - _id: Moon 27 | value: Luna 28 | - _id: Earth 29 | value: Terra 30 | fixer: 31 | default: 32 | - nothing() 33 | other: 34 | - nothing() 35 | 36 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/downcase.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::downcase; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "${var} = lc(as_utf8(${var})) if is_string(${var});"; 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Catmandu::Fix::downcase - lowercase the value of a field 29 | 30 | =head1 SYNOPSIS 31 | 32 | # Lowercase 'foo'. E.g. foo => 'BAR' 33 | downcase(foo) # foo => 'bar' 34 | 35 | =head1 SEE ALSO 36 | 37 | L 38 | 39 | =cut 40 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/upcase.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::upcase; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "${var} = uc(as_utf8(${var})) if is_string(${var});"; 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Catmandu::Fix::upcase - uppercase the value of a field 29 | 30 | =head1 SYNOPSIS 31 | 32 | # Uppercase the value of 'foo'. E.g. foo => 'bar' 33 | upcase(foo) # foo => 'BAR' 34 | 35 | =head1 SEE ALSO 36 | 37 | L 38 | 39 | =cut 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-format.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::format'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('name','<%-10s>')->fix({name => 'Joe'}), 16 | {name => ""}, 17 | "formatted strings"; 18 | 19 | is_deeply 20 | $pkg->new('names','<%-10s> <%-10s>')->fix({names => ['Alice','Bob']}), 21 | {names => " "}, 22 | "formatted arrays"; 23 | 24 | is_deeply 25 | $pkg->new('data','<%-10s> <%-10s>')->fix({data => { name => "Alice"}}), 26 | {data => " "}, 27 | "formatted hashes"; 28 | 29 | done_testing 4; -------------------------------------------------------------------------------- /t/Catmandu-Counter.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Counter'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | { 16 | package T::Counter; 17 | use Moo; 18 | with $pkg; 19 | } 20 | 21 | my $c = T::Counter->new; 22 | 23 | can_ok $c, 'count'; 24 | can_ok $c, 'inc_count'; 25 | can_ok $c, 'dec_count'; 26 | can_ok $c, 'reset_count'; 27 | 28 | is $c->count, 0; 29 | 30 | $c->inc_count; 31 | is $c->count, 1; 32 | 33 | $c->dec_count; 34 | is $c->count, 0; 35 | $c->dec_count; 36 | is $c->count, 0; 37 | 38 | $c->inc_count; 39 | $c->reset_count; 40 | is $c->count, 0; 41 | 42 | done_testing 11; 43 | 44 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-Mock.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Exception; 5 | 6 | my $pkg; 7 | BEGIN { 8 | $pkg = 'Catmandu::Exporter::Mock'; 9 | use_ok $pkg; 10 | } 11 | require_ok $pkg; 12 | 13 | my $data = [{'a' => 'moose', b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}]; 14 | my $out = ""; 15 | 16 | my $exporter = $pkg->new(file => \$out); 17 | isa_ok $exporter, $pkg; 18 | 19 | $exporter->add($_) for @$data; 20 | $exporter->commit; 21 | 22 | is $out,'', "Null is empty ok"; 23 | is $exporter->count,3, "Count ok"; 24 | 25 | is_deeply $exporter->as_arrayref , [{'a' => 'moose', b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}] , 'as_arrayref'; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/capitalize.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::capitalize; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "${var} = ucfirst(lc(as_utf8(${var}))) if is_string(${var});"; 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Catmandu::Fix::capitalize - capitalize the value of a key 29 | 30 | =head1 SYNOPSIS 31 | 32 | # Capitalize the value of foo. E.g. foo => 'bar' 33 | capitalize(foo) # foo => 'Bar' 34 | 35 | =head1 SEE ALSO 36 | 37 | L 38 | 39 | =cut 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-code.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Catmandu::Importer::Mock; 6 | use Catmandu::Util qw(:is); 7 | 8 | use_ok 'Catmandu::Fix::code'; 9 | 10 | sub hello { 11 | my ($data) = @_; 12 | $data->{hello} = 'world'; 13 | $data; 14 | } 15 | 16 | my $fixer = Catmandu::Fix::code->new( \&hello ); 17 | is_deeply $fixer->fix({}), { hello => 'world' }, 'code fixer'; 18 | 19 | my $importer = Catmandu::Importer::Mock->new( size => 1, fix => [$fixer]); 20 | is_deeply $importer->first, { n => 0, hello => 'world' }, 'fix as instance'; 21 | 22 | $importer = Catmandu::Importer::Mock->new( size => 1, fix => [\&hello]); 23 | is_deeply $importer->first, { n => 0, hello => 'world' }, 'fix as code'; 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-YAML.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Exception; 6 | use YAML::XS (); 7 | 8 | BEGIN { use_ok 'Catmandu::Exporter::YAML' } 9 | require_ok 'Catmandu::Exporter::YAML'; 10 | 11 | my $data = [{'a' => 'moose'}, {'a' => 'pony'}, {'a' => 'shrimp'}]; 12 | my $file = ""; 13 | 14 | my $exporter = Catmandu::Exporter::YAML->new(file => \$file); 15 | isa_ok $exporter, 'Catmandu::Exporter::YAML'; 16 | 17 | $exporter->add($_) for @$data; 18 | $exporter->commit; 19 | is_deeply $data, [ YAML::XS::Load($file) ]; 20 | 21 | is $exporter->count, 3, 'Count ok'; 22 | 23 | like $file, qr/^---(.+)\.\.\.$/sm, 'YAML doc'; 24 | is scalar @{[ split /^\.\.\./m, $file ]}, 4, 'YAML with --- and ...'; 25 | 26 | done_testing; 27 | 28 | -------------------------------------------------------------------------------- /t/Catmandu-Validator-Simple.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Validator::Simple'; 11 | use_ok $pkg; 12 | } 13 | 14 | require_ok $pkg; 15 | 16 | my $v = Catmandu::Validator::Simple->new(handler => sub { $_[0]->{field} eq '1' ? undef : 17 | 'Not 1'});; 18 | 19 | can_ok $v, 'validate_data'; 20 | 21 | throws_ok { $v->new(handler => 1) } qr/handler should be a CODE reference/; 22 | 23 | my $rec = {field => 1}; 24 | 25 | is $v->validate($rec), $rec,'validate - success' ; 26 | 27 | is $v->validate({field => 3}), undef, 'validate - fails'; 28 | 29 | is_deeply $v->last_errors, ['Not 1'], 'last_errors returns error message'; 30 | 31 | done_testing 7; 32 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-split_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::split_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('splitme', ',')->fix({splitme => "a,b,c"}), 16 | {splitme => ["a", "b", "c"]}, 17 | "split value"; 18 | 19 | is_deeply 20 | $pkg->new('many.*.splitme', ',')->fix({many => [{splitme => "a,b,c"}, {splitme => "a,b,c"}]}), 21 | {many => [{splitme => ["a", "b", "c"]}, {splitme => ["a", "b", "c"]}]}, 22 | "split wildcard values"; 23 | 24 | is_deeply 25 | $pkg->new('splitme', ',')->fix({splitme => ["a", "b", "c"]}), 26 | {splitme => ["a", "b", "c"]}, 27 | "only split values"; 28 | 29 | done_testing 4; 30 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-parse_text.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::parse_text'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('date','\d\d\d\d-\d\d-\d\d')->fix({date => '2015-03-07'}), 16 | {date => '2015-03-07'}, 17 | "parse without capture"; 18 | 19 | is_deeply 20 | $pkg->new('date','(\d\d\d\d)-(\d\d)-(\d\d)')->fix({date => '2015-03-07'}), 21 | {date => ['2015','03','07']}, 22 | "parse array value"; 23 | 24 | is_deeply 25 | $pkg->new('date','(?\d\d\d\d)-(?\d\d)-(?\d\d)')->fix({date => '2015-03-07'}), 26 | {date => {year => '2015', month => '03' , day => '07'}}, 27 | "parse hash value"; 28 | 29 | done_testing 4; -------------------------------------------------------------------------------- /t/Catmandu-Fix-uri_encode_decode.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use utf8; 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg1; 9 | my $pkg2; 10 | BEGIN { 11 | $pkg1 = 'Catmandu::Fix::uri_encode'; 12 | use_ok $pkg1; 13 | $pkg2 = 'Catmandu::Fix::uri_decode'; 14 | use_ok $pkg2; 15 | } 16 | 17 | my $obj = { name => 'café' }; 18 | my $obj2 = { name => 'ὁ τῶν Πέρσων βασιλεύς' }; 19 | my $fixer1 = $pkg1->new('name'); 20 | my $fixer2 = $pkg2->new('name'); 21 | 22 | is_deeply 23 | $fixer2->fix( $fixer1->fix($obj) ), 24 | { name => "café" }, 25 | "escape and unescape French"; 26 | 27 | is_deeply 28 | $fixer2->fix( $fixer1->fix($obj2) ), 29 | { name => "ὁ τῶν Πέρσων βασιλεύς" }, 30 | "escape and unescape Greek"; 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /t/Catmandu-Serializer.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | use lib 't/lib'; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Serializer'; 13 | use_ok $pkg; 14 | } 15 | require_ok $pkg; 16 | 17 | { 18 | package T::Serializer; 19 | use Moo; 20 | with $pkg; 21 | } 22 | 23 | my $t = T::Serializer->new; 24 | 25 | can_ok $t, qw(serialize deserialize serializer serialization_format); 26 | isa_ok $t->serializer, 'Catmandu::Serializer::json'; 27 | 28 | my $data = {foo => 'bar'}; 29 | 30 | is_deeply $data, $t->deserialize($t->serialize($data)); 31 | 32 | $t = T::Serializer->new(serialization_format => 'dumper'); 33 | 34 | isa_ok $t->serializer, 'Catmandu::Serializer::dumper'; 35 | 36 | done_testing 6; 37 | 38 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/sum.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::sum; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use List::Util (); 8 | use Moo; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has path => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var) = @_; 18 | 19 | "if (is_array_ref(${var})) {" . 20 | "${var} = List::Util::sum(\@{${var}}) // 0;" . 21 | "}"; 22 | } 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =head1 NAME 31 | 32 | Catmandu::Fix::sum - replace the value of an array field with the sum of it's elements 33 | 34 | =head1 SYNOPSIS 35 | 36 | # e.g. numbers => [2, 3] 37 | sum(numbers) 38 | # numbers => 5 39 | 40 | =head1 SEE ALSO 41 | 42 | L 43 | 44 | =cut 45 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-expand.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::expand'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new->fix({'names.0.name' => "joe", 'names.1.name' => "rick"}), 16 | {names => [{name => 'joe'}, {name => 'rick'}]}, 17 | "data is unflattened"; 18 | 19 | is_deeply 20 | $pkg->new('sep','-')->fix({'names-0-name' => "joe", 'names-1-name' => "rick"}), 21 | {names => [{name => 'joe'}, {name => 'rick'}]}, 22 | "data is unflattened"; 23 | 24 | lives_ok { 25 | my %flat = map { ("list.$_" => $_) } 0 .. 9999; 26 | my $deep = $pkg->new->fix(\%flat); 27 | die unless @{$deep->{list}} == 10000; 28 | } "expand large arrays"; 29 | 30 | done_testing; 31 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-paste.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::paste'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('my.field', 'a', 'b', 'c')->fix({a => 'A', b => 'B' , c => 'C'}), 16 | {my => {field => 'A B C'}, a => 'A', b => 'B' , c => 'C'} , 'paste paths'; 17 | 18 | is_deeply 19 | $pkg->new('my.field', 'a', 'b', 'c', join_char => '/')->fix({a => 'A', b => 'B' , c => 'C'}), 20 | {my => {field => 'A/B/C'}, a => 'A', b => 'B' , c => 'C'} , 'join_char'; 21 | 22 | is_deeply 23 | $pkg->new('my.field', 'a', '~b', 'c')->fix({a => 'A', b => 'B' , c => 'C'}), 24 | {my => {field => 'A b C'}, a => 'A', b => 'B' , c => 'C'} , 'literal strings'; 25 | 26 | done_testing 4; 27 | -------------------------------------------------------------------------------- /lib/Catmandu/Exporter/Null.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Exporter::Null; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Exporter'; 11 | 12 | sub add {} 13 | 14 | 1; 15 | 16 | __END__ 17 | 18 | =pod 19 | 20 | =head1 NAME 21 | 22 | Catmandu::Exporter::Null - a expoter that doesn't export anything 23 | 24 | =head1 SYNOPSIS 25 | 26 | # From the commandline 27 | $ catmandu convert JSON --fix myfixes to Null < /tmp/data.json 28 | 29 | $ catmandu convert JSON --fix 'add_to_exporter(.,JSON)' to Null < /tmp/data.json 30 | 31 | =head1 DESCRIPTION 32 | 33 | This exporter exports nothing and can be used as in situations where you export 34 | data in the Fix script itself. 35 | 36 | =head1 SEE ALSO 37 | 38 | L 39 | 40 | =cut 41 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/is_true.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::is_true; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::Condition::SimpleAllTest'; 14 | 15 | sub emit_test { 16 | my ($self, $var) = @_; 17 | "(((is_bool(${var}) || is_number(${var})) && ${var} + 0 == 1) || (is_string(${var}) && ${var} eq 'true'))"; 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Catmandu::Fix::Condition::is_true - only execute fixes if all path values are the boolean true, 1 or "true" 29 | 30 | =head1 SYNOPSIS 31 | 32 | if is_true(data.*.has_error) 33 | ... 34 | end 35 | 36 | =head1 SEE ALSO 37 | 38 | L 39 | 40 | =cut 41 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/append.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::append; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has value => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $value = $fixer->emit_string($self->value); 19 | "${var} = join('', ${var}, $value) if is_value(${var});"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::append - add a suffix to the value of a field 31 | 32 | =head1 SYNOPSIS 33 | 34 | # append to a value. e.g. {name => 'joe'} 35 | append(name, y) # {name => 'joey'} 36 | 37 | =head1 SEE ALSO 38 | 39 | L 40 | 41 | =cut 42 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-assoc.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::assoc'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('fields', 'pairs.*.key', 'pairs.*.val')->fix({pairs => [{key => 'year', val => 2009}, {key => 'subject', val => 'Perl'}]}), 16 | {fields => {subject => 'Perl', year => 2009}, pairs => [{key => 'year', val => 2009}, {key => 'subject', val => 'Perl'}]}; 17 | 18 | is_deeply 19 | $pkg->new('', 'pairs.*.key', 'pairs.*.val')->fix({pairs => [{key => 'year', val => 2009}, {key => 'subject', val => 'Perl'}]}), 20 | {subject => 'Perl', year => 2009, pairs => [{key => 'year', val => 2009}, {key => 'subject', val => 'Perl'}]}, 21 | "add to root"; 22 | 23 | done_testing 3; 24 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-sum.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::sum'; 11 | use_ok $pkg; 12 | } 13 | 14 | require_ok $pkg; 15 | 16 | lives_ok { $pkg->new('numbers')->fix({ numbers => [1,2] }) }; 17 | 18 | is_deeply 19 | $pkg->new('numbers')->fix({ numbers => [1,2] }), 20 | { numbers => 3 }, "Simple sum ok"; 21 | 22 | # Fibonacci sequence now! 23 | is_deeply 24 | $pkg->new('numbers')->fix({ numbers => [1,1,2,3,5,8,13,21] }), 25 | { numbers => 54 }, "Fibbonaci sum ok"; 26 | 27 | is_deeply 28 | $pkg->new('numbers')->fix({ numbers => [1.234, 4.653, 4.5] }), 29 | { numbers => 10.387 }, "Float sum ok"; 30 | 31 | dies_ok { $pkg->new('numbers')->fix({ numbers => ['hello', 'world'] }) }; 32 | 33 | done_testing 7; 34 | -------------------------------------------------------------------------------- /t/Catmandu-Pluggable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Pluggable'; 11 | use_ok $pkg; 12 | } 13 | 14 | { 15 | package Catmandu::Plugin::Frangle; 16 | use Moo::Role; 17 | sub frangle { 18 | "frangle"; 19 | } 20 | 21 | package T::Pluggable; 22 | use Moo; 23 | with $pkg; 24 | } 25 | 26 | my $t = T::Pluggable->new; 27 | 28 | can_ok $t, 'plugin_namespace'; 29 | can_ok $t, 'with_plugins'; 30 | is $t->plugin_namespace, 'Catmandu::Plugin'; 31 | dies_ok { $t->frangle } "original instance doesn't have plugin"; 32 | 33 | my $t_plugged = $t->with_plugins('Frangle'); 34 | 35 | ok $t_plugged, 'instance with plugin'; 36 | can_ok $t_plugged, 'frangle'; 37 | 38 | done_testing 7; 39 | 40 | -------------------------------------------------------------------------------- /lib/Catmandu/IdGenerator/UUID.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::IdGenerator::UUID; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Data::UUID; 8 | use Moo; 9 | use namespace::clean; 10 | 11 | with 'Catmandu::IdGenerator'; 12 | 13 | has _uuid => (is => 'lazy', builder => '_build_uuid'); 14 | 15 | sub _build_uuid { Data::UUID->new } 16 | 17 | sub generate { 18 | $_[0]->_uuid->create_str; 19 | } 20 | 21 | 1; 22 | 23 | __END__ 24 | 25 | =pod 26 | 27 | =head1 NAME 28 | 29 | Catmandu::IdGenerator::Mock - Generator of UUID identifiers 30 | 31 | =head1 SYNOPSIS 32 | 33 | use Catmandu::IdGenerator::UUID; 34 | 35 | my $x = Catmandu::IdGenerator::Mock->new; 36 | 37 | for (1..100) { 38 | printf "id: %s\n" m $x->generate; 39 | } 40 | 41 | =head1 SEE ALSO 42 | 43 | L 44 | 45 | =cut 46 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/is_false.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::is_false; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::Condition::SimpleAllTest'; 14 | 15 | sub emit_test { 16 | my ($self, $var) = @_; 17 | "(((is_bool(${var}) || is_number(${var})) && ${var} + 0 == 0) || (is_string(${var}) && ${var} eq 'false'))"; 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Catmandu::Fix::Condition::is_false - only execute fixes if all path values are the boolean false, 0 or "false" 29 | 30 | =head1 SYNOPSIS 31 | 32 | if is_false(data.*.has_error) 33 | ... 34 | end 35 | 36 | =head1 SEE ALSO 37 | 38 | L 39 | 40 | =cut 41 | -------------------------------------------------------------------------------- /lib/Catmandu/IdGenerator.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::IdGenerator; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo::Role; 8 | use namespace::clean; 9 | 10 | requires 'generate'; 11 | 12 | 1; 13 | 14 | __END__ 15 | 16 | =pod 17 | 18 | =head1 NAME 19 | 20 | Catmandu::IdGenerator - A base class for modules that needs to generate identifiers 21 | 22 | =head1 SYNOPSIS 23 | 24 | package MyPackage; 25 | 26 | use Moo; 27 | 28 | with 'Catmandu::IdGenerator'; 29 | 30 | sub generate { 31 | return int(rand(999999)) . "-" . time; 32 | } 33 | 34 | package main; 35 | 36 | my $x = MyPackage->new; 37 | 38 | for (1..100) { 39 | printf "id: %s\n" m $x->generate; 40 | } 41 | 42 | =head1 SEE ALSO 43 | 44 | L , 45 | L 46 | 47 | =cut 48 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/prepend.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::prepend; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has value => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $value = $fixer->emit_string($self->value); 19 | "${var} = join('', ${value}, ${var}) if is_value(${var});"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::prepend - add a prefix to the value of a field 31 | 32 | =head1 SYNOPSIS 33 | 34 | # prepend to a value. e.g. {name => 'smith'} 35 | prepend(name, 'mr. ') # {name => 'mr. smith'} 36 | 37 | =head1 SEE ALSO 38 | 39 | L 40 | 41 | =cut 42 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/count.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::count; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "if (is_array_ref(${var})) {" . 18 | "${var} = scalar \@{${var}};" . 19 | "} elsif (is_hash_ref(${var})) {" . 20 | "${var} = scalar keys \%{${var}};" . 21 | "}"; 22 | } 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =head1 NAME 31 | 32 | Catmandu::Fix::count - replace the value of an array or hash field with it's count 33 | 34 | =head1 SYNOPSIS 35 | 36 | # e.g. tags => ["foo", "bar"] 37 | count(tags) # tags => 2 38 | 39 | =head1 SEE ALSO 40 | 41 | L 42 | 43 | =cut 44 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/from_json.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::from_json; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use JSON::XS (); 8 | use Moo; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has path => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $json_var = $fixer->capture(JSON::XS->new->utf8(0)->pretty(0)->allow_nonref(1)); 19 | 20 | "if (is_string(${var})) {" . 21 | "${var} = ${json_var}->decode(${var});" . 22 | "}"; 23 | } 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Catmandu::Fix::from_json - replace a json field with the parsed value 34 | 35 | =head1 SYNOPSIS 36 | 37 | from_json(my.field) 38 | 39 | =head1 SEE ALSO 40 | 41 | L 42 | 43 | =cut 44 | 45 | 46 | -------------------------------------------------------------------------------- /lib/Catmandu/Fixable.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fixable; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Util qw(is_instance); 8 | use Catmandu; 9 | use Moo::Role; 10 | use namespace::clean; 11 | 12 | has _fixer => ( 13 | is => 'ro', 14 | init_arg => 'fix', 15 | coerce => sub { Catmandu->fixer($_[0]) }, 16 | ); 17 | 18 | 1; 19 | 20 | __END__ 21 | 22 | =pod 23 | 24 | =head1 NAME 25 | 26 | Catmandu::Fixable - a Catmandu role to apply fixes 27 | 28 | =head1 DESCRIPTION 29 | 30 | This role provides a C attribute to apply fixes to items processed by 31 | L, L, and L. 32 | 33 | =head1 CONFIGURATION 34 | 35 | =head2 fix 36 | 37 | An ARRAY of one or more fixes or file scripts to be applied to items. 38 | 39 | =head1 SEE ALSO 40 | 41 | L 42 | 43 | =cut 44 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Role::Tiny; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Exporter'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | { 17 | package T::ExporterWithoutAdd; 18 | use Moo; 19 | 20 | package T::Exporter; 21 | use Moo; 22 | with $pkg; 23 | 24 | sub add {} 25 | 26 | } 27 | 28 | throws_ok { Role::Tiny->apply_role_to_package('T::ExporterWithoutAdd', $pkg) } qr/missing add/; 29 | 30 | my $e = T::Exporter->new; 31 | ok $e->does('Catmandu::Addable'); 32 | ok $e->does('Catmandu::Counter'); 33 | can_ok $e, 'encoding'; 34 | can_ok $e, 'commit'; 35 | 36 | is $e->encoding, ':utf8'; 37 | 38 | $e->add(1); 39 | is $e->count, 1; 40 | $e->add_many([2,3,4]); 41 | is $e->count, 4; 42 | 43 | done_testing 10; 44 | 45 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-copy_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::copy_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('old', 'new')->fix({old => 'old'}), 16 | {old => 'old', new => 'old'}, 17 | "copy field at root"; 18 | 19 | is_deeply 20 | $pkg->new('old', 'deeply.nested.$append.new')->fix({old => 'old'}), 21 | {old => 'old', deeply => {nested => [{new => 'old'}]}}, 22 | "copy field creates intermediate path"; 23 | 24 | is_deeply 25 | $pkg->new('old.*', 'deeply.nested.$append.new')->fix({old => ['old', 'older']}), 26 | {old => ['old', 'older'], deeply => {nested => [{new => 'old'}, {new => 'older'}]}}, 27 | "copy field creates intermediate path (with wildcard)"; 28 | 29 | done_testing 4; 30 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-substring.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::substring'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('rel', 5, 3)->fix({rel => "grandson"}), 16 | {rel => "son"}; 17 | 18 | lives_ok { $pkg->new('rel', 9, 3)->fix({rel => "grandson"}) }; 19 | is_deeply 20 | $pkg->new('rel', 9, 3)->fix({rel => "grandson"}), 21 | {rel => "grandson"}, 22 | "ignore substr outside of string"; 23 | 24 | is_deeply 25 | $pkg->new('rel', 5, 3, 'daughter')->fix({rel => "grandson"}), 26 | {rel => "granddaughter"}; 27 | 28 | is_deeply 29 | $pkg->new('arr.*.rel', 5)->fix({arr => [{rel => "grandson"}, {rel => "granddaughter"}]}), 30 | {arr => [{rel => "son"}, {rel => "daughter"}]}; 31 | 32 | done_testing 6; 33 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/flatten.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::flatten; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "if (is_array_ref(${var})) {" . 18 | "${var} = [map { ref \$_ eq 'ARRAY' ? \@\$_ : \$_ } \@{${var}}] " . 19 | "while grep ref \$_ eq 'ARRAY', \@{${var}};" . 20 | "}"; 21 | } 22 | 23 | 1; 24 | 25 | __END__ 26 | 27 | =pod 28 | 29 | =head1 NAME 30 | 31 | Catmandu::Fix::flatten - flatten a nested array field 32 | 33 | =head1 SYNOPSIS 34 | 35 | # {deep => [1, [2, 3], 4, [5, [6, 7]]]} 36 | flatten(deep) 37 | # {deep => [1, 2, 3, 4, 5, 6, 7]} 38 | 39 | =head1 SEE ALSO 40 | 41 | L 42 | 43 | =cut 44 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/remove_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::remove_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has path => (fix_arg => 1); 14 | 15 | sub emit { 16 | my ($self, $fixer) = @_; 17 | my $path = $fixer->split_path($self->path); 18 | my $key = pop @$path; 19 | 20 | $fixer->emit_walk_path($fixer->var, $path, sub { 21 | my $var = shift; 22 | $fixer->emit_delete_key($var, $key); 23 | }); 24 | } 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =head1 NAME 33 | 34 | Catmandu::Fix::remove_field - remove a field form the data 35 | 36 | =head1 SYNOPSIS 37 | 38 | # Remove the foo.bar field 39 | remove_field(foo.bar) 40 | 41 | =head1 SEE ALSO 42 | 43 | L 44 | 45 | =cut 46 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/uniq.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::uniq; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use List::MoreUtils (); 8 | use Moo; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has path => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | 19 | "if (is_array_ref(${var})) {" . 20 | "no warnings 'uninitialized';" . 21 | "${var} = [List::MoreUtils::uniq(\@{${var}})];" . 22 | "}"; 23 | } 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Catmandu::Fix::uniq - strip duplicate values from an array 34 | 35 | =head1 SYNOPSIS 36 | 37 | # {tags => ["foo", "bar", "bar", "foo"]} 38 | uniq(tags) 39 | # {tags => ["foo", "bar"]} 40 | 41 | =head1 SEE ALSO 42 | 43 | L 44 | 45 | =cut 46 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Bind/identity.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Bind::identity; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Fix::Bind'; 11 | 12 | 1; 13 | 14 | __END__ 15 | 16 | =pod 17 | 18 | =head1 NAME 19 | 20 | Catmandu::Fix::Bind::identity - a binder that doesn't influence computation 21 | 22 | =head1 SYNOPSIS 23 | 24 | do identity() 25 | fix1() 26 | fix2() 27 | fix3() 28 | . 29 | . 30 | . 31 | fixN() 32 | end 33 | 34 | # will have the same (side)effects as 35 | 36 | fix1() 37 | fix2() 38 | fix3() 39 | . 40 | . 41 | . 42 | fixN() 43 | 44 | =head1 DESCRIPTION 45 | 46 | The identity binder doesn't embody any computational strategy. It simply 47 | applies the bound fix functions to its input without any modification. 48 | 49 | =head1 SEE ALSO 50 | 51 | L 52 | 53 | =cut 54 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-vacuum.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | package T::MyBlessed; 4 | 5 | use Moo; 6 | use overload '""' => 'stringify'; 7 | 8 | sub stringify { ":-P yuck" } 9 | 10 | package main; 11 | 12 | use strict; 13 | use warnings; 14 | use Test::More; 15 | use Test::Exception; 16 | 17 | my $pkg; 18 | BEGIN { 19 | $pkg = 'Catmandu::Fix::vacuum'; 20 | use_ok $pkg; 21 | } 22 | 23 | my $res = $pkg->new()->fix({ 24 | arrays => [] , 25 | hashes => {} , 26 | strings => '' , 27 | nested_strings => { nested => '' } , 28 | nested_arrays => { arrays => [] } , 29 | nested_hashes => { hashes => {} } , 30 | keep_me => { arrays => [] , hashes => { foo => [] } , me => 1} , 31 | keep_me_2 => [ [] , [T::MyBlessed->new] ], 32 | }); 33 | 34 | is_deeply 35 | $res, 36 | { keep_me => {me => 1} , keep_me_2 => [undef,[":-P yuck"]]}, 37 | "data is vacuumed"; 38 | 39 | done_testing 2; 40 | -------------------------------------------------------------------------------- /lib/Catmandu/Store/Multi.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Store::Multi; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Util qw(:is); 8 | use Catmandu::Store::Multi::Bag; 9 | use Moo; 10 | use namespace::clean; 11 | 12 | with 'Catmandu::Store'; 13 | 14 | has stores => ( 15 | is => 'ro', 16 | default => sub { [] }, 17 | coerce => sub { 18 | my $stores = $_[0]; 19 | return [ map { 20 | if (is_string($_)) { 21 | Catmandu->store($_); 22 | } else { 23 | $_; 24 | } 25 | } @$stores ]; 26 | }, 27 | ); 28 | 29 | sub drop { 30 | my ($self) = @_; 31 | for my $store (@{$self->store->stores}) { 32 | $store->drop; 33 | } 34 | } 35 | 36 | 1; 37 | 38 | __END__ 39 | 40 | =pod 41 | 42 | =head1 NAME 43 | 44 | Catmandu::Store::Multi - A store that adds your data to multiple stores 45 | 46 | =cut 47 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-help.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd::help'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | { 19 | my $result = test_app(qq|Catmandu::CLI| => [ qw(help) ]); 20 | 21 | is $result->error, undef, 'threw no exceptions' ; 22 | } 23 | 24 | { 25 | my $result = test_app(qq|Catmandu::CLI| => [ qw(help importer JSON) ]); 26 | 27 | is $result->error, undef, 'threw no exceptions' ; 28 | } 29 | 30 | { 31 | my $result = test_app(qq|Catmandu::CLI| => [ qw(help exporter JSON) ]); 32 | 33 | is $result->error, undef, 'threw no exceptions' ; 34 | } 35 | 36 | { 37 | my $result = test_app(qq|Catmandu::CLI| => [ qw(help store Hash) ]); 38 | 39 | is $result->error, undef, 'threw no exceptions' ; 40 | } 41 | 42 | done_testing 6; -------------------------------------------------------------------------------- /lib/Catmandu/Fix/filter.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::filter; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has search => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var) = @_; 18 | my $search = $self->search; 19 | 20 | "if (is_array_ref(${var})) {" . 21 | "${var} = [ grep { /${search}/ } \@{${var}} ];" . 22 | "}"; 23 | } 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Catmandu::Fix::filter - Filter values out of an array based on a regular expression 34 | 35 | =head1 SYNOPSIS 36 | 37 | # words => ["Patrick","Nicolas","Paul","Frank"] 38 | 39 | filter(words,'Pa') 40 | 41 | # words => ["Patrick","Paul"] 42 | 43 | =head1 SEE ALSO 44 | 45 | L 46 | 47 | =cut 48 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/split_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::split_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has split_char => (fix_arg => 1, default => sub { qr'\s+' }); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $split_char = $fixer->emit_string($self->split_char); 19 | 20 | "${var} = [split ${split_char}, ${var}] if is_value(${var});"; 21 | } 22 | 23 | 1; 24 | 25 | __END__ 26 | 27 | =pod 28 | 29 | =head1 NAME 30 | 31 | Catmandu::Fix::split_field - split a string value in a field into an ARRAY 32 | 33 | =head1 SYNOPSIS 34 | 35 | # Split the 'foo' value into an array. E.g. foo => '1:2:3' 36 | split_field(foo, ':') # foo => [1,2,3] 37 | 38 | =head1 SEE ALSO 39 | 40 | L 41 | 42 | =cut 43 | -------------------------------------------------------------------------------- /t/Catmandu-Error.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Error'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | throws_ok { Catmandu::Error->throw("Oops!"); } 'Catmandu::Error' , qq|caught an error|; 16 | throws_ok { Catmandu::Error->throw; } 'Catmandu::Error' , qq|caught an error with no message|; 17 | is(Catmandu::Error->new->message, '' , qq|default error message is an empty string|); 18 | throws_ok { Catmandu::BadVal->throw("Whoo!"); } 'Catmandu::BadVal' , qq|caught a badval|; 19 | throws_ok { Catmandu::BadArg->throw("Aarrgh!"); } 'Catmandu::BadArg', qq|caught a badarg|; 20 | throws_ok { Catmandu::BadArg->throw("Aarrgh!"); } 'Catmandu::BadArg', qq|caught a badarg|; 21 | throws_ok { Catmandu::NotImplemented->throw("Huh?!"); } 'Catmandu::NotImplemented' , qq|caught a notimplemented|; 22 | 23 | done_testing; 24 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-config.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | use JSON::XS; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Cmd::config'; 13 | use_ok $pkg; 14 | } 15 | require_ok $pkg; 16 | 17 | use Catmandu::CLI; 18 | 19 | my $result = test_app(qq|Catmandu::CLI| => [ qw(config to JSON) ]); 20 | my $perl = decode_json($result->stdout); 21 | 22 | ok $perl, 'got JSON'; 23 | is $perl->[0]->{importer}{default}{package} , 'YAML' , 'got data'; 24 | is $result->error, undef, 'threw no exceptions' ; 25 | is $result->stderr, '', 'nothing sent to sderr' ; 26 | 27 | $result = test_app(qq|Catmandu::CLI| => [ qw(config importer.default.package to JSON) ]); 28 | 29 | like $result->stdout , qr/"YAML"/ , 'got data'; 30 | is $result->error, undef, 'threw no exceptions' ; 31 | is $result->stderr, '', 'nothing sent to sderr' ; 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/any_match.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::any_match; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has pattern => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::Condition::SimpleAnyTest'; 15 | 16 | sub emit_test { 17 | my ($self, $var, $parser) = @_; 18 | "is_value(${var}) && ${var} =~ ".$parser->emit_match($self->pattern); 19 | } 20 | 21 | 1; 22 | 23 | __END__ 24 | 25 | =pod 26 | 27 | =head1 NAME 28 | 29 | Catmandu::Fix::Condition::any_match - only execute fixes if any path value matches the given regex 30 | 31 | =head1 SYNOPSIS 32 | 33 | # uppercase the value of field 'foo' if field 'oogly' has the value 'doogly' 34 | if any_match(oogly, "doogly") 35 | upcase(foo) # foo => 'BAR' 36 | end 37 | 38 | =head1 SEE ALSO 39 | 40 | L 41 | 42 | =cut 43 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/array.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::array; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "if (is_hash_ref(${var})) {" . 18 | "${var} = [\%{${var}}];" . 19 | "}"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::array - creates an array out of a hash 31 | 32 | =head1 SYNOPSIS 33 | 34 | # tags => {name => 'Peter', age => 12} 35 | array(tags) 36 | # tags => ['name', 'Peter', 'age', 12] 37 | 38 | =head1 DESCRIPTION 39 | 40 | This fix functions transforms hash fields to array. String fields and array 41 | fields are left unchanged. 42 | 43 | =head1 SEE ALSO 44 | 45 | L, L 46 | 47 | =cut 48 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/to_json.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::to_json; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use JSON::XS (); 8 | use Moo; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has path => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | # memoize in case called multiple times 19 | my $json_var = $fixer->capture(JSON::XS->new->utf8(0)->pretty(0)->allow_nonref(1)); 20 | 21 | "if (is_maybe_value(${var}) || is_array_ref(${var}) || is_hash_ref(${var})) {" . 22 | "${var} = ${json_var}->encode(${var});" . 23 | "}"; 24 | } 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =head1 NAME 33 | 34 | Catmandu::Fix::to_json - convert the value of a field to json 35 | 36 | =head1 SYNOPSIS 37 | 38 | to_json(my.field) 39 | 40 | =head1 SEE ALSO 41 | 42 | L 43 | 44 | =cut 45 | 46 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-JSON.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use JSON::XS (); 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Exporter::JSON'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $data = [{'a' => 'moose'}, {'a' => 'pony'}, {'a' => 'shrimp'}]; 17 | my $file = ""; 18 | 19 | my $exporter = $pkg->new(file => \$file, line_delimited => 1); 20 | 21 | isa_ok $exporter, $pkg; 22 | 23 | $exporter->add($_) for @$data; 24 | $exporter->commit; 25 | is_deeply $data, [ map { JSON::XS::decode_json($_) } split /[\r\n]+/, $file ]; 26 | 27 | is($exporter->count, 3, "Count ok"); 28 | 29 | $file = ""; 30 | Catmandu::Exporter::JSON->new( file => \$file, line_delimited => 1, canonical => 1 ) 31 | ->add( { map { chr(ord('z')-$_) => $_ } (0..25) } ); 32 | is_deeply [ $file =~ /(\d+)/g ], [ map { "".(25-$_) } (0..25) ], 'canonical'; 33 | 34 | done_testing; 35 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Base.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Role::Tiny; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::Base'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | { 17 | package T::FixBaseWithoutEmit; 18 | use Moo; 19 | 20 | package T::FixBase; 21 | use Moo; 22 | with $pkg; 23 | 24 | sub emit { 25 | '$_[0]->{fix} = "base"'; 26 | } 27 | 28 | package T::UseFixBase; 29 | use Moo; 30 | T::FixBase->import(as => 'do_fix_base'); 31 | } 32 | 33 | throws_ok { Role::Tiny->apply_role_to_package('T::FixBaseWithoutEmit', $pkg) } qr/missing emit/; 34 | 35 | my $fb = T::FixBase->new; 36 | can_ok $fb, 'fixer'; 37 | can_ok $fb, 'emit'; 38 | can_ok $fb, 'import'; 39 | 40 | isa_ok $fb->fixer, 'Catmandu::Fix'; 41 | 42 | is_deeply {fix => 'base'}, T::UseFixBase::do_fix_base({}); 43 | 44 | done_testing 8; 45 | 46 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-move_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::move_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('old', 'new')->fix({old => 'old'}), 16 | {new => 'old'}, 17 | "move field at root"; 18 | 19 | is_deeply 20 | $pkg->new('old', 'deeply.nested.$append.new')->fix({old => 'old'}), 21 | {deeply => {nested => [{new => 'old'}]}}, 22 | "move field creates intermediate path"; 23 | 24 | is_deeply 25 | $pkg->new('old', 'new.$prepend')->fix({old => 'hello',new => ['world']}), 26 | {new => ['hello','world']} , 27 | "move field creates intermediate path"; 28 | 29 | is_deeply 30 | $pkg->new('old', 'new.$append')->fix({old => 'hello',new => ['world']}), 31 | {new => ['world','hello']} , 32 | "move field creates intermediate path"; 33 | 34 | done_testing 5; 35 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/all_match.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::all_match; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has pattern => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::Condition::SimpleAllTest'; 15 | 16 | sub emit_test { 17 | my ($self, $var, $parser) = @_; 18 | "is_value(${var}) && ${var} =~ ".$parser->emit_match($self->pattern); 19 | } 20 | 21 | 1; 22 | 23 | __END__ 24 | 25 | =pod 26 | 27 | =head1 NAME 28 | 29 | Catmandu::Fix::Condition::all_match - only execute fixes if all path values match the given regex 30 | 31 | =head1 SYNOPSIS 32 | 33 | # uppercase the value of field 'foo' if all members of 'oogly' have the value 'doogly' 34 | if all_match(oogly.*, "doogly") 35 | upcase(foo) # foo => 'BAR' 36 | end 37 | 38 | =head1 SEE ALSO 39 | 40 | L 41 | 42 | =cut 43 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-export.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester::CaptureExternal; 8 | use JSON::XS; 9 | use utf8; 10 | 11 | my $pkg; 12 | BEGIN { 13 | $pkg = 'Catmandu::Cmd::export'; 14 | use_ok $pkg; 15 | } 16 | require_ok $pkg; 17 | 18 | use Catmandu::CLI; 19 | 20 | my $result = test_app(qq|Catmandu::CLI| => [ qw(export -v test to JSON --line-delimited 1 --fix t/myfixes.fix --total 1) ]); 21 | 22 | my @lines = split(/\n/, $result->stdout); 23 | 24 | ok @lines == 1 , 'test total'; 25 | 26 | my $perl = decode_json($lines[0]); 27 | 28 | ok $perl, 'got JSON'; 29 | is $perl->{value} , 'Sol' , 'got data'; 30 | is $perl->{utf8_name} , 'ვეპხის ტყაოსანი შოთა რუსთაველი' , 'got utf8 data'; 31 | is $result->error, undef, 'threw no exceptions'; 32 | 33 | # next test can fail on buggy Perl installations 34 | #is $result->stderr, '', 'nothing sent to sderr'; 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/Catmandu-Importer-YAML.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use utf8; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Importer::YAML'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $data = [ 17 | {name=>'Patrick',age=>'39'}, 18 | {name=>'Nicolas',age=>'34'}, 19 | {name=>'村上 春樹',age=>'65'}, 20 | ]; 21 | 22 | my $yaml = <new(file => \$yaml); 36 | 37 | isa_ok $importer, $pkg; 38 | 39 | my $arr = $importer->to_array; 40 | is_deeply $arr, $data, 'checking correct import'; 41 | 42 | is $arr->[2]->{name} , '村上 春樹' , 'checking utf8 issues'; 43 | 44 | $importer = $pkg->new(file => 't/non_ascii.yaml'); 45 | 46 | is $importer->count, 1000 , 'parsed non ascii file'; 47 | 48 | done_testing 6; 49 | 50 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/reverse.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::reverse; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var, $fixer) = @_; 17 | 18 | "if (is_array_ref(${var})) {" 19 | ."${var} = [reverse(\@{${var}})];" 20 | ."}" 21 | ."elsif (is_string(${var})) {" 22 | ."${var} = scalar(reverse(${var}));" 23 | ."}"; 24 | } 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =head1 NAME 33 | 34 | Catmandu::Fix::reverse - reverse a string or an array 35 | 36 | =head1 SYNOPSIS 37 | 38 | # {author => "tom jones"} 39 | reverse(author) 40 | # {author => "senoj mot"} 41 | 42 | # {numbers => [1,14,2]} 43 | reverse(numbers) 44 | # {numbers => [2,14,1]} 45 | 46 | =head1 SEE ALSO 47 | 48 | L 49 | 50 | =cut 51 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/uri_encode.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::uri_encode; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use URI::Escape (); 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has path => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var) = @_; 18 | "${var} = URI::Escape::uri_escape_utf8(${var});"; 19 | } 20 | 21 | 1; 22 | 23 | __END__ 24 | 25 | =pod 26 | 27 | =encoding utf8 28 | 29 | =head1 NAME 30 | 31 | Catmandu::Fix::uri_encode - percent encode a URI 32 | 33 | =head1 SYNOPSIS 34 | 35 | # 'café' => '3%A9' 36 | uri_encode(place) 37 | 38 | # 'ὁ τῶν Πέρσων βασιλεύς' => '%E1%BD%81+%CF%84%E1%BF%B6%CE%BD+%CE%A0%CE%AD%CF%81%CF%83%CF%89%CE%BD+%CE%B2%CE%B1%CF%83%CE%B9%CE%BB%CE%B5%CF%8D%CF%82' 39 | uri_encode(title) 40 | 41 | =head1 SEE ALSO 42 | 43 | L, L, L 44 | 45 | =cut 46 | 47 | -------------------------------------------------------------------------------- /t/Catmandu-Env.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Env'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $env = Catmandu::Env->new(load_paths => [qw(t/)]); 16 | 17 | ok $env , qq|new|; 18 | like $env->root , qr/t$/ , 'got root'; 19 | isa_ok $env->store , qq|Catmandu::Store::Hash| , qq|store()|; 20 | isa_ok $env->store('hash') , qq|Catmandu::Store::Hash| , qq|store(hash)|; 21 | isa_ok $env->fixer , qq|Catmandu::Fix| , qq|fixer|; 22 | isa_ok $env->fixer('other') , qq|Catmandu::Fix| , qq|fixer(other)|; 23 | isa_ok $env->importer , qq|Catmandu::Importer::YAML| , qq|importer()|; 24 | isa_ok $env->importer('mock') , qq|Catmandu::Importer::Mock| , qq|importer(mock)|; 25 | isa_ok $env->exporter , qq|Catmandu::Exporter::YAML| , qq|importer()|; 26 | isa_ok $env->exporter('csv') , qq|Catmandu::Exporter::CSV| , qq|importer(csv)|; 27 | 28 | done_testing 12; -------------------------------------------------------------------------------- /lib/Catmandu/Serializer/json.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Serializer::json; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use JSON::XS (); 8 | use Moo; 9 | use namespace::clean; 10 | 11 | sub serialize { 12 | JSON::XS::encode_json($_[1]); 13 | } 14 | 15 | sub deserialize { 16 | JSON::XS::decode_json($_[1]); 17 | } 18 | 19 | 1; 20 | 21 | __END__ 22 | 23 | =pod 24 | 25 | =head1 NAME 26 | 27 | Catmandu::Serializer - A (de)serializer from and to json 28 | 29 | =head1 SYNOPSIS 30 | 31 | package MyPackage; 32 | 33 | use Moo; 34 | 35 | with 'Catmandu::Serializer'; 36 | 37 | # You have now serialize and deserialize methods available 38 | 39 | package main; 40 | 41 | my $obj = MyPackage->new; 42 | my $obj = MyPackage->new(serializer => 'json'); 43 | 44 | $obj->serialize( { foo => 'bar' } ); # JSON 45 | $obj->deserialize( "{'foo':'bar'}" ); # Perl 46 | 47 | =head1 SEE ALSO 48 | 49 | L 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/code.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::code; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Util qw(is_code_ref); 8 | use Moo; 9 | 10 | has code => ( 11 | is => 'ro', 12 | default => sub { return sub { } }, 13 | isa => sub { 14 | die "code must be a CODE reference" unless is_code_ref($_[0]) 15 | } 16 | ); 17 | 18 | around BUILDARGS => sub { 19 | my ($orig, $class, $code) = @_; 20 | $orig->($class, code => $code); 21 | }; 22 | 23 | sub fix { 24 | my ($self, $data) = @_; 25 | $self->code->($data); 26 | } 27 | 28 | 1; 29 | 30 | __END__ 31 | 32 | =pod 33 | 34 | =head1 NAME 35 | 36 | Catmandu::Fix::code - run arbitrary code as fix 37 | 38 | =head1 SYNOPSIS 39 | 40 | my $fix = Catmandu::Fix::code->new( sub { 41 | my ($data) = @_; 42 | # ...do something 43 | return $data; 44 | }); 45 | 46 | =head1 SEE ALSO 47 | 48 | L, L 49 | 50 | =cut 51 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/join_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::join_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has join_char => (fix_arg => 1, default => sub { '' }); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $join_char = $fixer->emit_string($self->join_char); 19 | 20 | "if (is_array_ref(${var})) {". 21 | "${var} = join(${join_char}, grep { is_value(\$_) } \@{${var}});". 22 | "}"; 23 | } 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Catmandu::Fix::join_field - join the ARRAY values of a field into a string 34 | 35 | =head1 SYNOPSIS 36 | 37 | # Join the array values of a field into a string. E.g. foo => [1,2,3] 38 | join_field(foo, /) # foo => "1/2/3" 39 | 40 | =head1 SEE ALSO 41 | 42 | L 43 | 44 | =cut 45 | -------------------------------------------------------------------------------- /lib/Catmandu/Transactional.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Transactional; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo::Role; 8 | use namespace::clean; 9 | 10 | requires 'transaction'; 11 | 12 | 1; 13 | 14 | __END__ 15 | 16 | =pod 17 | 18 | =head1 NAME 19 | 20 | Catmandu::Transactional - Optional role for transactional stores 21 | 22 | =head1 SYNOPSIS 23 | 24 | # bag will be untouched 25 | my $store->transaction(sub { 26 | $store->bag('books')->add({title => 'Time must have a stop'}); 27 | die; 28 | }); 29 | 30 | =head1 METHODS 31 | 32 | =head2 transaction($sub) 33 | 34 | C takes a coderef that will be executed in the context of a 35 | transaction. If an error is thrown, the transaction will rollback. If the code 36 | executes successfully, the transaction will be committed. There is no support 37 | for nested transactions, nested calls to C will simply be subsumed 38 | by their parent transaction. 39 | 40 | =cut 41 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/uri_decode.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::uri_decode; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Encode (); 9 | use URI::Escape (); 10 | use namespace::clean; 11 | use Catmandu::Fix::Has; 12 | 13 | has path => (fix_arg => 1); 14 | 15 | with 'Catmandu::Fix::SimpleGetValue'; 16 | 17 | sub emit_value { 18 | my ($self, $var) = @_; 19 | "${var} = Encode::decode_utf8(URI::Escape::uri_unescape(${var}));"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =encoding utf8 29 | 30 | =head1 NAME 31 | 32 | Catmandu::Fix::uri_decode - percent decode a URI 33 | 34 | =head1 SYNOPSIS 35 | 36 | # '3%A9' => 'café' 37 | uri_decode(place) 38 | 39 | # '%E1%BD%81+%CF%84%E1%BF%B6%CE%BD+%CE%A0%CE%AD%CF%81%CF%83%CF%89%CE%BD+%CE%B2%CE%B1%CF%83%CE%B9%CE%BB%CE%B5%CF%8D%CF%82' => 'ὁ τῶν Πέρσων βασιλεύς' 40 | uri_decode(title) 41 | 42 | =head1 SEE ALSO 43 | 44 | L, L, L 45 | 46 | =cut 47 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/retain_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::retain_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has path => (fix_arg => 1); 14 | 15 | sub emit { 16 | my ($self, $fixer) = @_; 17 | my $path = $fixer->split_path($self->path); 18 | my $key = pop @$path; 19 | 20 | $fixer->emit_walk_path($fixer->var, $path, sub { 21 | my $var = shift; 22 | $fixer->emit_retain_key($var, $key); 23 | }); 24 | } 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =head1 NAME 33 | 34 | Catmandu::Fix::retain_field - delete everything from a field except 35 | 36 | =head1 DEPRECIATION NOTICE 37 | 38 | This fix is deprecated, Please use L instead. 39 | 40 | =head1 SYNOPSIS 41 | 42 | # Delete every key from foo except bar 43 | retain_field(foo.bar) 44 | 45 | =head1 SEE ALSO 46 | 47 | L 48 | 49 | =cut 50 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-convert.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester::CaptureExternal; 8 | use JSON::XS; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Cmd::convert'; 13 | use_ok $pkg; 14 | } 15 | require_ok $pkg; 16 | 17 | use Catmandu::CLI; 18 | 19 | my $result = test_app(qq|Catmandu::CLI| => [ qw(convert -v YAML --file t/catmandu.yml to JSON) ]); 20 | 21 | my $perl = decode_json($result->stdout); 22 | 23 | ok $perl, 'got JSON'; 24 | is $perl->[0]->{importer}{default}{package}, 'YAML', 'got data'; 25 | is $result->error, undef, 'threw no exceptions'; 26 | # next test can fail on buggy Perl installations 27 | #is $result->stderr, '', 'nothing sent to sderr'; 28 | 29 | $result = test_app(qq|Catmandu::CLI| => ['convert', '-v', '--start=2' ,'--total=1', 'CSV', '--file', 't/planets.csv', 'to', 'CSV', '--header', '0', '--fields', 'english,latin']); 30 | is $result->stdout, "Moon,Luna\n", 'start and limit' ; 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-set_array.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::set_array'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('job')->fix({}), 16 | {job => []}, 17 | "set array at root"; 18 | 19 | is_deeply 20 | $pkg->new('deeply.nested.$append.job')->fix({}), 21 | {}, 22 | "set array doesn't create intermediate path"; 23 | 24 | is_deeply 25 | $pkg->new('deeply.nested.*.job')->fix({deeply => {nested => [undef, {}]}}), 26 | {deeply => {nested => [undef, {job => []}]}}, 27 | "set deeply nested array"; 28 | 29 | is_deeply 30 | $pkg->new('deeply.nested.$append.job')->fix({deeply => {nested => {}}}), 31 | {deeply => {nested => {}}}, 32 | "only set array if the path matches"; 33 | 34 | is_deeply 35 | $pkg->new('job', 1, "foo", 2)->fix({}), 36 | {job => [1, "foo", 2]}, 37 | "set array with initial contents"; 38 | 39 | done_testing 6; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-set_hash.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::set_hash'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('job')->fix({}), 16 | {job => {}}, 17 | "set hash at root"; 18 | 19 | is_deeply 20 | $pkg->new('deeply.nested.$append.job')->fix({}), 21 | {}, 22 | "set hash doesn't create intermediate path"; 23 | 24 | is_deeply 25 | $pkg->new('deeply.nested.*.job')->fix({deeply => {nested => [undef, {}]}}), 26 | {deeply => {nested => [undef, {job => {}}]}}, 27 | "set deeply nested hash"; 28 | 29 | is_deeply 30 | $pkg->new('deeply.nested.$append.job')->fix({deeply => {nested => {}}}), 31 | {deeply => {nested => {}}}, 32 | "only set hash if the path matches"; 33 | 34 | is_deeply 35 | $pkg->new('job', 'a', 'b', 'c', 'd')->fix({}), 36 | {job => {'a' => 'b', 'c' => 'd'}}, 37 | "set hash with initial contents"; 38 | 39 | 40 | done_testing 6; 41 | -------------------------------------------------------------------------------- /t/Catmandu-Importer-JSON.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Importer::JSON'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $data = [ 16 | {name=>'Patrick',age=>'39'}, 17 | {name=>'Nicolas',age=>'34'}, 18 | ]; 19 | 20 | my $json = <new(file => \$json); 26 | 27 | isa_ok $importer, $pkg; 28 | 29 | is_deeply $importer->to_array, $data; 30 | 31 | $json = <new(file => \$json); 39 | 40 | is_deeply $importer->to_array, $data; 41 | 42 | $json = <new(file => \$json); 48 | 49 | is_deeply $importer->to_array, $data; 50 | 51 | done_testing; 52 | -------------------------------------------------------------------------------- /t/Catmandu-ArrayIterator.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::ArrayIterator'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $arr = [{n=>1}, {n=>2}, {n=>3}]; 15 | my $it = $pkg->new($arr); 16 | 17 | ok $it->does('Catmandu::Iterable'); 18 | 19 | is_deeply [@{$it}], $arr; 20 | 21 | is $it->count, 3; 22 | 23 | is_deeply $it->first, $arr->[0]; 24 | 25 | is $it->contains({n=>2}), 1; 26 | 27 | is $it->contains(10), 0; 28 | 29 | # test external iteration again because of circular dependency 30 | is_deeply $it->next, {n=>1}; 31 | is_deeply $it->next, {n=>2}; 32 | $it->rewind; 33 | is_deeply $it->next, {n=>1}; 34 | 35 | $it->rewind; 36 | 37 | my $count = 0; 38 | $it->each(sub { 39 | is shift->{n} , ++$count , "each ($count)"; 40 | }); 41 | 42 | $it->rewind; 43 | 44 | $count = 0; 45 | $it->each_until(sub { 46 | is shift->{n} , ++$count , "each ($count)"; 47 | return $count == 2 ? undef : 1; 48 | }); 49 | 50 | done_testing 15; 51 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/replace_all.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::replace_all; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has search => (fix_arg => 1); 13 | has replace => (fix_arg => 1); 14 | 15 | with 'Catmandu::Fix::SimpleGetValue'; 16 | 17 | sub emit_value { 18 | my ($self, $var, $fixer) = @_; 19 | 20 | "if (is_value(${var})) {" 21 | ."utf8::upgrade(${var});" 22 | ."${var} =~ ".$fixer->emit_substitution($self->search, $self->replace)."g;" 23 | ."}"; 24 | } 25 | 26 | 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =head1 NAME 33 | 34 | Catmandu::Fix::replace_all - search and replace using regex expressions 35 | 36 | =head1 SYNOPSIS 37 | 38 | # Extract a substring out of the value of a field 39 | # {author => "tom jones"} 40 | replace_all(author, '([^ ]+) ([^ ]+)', '$2, $1') 41 | # {author => "jones, tom"} 42 | 43 | =head1 SEE ALSO 44 | 45 | L 46 | 47 | =cut 48 | -------------------------------------------------------------------------------- /t/Catmandu-Importer-TSV.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Importer::TSV'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $data = [ 16 | {name=>'Patrick',age=>'44'}, 17 | {name=>'Nicolas',age=>'39'}, 18 | ]; 19 | 20 | my $tsv = <new(file => \$tsv); 27 | 28 | isa_ok $importer, $pkg; 29 | 30 | is_deeply $importer->to_array, $data; 31 | 32 | $data = [ 33 | {0=>'Patrick',1=>'44'}, 34 | {0=>'Nicolas',1=>'39'}, 35 | ]; 36 | 37 | $tsv = <new(file => \$tsv, header => 0); 43 | 44 | is_deeply $importer->to_array, $data; 45 | 46 | $tsv = <new(file => \$tsv, header => 0, sep_char => ' '); 52 | 53 | is_deeply $importer->to_array, $data; 54 | 55 | done_testing; 56 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/hash.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::hash; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | 13 | with 'Catmandu::Fix::SimpleGetValue'; 14 | 15 | sub emit_value { 16 | my ($self, $var) = @_; 17 | "if (is_array_ref(${var})) {" . 18 | "${var} = {\@{${var}}};" . 19 | "}"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::hash - creates a hash out of an array 31 | 32 | =head1 SYNOPSIS 33 | 34 | # tags => ['name', 'Peter', 'age', 12] 35 | hash(tags) 36 | # tags => {name => 'Peter', age => 12} 37 | 38 | =head1 DESCRIPTION 39 | 40 | This fix functions transforms array fields to hashes. The number of array 41 | elements must be even and fields to be used as field values must be simple 42 | strings. String fields and hash fields are left unchanged. 43 | 44 | =head1 SEE ALSO 45 | 46 | L, L 47 | 48 | =cut 49 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-add_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::add_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('job', 'fixer')->fix({}), 16 | {job => "fixer"}, 17 | "add field at root"; 18 | 19 | is_deeply 20 | $pkg->new('deeply.nested.$append.job', 'fixer')->fix({}), 21 | {deeply => {nested => [{job => "fixer"}]}}, 22 | "add field creates intermediate path"; 23 | 24 | is_deeply 25 | $pkg->new('deeply.nested.1.job', 'fixer')->fix({}), 26 | {deeply => {nested => [undef, {job => "fixer"}]}}, 27 | "add field creates intermediate path"; 28 | 29 | is_deeply 30 | $pkg->new('deeply.nested.$append.job', 'fixer')->fix({deeply => {nested => {}}}), 31 | {deeply => {nested => {}}}, 32 | "only add field if the path matches"; 33 | 34 | is_deeply 35 | $pkg->new('test', '0123')->fix({}), 36 | {test => '0123'}, 37 | "add a number"; 38 | 39 | done_testing 6; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-set_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::set_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('job', 'fixer')->fix({}), 16 | {job => "fixer"}, 17 | "set field at root"; 18 | 19 | is_deeply 20 | $pkg->new('deeply.nested.$append.job', 'fixer')->fix({}), 21 | {}, 22 | "set field doesn't create intermediate path"; 23 | 24 | is_deeply 25 | $pkg->new('deeply.nested.*.job', 'fixer')->fix({deeply => {nested => [undef, {}]}}), 26 | {deeply => {nested => [undef, {job => "fixer"}]}}, 27 | "set deeply nested field"; 28 | 29 | is_deeply 30 | $pkg->new('deeply.nested.$append.job', 'fixer')->fix({deeply => {nested => {}}}), 31 | {deeply => {nested => {}}}, 32 | "only set field if the path matches"; 33 | 34 | is_deeply 35 | $pkg->new('test', '0123')->fix({test => 'ok'}), 36 | {test => '0123'}, 37 | "set a number"; 38 | 39 | done_testing 6; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Bind-importer.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Exception; 6 | use Catmandu; 7 | use Capture::Tiny ':all'; 8 | use Catmandu::Util qw(:is); 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Fix::Bind::importer'; 13 | use_ok $pkg; 14 | } 15 | require_ok $pkg; 16 | 17 | { 18 | my ($stdout, $stderr, $exit) = capture { 19 | my $fixer = Catmandu->fixer('do importer(Mock,size:1) add_to_exporter(.,JSON) end'); 20 | $fixer->fix({}); 21 | }; 22 | 23 | is $stdout, qq|[{"n":0}]\n| , 'fixed ok'; 24 | } 25 | 26 | { 27 | my ($stdout, $stderr, $exit) = capture { 28 | my $fixer = Catmandu->fixer('do importer(Mock,size:1) reject() end'); 29 | $fixer->fix({}); 30 | }; 31 | 32 | is $stdout, qq||, 'fixed ok'; 33 | } 34 | 35 | { 36 | my ($stdout, $stderr, $exit) = capture { 37 | my $fixer = Catmandu->fixer('do importer(Mock,size:1) select exists(n) end'); 38 | $fixer->fix({}); 39 | }; 40 | 41 | is $stdout, qq||, 'fixed ok'; 42 | } 43 | 44 | done_testing; 45 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/reject.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::reject; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Fix::Base'; 11 | 12 | sub emit { 13 | my ($self, $fixer) = @_; 14 | $fixer->emit_reject; 15 | } 16 | 17 | 1; 18 | 19 | __END__ 20 | 21 | =pod 22 | 23 | =head1 NAME 24 | 25 | Catmandu::Fix::reject - remove a record form the data 26 | 27 | =head1 SYNOPSIS 28 | 29 | # Reject all items from from the output 30 | reject() 31 | 32 | # Reject all items with have an 'ignore_me' field 33 | reject exists(ignore_me) 34 | 35 | # Reject all items with have a 'ignore' field with value 'true' 36 | reject all_match(ignore,true) 37 | 38 | # Select all items 39 | select() 40 | 41 | # Select only those items that have an 'include_me' field 42 | select exists(include_me) 43 | 44 | # Select only those items that have an 'include' field with value 'true' 45 | select all_match(include,true) 46 | 47 | =head1 SEE ALSO 48 | 49 | L 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/less_than.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::less_than; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has value => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::Condition::SimpleAllTest'; 15 | 16 | sub emit_test { 17 | my ($self, $var) = @_; 18 | my $value = $self->value; 19 | "is_value(${var}) && ${var} < int('$value')"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::Condition::less_than - Excute fixes when a field is less than a value 31 | 32 | =head1 SYNOPSIS 33 | 34 | # less_than(X,Y) is true when X < Y 35 | if less_than('year','2018') 36 | add_field('my.funny.title','true') 37 | end 38 | 39 | # less_than on arrays checks if all values are X < Y 40 | if less_than('years.*','2018') 41 | add_field('my.funny.title','true') 42 | end 43 | 44 | =head1 SEE ALSO 45 | 46 | L 47 | 48 | =cut 49 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-Multi.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use JSON::XS (); 8 | use Catmandu::Exporter::JSON; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Exporter::Multi'; 13 | use_ok $pkg; 14 | } 15 | require_ok $pkg; 16 | 17 | my $data = [{'a' => 'moose'}, {'a' => 'pony'}, {'a' => 'shrimp'}]; 18 | my $file1 = ""; 19 | my $file2 = ""; 20 | my $exporter1 = Catmandu::Exporter::JSON->new(file => \$file1, line_delimited => 1); 21 | my $exporter2 = Catmandu::Exporter::JSON->new(file => \$file2, line_delimited => 1); 22 | 23 | my $exporter = $pkg->new(exporters => [ 24 | $exporter1, 25 | $exporter2, 26 | ]); 27 | 28 | isa_ok $exporter, $pkg; 29 | 30 | $exporter->add_many($data); 31 | $exporter->commit; 32 | 33 | is $exporter1->count, 3; 34 | is $exporter2->count, 3; 35 | is $exporter->count, 3; 36 | is_deeply $data, [ map { JSON::XS::decode_json($_) } split /[\r\n]+/, $file1 ]; 37 | is_deeply $data, [ map { JSON::XS::decode_json($_) } split /[\r\n]+/, $file2 ]; 38 | 39 | done_testing; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Searchable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Searchable'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | { 16 | package T::SearchableWithoutGenerator; 17 | use Moo; 18 | 19 | package T::Searchable; 20 | use Moo; 21 | with $pkg; 22 | 23 | sub search { die "not implemented" } 24 | sub searcher { die "not implemented" } 25 | sub delete_by_query { die "not implemented" } 26 | sub translate_cql_query { die "not implemented" } 27 | sub translate_sru_sortkeys { die "not implemented" } 28 | } 29 | 30 | throws_ok { Role::Tiny->apply_role_to_package('T::SearchableWithoutGenerator', $pkg) } qr/missing translate_sru_sortkeys, translate_cql_query, search, searcher, delete_by_query/; 31 | 32 | my $iter = T::Searchable->new(); 33 | 34 | is $iter->default_default_limit , 10 ; 35 | is $iter->default_maximum_limit , 1000; 36 | is $iter->normalize_query("foo bar") , "foo bar"; 37 | 38 | done_testing 6; 39 | 40 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/greater_than.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::greater_than; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has value => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::Condition::SimpleAllTest'; 15 | 16 | sub emit_test { 17 | my ($self, $var) = @_; 18 | my $value = $self->value; 19 | "is_value(${var}) && ${var} > int('$value')"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::Condition::greater_than - Excute fixes when a field is greater than a value 31 | 32 | =head1 SYNOPSIS 33 | 34 | # greater_than(X,Y) is true when X > Y 35 | if greater_than('year','2018') 36 | add_field('my.funny.title','true') 37 | end 38 | 39 | # greater_than on arrays checks if all values are X > Y 40 | if greater_than('years.*','2018') 41 | add_field('my.funny.title','true') 42 | end 43 | 44 | =head1 SEE ALSO 45 | 46 | L 47 | 48 | =cut 49 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/drop.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::drop; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu; 9 | use Catmandu::Util qw(check_able); 10 | use namespace::clean; 11 | 12 | sub command_opt_spec { 13 | ( 14 | [ "bag=s", "drop a bag" ], 15 | ); 16 | } 17 | 18 | sub command { 19 | my ($self, $opts, $args) = @_; 20 | 21 | my ($from_args, $from_opts) = $self->_parse_options($args); 22 | 23 | my $from = Catmandu->store($from_args->[0], $from_opts); 24 | if ($opts->bag) { 25 | check_able($from->bag($opts->bag), 'drop')->drop; 26 | } else { 27 | check_able($from, 'drop')->drop; 28 | } 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 NAME 38 | 39 | Catmandu::Cmd::drop - drop a store or one of it's bags 40 | 41 | =head1 EXAMPLES 42 | 43 | catmandu drop 44 | 45 | # drop the whole store 46 | catmandu drop ElasticSearch --index-name items 47 | # drop a single bag 48 | catmandu drop ElasticSearch --index-name items --bag thingies 49 | 50 | =cut 51 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo::Role; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Fix::Base'; 11 | 12 | has pass_fixes => (is => 'rw', default => sub { [] }); 13 | has fail_fixes => (is => 'rw', default => sub { [] }); 14 | 15 | 1; 16 | 17 | __END__ 18 | 19 | =pod 20 | 21 | =head1 NAME 22 | 23 | Catmandu::Fix::Condition - Role for all Catmandu::Fix conditionals 24 | 25 | =head1 SYNOPSIS 26 | 27 | if 28 | 29 | else 30 | 31 | end 32 | 33 | =head1 DESCRIPTION 34 | 35 | All Catmandu::Fix conditional need to implement Catmandu::Fix::Condition which provides 36 | a list of fixes that need to be executed when a conditional matches (pass_fixes) and 37 | conditional that need to be executed when a conditional fails (fail_fixes). 38 | 39 | =head1 SEE ALSO 40 | 41 | L, 42 | L, 43 | L, 44 | L, 45 | 46 | =cut 47 | -------------------------------------------------------------------------------- /lib/Catmandu/IdGenerator/Mock.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::IdGenerator::Mock; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Catmandu::Util qw(check_natural); 9 | use namespace::clean; 10 | 11 | with 'Catmandu::IdGenerator'; 12 | 13 | has first_id => ( 14 | is => 'ro', 15 | isa => sub { check_natural($_[0]) }, 16 | default => sub { 0 }, 17 | ); 18 | 19 | has next_id => ( 20 | is => 'rwp', 21 | init_arg => undef, 22 | lazy => 1, 23 | builder => 'first_id', 24 | ); 25 | 26 | sub generate { 27 | my ($self) = @_; 28 | my $id = $self->next_id; 29 | $self->_set_next_id($id + 1); 30 | $id; 31 | } 32 | 33 | 1; 34 | 35 | __END__ 36 | 37 | =pod 38 | 39 | =head1 NAME 40 | 41 | Catmandu::IdGenerator::Mock - Generator of increasing identifiers 42 | 43 | =head1 SYNOPSIS 44 | 45 | use Catmandu::IdGenerator::Mock; 46 | 47 | my $x = Catmandu::IdGenerator::Mock->new(first_id => 10); 48 | 49 | for (1..100) { 50 | printf "id: %s\n" m $x->generate; 51 | } 52 | 53 | =head1 SEE ALSO 54 | 55 | L 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-join_field.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::join_field'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('joinme', ',')->fix({joinme => ['J', 'O', 'I', 'N']}), 16 | {joinme => "J,O,I,N"}, 17 | "join value"; 18 | 19 | is_deeply 20 | $pkg->new('many.*.joinme', ',')->fix({many => [{joinme => ['J', 'O', 'I', 'N']}, {joinme => ['J', 'O', 'I', 'N']}]}), 21 | {many => [{joinme => "J,O,I,N"}, {joinme => "J,O,I,N"}]}, 22 | "join wildcard values"; 23 | 24 | is_deeply 25 | $pkg->new('joinme', ',')->fix({joinme => {skip => 'me'}}), 26 | {joinme => {skip => 'me'}}, 27 | "only join array values"; 28 | 29 | is_deeply 30 | $pkg->new('joinme', ',')->fix({joinme => ['J', {skip => 'me'}, 'I', 'N']}), 31 | {joinme => "J,I,N"}, 32 | "only join array values"; 33 | 34 | is_deeply 35 | $pkg->new('joinme', '/')->fix({joinme => ['J', 'O', 'I', 'N']}), 36 | {joinme => "J/O/I/N"}, 37 | "join value"; 38 | 39 | done_testing 6; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Importer-CSV.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Importer::CSV'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $data = [ 16 | {name=>'Patrick',age=>'39'}, 17 | {name=>'Nicolas',age=>'34'}, 18 | ]; 19 | 20 | my $csv = <new(file => \$csv); 27 | 28 | isa_ok $importer, $pkg; 29 | 30 | is_deeply $importer->to_array, $data; 31 | 32 | $data = [ 33 | {0=>'Patrick',1=>'39'}, 34 | {0=>'Nicolas',1=>'34'}, 35 | ]; 36 | 37 | $csv = <new(file => \$csv, header => 0); 43 | 44 | is_deeply $importer->to_array, $data; 45 | 46 | $data = [ 47 | {name=>'Nicolas',age=>'34'}, 48 | ]; 49 | 50 | $csv = <new(file => \$csv, sep_char => '\t'); 56 | 57 | is_deeply $importer->to_array, $data; 58 | 59 | done_testing; 60 | 61 | -------------------------------------------------------------------------------- /t/Catmandu-Buffer.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Buffer'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | { 16 | package T::Buffer; 17 | use Moo; 18 | with $pkg; 19 | } 20 | 21 | my $b = T::Buffer->new; 22 | 23 | can_ok $b, 'buffer_size'; 24 | can_ok $b, 'buffer'; 25 | can_ok $b, 'default_buffer_size'; 26 | can_ok $b, 'buffer_used'; 27 | can_ok $b, 'buffer_is_full'; 28 | can_ok $b, 'buffer_add'; 29 | can_ok $b, 'clear_buffer'; 30 | 31 | is $b->buffer_size, $b->default_buffer_size; 32 | 33 | $b = T::Buffer->new(buffer_size => 5); 34 | is $b->buffer_size, 5; 35 | is $b->buffer_used, 0; 36 | 37 | $b->buffer_add(1,2,3); 38 | is $b->buffer_used, 3; 39 | is_deeply $b->buffer, [1,2,3]; 40 | is $b->buffer_is_full, 0; 41 | 42 | $b->buffer_add(4,5,6); 43 | is $b->buffer_used, 6; 44 | is_deeply $b->buffer, [1,2,3,4,5,6]; 45 | is $b->buffer_is_full, 1; 46 | 47 | $b->clear_buffer; 48 | is $b->buffer_used, 0; 49 | is_deeply $b->buffer, []; 50 | is $b->buffer_is_full, 0; 51 | 52 | done_testing 21; 53 | 54 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd-info.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd::info'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | my $result; 19 | 20 | $result = test_app(qq|Catmandu::CLI| => [ qw(info) ]); 21 | 22 | is $result->error, undef, 'threw no exceptions' ; 23 | 24 | $result = test_app(qq|Catmandu::CLI| => [ qw(info --exporters) ]); 25 | 26 | is $result->error, undef, 'threw no exceptions' ; 27 | 28 | $result = test_app(qq|Catmandu::CLI| => [ qw(info --importers) ]); 29 | 30 | is $result->error, undef, 'threw no exceptions' ; 31 | 32 | $result = test_app(qq|Catmandu::CLI| => [ qw(info --fixes) ]); 33 | 34 | is $result->error, undef, 'threw no exceptions' ; 35 | 36 | $result = test_app(qq|Catmandu::CLI| => [ qw(info --stores) ]); 37 | 38 | is $result->error, undef, 'threw no exceptions' ; 39 | 40 | $result = test_app(qq|Catmandu::CLI| => [ qw(info --fixes to JSON) ]); 41 | 42 | is $result->error, undef, 'threw no exceptions' ; 43 | 44 | done_testing 8; -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-all_equal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Catmandu::Fix::set_field; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::Condition::all_equal'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $cond = $pkg->new('string', 'foo'); 15 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 16 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 17 | 18 | is_deeply 19 | $cond->fix({string => 'foo'}), 20 | { string => 'foo', test => 'pass'}; 21 | 22 | is_deeply 23 | $cond->fix({string => 'foobar'}), 24 | { string => 'foobar', test => 'fail'}; 25 | 26 | $cond = $pkg->new( 'string.*', 'foo'); 27 | 28 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 29 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 30 | 31 | is_deeply 32 | $cond->fix({string => [ 'foo', 'foo' ]}), 33 | { string => [ 'foo', 'foo' ], test => 'pass'}; 34 | 35 | is_deeply 36 | $cond->fix({string => [ 'foo', 'foobar' ]}), 37 | { string => [ 'foo', 'foobar' ], test => 'fail'}; 38 | 39 | done_testing 5; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-any_equal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Catmandu::Fix::set_field; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::Condition::any_equal'; 11 | use_ok $pkg; 12 | } 13 | 14 | my $cond = $pkg->new('string', 'foo'); 15 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 16 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 17 | 18 | is_deeply 19 | $cond->fix({string => 'foo'}), 20 | { string => 'foo', test => 'pass'}; 21 | 22 | is_deeply 23 | $cond->fix({string => 'foobar'}), 24 | { string => 'foobar', test => 'fail'}; 25 | 26 | $cond = $pkg->new( 'string.*', 'foo'); 27 | 28 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 29 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 30 | 31 | is_deeply 32 | $cond->fix({string => [ 'foo', 'foobar' ]}), 33 | { string => [ 'foo', 'foobar' ], test => 'pass'}; 34 | 35 | is_deeply 36 | $cond->fix({string => [ 'foo2', 'foobar' ]}), 37 | { string => [ 'foo2', 'foobar' ], test => 'fail'}; 38 | 39 | done_testing 5; 40 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/collapse.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::collapse; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Catmandu::Expander (); 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has sep => (fix_opt => 1, default => sub { undef }); 13 | 14 | sub fix { 15 | my ($self,$data) = @_; 16 | my $ref = Catmandu::Expander->collapse_hash($data); 17 | 18 | if (defined(my $char = $self->sep)) { 19 | my $new_ref = {}; 20 | for my $key (keys %$ref) { 21 | my $val = $ref->{$key}; 22 | $key =~ s{\.}{$char}g; 23 | $new_ref->{$key} = $val; 24 | } 25 | $ref = $new_ref; 26 | } 27 | 28 | $ref; 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 NAME 38 | 39 | Catmandu::Fix::collapse - convert nested data into a flat hash using the TT2 dot convention 40 | 41 | =head1 SYNOPSIS 42 | 43 | # Collapse the data into a flat hash 44 | collapse() 45 | 46 | # Collaps the data into a flat hash with '-' as path seperator 47 | collapse(-sep => '-') 48 | 49 | =head1 SEE ALSO 50 | 51 | L 52 | 53 | =cut 54 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | Christian Pietsch 2 | Dave Sherohman 3 | Dave Sherohman 4 | Jakob Voß 5 | Jakob Voß 6 | Johann Rolschewski 7 | Magnus Enger 8 | Nicolas Franck 9 | Nicolas Franck 10 | Nicolas Steenlant 11 | Nicolas Steenlant 12 | Nicolas Steenlant 13 | Patrick Hochstenbach 14 | Patrick Hochstenbach 15 | Patrick Hochstenbach 16 | Snorri Briem 17 | Upasana Shukla 18 | Vitali Peil 19 | -------------------------------------------------------------------------------- /t/Catmandu-Importer-Modules.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Exception; 5 | 6 | use_ok 'Catmandu::Importer::Modules'; 7 | require_ok 'Catmandu::Importer::Modules'; 8 | 9 | my @modules; 10 | 11 | ok Catmandu::Importer::Modules->new->first, 'default importer'; 12 | 13 | lives_ok sub{ 14 | @modules = @{ Catmandu::Importer::Modules->new( 15 | inc => ["lib"], 16 | namespace => "Catmandu::Fix", 17 | max_depth => 1, 18 | pattern => qr/add_field/ 19 | )->to_array } 20 | }; 21 | 22 | ok @modules > 0, 'imported with options'; 23 | is $modules[0]->{name}, 'Catmandu::Fix::add_field', 'name'; 24 | like $modules[0]->{about}, qr/^add or change the value of a HASH key/, 'about'; 25 | 26 | lives_ok sub{ 27 | @modules = @{ Catmandu::Importer::Modules->new( 28 | inc => ["lib"], 29 | namespace => "Catmandu::Importer,Catmandu::Exporter", 30 | max_depth => 1, 31 | pattern => qr/JSON/ 32 | )->to_array } 33 | }; 34 | 35 | is_deeply [ map { $_->{name} } @modules ], 36 | [qw(Catmandu::Importer::JSON Catmandu::Exporter::JSON)], 37 | "multiple namespaces"; 38 | 39 | done_testing; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-less_than.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Fix::set_field; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::Condition::less_than'; 12 | use_ok $pkg; 13 | } 14 | 15 | my $cond = $pkg->new('year','1970'); 16 | 17 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 18 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 19 | 20 | is_deeply 21 | $cond->fix({year => '1980'}), 22 | {year => '1980' , test => 'fail'}; 23 | 24 | is_deeply 25 | $cond->fix({year => '1960'}), 26 | {year => '1960' , test => 'pass'}; 27 | 28 | $cond = $pkg->new('a.deep.year','1970'); 29 | 30 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 31 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 32 | 33 | is_deeply 34 | $cond->fix({ a => { deep => {year => '1980'} } }), 35 | { a => { deep => {year => '1980'} } , test => 'fail'}; 36 | 37 | is_deeply 38 | $cond->fix({ a => { deep => {year => '1960'} } }), 39 | { a => { deep => {year => '1960'} } , test => 'pass'}; 40 | 41 | done_testing 5; 42 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-greater_than.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Fix::set_field; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Fix::Condition::greater_than'; 12 | use_ok $pkg; 13 | } 14 | 15 | my $cond = $pkg->new('year','1970'); 16 | 17 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 18 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 19 | 20 | is_deeply 21 | $cond->fix({year => '1980'}), 22 | {year => '1980' , test => 'pass'}; 23 | 24 | is_deeply 25 | $cond->fix({year => '1960'}), 26 | {year => '1960' , test => 'fail'}; 27 | 28 | $cond = $pkg->new('a.deep.year','1970'); 29 | 30 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 31 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 32 | 33 | is_deeply 34 | $cond->fix({ a => { deep => {year => '1980'} } }), 35 | { a => { deep => {year => '1980'} } , test => 'pass'}; 36 | 37 | is_deeply 38 | $cond->fix({ a => { deep => {year => '1960'} } }), 39 | { a => { deep => {year => '1960'} } , test => 'fail'}; 40 | 41 | done_testing 5; 42 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-is_true.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Fix::set_field; 8 | use JSON::XS; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Fix::Condition::is_true'; 13 | use_ok $pkg; 14 | } 15 | 16 | my $cond = $pkg->new('foo'); 17 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 18 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 19 | 20 | # Integers 21 | is_deeply 22 | $cond->fix({ foo => 1 }), 23 | {foo => 1 , test => 'pass'}; 24 | 25 | is_deeply 26 | $cond->fix({ foo => 0 }), 27 | {foo => 0 , test => 'fail'}; 28 | 29 | # Strings 30 | is_deeply 31 | $cond->fix({ foo => "true" }), 32 | {foo => "true" , test => 'pass'}; 33 | 34 | is_deeply 35 | $cond->fix({ foo => "false" }), 36 | {foo => "false" , test => 'fail'}; 37 | 38 | # Boolean 39 | my $hash = decode_json(qq|{"foo":true}|); 40 | is_deeply 41 | $cond->fix($hash), 42 | {%$hash , test => 'pass'}; 43 | 44 | my $hash2 = decode_json(qq|{"foo":false}|); 45 | is_deeply 46 | $cond->fix($hash2), 47 | {%$hash2 , test => 'fail'}; 48 | 49 | done_testing 7; -------------------------------------------------------------------------------- /t/Catmandu-IdGenerator-Mock.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::IdGenerator::Mock'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | { 16 | my $expected = [0..10]; 17 | my $generated = []; 18 | my $id_generator = $pkg->new; 19 | isa_ok $id_generator, $pkg; 20 | ok $id_generator->does("Catmandu::IdGenerator"), 21 | "an object of class '$pkg' does 'Catmandu::IdGenerator'"; 22 | push @$generated, map { $id_generator->generate } @$expected; 23 | is_deeply $generated, $expected, 24 | "generated ids correct (default first_id)"; 25 | } 26 | 27 | { 28 | my $expected = [5..20]; 29 | my $generated = []; 30 | my $id_generator = $pkg->new(first_id => $expected->[0]); 31 | isa_ok $id_generator, $pkg; 32 | ok $id_generator->does("Catmandu::IdGenerator"), 33 | "an object of class '$pkg' does 'Catmandu::IdGenerator'"; 34 | push @$generated, map { $id_generator->generate } @$expected; 35 | is_deeply $generated, $expected, 36 | "generated ids correct (custom first_id)"; 37 | } 38 | 39 | done_testing; 40 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-is_false.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Fix::set_field; 8 | use JSON::XS; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Fix::Condition::is_false'; 13 | use_ok $pkg; 14 | } 15 | 16 | my $cond = $pkg->new('foo'); 17 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 18 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 19 | 20 | # Integers 21 | is_deeply 22 | $cond->fix({ foo => 1 }), 23 | {foo => 1 , test => 'fail'}; 24 | 25 | is_deeply 26 | $cond->fix({ foo => 0 }), 27 | {foo => 0 , test => 'pass'}; 28 | 29 | # Strings 30 | is_deeply 31 | $cond->fix({ foo => "true" }), 32 | {foo => "true" , test => 'fail'}; 33 | 34 | is_deeply 35 | $cond->fix({ foo => "false" }), 36 | {foo => "false" , test => 'pass'}; 37 | 38 | # Boolean 39 | my $hash = decode_json(qq|{"foo":true}|); 40 | is_deeply 41 | $cond->fix($hash), 42 | {%$hash , test => 'fail'}; 43 | 44 | my $hash2 = decode_json(qq|{"foo":false}|); 45 | is_deeply 46 | $cond->fix($hash2), 47 | {%$hash2 , test => 'pass'}; 48 | 49 | done_testing 7; -------------------------------------------------------------------------------- /lib/Catmandu/Fix/expand.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::expand; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Expander (); 10 | use Catmandu::Fix::Has; 11 | 12 | has sep => (fix_opt => 1, default => sub { undef }); 13 | 14 | sub fix { 15 | my ($self,$data) = @_; 16 | 17 | if (defined(my $char = $self->sep)) { 18 | my $new_ref = {}; 19 | for my $key (keys %$data) { 20 | my $val = $data->{$key}; 21 | $key =~ s{$char}{\.}g; 22 | $new_ref->{$key} = $val; 23 | } 24 | 25 | $data = $new_ref; 26 | } 27 | 28 | Catmandu::Expander->expand_hash($data); 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 NAME 38 | 39 | Catmandu::Fix::expand - convert a flat hash into nested data using the TT2 dot convention 40 | 41 | =head1 SYNOPSIS 42 | 43 | # collapse the data into a flat hash 44 | collapse() 45 | 46 | # expand again to the nested original 47 | expand() 48 | 49 | # optionally provide a path separator 50 | collapse(-sep => '/') 51 | expand(-sep => '/') 52 | 53 | =head1 SEE ALSO 54 | 55 | L 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /lib/Catmandu/MultiIterator.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::MultiIterator; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Role::Tiny::With; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Iterable'; 11 | 12 | sub new { 13 | my ($class, @iterators) = @_; 14 | my $self = \@iterators; 15 | bless $self, $class; 16 | } 17 | 18 | sub generator { 19 | my ($self) = @_; 20 | sub { 21 | state $generators = [ map { $_->generator } @$self ]; 22 | while (@$generators) { 23 | my $data = $generators->[0]->(); 24 | return $data if defined $data; 25 | shift @$generators; 26 | } 27 | return; 28 | }; 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 NAME 38 | 39 | Catmandu::MultiIterator - chain multiple iterators together 40 | 41 | =head1 SYNOPSIS 42 | 43 | my $it = Catmandu::MultiIterator->new( 44 | Catmandu::Importer::Mock->new, 45 | Catmandu::Importer::Mock->new, 46 | ); 47 | 48 | # return all the items of each importer in turn 49 | $it->each(sub { 50 | # ... 51 | }); 52 | 53 | =head1 METHODS 54 | 55 | All L methods are available. 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-lookup_in_store.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | use Data::Dumper; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Fix::lookup_in_store'; 13 | use_ok $pkg; 14 | } 15 | 16 | require_ok $pkg; 17 | 18 | is_deeply 19 | $pkg->new('planet', 'test')->fix({planet => 'Earth'}), 20 | {planet => { _id => 'Earth' , value => 'Terra' } }; 21 | 22 | is_deeply 23 | $pkg->new('planet', 'test')->fix({planet => 'Bartledan'}), 24 | {planet => 'Bartledan'}; 25 | 26 | is_deeply 27 | $pkg->new('planet', 'test', 'delete', 1)->fix({planet => 'Bartledan'}), 28 | {}; 29 | 30 | is_deeply 31 | $pkg->new('planets.*', 'test', 'delete', 1)->fix({planets => ['Bartledan', 'Earth']}), 32 | {planets => [{ _id => 'Earth' , value => 'Terra' }]}; 33 | 34 | is_deeply 35 | $pkg->new('planet', 'test', 'default', 'Mars')->fix({planet => 'Bartledan'}), 36 | {planet => 'Mars'}; 37 | 38 | is_deeply 39 | $pkg->new('planets.*', 'test', 'default', 'Mars')->fix({planets => ['Bartledan', 'Earth']}), 40 | {planets => ['Mars', { _id => 'Earth' , value => 'Terra' }]}, 41 | 'default with wildcard'; 42 | 43 | done_testing 8; 44 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/all_equal.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::all_equal; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has value => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::Condition::SimpleAllTest'; 15 | 16 | sub emit_test { 17 | my ($self, $var) = @_; 18 | my $value = $self->value; 19 | "is_value(${var}) && ${var} eq '$value'"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::Condition::all_equal - Execute fixes when all path values equal a string value 31 | 32 | =head1 DESCRIPTION 33 | 34 | This fix is meant as an simple alternative to L. 35 | No regular expressions are involved. String are compared using the regular 36 | operator 'eq'. 37 | 38 | =head1 SYNOPSIS 39 | 40 | # all_equal(X,Y) is true when value of X == 'Y' 41 | if all_equal('year','2018') 42 | add_field('my.funny.title','true') 43 | end 44 | 45 | # all_equal(X,Y) is false when value of X == 'Ya' 46 | 47 | =head1 SEE ALSO 48 | 49 | L , L 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-all_match.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Catmandu::Fix::set_field; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::Condition::all_match'; 11 | use_ok $pkg; 12 | } 13 | 14 | { 15 | my $cond = $pkg->new('foo','abc'); 16 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 17 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 18 | 19 | is_deeply 20 | $cond->fix({foo => qw(abc)}), 21 | {foo => qw(abc), test => 'pass'}; 22 | 23 | is_deeply 24 | $cond->fix({foo => qw(cbc)}), 25 | {foo => qw(cbc), test => 'fail'}; 26 | } 27 | 28 | { 29 | my $cond = $pkg->new('foo.*','abc'); 30 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 31 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 32 | 33 | is_deeply 34 | $cond->fix({foo => [qw(abc)]}), 35 | {foo => [qw(abc)], test => 'pass'}; 36 | 37 | is_deeply 38 | $cond->fix({foo => [qw(abc abc)]}), 39 | {foo => [qw(abc abc)], test => 'pass'}; 40 | 41 | is_deeply 42 | $cond->fix({foo => [qw(abc cbc)]}), 43 | {foo => [qw(abc cbc)], test => 'fail'}; 44 | } 45 | 46 | done_testing 6; 47 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/add_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::add_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has path => (fix_arg => 1); 14 | has value => (fix_arg => 1); 15 | 16 | sub emit { 17 | my ($self, $fixer) = @_; 18 | my $path = $fixer->split_path($self->path); 19 | my $value = $fixer->emit_value($self->value); 20 | 21 | $fixer->emit_create_path($fixer->var, $path, sub { 22 | my $var = shift; 23 | "${var} = ${value};"; 24 | }); 25 | } 26 | 27 | 1; 28 | 29 | __END__ 30 | 31 | =pod 32 | 33 | =head1 NAME 34 | 35 | Catmandu::Fix::add_field - add or change the value of a HASH key or ARRAY index 36 | 37 | =head1 DESCRIPTION 38 | 39 | Contrary to C, this will create the intermediate structures 40 | if they are missing. 41 | 42 | =head1 SYNOPSIS 43 | 44 | # Add a new field 'foo' with value 2 45 | add_field(foo, 2) 46 | 47 | # Change the value of 'foo' to 'bar 123' 48 | add_field(foo, 'bar 123') 49 | 50 | # Create a deeply nested key 51 | add_field(my.deep.nested.key, hi) 52 | 53 | =head1 SEE ALSO 54 | 55 | L 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/log.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::log; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Catmandu; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | with 'Catmandu::Logger'; 13 | 14 | has message => (fix_arg => 1); 15 | has level => (fix_opt => 1); 16 | 17 | sub fix { 18 | my ($self,$data) = @_; 19 | my $id = $data->{_id} // ''; 20 | my $level = $self->level // 'INFO'; 21 | 22 | if ($level =~ /^(trace|debug|info|notice|warn|error|critical|alert|emergency)$/i) { 23 | my $lvl = lc $level; 24 | $self->log->$lvl(sprintf "%s : %s\n" , $id , $self->message); 25 | } 26 | 27 | $data; 28 | } 29 | 30 | 1; 31 | 32 | __END__ 33 | 34 | =pod 35 | 36 | =head1 NAME 37 | 38 | Catmandu::Fix::log - Log::Any logger as fix 39 | 40 | =head1 SYNOPSIS 41 | 42 | log('test123') 43 | 44 | log('hello world' , level:DEBUG); 45 | 46 | =head1 DESCRIPTION 47 | 48 | This fix add debugging capabilities to fixes. To use it via the command line you need to add the 49 | '-D' option to your script. E.g. 50 | 51 | echo '{}' | catmandu convert -D to YAML --fix 'log("help!", level:WARN)' 52 | 53 | =head1 SEE ALSO 54 | 55 | L 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/set_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::set_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Clone qw(clone); 8 | use Moo; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | with 'Catmandu::Fix::Base'; 13 | 14 | has path => (fix_arg => 1); 15 | has value => (fix_arg => 1); 16 | 17 | sub emit { 18 | my ($self, $fixer) = @_; 19 | my $path = $fixer->split_path($self->path); 20 | my $key = pop @$path; 21 | my $value = $fixer->emit_value($self->value); 22 | 23 | $fixer->emit_walk_path($fixer->var, $path, sub { 24 | my $var = shift; 25 | $fixer->emit_set_key($var, $key, $value); 26 | }); 27 | } 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =head1 NAME 36 | 37 | Catmandu::Fix::set_field - add or change the value of a HASH key or ARRAY index 38 | 39 | =head1 DESCRIPTION 40 | 41 | Contrary to C, this will not create the intermediate structures 42 | if they are missing. 43 | 44 | =head1 SYNOPSIS 45 | 46 | # Change the value of 'foo' to 'bar 123' 47 | set_field(foo, 'bar 123') 48 | 49 | # Change a deeply nested key 50 | set_field(my.deep.nested.key, hi) 51 | 52 | =head1 SEE ALSO 53 | 54 | L 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Catmandu/Importer/Null.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Importer::Null; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Importer'; 11 | 12 | sub generator { 13 | my ($self) = @_; 14 | my $n = 0; 15 | sub { 16 | return undef if $n++; 17 | +{}; 18 | }; 19 | } 20 | 21 | 1; 22 | 23 | __END__ 24 | 25 | =pod 26 | 27 | =head1 NAME 28 | 29 | Catmandu::Importer::Null - Null importer used for testing purposes 30 | 31 | =head1 SYNOPSIS 32 | 33 | # From the command line 34 | 35 | catmandu convert Null --fix 'add_field(foo,bar)' 36 | # creates { "foo": "bar" } 37 | 38 | # In a Perl script 39 | use Catmandu; 40 | 41 | my $importer = Catmandu->importer('Null'); 42 | 43 | my $n = $importer->each(sub { 44 | my $hashref = $_[0]; 45 | # ... 46 | }); 47 | 48 | =head1 DESCRIPTION 49 | 50 | The importer generates one empty record and then exists. This importer can be used to 51 | test fix functions, generating a single record. 52 | 53 | =head1 METHODS 54 | 55 | Every L is a L all its methods are 56 | inherited. 57 | 58 | =head1 SEE ALSO 59 | 60 | L 61 | 62 | =cut 63 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-lookup.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::lookup'; 11 | use_ok $pkg; 12 | } 13 | 14 | is_deeply 15 | $pkg->new('planet', 't/planets.csv')->fix({planet => 'Earth'}), 16 | {planet => 'Terra'}; 17 | 18 | is_deeply 19 | $pkg->new('planet', 't/planets.csv')->fix({planet => 'Bartledan'}), 20 | {planet => 'Bartledan'}; 21 | 22 | is_deeply 23 | $pkg->new('planet', 't/planets.csv', 'delete', 1)->fix({planet => 'Bartledan'}), 24 | {}; 25 | 26 | is_deeply 27 | $pkg->new('planets.*', 't/planets.csv', 'delete', 1)->fix({planets => ['Bartledan', 'Earth']}), 28 | {planets => ['Terra']}; 29 | 30 | is_deeply 31 | $pkg->new('planet', 't/planets.csv', 'default', 'Mars')->fix({planet => 'Bartledan'}), 32 | {planet => 'Mars'}; 33 | 34 | is_deeply 35 | $pkg->new('planets.*', 't/planets.csv', 'default', 'Mars')->fix({planets => ['Bartledan', 'Earth']}), 36 | {planets => ['Mars', 'Terra']}, 37 | 'default with wildcard'; 38 | 39 | is_deeply 40 | $pkg->new('planet', 't/planets.tab', 'sep_char', "\t")->fix({planet => 'Earth'}), 41 | {planet => 'Terra'}, 42 | "pass csv options"; 43 | 44 | done_testing 8; 45 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/set_hash.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::set_hash; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has path => (fix_arg => 1); 14 | has values => (fix_arg => 'collect', default => sub { [] }); 15 | 16 | sub emit { 17 | my ($self, $fixer) = @_; 18 | my $path = $fixer->split_path($self->path); 19 | my $key = pop @$path; 20 | my $values = $self->values; 21 | 22 | $fixer->emit_walk_path($fixer->var, $path, sub { 23 | my $var = shift; 24 | $fixer->emit_set_key($var, $key, 25 | "{".join(',', map { $fixer->emit_value($_) } @$values)."}"); 26 | }); 27 | } 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =head1 NAME 36 | 37 | Catmandu::Fix::set_hash - add or change the value of a HASH key or ARRAY index to a hash 38 | 39 | =head1 DESCRIPTION 40 | 41 | Contrary to C, this will not create the intermediate structures 42 | if they are missing. 43 | 44 | =head1 SYNOPSIS 45 | 46 | # Change the value of 'foo' to an empty hash 47 | set_hash(foo) 48 | # Or a hash with initial contents 49 | set_hash(a: b, c: d) 50 | 51 | =head1 SEE ALSO 52 | 53 | L 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/any_equal.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::any_equal; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has value => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::Condition::SimpleAnyTest'; 15 | 16 | sub emit_test { 17 | my ($self, $var) = @_; 18 | my $value = $self->value; 19 | "is_value(${var}) && ${var} eq '$value'"; 20 | } 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Catmandu::Fix::Condition::any_equal - Execute fixes when at least one of the path values equal a string value 31 | 32 | =head1 DESCRIPTION 33 | 34 | This fix is meant as an simple alternative to L. 35 | No regular expressions are involved. String are compared using the regular 36 | operator 'eq'. 37 | 38 | =head1 SYNOPSIS 39 | 40 | # any_equal(X,Y) is true when at least one value of the array X equals 'Y' 41 | if any_equal('years.*','2018') 42 | add_field('my.funny.title','true') 43 | end 44 | 45 | # any_equal(X,Y) is false when none of the values of X equal 'Y' 46 | 47 | =head1 SEE ALSO 48 | 49 | L , L 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/substring.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::substring; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has args => (fix_arg => 'collect'); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $args = $self->args; 19 | my $str_args = @$args > 1 ? join(", ", @$args[0, 1]) : $args->[0]; 20 | 21 | if (@$args < 3) { 22 | return "eval { ${var} = substr(as_utf8(${var}), ${str_args}) } if is_value(${var});"; 23 | } 24 | my $replace = $fixer->emit_string($args->[2]); 25 | "if (is_value(${var})) {" 26 | ."utf8::upgrade(${var});" 27 | ."eval { substr(${var}, ${str_args}) = ${replace} };" 28 | ."}"; 29 | } 30 | 31 | 1; 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 NAME 38 | 39 | Catmandu::Fix::substring - extract a substring out of the value of a field 40 | 41 | =head1 SYNOPSIS 42 | 43 | # Extract a substring out of the value of a field 44 | # - Extact from 'initials' the characters at offset 0 (first character) with a length 3 45 | substring(initials, 0, 3) 46 | 47 | =head1 SEE ALSO 48 | 49 | L, substr 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/set_array.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::set_array; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has path => (fix_arg => 1); 14 | has values => (fix_arg => 'collect', default => sub { [] }); 15 | 16 | sub emit { 17 | my ($self, $fixer) = @_; 18 | my $path = $fixer->split_path($self->path); 19 | my $key = pop @$path; 20 | my $values = $self->values; 21 | 22 | $fixer->emit_walk_path($fixer->var, $path, sub { 23 | my $var = shift; 24 | $fixer->emit_set_key($var, $key, 25 | "[".join(',', map { $fixer->emit_value($_) } @$values)."]"); 26 | }); 27 | } 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =head1 NAME 36 | 37 | Catmandu::Fix::set_array - add or change the value of a HASH key or ARRAY index to an array 38 | 39 | =head1 DESCRIPTION 40 | 41 | Contrary to C, this will not create the intermediate structures 42 | if they are missing. 43 | 44 | =head1 SYNOPSIS 45 | 46 | # Change the value of 'foo' to an empty array 47 | set_array(foo) 48 | # Or an array with initial contents 49 | set_array(foo, "a", "b", "c") 50 | 51 | =head1 SEE ALSO 52 | 53 | L 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /t/Catmandu-Store.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Role::Tiny; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Store'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | { 17 | package T::Store; 18 | use Moo; 19 | with $pkg; 20 | package T::Store::Bag; 21 | use Moo; 22 | package T::CustomBagClass; 23 | use Moo; 24 | has store => (is => 'ro'); 25 | has name => (is => 'ro'); 26 | has prop => (is => 'ro'); 27 | } 28 | 29 | my $s = T::Store->new; 30 | can_ok $s, 'bag_class'; 31 | can_ok $s, 'default_bag'; 32 | can_ok $s, 'bags'; 33 | can_ok $s, 'bag'; 34 | 35 | is $s->bag_class, 'T::Store::Bag'; 36 | $s = T::Store->new(bag_class => 'T::CustomBagClass'); 37 | is $s->bag_class, 'T::CustomBagClass'; 38 | 39 | is $s->default_bag, 'data'; 40 | 41 | my $b = $s->bag; 42 | isa_ok $b, $s->bag_class; 43 | is $s->bag, $b; 44 | is $b->store, $s; 45 | is $b->name, 'data'; 46 | $b = $s->bag('foo'); 47 | is $b->name, 'foo'; 48 | $s->bags->{foo}{prop} = 'another val'; 49 | $s->bags->{bar}{prop} = 'val'; 50 | $s->bags->{bar}{name} = 'baz'; 51 | isnt $s->bag('foo')->prop, 'another val'; 52 | is $s->bag('bar')->prop, 'val'; 53 | isnt $s->bag('bar')->name, 'baz'; 54 | 55 | done_testing; 56 | 57 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-Text.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Test::Exception; 6 | use YAML::XS (); 7 | 8 | BEGIN { use_ok 'Catmandu::Exporter::Text' } 9 | require_ok 'Catmandu::Exporter::Text'; 10 | 11 | { 12 | my $data = [{'a' => 'moose'}, {'a' => 'pony'}, {'a' => ['shrimp','lobster']}]; 13 | my $file = ""; 14 | 15 | my $exporter = Catmandu::Exporter::Text->new(file => \$file, field_sep => ','); 16 | isa_ok $exporter, 'Catmandu::Exporter::Text'; 17 | 18 | $exporter->add($_) for @$data; 19 | $exporter->commit; 20 | 21 | is $exporter->count, 3, 'Count ok'; 22 | 23 | my $text =< 'moose'}, {'a' => 'pony'}, {'a' => ['shrimp','lobster']}]; 34 | my $file = ""; 35 | 36 | my $exporter = Catmandu::Exporter::Text->new(file => \$file, line_sep => '\t' , field_sep => ','); 37 | isa_ok $exporter, 'Catmandu::Exporter::Text'; 38 | 39 | $exporter->add_many($data); 40 | # don't call commit to test streaming output 41 | 42 | is $exporter->count, 3, 'Count ok'; 43 | is $file, "moose\tpony\tshrimp,lobster\t", 'Text doc array'; 44 | } 45 | 46 | done_testing; 47 | -------------------------------------------------------------------------------- /t/Catmandu-Plugin-Datestamps.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Store::Hash; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Plugin::Datestamps'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $store = Catmandu::Store::Hash->new(bags => { data => { plugins => [qw(Datestamps)] } }); 17 | 18 | ok $store->does('Catmandu::Store') , 'create Catmandu-Store with Datestamps plugin'; 19 | ok $store->bag->add( { _id => '001' , name => 'Penguin' } ) , 'store something'; 20 | ok $store->bag->get( '001' ) , 'get 001'; 21 | ok $store->bag->get( '001' )->{date_created} , 'has date_created'; 22 | ok $store->bag->get( '001' )->{date_updated} , 'has date_updated'; 23 | 24 | my $created = $store->bag->get( '001' )->{date_created}; 25 | my $updated = $store->bag->get( '001' )->{date_updated}; 26 | my $obj = $store->bag->get( '001' ); 27 | $obj->{name} = 'John'; 28 | 29 | sleep 2; 30 | 31 | ok $store->bag->add( $obj ) , 'update something'; 32 | ok $store->bag->get( '001' )->{date_updated} , 'has date_updated'; 33 | ok $store->bag->get( '001' )->{date_updated} ne $updated , 'dates change'; 34 | is $store->bag->get( '001' )->{date_created} , $created , 'but created dates dont change'; 35 | 36 | done_testing 11; 37 | 38 | -------------------------------------------------------------------------------- /lib/Catmandu/Iterator.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Iterator; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Role::Tiny::With; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Iterable'; 11 | 12 | sub new { 13 | bless $_[1], $_[0]; 14 | } 15 | 16 | sub generator { 17 | goto &{$_[0]}; 18 | } 19 | 20 | 1; 21 | 22 | __END__ 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Catmandu::Iterator - Base class for all Catmandu iterators 29 | 30 | =head1 SYNOPSIS 31 | 32 | package My::MockIterator; 33 | 34 | use Moo; 35 | 36 | with 'Catmandu::Iterable'; 37 | 38 | sub generator { 39 | sub { 40 | # Generator some random data 41 | +{ random => rand }; 42 | } 43 | } 44 | 45 | package main; 46 | 47 | my $it = My::MockIterator->new; 48 | 49 | my first = $it->first; 50 | 51 | $it->each(sub { 52 | my $item = shift; 53 | 54 | print $item->{random} , "\n"; 55 | }); 56 | 57 | my $it2 = $it->map(sub { shift->{random} * 2 }); 58 | 59 | =head1 METHODS 60 | 61 | =head2 generator 62 | 63 | Should return a closure that generates one Perl hash. 64 | 65 | =head1 INHERIT 66 | 67 | If you provide a generator, then the class will generator all methods from L. 68 | 69 | =head1 SEE ALSO 70 | 71 | L 72 | 73 | =cut 74 | -------------------------------------------------------------------------------- /t/Catmandu-Store-Multi.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Catmandu::Store::Hash; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Store::Multi'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $data = [ 17 | {_id => '123', name=>'Patrick',age=>'39'}, 18 | {_id => '321', name=>'Nicolas',age=>'34'}, 19 | ]; 20 | 21 | my $stores = [ 22 | Catmandu::Store::Hash->new, 23 | Catmandu::Store::Hash->new, 24 | ]; 25 | my $store = $pkg->new(stores => $stores); 26 | my $bag = $store->bag; 27 | 28 | $bag->add_many($data); 29 | is_deeply $bag->to_array, $data; 30 | is_deeply $stores->[0]->bag->to_array, $data; 31 | is_deeply $stores->[1]->bag->to_array, $data; 32 | 33 | is_deeply $bag->get('123'), $data->[0]; 34 | is_deeply $stores->[0]->bag->get('123'), $data->[0]; 35 | is_deeply $stores->[1]->bag->get('123'), $data->[0]; 36 | 37 | $bag->delete('123'); 38 | is_deeply $bag->first, $data->[1]; 39 | is_deeply $stores->[0]->bag->first, $data->[1]; 40 | is_deeply $stores->[1]->bag->first, $data->[1]; 41 | 42 | $bag->delete_all; 43 | is $bag->count, 0; 44 | is $stores->[0]->bag->count, 0; 45 | is $stores->[1]->bag->count, 0; 46 | 47 | $bag->add_many($data); 48 | $bag->drop; 49 | is $bag->count, 0; 50 | 51 | done_testing; 52 | 53 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-trim.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | use utf8; 9 | 10 | my $pkg; 11 | BEGIN { 12 | $pkg = 'Catmandu::Fix::trim'; 13 | use_ok $pkg; 14 | } 15 | 16 | is_deeply 17 | $pkg->new('name')->fix({name => "\tjoe "}), 18 | {name => "joe"}, 19 | "trim horizontal whitespace"; 20 | 21 | is_deeply 22 | $pkg->new('name', 'whitespace')->fix({name => "\cK / joe "}), 23 | {name => "/ joe"}, 24 | "trim vertical whitespace"; 25 | 26 | is_deeply 27 | $pkg->new('name', 'nonword')->fix({name => "/\tjoe . "}), 28 | {name => "joe"}, 29 | "trim nonword characters"; 30 | 31 | is_deeply 32 | $pkg->new('id', 'whitespace')->fix({id => " 0423985325 "}), 33 | {id => "0423985325"}, 34 | "trim digit string"; 35 | 36 | is_deeply 37 | $pkg->new('name', 'whitespace')->fix({name => " 宮川 "}), 38 | {name => "宮川"}, 39 | "trim utf8 string"; 40 | 41 | is_deeply 42 | $pkg->new('names.*.name')->fix({names => [{name => "\tjoe "}, {name => " rick "}]}), 43 | {names => [{name => "joe"}, {name => "rick"}]}, 44 | "trim wildcard values"; 45 | 46 | is_deeply 47 | $pkg->new('name', 'diacritics')->fix({name => "français"}), 48 | {name => "francais"}, 49 | "trim utf8 string"; 50 | 51 | done_testing 8; 52 | 53 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/count.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::count; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu; 9 | use Catmandu::Fix; 10 | use namespace::clean; 11 | 12 | sub command_opt_spec { 13 | ( 14 | [ "cql-query|q=s", "" ], 15 | [ "query=s", "" ], 16 | ); 17 | } 18 | 19 | sub command { 20 | my ($self, $opts, $args) = @_; 21 | 22 | my ($from_args, $from_opts) = $self->_parse_options($args); 23 | 24 | my $from_bag = delete $from_opts->{bag}; 25 | my $from = Catmandu->store($from_args->[0], $from_opts)->bag($from_bag); 26 | 27 | if ($opts->query // $opts->cql_query) { 28 | $self->usage_error("Bag isn't searchable") unless $from->can('searcher'); 29 | $from = $from->searcher( 30 | cql_query => $opts->cql_query, 31 | query => $opts->query, 32 | ); 33 | } 34 | 35 | say $from->count; 36 | } 37 | 38 | 1; 39 | 40 | __END__ 41 | 42 | =pod 43 | 44 | =head1 NAME 45 | 46 | Catmandu::Cmd::count - count the number of objects in a store 47 | 48 | =head1 EXAMPLES 49 | 50 | catmandu count 51 | 52 | catmandu count ElasticSearch --index-name shop --bag products \ 53 | --query 'brand:Acme' 54 | 55 | catmandu help store ElasticSearch 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /t/Catmandu-Fix-Condition-any_match.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Catmandu::Fix::set_field; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Fix::Condition::any_match'; 11 | use_ok $pkg; 12 | } 13 | 14 | { 15 | my $cond = $pkg->new('foo','abc'); 16 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 17 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 18 | 19 | is_deeply 20 | $cond->fix({foo => qw(abc)}), 21 | {foo => qw(abc), test => 'pass'}; 22 | 23 | is_deeply 24 | $cond->fix({foo => qw(cbc)}), 25 | {foo => qw(cbc), test => 'fail'}; 26 | } 27 | 28 | { 29 | my $cond = $pkg->new('foo.*','abc'); 30 | $cond->pass_fixes([Catmandu::Fix::set_field->new('test', 'pass')]); 31 | $cond->fail_fixes([Catmandu::Fix::set_field->new('test', 'fail')]); 32 | 33 | is_deeply 34 | $cond->fix({foo => [qw(abc)]}), 35 | {foo => [qw(abc)], test => 'pass'}; 36 | 37 | is_deeply 38 | $cond->fix({foo => [qw(abc abc)]}), 39 | {foo => [qw(abc abc)], test => 'pass'}; 40 | 41 | is_deeply 42 | $cond->fix({foo => [qw(abc cbc)]}), 43 | {foo => [qw(abc cbc)], test => 'pass'}; 44 | 45 | is_deeply 46 | $cond->fix({foo => [qw(cbc cbc)]}), 47 | {foo => [qw(cbc cbc)], test => 'fail'}; 48 | } 49 | 50 | done_testing 7; 51 | -------------------------------------------------------------------------------- /benchmark/clone.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { 4 | use strict; 5 | use warnings; 6 | use FindBin; 7 | use File::Spec (); 8 | use lib File::Spec->catdir($FindBin::Bin, '..', 'lib'); 9 | use Catmandu (); 10 | use Benchmark qw(:all); 11 | } 12 | 13 | package NothingFix; 14 | 15 | use strict; 16 | use warnings; 17 | use Moo; 18 | use Clone qw(clone); 19 | 20 | sub fix { 21 | $_[0]; 22 | } 23 | 24 | package CloneFix; 25 | 26 | use strict; 27 | use warnings; 28 | use Moo; 29 | use Clone qw(clone); 30 | 31 | sub fix { 32 | clone($_[0]); 33 | } 34 | 35 | package DataCloneFix; 36 | 37 | use strict; 38 | use warnings; 39 | use Moo; 40 | use Data::Clone qw(clone); 41 | 42 | sub fix { 43 | clone($_[0]); 44 | } 45 | 46 | package main; 47 | 48 | my $data = Catmandu->importer('JSON', 49 | file => File::Spec->catfile($FindBin::Bin, 'data.json'))->first; 50 | my $nothing_fixer = Catmandu::Fix->new(fixes => [(NothingFix->new) x 1000]); 51 | my $clone_fixer = Catmandu::Fix->new(fixes => [(CloneFix->new) x 1000]); 52 | my $data_clone_fixer = Catmandu::Fix->new(fixes => [(DataCloneFix->new) x 1000]); 53 | 54 | cmpthese(10000, { 55 | "nothing" => sub { $nothing_fixer->fix($data) }, 56 | "Clone" => sub { $clone_fixer->fix($data) }, 57 | "Data::Clone" => sub { $data_clone_fixer->fix($data) }, 58 | }); 59 | 60 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/sleep.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::sleep; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Time::HiRes; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has seconds => (fix_arg => 1); 13 | has units => (fix_arg => 1); 14 | 15 | sub fix { 16 | my ($self, $data) = @_; 17 | 18 | my $sleep = $self->seconds; 19 | my $units = $self->units; 20 | 21 | if ($units =~ /^MICROSECOND(S)?$/i) {} 22 | elsif ($units =~ /^MILLISECOND(S)$/i) { 23 | $sleep *= 1000; 24 | } 25 | elsif ($units =~ /^SECOND(S)?$/i) { 26 | $sleep *= 1000000; 27 | } 28 | elsif ($units =~ /^MINUTE(S)?$/i) { 29 | $sleep *= 60*1000000; 30 | } 31 | elsif ($units =~ /^HOUR(S)?$/i) { 32 | $sleep *= 3600 * 1000000; 33 | } 34 | else { 35 | $sleep *= 1000000; 36 | } 37 | 38 | Time::HiRes::usleep($sleep); 39 | 40 | $data; 41 | } 42 | 43 | 1; 44 | 45 | __END__ 46 | 47 | =pod 48 | 49 | =head1 NAME 50 | 51 | Catmandu::Fix::sleep - Do nothing for a specified amount of time 52 | 53 | =head1 SYNOPSIS 54 | 55 | sleep(10,MICROSECONDS) 56 | 57 | sleep(3,MILLISECONDS) 58 | 59 | sleep(1,SECOND) 60 | sleep(2,SECONDS) 61 | 62 | sleep(5,MINUTES) 63 | 64 | sleep(1,HOURS) 65 | 66 | =head1 SEE ALSO 67 | 68 | L 69 | 70 | =cut 71 | -------------------------------------------------------------------------------- /t/Catmandu-Store-Hash.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Store::Hash'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $data = [ 16 | {_id => '123', name=>'Patrick',age=>'39'}, 17 | {_id => '321', name=>'Nicolas',age=>'34'}, 18 | ]; 19 | 20 | my $store = $pkg->new(); 21 | my $bag = $store->bag; 22 | my @method = qw(to_array each take add add_many count slice first rest any many all tap map reduce); 23 | can_ok $bag, $_ for @method; 24 | 25 | $bag->add_many($data); 26 | is $bag->count, 2, "Count bag size"; 27 | isnt $bag->count, 0, "Count bag size"; 28 | 29 | is_deeply $bag->first, {_id => '123', name=>'Patrick',age=>'39'}, "Data package ok."; 30 | is_deeply $bag->rest->first, {_id => '321', name=>'Nicolas',age=>'34'}, "Data package ok."; 31 | 32 | $bag->delete('123'); 33 | is_deeply $bag->first, {_id => '321', name=>'Nicolas',age=>'34'}, "Data package ok."; 34 | is $bag->count, 1, "Count bag size"; 35 | $bag->delete_all; 36 | is $bag->count, 0, "Count bag size"; 37 | isnt $bag->count, 1, "Count bag size"; 38 | 39 | $bag->add({ _id => '123' , foo => "bar"}); 40 | 41 | my $bag2 = $store->bag; 42 | is $bag2->count , 1 , "Bags stay alive"; 43 | 44 | my $bag3 = $store->bag('foo'); 45 | ok ! $bag3->get('123') , "foo doesnt have 123"; 46 | 47 | done_testing 27; 48 | 49 | -------------------------------------------------------------------------------- /lib/Catmandu/Exporter/Multi.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Exporter::Multi; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Util qw(is_string); 8 | use Catmandu; 9 | use Moo; 10 | use namespace::clean; 11 | 12 | with 'Catmandu::Exporter'; 13 | 14 | has exporters => ( 15 | is => 'ro', 16 | default => sub { [] }, 17 | coerce => sub { 18 | my $exporters = $_[0]; 19 | return [ map { 20 | if (is_string($_)) { 21 | Catmandu->exporter($_); 22 | } else { 23 | $_; 24 | } 25 | } @$exporters ]; 26 | }, 27 | ); 28 | 29 | sub add { 30 | my ($self, $data) = @_; 31 | $_->add($data) for @{$self->exporters}; 32 | } 33 | 34 | sub commit { 35 | my ($self) = @_; 36 | $_->commit for @{$self->exporters}; 37 | } 38 | 39 | 1; 40 | 41 | __END__ 42 | 43 | =pod 44 | 45 | =head1 NAME 46 | 47 | Catmandu::Exporter::Multi - export you data to multiple exporters 48 | 49 | =head1 SYNOPSIS 50 | 51 | # this will write both a CSV and an XLS file 52 | my $exporter = Catmandu::Exporter::Multi->new(exporters => [ 53 | Catmandu::Exporter::CSV->new(file => 'mydata.csv'), 54 | Catmandu::Exporter::XLS->new(file => 'mydata.xls'), 55 | ]); 56 | $exporter->add({col1 => 'val1', col2 => 'val2'}); 57 | $exporter->commit; 58 | 59 | =head1 SEE ALSO 60 | 61 | L 62 | 63 | =cut 64 | 65 | -------------------------------------------------------------------------------- /lib/Catmandu/Store/Multi/Bag.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Store::Multi::Bag; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Hits; 8 | use Moo; 9 | use namespace::clean; 10 | 11 | with 'Catmandu::Bag'; 12 | 13 | sub generator { 14 | my ($self) = @_; 15 | $self->store->stores->[0]->bag($self->name)->generator; 16 | } 17 | 18 | sub get { 19 | my ($self, $id) = @_; 20 | $self->store->stores->[0]->bag($self->name)->get($id); 21 | } 22 | 23 | sub add { 24 | my ($self, $data) = @_; 25 | for my $store (@{$self->store->stores}) { 26 | $store->bag($self->name)->add($data); 27 | } 28 | } 29 | 30 | sub delete { 31 | my ($self, $id) = @_; 32 | for my $store (@{$self->store->stores}) { 33 | $store->bag($self->name)->delete($id); 34 | } 35 | } 36 | 37 | sub delete_all { 38 | my ($self) = @_; 39 | for my $store (@{$self->store->stores}) { 40 | $store->bag($self->name)->delete_all; 41 | } 42 | } 43 | 44 | sub drop { 45 | my ($self) = @_; 46 | for my $store (@{$self->store->stores}) { 47 | $store->bag($self->name)->drop; 48 | } 49 | } 50 | 51 | sub commit { 52 | my ($self) = @_; 53 | for my $store (@{$self->store->stores}) { 54 | $store->bag($self->name)->commit; 55 | } 56 | } 57 | 58 | 1; 59 | 60 | __END__ 61 | 62 | =pod 63 | 64 | =head1 NAME 65 | 66 | Catmandu::Store::Multi::Bag - Bag implementation for the Multi store 67 | 68 | =cut 69 | -------------------------------------------------------------------------------- /t/Catmandu-Hits.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | 8 | my $pkg; 9 | BEGIN { 10 | $pkg = 'Catmandu::Hits'; 11 | use_ok $pkg; 12 | } 13 | require_ok $pkg; 14 | 15 | my $data = [(1..100)]; 16 | my $h = Catmandu::Hits->new(start => 0, limit => 10, total => 100, hits => $data); 17 | can_ok $h, 'start'; 18 | can_ok $h, 'limit'; 19 | can_ok $h, 'total'; 20 | can_ok $h, 'hits'; 21 | can_ok $h, 'size'; 22 | throws_ok { Catmandu::Hits->new(limit => 10, total => 100, hits => $data) } qr/missing required arguments: start/i; 23 | throws_ok { Catmandu::Hits->new(start => 0, total => 100, hits => $data) } qr/missing required arguments: limit/i; 24 | throws_ok { Catmandu::Hits->new(start => 0, limit => 10, hits => $data) } qr/missing required arguments: total/i; 25 | throws_ok { Catmandu::Hits->new(start => 0, limit => 10, total => 100) } qr/missing required arguments: hits/i; 26 | ok $h->does('Catmandu::Iterable'), 'is an Iterable'; 27 | ok $h->does('Catmandu::Paged'), 'is a Paged'; 28 | 29 | is_deeply $h->hits, $data , 'test content'; 30 | 31 | ok $h->more, 'test mode'; 32 | is $h->limit , 10 , 'test limit'; 33 | is $h->size, 100 , 'test size'; 34 | is $h->start, 0 , 'test start'; 35 | is $h->first, 1 , 'test first'; 36 | 37 | my $sum = 0; 38 | $h->each(sub { $sum += shift }); 39 | is $sum , 5050 , 'test each'; 40 | 41 | is_deeply $h->to_array , [(1..100)] , 'test to_array'; 42 | 43 | is $h->generator->() , 1 , 'test generator'; 44 | 45 | done_testing 22; 46 | -------------------------------------------------------------------------------- /lib/Catmandu/Counter.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Counter; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo::Role; 8 | use namespace::clean; 9 | 10 | has count => (is => 'rwp', default => sub { 0 }); 11 | 12 | sub inc_count { 13 | my $self = $_[0]; $self->_set_count($self->count + 1); 14 | } 15 | 16 | sub dec_count { 17 | my $self = $_[0]; $self->count ? $self->_set_count($self->count - 1) : 0; 18 | } 19 | 20 | sub reset_count { 21 | my $self = $_[0]; $self->_set_count(0); 22 | } 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =head1 NAME 31 | 32 | Catmandu::Counter - A Base class for modules who need to count things 33 | 34 | =head1 SYNOPSIS 35 | 36 | package MyPackage; 37 | 38 | use Moo; 39 | 40 | with 'Catmandu::Counter'; 41 | 42 | sub calculate { 43 | my ($self) = @_; 44 | $self->inc_count; 45 | #...do stuff 46 | } 47 | 48 | package main; 49 | 50 | my $x = MyPackage->new; 51 | 52 | $x->calculate; 53 | $x->calculate; 54 | $x->calculate; 55 | 56 | print "Executed calculate %d times\n" , $x->count; 57 | 58 | =head1 ATTRIBUTES 59 | 60 | =head2 count 61 | 62 | The current value of the counter. 63 | 64 | =head1 METHODS 65 | 66 | =head2 inc_count() 67 | 68 | =head2 inc_count(NUMBER) 69 | 70 | Increment the counter. 71 | 72 | =head2 dec_count() 73 | 74 | =head2 dec_count(NUMBER) 75 | 76 | Decrement the counter. 77 | 78 | =head2 reset_count() 79 | 80 | Reset the counter to zero. 81 | 82 | =head1 SEE ALSO 83 | 84 | L 85 | 86 | =cut 87 | -------------------------------------------------------------------------------- /t/Catmandu-Addable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use Role::Tiny; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Addable'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | my $data = []; 17 | 18 | { 19 | package T::AddableWithoutAdd; 20 | use Moo; 21 | 22 | package T::Addable; 23 | use Moo; 24 | with $pkg; 25 | 26 | sub add { 27 | push @$data, $_[1]; 28 | } 29 | 30 | package T::WithoutGenerator; 31 | use Moo; 32 | package T::WithGenerator; 33 | use Moo; 34 | sub generator { sub {} } 35 | } 36 | 37 | throws_ok { Role::Tiny->apply_role_to_package('T::AddableWithoutAdd', $pkg) } qr/missing add/; 38 | 39 | my $a = T::Addable->new; 40 | can_ok $a, 'add_many'; 41 | 42 | is_deeply $a->add({a=>'pony'}), {a=>'pony'}, 'add returns data added'; 43 | 44 | $data = []; 45 | $a->add(undef); 46 | is_deeply $data, [], 'undef gets rejected'; 47 | 48 | lives_ok { $a->add_many({}) } 'add_many takes a single hash ref'; 49 | lives_ok { $a->add_many([]) } 'add_many takes an array ref'; 50 | lives_ok { $a->add_many(sub {}) } 'add_many takes a generator code ref'; 51 | lives_ok { $a->add_many(T::WithGenerator->new) } 'add_many takes an object with a generator method'; 52 | throws_ok { $a->add_many(T::WithoutGenerator->new) } qr/should be able to generator/; 53 | 54 | $data = []; 55 | is $a->add_many([1,2,3]), 3, 'add_many returns count of data added'; 56 | is_deeply $data, [1,2,3], 'add_many passes all data to add'; 57 | 58 | done_testing 13; 59 | 60 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/convert.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::convert; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu; 9 | use namespace::clean; 10 | 11 | sub command_opt_spec { 12 | ( 13 | [ "verbose|v", "" ], 14 | [ "fix=s@", "" ], 15 | [ "start=i", "" ], 16 | [ "total=i", "" ], 17 | ); 18 | } 19 | 20 | sub command { 21 | my ($self, $opts, $args) = @_; 22 | 23 | my ($from_args, $from_opts, $into_args, $into_opts) = $self->_parse_options($args); 24 | 25 | my $from = Catmandu->importer($from_args->[0], $from_opts); 26 | my $into = Catmandu->exporter($into_args->[0], $into_opts); 27 | 28 | if ($opts->start // $opts->total) { 29 | $from = $from->slice($opts->start, $opts->total); 30 | } 31 | if ($opts->fix) { 32 | $from = Catmandu->fixer($opts->fix)->fix($from); 33 | } 34 | if ($opts->verbose) { 35 | $from = $from->benchmark; 36 | } 37 | 38 | my $n = $into->add_many($from); 39 | $into->commit; 40 | if ($opts->verbose) { 41 | say STDERR $n == 1 ? "converted 1 object" : "converted $n objects"; 42 | say STDERR "done"; 43 | } 44 | } 45 | 46 | 1; 47 | 48 | __END__ 49 | 50 | =pod 51 | 52 | =head1 NAME 53 | 54 | Catmandu::Cmd::convert - convert objects 55 | 56 | =head1 EXAMPLES 57 | 58 | catmandu convert to 59 | 60 | cat books.json | catmandu convert JSON to CSV --fields id,title 61 | 62 | catmandu help importer JSON 63 | catmandu help exporter YAML 64 | 65 | =cut 66 | -------------------------------------------------------------------------------- /lib/Catmandu/Sane.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Sane; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '1.0002'; 7 | 8 | use feature (); 9 | use utf8; 10 | use IO::File (); 11 | use IO::Handle (); 12 | use Try::Tiny::ByClass; 13 | use Catmandu::Error; 14 | 15 | sub import { 16 | my $pkg = caller; 17 | strict->import; 18 | warnings->import; 19 | feature->import(qw(:5.10)); 20 | utf8->import; 21 | Try::Tiny::ByClass->export_to_level(1, $pkg); 22 | } 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =head1 NAME 31 | 32 | Catmandu::Sane - Package boilerplate 33 | 34 | =head1 SYNOPSIS 35 | 36 | use Catmandu::Sane; 37 | 38 | # Provides all the 5.10 features. 39 | say("what"); 40 | given($foo) { 41 | when(1) { say "1" } 42 | when([2,3]) { say "2 or 3" } 43 | when(/abc/) { say "has abc" } 44 | default { none of the above } 45 | } 46 | sub next_id{ 47 | state $id; 48 | ++$id; 49 | } 50 | 51 | # Provides try/catch[/finally] try/catch_case[/finally] 52 | try { 53 | } catch {}; 54 | 55 | # Provides 56 | Catmandu::Error->throw("error"); 57 | Catmandu::BadVal->throw("eek val"); 58 | Catmandu::BadArg->throw("eek arg"); 59 | Catmandu::NotImplemented->throw("can't do that!"); 60 | 61 | =head1 DESCRIPTION 62 | 63 | Package boilerplate equivalent to: 64 | 65 | use strict; 66 | use warnings; 67 | use feature qw(:5.10); 68 | use utf8; 69 | use IO::File (); 70 | use IO::Handle (); 71 | use Try::Tiny::ByClass; 72 | use Catmandu::Error; 73 | 74 | =cut 75 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/run.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::run; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu; 9 | use Catmandu::Interactive; 10 | use Catmandu::Fix; 11 | use namespace::clean; 12 | 13 | sub command_opt_spec { 14 | ( 15 | [ "verbose|v", "" ], 16 | [ "i" , "interactive mode"], 17 | ); 18 | } 19 | 20 | sub command { 21 | my ($self, $opts, $args) = @_; 22 | 23 | if (defined $opts->{i} || !defined $args->[0]) { 24 | my $app = Catmandu::Interactive->new(); 25 | $app->run(); 26 | } 27 | else { 28 | my $fix_file = $args->[0]; 29 | $fix_file = [\*STDIN] unless defined $fix_file; 30 | 31 | my $from = Catmandu->importer('Null'); 32 | my $into = Catmandu->exporter('Null', fix => $fix_file); 33 | 34 | $from = $from->benchmark if $opts->verbose; 35 | my $n = $into->add_many($from); 36 | $into->commit; 37 | 38 | if ($opts->verbose) { 39 | say STDERR $n == 1 ? "converted 1 object" : "converted $n objects"; 40 | say STDERR "done"; 41 | } 42 | } 43 | } 44 | 45 | 1; 46 | 47 | __END__ 48 | 49 | =pod 50 | 51 | =head1 NAME 52 | 53 | Catmandu::Cmd::run - run a fix command 54 | 55 | =head1 EXAMPLES 56 | 57 | # Run an interactive Fix shell 58 | $ catmandu run 59 | 60 | # Execute the fix script 61 | $ catmandu run myfixes.txt 62 | 63 | # Or create an execurable fix script: 64 | 65 | #!/usr/bin/env catmandu run 66 | do importer(Mock,size:10) 67 | add_field(foo,bar) 68 | end 69 | 70 | =cut 71 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/trim.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::trim; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Unicode::Normalize; 9 | use namespace::clean; 10 | use Catmandu::Fix::Has; 11 | 12 | has path => (fix_arg => 1); 13 | has mode => (fix_arg => 1, default => sub { 'whitespace' }); 14 | 15 | with 'Catmandu::Fix::SimpleGetValue'; 16 | 17 | sub emit_value { 18 | my ($self, $var) = @_; 19 | 20 | my $perl = "if (is_string(${var})) {"; 21 | if ($self->mode eq 'whitespace') { 22 | $perl .= "${var} = trim(${var});"; 23 | } 24 | elsif ($self->mode eq 'nonword') { 25 | $perl .= $var.' =~ s/^\W+//;'; 26 | $perl .= $var.' =~ s/\W+$//;'; 27 | } 28 | elsif ($self->mode eq 'diacritics') { 29 | $perl .= "${var} = Unicode::Normalize::NFKD(${var});"; 30 | $perl .= "${var} =~ s/\\p{NonspacingMark}//g;"; 31 | } 32 | $perl .= "}"; 33 | $perl; 34 | } 35 | 36 | 1; 37 | 38 | __END__ 39 | 40 | =pod 41 | 42 | =encoding utf-8 43 | 44 | =head1 NAME 45 | 46 | Catmandu::Fix::trim - trim leading and ending junk from the value of a field 47 | 48 | =head1 SYNOPSIS 49 | 50 | # the default mode trims whitespace 51 | # e.g. foo => ' abc '; 52 | 53 | trim(foo) # foo => 'abc'; 54 | trim(foo, whitespace) # foo => 'abc'; 55 | 56 | # trim non-word characters 57 | # e.g. foo => ' abc / : .'; 58 | trim(foo, nonword) # foo => 'abc'; 59 | 60 | # trim accents 61 | # e.g. foo => 'français' ; 62 | trim(foo,diacritics) # foo => 'francais' 63 | 64 | =head1 SEE ALSO 65 | 66 | L 67 | 68 | =cut 69 | -------------------------------------------------------------------------------- /lib/Catmandu/Exporter/Mock.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Exporter::Mock; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Exporter'; 11 | 12 | has _data_ => (is => 'ro', default => sub { [] }); 13 | 14 | sub add { 15 | my ($self, $data) = @_; 16 | push @{$self->_data_} , $data; 17 | 1; 18 | } 19 | 20 | sub as_arrayref { 21 | my ($self) = @_; 22 | return $self->_data_; 23 | } 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Catmandu::Exporter::Mock - a expoter that doesn't export anything 34 | 35 | =head1 SYNOPSIS 36 | 37 | # From the commandline 38 | $ catmandu convert JSON --fix myfixes to Mock < /tmp/data.json 39 | 40 | # From Perl 41 | 42 | use Catmandu::Exporter::Mock; 43 | 44 | # Print to STDOUT 45 | my $exporter = Catmandu::Exporter::Mock->new(fix => 'myfix.txt'); 46 | 47 | $exporter->add_many($arrayref); 48 | $exporter->add_many($iterator); 49 | $exporter->add_many(sub { }); 50 | 51 | $exporter->add($hashref); 52 | 53 | printf "exported %d objects\n" , $exporter->count; 54 | 55 | # Get an array ref of all records exported 56 | my $data = $exporter->as_arrayref; 57 | 58 | =head1 DESCRIPTION 59 | 60 | This exporter exports nothing and can be used as in situations where you e.g. export 61 | data from a fix. Other the Null exporter, the Mock exporter will keep an internal 62 | array of all the records exported which can be retrieved with the 'as_arrayref' method. 63 | 64 | =head1 SEE ALSO 65 | 66 | L 67 | 68 | =cut 69 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/vacuum.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::vacuum; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use Catmandu::Expander (); 9 | use Catmandu::Fix::Bind::visitor; 10 | use namespace::clean; 11 | use Catmandu::Fix::Has; 12 | 13 | sub fix { 14 | my ($self,$data) = @_; 15 | 16 | my $ref = eval { 17 | # This can die with 'Unknown reference type' when the data is blessed 18 | Catmandu::Expander->collapse_hash($data); 19 | }; 20 | 21 | # Try to unbless data 22 | if ($@) { 23 | my $bind = Catmandu::Fix::Bind::visitor->new; 24 | my $data = $bind->unit($data); 25 | 26 | $data = $bind->bind($data,sub { 27 | my $item = $_[0]; 28 | 29 | $item->{scalar} = sprintf "%s" , $item->{scalar} if (ref $item->{scalar}); 30 | 31 | $item; 32 | }); 33 | 34 | $ref = Catmandu::Expander->collapse_hash($data); 35 | } 36 | 37 | for my $key (keys %$ref) { 38 | my $value = $ref->{$key}; 39 | delete $ref->{$key} unless defined($value) && length $value && $value =~ /\S/; 40 | } 41 | 42 | Catmandu::Expander->expand_hash($ref); 43 | } 44 | 45 | 1; 46 | 47 | __END__ 48 | 49 | =pod 50 | 51 | =head1 NAME 52 | 53 | Catmandu::Fix::vacuum - delete all empty fields from your data 54 | 55 | =head1 SYNOPSIS 56 | 57 | # Delete all the empty fields 58 | # 59 | # input: 60 | # 61 | # foo: '' 62 | # bar: [] 63 | # relations: {} 64 | # test: 123 65 | # 66 | vacuum() 67 | 68 | # output: 69 | # 70 | # test: 123 71 | # 72 | 73 | =head1 SEE ALSO 74 | 75 | L 76 | 77 | =cut 78 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Base.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Base; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Fix; 8 | use Clone (); 9 | use Moo::Role; 10 | use namespace::clean; 11 | 12 | with 'Catmandu::Logger'; 13 | 14 | requires 'emit'; 15 | 16 | has fixer => (is => 'lazy', init_arg => undef); 17 | 18 | sub _build_fixer { 19 | my ($self) = @_; 20 | Catmandu::Fix->new(fixes => [$self]); 21 | } 22 | 23 | sub fix { 24 | my ($self, $data) = @_; 25 | $self->fixer->fix($data); 26 | } 27 | 28 | sub import { 29 | my $target = caller; 30 | my ($fix, %opts) = @_; 31 | 32 | if (my $sym = $opts{as}) { 33 | my $sub = sub { 34 | my $data = shift; 35 | if ($opts{clone}) { 36 | $data = Clone::clone($data); 37 | } 38 | $fix->new(@_)->fix($data); 39 | }; 40 | no strict 'refs'; 41 | *{"${target}::$sym"} = $sub; 42 | } 43 | } 44 | 45 | 1; 46 | 47 | __END__ 48 | 49 | =pod 50 | 51 | =head1 NAME 52 | 53 | Catmandu::Fix::Base - Base class for all code emitting Catmandu fixes 54 | 55 | =head1 SYNOPSIS 56 | 57 | package Catmandu::Fix::my_fix; 58 | 59 | use Catmandu::Sane; 60 | use Moo; 61 | 62 | with 'Catmandu::Fix::Base'; 63 | 64 | sub emit { 65 | my ($self, $fixer) = @_; 66 | ....FIXER GENERATING CODE.... 67 | } 68 | 69 | =head1 SEE ALSO 70 | 71 | For more information how to create fixes read the following two blog posts: 72 | 73 | http://librecat.org/catmandu/2014/03/14/create-a-fixer.html 74 | http://librecat.org/catmandu/2014/03/26/creating-a-fixer-2.html 75 | =cut 76 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/copy_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::copy_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has old_path => (fix_arg => 1); 14 | has new_path => (fix_arg => 1); 15 | 16 | sub emit { 17 | my ($self, $fixer) = @_; 18 | my $old_path = $fixer->split_path($self->old_path); 19 | my $old_key = pop @$old_path; 20 | my $new_path = $fixer->split_path($self->new_path); 21 | 22 | my $vals = $fixer->generate_var; 23 | my $current_val = $fixer->generate_var; 24 | my $perl = ""; 25 | $perl .= $fixer->emit_declare_vars($vals, '[]'); 26 | $perl .= $fixer->emit_declare_vars($current_val); 27 | 28 | $perl .= $fixer->emit_walk_path($fixer->var, $old_path, sub { 29 | my $var = shift; 30 | $fixer->emit_get_key($var, $old_key, sub { 31 | my $var = shift; 32 | "push(\@{${vals}}, ${var});"; 33 | }); 34 | }); 35 | 36 | $perl .= "while (\@{${vals}}) {" . 37 | "${current_val} = clone(shift(\@{${vals}}));" . 38 | $fixer->emit_create_path($fixer->var, $new_path, sub { 39 | my $var = shift; 40 | "${var} = ${current_val};"; 41 | }). 42 | "}"; 43 | 44 | $perl; 45 | } 46 | 47 | 1; 48 | 49 | __END__ 50 | 51 | =pod 52 | 53 | =head1 NAME 54 | 55 | Catmandu::Fix::copy_field - copy the value of one field to a new field 56 | 57 | =head1 SYNOPSIS 58 | 59 | # Copy the values of foo.bar into bar.foo 60 | copy_field(foo.bar, bar.foo) 61 | 62 | =head1 SEE ALSO 63 | 64 | L 65 | 66 | =cut 67 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/parse_text.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::parse_text; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has pattern => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $pattern = $fixer->emit_match($self->pattern); 19 | 20 | "if (is_string(${var}) && ${var} =~ ${pattern}) {" . 21 | "if (\@+ < 2) { " . 22 | # # no capturing groups 23 | "}" . 24 | "elsif (\%+) { " . 25 | # named capturing groups 26 | "${var} = { \%+ }; " . 27 | "} else {" . 28 | # numbered capturing groups 29 | "no strict 'refs';" . 30 | "${var} = [ map { \${\$_} } 1..(\@{+} - 1) ];" . 31 | "}". 32 | "}"; 33 | } 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =head1 NAME 42 | 43 | Catmandu::Fix::parse_text - parses a text into an array or hash of values 44 | 45 | =head1 SYNOPSIS 46 | 47 | # date: "2015-03-07" 48 | parse_text(date, '(\d\d\d\d)-(\d\d)-(\d\d)') 49 | # date: 50 | # - 2015 51 | # - 03 52 | # - 07 53 | 54 | # date: "2015-03-07" 55 | parse_text(date, '(?\d\d\d\d)-(?\d\d)-(?\d\d)') 56 | # date: 57 | # year: "2015" 58 | # month: "03" 59 | # day: "07" 60 | 61 | # date: "abcd" 62 | parse_text(date, '(\d\d\d\d)-(\d\d)-(\d\d)') 63 | # date: "abcd" 64 | 65 | =head1 SEE ALSO 66 | 67 | L 68 | 69 | L 70 | 71 | =cut 72 | -------------------------------------------------------------------------------- /lib/Catmandu/Importer/Mock.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Importer::Mock; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | 10 | with 'Catmandu::Importer'; 11 | 12 | has size => (is => 'ro'); 13 | 14 | sub generator { 15 | my ($self) = @_; 16 | my $n = 0; 17 | sub { 18 | return if defined $self->size && $n == $self->size; 19 | return { n => $n++ }; 20 | }; 21 | } 22 | 23 | 1; 24 | 25 | __END__ 26 | 27 | =pod 28 | 29 | =head1 NAME 30 | 31 | Catmandu::Importer::Mock - Mock importer used for testing purposes 32 | 33 | =head1 SYNOPSIS 34 | 35 | use Catmandu::Importer::Mock; 36 | 37 | my $importer = Catmandu::Importer::Mock->new(); 38 | 39 | my $n = $importer->each(sub { 40 | my $hashref = $_[0]; 41 | # ... 42 | }); 43 | 44 | =head1 CONFIGURATION 45 | 46 | =over 47 | 48 | =item file 49 | 50 | Read input from a local file given by its path. Alternatively a scalar 51 | reference can be passed to read from a string. 52 | 53 | =item fh 54 | 55 | Read input from an L. If not specified, L is used to 56 | create the input stream from the C argument or by using STDIN. 57 | 58 | =item encoding 59 | 60 | Binmode of the input stream C. Set to C<:utf8> by default. 61 | 62 | =item fix 63 | 64 | An ARRAY of one or more fixes or file scripts to be applied to imported items. 65 | 66 | =item size 67 | 68 | Number of items. If not set, an endless stream is imported. 69 | 70 | =back 71 | 72 | =head1 METHODS 73 | 74 | Every L is a L all its methods are 75 | inherited. 76 | 77 | =head1 SEE ALSO 78 | 79 | L 80 | 81 | =cut 82 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/delete.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::delete; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu; 9 | use Catmandu::Util qw(check_able); 10 | use namespace::clean; 11 | 12 | sub command_opt_spec { 13 | ( 14 | [ "cql-query|q=s", "" ], 15 | [ "query=s", "" ], 16 | [ "id=s@", "" ], 17 | ); 18 | } 19 | 20 | sub command { 21 | my ($self, $opts, $args) = @_; 22 | 23 | my ($from_args, $from_opts) = $self->_parse_options($args); 24 | 25 | my $from_bag = delete $from_opts->{bag}; 26 | my $from = Catmandu->store($from_args->[0], $from_opts)->bag($from_bag); 27 | if ($opts->id) { 28 | $from->delete($_) for @{$opts->id}; 29 | } elsif ($opts->query // $opts->cql_query) { 30 | check_able($from, 'delete_by_query'); 31 | $from->delete_by_query( 32 | cql_query => $opts->cql_query, 33 | query => $opts->query, 34 | ); 35 | } else { 36 | $from->delete_all; 37 | } 38 | 39 | $from->commit; 40 | } 41 | 42 | 1; 43 | 44 | __END__ 45 | 46 | =pod 47 | 48 | =head1 NAME 49 | 50 | Catmandu::Cmd::delete - delete objects from a store 51 | 52 | =head1 EXAMPLES 53 | 54 | catmandu delete 55 | 56 | 57 | # delete items with matching _id 58 | catmandu delete ElasticSearch --index-name items --bag book \ 59 | --id 1234 --id 2345 60 | 61 | # delete items matching the query 62 | catmandu delete ElasticSearch --index-name items --bag book \ 63 | --query 'title:"My Rabbit"' 64 | 65 | # delete all items 66 | catmandu delete ElasticSearch --index-name items --bag book 67 | 68 | catmandu help store ElasticSearch 69 | 70 | =cut 71 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/Condition/exists.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::Condition::exists; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Condition'; 12 | 13 | has path => (fix_arg => 1); 14 | 15 | sub emit { 16 | my ($self, $fixer, $label) = @_; 17 | my $path = $fixer->split_path($self->path); 18 | my $key = pop @$path; 19 | my $str_key = $fixer->emit_string($key); 20 | 21 | my $perl = $fixer->emit_walk_path($fixer->var, $path, sub { 22 | my $var = shift; 23 | my $perl = "if ("; 24 | if ($key eq '$first' || $key eq '$last') { 25 | $perl .= "is_array_ref(${var}) && \@{${var}}"; 26 | } elsif ($key =~ /^\d+$/) { 27 | $perl .= "is_hash_ref(${var}) && exists(${var}->{${str_key}}) || is_array_ref(${var}) && \@{${var}} > ${key}"; 28 | } else { 29 | $perl .= "is_hash_ref(${var}) && exists(${var}->{${str_key}})"; 30 | } 31 | $perl .= ") {"; 32 | 33 | $perl .= $fixer->emit_fixes($self->pass_fixes); 34 | 35 | $perl .= "last $label;"; 36 | $perl .= "}"; 37 | $perl; 38 | }); 39 | 40 | $perl .= $fixer->emit_fixes($self->fail_fixes); 41 | 42 | $perl; 43 | } 44 | 45 | 1; 46 | 47 | __END__ 48 | 49 | =pod 50 | 51 | =head1 NAME 52 | 53 | Catmandu::Fix::Condition::exists - only execute fixes if the path exists 54 | 55 | =head1 SYNOPSIS 56 | 57 | # uppercase the value of field 'foo' if the field 'oogly' exists 58 | if exists(oogly) 59 | upcase(foo) # foo => 'BAR' 60 | end 61 | # inverted 62 | unless exists(oogly) 63 | upcase(foo) # foo => 'bar' 64 | end 65 | 66 | =head1 SEE ALSO 67 | 68 | L 69 | 70 | =cut 71 | -------------------------------------------------------------------------------- /lib/Catmandu/Importer/Multi.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Importer::Multi; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Catmandu::Util qw(is_string); 8 | use Catmandu; 9 | use Catmandu::MultiIterator; 10 | use Moo; 11 | use namespace::clean; 12 | 13 | with 'Catmandu::Importer'; 14 | 15 | has importers => ( 16 | is => 'ro', 17 | default => sub { [] }, 18 | coerce => sub { 19 | my $importers = $_[0]; 20 | return [ map { 21 | if (is_string($_)) { 22 | Catmandu->importer($_); 23 | } else { 24 | $_; 25 | } 26 | } @$importers ]; 27 | }, 28 | ); 29 | 30 | sub generator { 31 | my ($self) = @_; 32 | sub { 33 | state $generators = [ map { $_->generator } @{$self->importers} ]; 34 | while (@$generators) { 35 | my $data = $generators->[0]->(); 36 | return $data if defined $data; 37 | shift @$generators; 38 | } 39 | return; 40 | }; 41 | } 42 | 43 | 1; 44 | 45 | __END__ 46 | 47 | =pod 48 | 49 | =head1 NAME 50 | 51 | Catmandu::Importer::Multi - Chain multiple importers together 52 | 53 | =head1 SYNOPSIS 54 | 55 | use Catmandu::Importer::Multi; 56 | 57 | my $importer = Catmandu::Importer::Multi->new(importers => [ 58 | Catmandu::Importer::Mock->new, 59 | Catmandu::Importer::Mock->new, 60 | ]); 61 | 62 | my $importer = Catmandu::Importer::Multi->new( 63 | 'importer1', 64 | 'importer2', 65 | ); 66 | 67 | # return all the items of each importer in turn 68 | $importer->each(sub { 69 | # ... 70 | }); 71 | 72 | =head1 METHODS 73 | 74 | Every L is a L all its methods are 75 | inherited. 76 | 77 | =cut 78 | -------------------------------------------------------------------------------- /t/Catmandu-Cmd.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Test::Exception; 7 | use App::Cmd::Tester; 8 | 9 | my $pkg; 10 | BEGIN { 11 | $pkg = 'Catmandu::Cmd'; 12 | use_ok $pkg; 13 | } 14 | require_ok $pkg; 15 | 16 | use Catmandu::CLI; 17 | 18 | my $result = test_app(qq|Catmandu::CLI| => [ qw() ]); 19 | 20 | like $result->stdout , qr/commands:/, 'printed what we expected'; 21 | is $result->error, undef, 'threw no exceptions' ; 22 | is $result->stderr, '', 'nothing sent to sderr' ; 23 | 24 | $result = test_app('Catmandu::CLI' => [ qw(help) ]); 25 | 26 | like $result->stdout , qr/commands:/, 'printed what we expected'; 27 | is $result->error, undef, 'threw no exceptions' ; 28 | is $result->stderr, '', 'nothing sent to sderr' ; 29 | 30 | $result = test_app('Catmandu::CLI' => [ qw(-h) ]); 31 | 32 | like $result->stdout , qr/commands:/, 'printed what we expected'; 33 | is $result->error, undef, 'threw no exceptions' ; 34 | is $result->stderr, '', 'nothing sent to sderr' ; 35 | 36 | $result = test_app('Catmandu::CLI' => [ qw(--help) ]); 37 | 38 | like $result->stdout , qr/commands:/, 'printed what we expected'; 39 | is $result->error, undef, 'threw no exceptions' ; 40 | is $result->stderr, '', 'nothing sent to sderr' ; 41 | 42 | $result = test_app('Catmandu::CLI' => [ qw(version) ]); 43 | 44 | like $result->stdout , qr/version $Catmandu::VERSION/, 'printed what we expected'; 45 | is $result->error, undef, 'threw no exceptions' ; 46 | is $result->stderr, '', 'nothing sent to sderr' ; 47 | 48 | $result = test_app('Catmandu::CLI' => [ qw(--version) ]); 49 | 50 | like $result->stdout , qr/version $Catmandu::VERSION/, 'printed what we expected'; 51 | is $result->error, undef, 'threw no exceptions' ; 52 | is $result->stderr, '', 'nothing sent to sderr' ; 53 | 54 | done_testing 20; 55 | 56 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-CSV.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Exception; 5 | 6 | my $pkg; 7 | BEGIN { 8 | $pkg = 'Catmandu::Exporter::CSV'; 9 | use_ok $pkg; 10 | } 11 | require_ok $pkg; 12 | 13 | my $data = [{'a' => 'moose', b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}]; 14 | my $out = ""; 15 | 16 | my $exporter = $pkg->new(file => \$out); 17 | isa_ok $exporter, $pkg; 18 | 19 | $exporter->add_many($data); 20 | $exporter->commit; 21 | 22 | my $csv = <count,3, "Count ok"; 31 | 32 | $data = [{b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}]; 33 | $out = ""; 34 | $exporter = $pkg->new(file => \$out); 35 | $exporter->add_many($data); 36 | $exporter->commit; 37 | $csv = <new(file => \$out, collect_fields => 1); 47 | $exporter->add_many($data); 48 | $exporter->commit; 49 | $csv = <new(fields => 'a,x', columns => 'Longname,X', file => \$out ); 59 | $exporter->add( { a => 'Hello', b => 'World' } ); 60 | $csv = "Longname,X\nHello,\n"; 61 | is $out, $csv, "custom column names"; 62 | 63 | $out=""; 64 | my $fixer = Catmandu->fixer('if exists(foo) reject() end'); 65 | my $importer = Catmandu->importer('JSON', file => 't/csv_test.json'); 66 | 67 | $exporter = $pkg->new(file => \$out); 68 | $exporter->add_many($fixer->fix($importer)); 69 | $csv = "fob\ntest\n"; 70 | is $out, $csv, "custom column names as HASH with reject fix"; 71 | 72 | done_testing; 73 | -------------------------------------------------------------------------------- /t/Catmandu-Exporter-TSV.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Exception; 5 | 6 | my $pkg; 7 | BEGIN { 8 | $pkg = 'Catmandu::Exporter::TSV'; 9 | use_ok $pkg; 10 | } 11 | require_ok $pkg; 12 | 13 | my $data = [{'a' => 'moose', b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}]; 14 | my $out = ""; 15 | 16 | my $exporter = $pkg->new(file => \$out); 17 | isa_ok $exporter, $pkg; 18 | 19 | $exporter->add_many($data); 20 | $exporter->commit; 21 | 22 | my $tsv = <count,3, "Count ok"; 31 | 32 | $data = [{b => '1'}, {'a' => 'pony', b => '2'}, {'a' => 'shrimp', b => '3'}]; 33 | $out = ""; 34 | $exporter = $pkg->new(file => \$out); 35 | $exporter->add_many($data); 36 | $exporter->commit; 37 | $tsv = <new(file => \$out, collect_fields => 1); 47 | $exporter->add_many($data); 48 | $exporter->commit; 49 | $tsv = <new(fields => 'a,x', columns => 'Longname,X', file => \$out ); 59 | $exporter->add( { a => 'Hello', b => 'World' } ); 60 | $tsv = "Longname\tX\nHello\t\n"; 61 | is $out, $tsv, "custom column names"; 62 | 63 | $out=""; 64 | my $fixer = Catmandu->fixer('if exists(foo) reject() end'); 65 | my $importer = Catmandu->importer('JSON', file => 't/csv_test.json'); 66 | 67 | $exporter = $pkg->new(file => \$out); 68 | $exporter->add_many($fixer->fix($importer)); 69 | $tsv = "fob\ntest\n"; 70 | is $out, $tsv, "custom column names as HASH with reject fix"; 71 | 72 | done_testing; 73 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/config.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::config; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu::Util qw(data_at); 9 | use Catmandu; 10 | use namespace::clean; 11 | 12 | sub command { 13 | my ($self, $opts, $args) = @_; 14 | my $path; 15 | my $into_args = []; 16 | my $into_opts = {}; 17 | my $into; 18 | 19 | if (@$args == 1 || (@$args > 1 && $args->[1] eq 'to')) { 20 | $path = shift @$args; 21 | } 22 | 23 | if (@$args && $args->[0] eq 'to') { 24 | for (my $i = 1; $i < @$args; $i++) { 25 | my $arg = $args->[$i]; 26 | if ($arg =~ s/^-+//) { 27 | $arg =~ s/-/_/g; 28 | if ($arg eq 'fix') { 29 | push @{$into_opts->{$arg} ||= []}, $args->[++$i]; 30 | } else { 31 | $into_opts->{$arg} = $args->[++$i]; 32 | } 33 | } else { 34 | push @$into_args, $arg; 35 | } 36 | } 37 | } 38 | 39 | if (@$into_args || %$into_opts) { 40 | $into = Catmandu->exporter($into_args->[0], $into_opts); 41 | } else { 42 | $into = Catmandu->exporter('JSON', pretty => 1, array => 0); 43 | } 44 | 45 | $into->add(defined $path ? 46 | data_at($path, Catmandu->config) : 47 | Catmandu->config); 48 | $into->commit; 49 | } 50 | 51 | 1; 52 | 53 | __END__ 54 | 55 | =pod 56 | 57 | =head1 NAME 58 | 59 | Catmandu::Cmd::config - export the Catmandu config 60 | 61 | =head1 EXAMPLES 62 | 63 | # export config to JSON 64 | catmandu config 65 | # or any other Catmandu::Exporter 66 | catmandu config to YAML --fix 'delete_field(password)' 67 | # export only part of the config file 68 | catmandu config my.prefix to CSV 69 | 70 | =cut 71 | -------------------------------------------------------------------------------- /lib/Catmandu/Cmd/import.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Cmd::import; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use parent 'Catmandu::Cmd'; 8 | use Catmandu; 9 | use namespace::clean; 10 | 11 | sub command_opt_spec { 12 | ( 13 | [ "verbose|v", "" ], 14 | [ "fix=s@", "" ], 15 | [ "start=i", "" ], 16 | [ "total=i", "" ], 17 | [ "delete", "delete existing objects first" ], 18 | ); 19 | } 20 | 21 | sub command { 22 | my ($self, $opts, $args) = @_; 23 | 24 | my ($from_args, $from_opts, $into_args, $into_opts) = $self->_parse_options($args); 25 | 26 | my $from = Catmandu->importer($from_args->[0], $from_opts); 27 | my $into_bag = delete $into_opts->{bag}; 28 | my $into = Catmandu->store($into_args->[0], $into_opts)->bag($into_bag); 29 | 30 | if ($opts->start // $opts->total) { 31 | $from = $from->slice($opts->start, $opts->total); 32 | } 33 | if ($opts->fix) { 34 | $from = Catmandu->fixer($opts->fix)->fix($from); 35 | } 36 | if ($opts->verbose) { 37 | $from = $from->benchmark; 38 | } 39 | 40 | if ($opts->delete) { 41 | $into->delete_all; 42 | $into->commit; 43 | } 44 | 45 | my $n = $into->add_many($from); 46 | $into->commit; 47 | if ($opts->verbose) { 48 | say STDERR $n == 1 ? "imported 1 object" : "imported $n objects"; 49 | say STDERR "done"; 50 | } 51 | } 52 | 53 | 1; 54 | 55 | __END__ 56 | 57 | =pod 58 | 59 | =head1 NAME 60 | 61 | Catmandu::Cmd::import - import objects into a store 62 | 63 | =head1 EXAMPLES 64 | 65 | catmandu import to 66 | 67 | catmandu import YAML to MongoDB --database-name items --bag book < books.yml 68 | 69 | catmandu help importer YAML 70 | catmandu help importer MongoDB 71 | 72 | =cut 73 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/format.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::format; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | has path => (fix_arg => 1); 12 | has spec => (fix_arg => 1); 13 | 14 | with 'Catmandu::Fix::SimpleGetValue'; 15 | 16 | sub emit_value { 17 | my ($self, $var, $fixer) = @_; 18 | my $spec = $fixer->emit_string($self->spec); 19 | 20 | "if (is_array_ref(${var})) {" . 21 | "${var} = sprintf(${spec},\@{${var}});" . 22 | "} elsif (is_hash_ref(${var})) {" . 23 | "${var} = sprintf(${spec},\%{${var}});" . 24 | "} elsif (is_string(${var})) {" . 25 | "${var} = sprintf(${spec},${var});" . 26 | "}"; 27 | } 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =head1 NAME 36 | 37 | Catmandu::Fix::format - replace the value with a formatted (sprintf-like) version 38 | 39 | =head1 SYNOPSIS 40 | 41 | # e.g. number: 41 42 | format(number,"%-10.10d") # number => "0000000041" 43 | 44 | # e.g. numbers: 45 | # - 41 46 | # - 15 47 | format(number,"%-10.10d %-5.5d") # numbers => "0000000041 00015" 48 | 49 | # e.g. hash: 50 | # name: Albert 51 | format(name,"%-10s: %s") # hash: "name : Albert" 52 | 53 | # e.g. array: 54 | # - 1 55 | format(array,"%d %d %d") # Fails! The array contains only one value, but you request 3 values 56 | 57 | # Test first if the array contains 3 values 58 | if exists(array.2) 59 | format(array,"%d %d %d") 60 | end 61 | 62 | =head1 DESCRIPTION 63 | 64 | Create a string formatted by the usual printf conventions of the C library function sprintf. 65 | See L for a complete description. 66 | 67 | =head1 SEE ALSO 68 | 69 | L , L 70 | 71 | =cut 72 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'perl', 'v5.10.1'; 2 | 3 | on 'test', sub { 4 | requires 'Test::Deep', '0.112'; 5 | requires 'Test::Exception', '0.32'; 6 | requires 'Test::More', '0.99'; 7 | requires 'Test::Pod', 0; 8 | requires 'Log::Any::Test', '1.03'; 9 | requires 'Test::LWP::UserAgent' , 0; 10 | requires 'Log::Log4perl' , 0; 11 | requires 'Log::Any::Adapter::Log4perl', 0; 12 | requires 'Perl::Tidy', 0; 13 | }; 14 | 15 | requires 'Any::URI::Escape', 0; 16 | requires 'App::Cmd', '0.33'; 17 | requires 'CGI::Expand', '2.02'; 18 | requires 'Clone', '0.31'; 19 | requires 'Config::Onion', '1.004'; 20 | requires 'Data::Compare', '1.22'; 21 | requires 'Data::UUID', '1.217'; 22 | requires 'File::Find::Rule', '0.33'; 23 | requires 'File::Slurp::Tiny', '0.003'; 24 | requires 'Hash::Merge::Simple', 0; 25 | requires 'IO::Handle::Util', '0.01'; 26 | requires 'JSON::XS', '2.3'; 27 | requires 'List::MoreUtils', '0.33'; 28 | requires 'Log::Any::Adapter', 0; 29 | requires 'LWP::UserAgent', 0; 30 | requires 'Time::Piece', 0; # undeclared Marpa dependency 31 | requires 'Marpa::R2', '2.084000'; 32 | requires 'Module::Info', 0; 33 | requires 'Moo', '1.004006'; 34 | requires 'MooX::Aliases', '0.001006'; 35 | requires 'MooX::Role::Logger', '0.005'; 36 | requires 'namespace::clean', '0.24'; 37 | requires 'Unicode::Normalize', '0'; 38 | requires 'Sub::Exporter', '0.982'; 39 | requires 'Sub::Quote', 0; 40 | requires 'Text::CSV', '1.21'; 41 | requires 'Time::HiRes', 0; # not always installed? 42 | requires 'Throwable', '0.200004'; 43 | requires 'Try::Tiny::ByClass', '0.01'; 44 | requires 'URI', 0; 45 | requires 'URI::Template', 0.22; 46 | requires 'YAML::XS', '0.41'; 47 | 48 | recommends 'Log::Log4perl', '1.44'; 49 | recommends 'Log::Any::Adapter::Log4perl', '0.06'; 50 | 51 | feature 'tidy', 52 | "Support pretty printing compiled fix code", 53 | sub { 54 | requires 'Perl::Tidy', 0; 55 | }; 56 | 57 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/retain.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::retain; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has paths => (fix_arg => 'collect', default => sub { [] }); 14 | 15 | sub emit { 16 | my ($self, $fixer) = @_; 17 | my $paths = $self->paths; 18 | my $var = $fixer->var; 19 | my $tmp_var = $fixer->generate_var; 20 | my $perl = $fixer->emit_declare_vars($tmp_var, '{}'); 21 | for (@$paths) { 22 | my $path = $fixer->split_path($_); 23 | my $key = pop @$path; 24 | $perl .= $fixer->emit_walk_path($var, $path, sub { 25 | my ($var) = @_; 26 | $fixer->emit_get_key($var, $key, sub { 27 | my ($var) = @_; 28 | $fixer->emit_create_path($tmp_var, [@$path, $key], sub { 29 | my ($tmp_var) = @_; 30 | "${tmp_var} = ${var};"; 31 | }); 32 | }); 33 | }); 34 | } 35 | # clear data 36 | $perl .= $fixer->emit_clear_hash_ref($var); 37 | # copy tmp data 38 | $perl .= $fixer->emit_foreach_key($tmp_var, sub { 39 | my ($key) = @_; 40 | "${var}\->{${key}} = ${tmp_var}\->{${key}};"; 41 | }); 42 | # free tmp data 43 | $perl .= "undef ${tmp_var};"; 44 | $perl; 45 | } 46 | 47 | 1; 48 | 49 | __END__ 50 | 51 | =pod 52 | 53 | =head1 NAME 54 | 55 | Catmandu::Fix::retain - delete everything except the paths given 56 | 57 | =head1 SYNOPSIS 58 | 59 | # Keep the field _id , name , title 60 | retain(_id , name, title) 61 | 62 | # Delete everything except foo.bar 63 | # {bar => { x => 1} , foo => {bar => 1, y => 2}} 64 | # to 65 | # {foo => {bar => 1}} 66 | retain(foo.bar) 67 | 68 | =head1 SEE ALSO 69 | 70 | L 71 | 72 | =cut 73 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/move_field.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::move_field; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | with 'Catmandu::Fix::Base'; 12 | 13 | has old_path => (fix_arg => 1); 14 | has new_path => (fix_arg => 1); 15 | 16 | sub emit { 17 | my ($self, $fixer) = @_; 18 | my $old_path = $fixer->split_path($self->old_path); 19 | my $old_key = pop @$old_path; 20 | my $new_path = $fixer->split_path($self->new_path); 21 | 22 | $fixer->emit_walk_path($fixer->var, $old_path, sub { 23 | my $var = shift; 24 | $fixer->emit_delete_key($var, $old_key, sub { 25 | my $vals = shift; 26 | if (@$new_path && ($new_path->[-1] eq '$prepend' || $new_path->[-1] eq '$append')) { 27 | my $new_key = pop @$new_path; 28 | $fixer->emit_create_path($fixer->var, $new_path, sub { 29 | my $var = shift; 30 | my $sym = $new_key eq '$prepend' ? 'unshift' : 'push'; 31 | "if (\@{${vals}} && is_array_ref(${var} //= [])) {" . 32 | "${sym}(\@{${var}}, \@{${vals}});" . 33 | "}"; 34 | }); 35 | } else { 36 | $fixer->emit_create_path($fixer->var, $new_path, sub { 37 | my $var = shift; 38 | "if (\@{${vals}}) {". 39 | "${var} = shift(\@{${vals}});". 40 | "}"; 41 | }); 42 | } 43 | }); 44 | }); 45 | } 46 | 47 | 1; 48 | 49 | __END__ 50 | 51 | =pod 52 | 53 | =head1 NAME 54 | 55 | Catmandu::Fix::move_field - move a field to another place in the data structure 56 | 57 | =head1 SYNOPSIS 58 | 59 | # Move 'foo.bar' to 'bar.foo' 60 | move_field(foo.bar, bar.foo) 61 | 62 | =head1 SEE ALSO 63 | 64 | L 65 | 66 | =cut 67 | -------------------------------------------------------------------------------- /lib/Catmandu/Fix/expand_date.pm: -------------------------------------------------------------------------------- 1 | package Catmandu::Fix::expand_date; 2 | 3 | use Catmandu::Sane; 4 | 5 | our $VERSION = '1.0002'; 6 | 7 | use Moo; 8 | use namespace::clean; 9 | use Catmandu::Fix::Has; 10 | 11 | my $DATE_REGEX = qr{ 12 | ^([0-9]{4}) 13 | (?: [:-] ([0-9]{1,2}) 14 | (?: [:-] ([0-9]{1,2}) )? 15 | )? 16 | }x; 17 | 18 | has date_field => (fix_arg => 1, default => sub { 'date' }); 19 | 20 | sub fix { 21 | my ($self, $data) = @_; 22 | if (my $date = $data->{$self->date_field}) { 23 | if (my ($y, $m, $d) = $date =~ $DATE_REGEX) { 24 | $data->{year} = $y; 25 | $data->{month} = 1*$m if $m; 26 | $data->{day} = 1*$d if $d; 27 | } 28 | } 29 | $data; 30 | } 31 | 32 | 1; 33 | 34 | __END__ 35 | 36 | =pod 37 | 38 | =head1 NAME 39 | 40 | Catmandu::Fix::expand_date - expand a date field into year, month and date 41 | 42 | =head1 NOTE 43 | 44 | This package is DEPRECATED and will be removed in the future. 45 | Please use L. 46 | 47 | Reasons: 48 | 49 | =over 4 50 | 51 | =item 52 | 53 | it writes directly in the root of the hash, which is a different 54 | behaviour compared to all the other fixes (sum, count, hash, array ..) 55 | 56 | =item 57 | 58 | it adds the new keys in a different location, instead of "in place". 59 | 60 | =item 61 | 62 | it's behaviour cannot be changed without breaking its current use 63 | 64 | =back 65 | 66 | =head1 SYNOPSIS 67 | 68 | # {date => "2001-09-11"} 69 | expand_date() 70 | # => {year => 2001, month => "9", day => "11", date => "2001-09-11"} 71 | 72 | # {datestamp => "2001:09"} 73 | expand_date(datestamp) 74 | # => {year => 2001, month => "9", datestamp => "2001:09"} 75 | 76 | =head1 DESCRIPTION 77 | 78 | The date field is expanded if it contains a year, optionally followed by 79 | numeric month and day, each separated by C<-> or C<:>. 80 | 81 | 82 | =cut 83 | --------------------------------------------------------------------------------