/usr/share/perl5/Catmandu/Fix/Has.pm is in libcatmandu-perl 1.0700-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 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 | package Catmandu::Fix::Has;
use Catmandu::Sane;
our $VERSION = '1.07';
use Class::Method::Modifiers qw(install_modifier);
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;
__END__
=pod
=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 => 1 , default => sub {'!'} ); # optional parameter 'eol' with default '!'
sub fix {
my ($self,$data) = @_;
print STDERR $self->greeting . ", " . $self->message . $self->eol . "\n";
$data;
}
1;
=head1 PARAMETERS
=over 4
=item fix_arg
Required argument when set to 1. The Fix containing the code fragment below needs
two arguments.
use Catmandu::Fix::Has;
has message => (fix_arg => 1); # required parameter 1
has number => (fix_arg => 1); # required parameter 2
When the fix_arg is set to 'collect', then all arguments are read into an
array. The Fix containing the code fragment below needs at least 1 or more
arguments. All arguments will get collected into the C<messages> array:
use Catmandu::Fix::Has;
has messages => (fix_arg => 'collect'); # required parameter
=item fix_opt
Optional named argument when set to 1. The Fix containing the code fragment
below can have two optional arguments C<message: ...>, C<number: ...>:
use Catmandu::Fix::Has;
has message => (fix_opt => 1); # optional parameter 1
has number => (fix_opt => 1); # optional parameter 2
When the fix_opt is set to 'collect', then all optional argument are read into
an array. The Fix containing the code fragment below needs at least 1 or more
arguments. All arguments will get collected into the C<options> array:
use Catmandu::Fix::Has;
has options => (fix_opt => 'collect'); # optional parameter
=back
=head1 SEE ALSO
L<Catmandu::Fix>
=cut
|