/usr/share/perl5/Catmandu/Fix/Has.pm is in libcatmandu-perl 0.9206-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | =head1 NAME
Catmandu::Fix::Has - helper class for creating Fix-es with (optional) parameters
=head1 SYNOPSIS
package Catmandu::Fix::foo;
use Moo;
use Catmandu::Fix::Has;
has greeting => (fix_arg => 1); # required parameter 1
has message => (fix_arg => 1); # required parameter 2
has eol => (fix_opt => '!'); # optional parameter 'eol' with default '!'
sub fix {
my ($self,$data) = @_;
print STDERR $self->greeting . ", " . $self->message . $self->eol . "\n";
$data;
}
1;
=head1 SEE ALSO
L<Catmandu::Fix>
=cut
package Catmandu::Fix::Has;
use Catmandu::Sane;
use Class::Method::Modifiers qw(install_modifier);
use namespace::clean;
sub import {
my $target = caller;
my $around = do { no strict 'refs'; \&{"${target}::around"} };
my $fix_args = [];
my $fix_opts = [];
install_modifier($target, 'around', 'has', sub {
my ($orig, $attr, %opts) = @_;
return $orig->($attr, %opts)
unless exists $opts{fix_arg} || exists $opts{fix_opt};
$opts{is} //= 'ro';
$opts{init_arg} //= $attr;
my $arg = {key => $opts{init_arg}};
if ($opts{fix_arg}) {
$opts{required} //= 1;
$arg->{collect} = 1 if $opts{fix_arg} eq 'collect';
push @$fix_args, $arg;
delete $opts{fix_arg};
}
if ($opts{fix_opt}) {
$arg->{collect} = 1 if $opts{fix_opt} eq 'collect';
push @$fix_opts, $arg;
delete $opts{fix_opt};
}
$orig->($attr, %opts);
});
$around->('BUILDARGS', sub {
my $orig = shift;
my $self = shift;
return $orig->($self, @_) unless @$fix_args || @$fix_opts;
my $args = {};
for my $arg (@$fix_args) {
last unless @_;
my $key = $arg->{key};
if ($arg->{collect}) {
$args->{$key} = [splice @_, 0, @_];
last;
}
$args->{$key} = shift;
}
my $orig_args = $self->$orig(@_);
for my $arg (@$fix_opts) {
my $key = $arg->{key};
if ($arg->{collect}) {
$args->{$key} = $orig_args;
last;
} elsif (exists $orig_args->{"-$key"}) {
$args->{$key} = delete $orig_args->{"-$key"};
} elsif (exists $orig_args->{$key}) {
$args->{$key} = delete $orig_args->{$key};
}
}
$args;
});
}
1;
|