diff --git a/Changes b/Changes index 08a79cadd..48117b712 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,7 @@ Revision history for Catmandu {{$NEXT}} - bring Dockerfile back to this repository + - include fix now accepts glob patterns - the export and convert commands get a new --id-file option 1.09 2018-03-06 11:24:35 CET diff --git a/lib/Catmandu.pm b/lib/Catmandu.pm index e12190f95..14b40e339 100644 --- a/lib/Catmandu.pm +++ b/lib/Catmandu.pm @@ -747,6 +747,14 @@ See L for more information on how this works. L +=item blog + +L + +=item step-by-step introduction from basics + +L + =item command line client L diff --git a/lib/Catmandu/Fix.pm b/lib/Catmandu/Fix.pm index a9c7824fc..ce9a065bf 100644 --- a/lib/Catmandu/Fix.pm +++ b/lib/Catmandu/Fix.pm @@ -808,10 +808,6 @@ You can load fixes from another namespace with the C statement: if fb.is_baz() end - # the import option makes them available without prefix - use(foo.bar, import: 1) - baz() - =head1 PATHS Most of the Fix commandsuse paths to point to values diff --git a/lib/Catmandu/Fix/Namespace.pm b/lib/Catmandu/Fix/Namespace.pm new file mode 100644 index 000000000..ad6cd2471 --- /dev/null +++ b/lib/Catmandu/Fix/Namespace.pm @@ -0,0 +1,14 @@ +package Catmandu::Fix::Namespace; + +use Catmandu::Sane; + +our $VERSION = '1.09'; + +use Moo::Role; +use namespace::clean; + +requires 'load'; + +has name => (is => 'ro', required => 1); + +1; diff --git a/lib/Catmandu/Fix/Namespace/perl.pm b/lib/Catmandu/Fix/Namespace/perl.pm new file mode 100644 index 000000000..32293a512 --- /dev/null +++ b/lib/Catmandu/Fix/Namespace/perl.pm @@ -0,0 +1,45 @@ +package Catmandu::Fix::Namespace::perl; + +use Catmandu::Sane; + +our $VERSION = '1.09'; + +use Catmandu::Util qw(is_instance require_package); +use String::CamelCase qw(camelize); +use Moo; +use namespace::clean; + +with 'Catmandu::Fix::Namespace'; + +sub load { + my ($self, $name, $args, $type) = @_; + my $ns = join('::', map {camelize($_)} split(/\./, $self->name)); + $ns = join('::', $ns, $type) if $type; + + my $pkg; + try { + $pkg = require_package($name, $ns); + } + catch_case [ + 'Catmandu::NoSuchPackage' => sub { + Catmandu::NoSuchFixPackage->throw( + message => "No such fix package: $name", + package_name => $_->package_name, + fix_name => $name, + ); + }, + ]; + try { + $pkg->new(@$args); + } + catch { + $_->throw if is_instance($_, 'Catmandu::Error'); + Catmandu::BadFixArg->throw( + message => $_, + package_name => $pkg, + fix_name => $name, + ); + }; +} + +1; diff --git a/lib/Catmandu/Fix/Parser.pm b/lib/Catmandu/Fix/Parser.pm index 20766c9da..01d11114e 100644 --- a/lib/Catmandu/Fix/Parser.pm +++ b/lib/Catmandu/Fix/Parser.pm @@ -6,15 +6,14 @@ our $VERSION = '1.09'; use Catmandu::Util qw(check_value check_string is_array_ref is_instance is_able require_package); -use String::CamelCase qw(camelize); use Module::Info; use Moo; use namespace::clean; extends 'Parser::MGC'; -has default_namespace => (is => 'lazy'); -has env_stack => (is => 'lazy'); +has env => (is => 'lazy'); +has default_ns => (is => 'lazy'); sub FOREIGNBUILDARGS { my ($class, $opts) = @_; @@ -22,63 +21,73 @@ sub FOREIGNBUILDARGS { %$opts; } -sub _build_default_namespace { - 'Catmandu::Fix'; +sub _build_default_ns { + my ($self) = @_; + $self->_build_ns('perl:catmandu.fix'); } -sub _build_env_stack { - [{_ns => []}]; +sub _build_env { + my ($self) = @_; + $self->init_env([]); } -sub clear_env { - my ($self) = @_; - my $envs = $self->env_stack; - splice(@$envs); +sub init_env { + my ($self, $envs) = @_; + splice(@$envs, 0, @$envs, {ns => {'' => $self->default_ns}}); $envs; } -sub env_get { - my ($self, $key, $default) = @_; - my $envs = $self->env_stack; +#sub env_get { +#my ($self, $key, $default) = @_; +#my $envs = $self->env_stack; +#for my $env (@$envs) { +#return $env->{$key} if exists $env->{$key}; +#} +#$default; +#} + +#sub env_add { +#my ($self, $key, $val) = @_; +#my $env = $self->env_stack->[-1]; +#Catmandu::FixParseError->throw("Already defined: $key") +#if exists $env->{$key}; +#$env->{$key} = $val; +#} + +sub get_ns { + my ($self, $name) = @_; + my $envs = $self->env; for my $env (@$envs) { - return $env->{$key} if exists $env->{$key}; + return $env->{ns}{$name} + if exists $env->{ns} && exists $env->{ns}{$name}; } - $default; + return; } -sub env_add { - my ($self, $key, $val) = @_; - my $env = $self->env_stack->[-1]; - Catmandu::FixParseError->throw("Already defined: $key") - if exists $env->{$key}; - $env->{$key} = $val; +sub add_ns { + my ($self, $name, $ns) = @_; + my $env = $self->env->[-1]; + ($env->{ns} //= {})->{$name} = $ns; } -sub add_namespace { - my ($self, $ns) = @_; - my $env = $self->env_stack->[-1]; - my $nss = $env->{_ns} //= []; - push @$nss, $ns; -} - -sub namespace_for { - my ($self, $name, $sub_ns) = @_; - my $envs = $self->env_stack; - for my $env (@$envs) { - my $nss = $env->{_ns} // next; - for my $ns (@$nss) { - $ns .= "::$sub_ns" if defined $sub_ns; - return $ns if Module::Info->new_from_module("${ns}::${name}"); - } - } - my $ns = $self->default_namespace; - $ns .= "::$sub_ns" if defined $sub_ns; - $ns; -} +#sub namespace_for { +#my ($self, $name, $sub_ns) = @_; +#my $envs = $self->env_stack; +#for my $env (@$envs) { +#my $nss = $env->{_ns} // next; +#for my $ns (@$nss) { +#$ns .= "::$sub_ns" if defined $sub_ns; +#return $ns if Module::Info->new_from_module("${ns}::${name}"); +#} +#} +#my $ns = $self->default_namespace; +#$ns .= "::$sub_ns" if defined $sub_ns; +#$ns; +#} sub scope { my ($self, $block) = @_; - my $envs = $self->env_stack; + my $envs = $self->env; push @$envs, +{}; my $res = $block->(); @@ -104,7 +113,7 @@ sub parse { Catmandu::FixParseError->throw(message => $err, source => $source,); } finally { - $self->clear_env; + $self->init_env; }; } @@ -143,15 +152,10 @@ sub parse_use { my ($self) = @_; $self->token_kw('use'); my $args = $self->parse_arguments; - my $as = check_string(shift(@$args)); - my $ns = join('::', map {camelize($_)} split(/\./, $as)); + my $name = check_string(shift(@$args)); + my $ns = $self->_build_ns($name); my %opts = @$args; - if ($opts{import}) { - $self->add_namespace($ns); - } - else { - $self->env_add($opts{as} // $as, $ns); - } + $self->add_ns($opts{as} // $name, $ns); return; } @@ -344,7 +348,7 @@ sub parse_double_quoted_string { sub _build_condition { my ($self, $name, $args, $pass, $fixes) = @_; $fixes = [$fixes] unless is_array_ref($fixes); - my $cond = $self->_build_fix_ns($name, $args, 'Condition'); + my $cond = $self->_build_fix($name, $args, 'Condition'); if ($pass) { $cond->pass_fixes($fixes); } @@ -357,56 +361,29 @@ sub _build_condition { sub _build_bind { my ($self, $name, $args, $return, $fixes) = @_; $fixes = [$fixes] unless is_array_ref($fixes); - my $bind = $self->_build_fix_ns($name, $args, 'Bind'); + my $bind = $self->_build_fix($name, $args, 'Bind'); $bind->__return__($return); $bind->__fixes__($fixes); $bind; } sub _build_fix { - my ($self, $name, $args) = @_; - $self->_build_fix_ns($name, $args); + my ($self, $name, $args, $type) = @_; + my @name_parts = split(/\./, $name); + my $fix_name = pop @name_parts; + my $ns_name = join('.', @name_parts); + my $ns = $self->get_ns($ns_name) + // Catmandu::FixParseError->throw("Unknown namespace: $ns_name"); + $ns->load($fix_name, $args, $type); } -sub _build_fix_ns { - my ($self, $name, $args, $sub_ns) = @_; - my @name_parts = split(/\./, $name); +sub _build_ns { + my ($self, $name) = @_; + my @name_parts = split(/:/, $name); $name = pop @name_parts; - my $ns; - if (@name_parts) { - my $as = join('.', @name_parts); - $ns = $self->env_get($as) - // Catmandu::FixParseError->throw("Unknown namespace: $as"); - $ns = join('::', $ns, $sub_ns) if defined $sub_ns; - } - else { - $ns = $self->namespace_for($name, $sub_ns); - } - - my $pkg; - try { - $pkg = require_package($name, $ns); - } - catch_case [ - 'Catmandu::NoSuchPackage' => sub { - Catmandu::NoSuchFixPackage->throw( - message => "No such fix package: $name", - package_name => $_->package_name, - fix_name => $name, - ); - }, - ]; - try { - $pkg->new(@$args); - } - catch { - $_->throw if is_instance($_, 'Catmandu::Error'); - Catmandu::BadFixArg->throw( - message => $_, - package_name => $pkg, - fix_name => $name, - ); - }; + my $pkg_name = $name_parts[0] // 'perl'; + my $pkg = require_package($pkg_name, 'Catmandu::Fix::Namespace'); + $pkg->new(name => $name); } 1; diff --git a/lib/Catmandu/Fix/include.pm b/lib/Catmandu/Fix/include.pm index fddeea2a9..41c7502f1 100644 --- a/lib/Catmandu/Fix/include.pm +++ b/lib/Catmandu/Fix/include.pm @@ -7,57 +7,92 @@ our $VERSION = '1.09'; use Moo; use Catmandu; use Catmandu::Fix; -use File::Spec qw(); -use Cwd qw(); +use File::Spec; +use Cwd qw(realpath); use namespace::clean; use Catmandu::Fix::Has; with 'Catmandu::Fix::Inlineable'; -has path => (fix_arg => 1); -has _path => ( - is => 'ro', - lazy => 1, - builder => sub { +has path => (fix_arg => 1); +has _files => (is => 'lazy'); +has _fixer => (is => 'lazy'); - my $self = $_[0]; +sub _build__files { + my ($self) = @_; + my $path = $self->path; - my $path = $self->path(); - my $real_path; - my $load_paths = Catmandu->_env->load_paths; + if ($path =~ /\*/) { # path is glob pattern + return $self->_find_glob($path); + } - if (File::Spec->file_name_is_absolute($path)) { - $real_path = $path; - } - else { - for my $p (@$load_paths) { - my $n = File::Spec->catfile($p, $path); - if (-r $n) { - $real_path = Cwd::realpath($n); - last; - } - } + [$self->_find_file($path)]; +} + +sub _find_file { + my ($self, $path) = @_; + my $roots = Catmandu->roots; + my $file; + if (File::Spec->file_name_is_absolute($path)) { + $file = $path; + } + else { + for my $root (@$roots) { + my $f = File::Spec->catfile($root, $path); + if (-r $f) { + $file = $f; + last; + } } - die("unable to find $path in load_path of Catmandu (load_path: " - . join(',', @$load_paths) . ")") - unless defined $real_path; - $real_path; } -); -has _fixer => ( - is => 'ro', - lazy => 1, - builder => sub { - Catmandu::Fix->new(fixes => [$_[0]->_path()]); + Catmandu::Error->throw( + "unable to find $path in " . join(',', @$roots) . ")") + unless defined $file; + + realpath($file); +} + +sub _find_glob { + my ($self, $path) = @_; + my $roots = Catmandu->roots; + + if (File::Spec->file_name_is_absolute($path)) { + return [sort map {realpath($_)} grep {-r $_} glob $path]; + } + + my %seen; + my $files = []; + + for my $root (@$roots) { + my $glob = File::Spec->catfile($root, $path); + for my $file (glob $glob) { + my $rel_path = File::Spec->abs2rel($file, $root); + next if $seen{$rel_path}; + if (-r $file) { + push @$files, realpath($file); + $seen{$rel_path} = 1; + } + } } -); + + [sort @$files]; +} + +sub _build__fixer { + my ($self) = @_; + my $files = $self->_files; + return unless @$files; + Catmandu::Fix->new(fixes => $files); +} sub fix { my ($self, $data) = @_; - $self->_fixer()->fix($data); + my $fixer = $self->_fixer; + return $data unless $fixer; + $fixer->fix($data); } 1; @@ -73,6 +108,7 @@ Catmandu::Fix::include - include fixes from another file =head1 SYNOPSIS include('/path/to/myfixes.txt') + include('fixes/*.fix') =head1 NOTES diff --git a/t/Catmandu-Fix-Parser.t b/t/Catmandu-Fix-Parser.t index 2f04c9722..b2ad20e4f 100644 --- a/t/Catmandu-Fix-Parser.t +++ b/t/Catmandu-Fix-Parser.t @@ -190,15 +190,6 @@ throws_ok { 'Catmandu::FixParseError'; throws_ok {$parser->parse(q|if exists(n) use(t.fix) end t.fix.test()|)} qr/Unknown namespace/; - lives_ok { - $parser->parse(q|use(t.fix, import: 1) if is_42(n) test() end|) - }; - throws_ok {$parser->parse(q|if is_42(n) end|)} - 'Catmandu::NoSuchFixPackage'; - throws_ok { - $parser->parse(q|if exists(n) use(t.fix, import: 1) end test()|) - } - 'Catmandu::NoSuchFixPackage'; } # block diff --git a/t/Catmandu-Fix-include.t b/t/Catmandu-Fix-include.t index e66581267..4aff60185 100644 --- a/t/Catmandu-Fix-include.t +++ b/t/Catmandu-Fix-include.t @@ -12,16 +12,23 @@ BEGIN { use_ok $pkg; } -my $object = {}; -my $intended_object = { - name => "Franck", - first_name => "Nicolas", - working_place => "University Library of Ghent", - hobbies => ['cooking', 'art', 'hiking'] -}; -my $fix_file = "fix-level-1.fix"; - -is_deeply($pkg->new($fix_file)->fix($object), - $intended_object, "include fix at multiple levels"); - -done_testing 2; +{ + my $result = { + name => "Franck", + first_name => "Nicolas", + working_place => "University Library of Ghent", + hobbies => ['cooking', 'art', 'hiking'] + }; + + is_deeply($pkg->new("fix-level-1.fix")->fix({}), + $result, "include fix at multiple levels"); +} + +{ + my $result = {'fix-1' => 'ok', 'fix-2' => 'ok', 'fix-3' => 'ok',}; + + is_deeply($pkg->new("fix-include-glob/*.fix")->fix({}), + $result, "include fixes with glob pattern"); +} + +done_testing; diff --git a/t/fix-include-glob/fix-1.fix b/t/fix-include-glob/fix-1.fix new file mode 100644 index 000000000..c9a3f5c7d --- /dev/null +++ b/t/fix-include-glob/fix-1.fix @@ -0,0 +1 @@ +set(fix-1, ok) diff --git a/t/fix-include-glob/fix-2.fix b/t/fix-include-glob/fix-2.fix new file mode 100644 index 000000000..256deaeb2 --- /dev/null +++ b/t/fix-include-glob/fix-2.fix @@ -0,0 +1 @@ +set(fix-2, ok) diff --git a/t/fix-include-glob/fix-3.fix b/t/fix-include-glob/fix-3.fix new file mode 100644 index 000000000..6936d8563 --- /dev/null +++ b/t/fix-include-glob/fix-3.fix @@ -0,0 +1 @@ +set(fix-3, ok)