/usr/share/perl5/MooX/SingleArg.pm is in libmoox-buildargs-perl 0.04-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 | package MooX::SingleArg;
$MooX::SingleArg::VERSION = '0.04';
=head1 NAME
MooX::SingleArg - Support single-argument instantiation.
=head2 SYNOPSIS
package Foo;
use Moo;
with 'MooX::SingleArg';
Foo->single_arg('bar');
has bar => ( is=>'ro' );
my $foo = Foo->new( 'goo' );
print $foo->bar(); # goo
=cut
use Class::Method::Modifiers qw( install_modifier );
use Carp qw( croak );
use Moo::Role;
use strictures 2;
use namespace::clean;
with 'MooX::BuildArgsHooks';
around NORMALIZE_BUILDARGS => sub{
my ($orig, $class, @args) = @_;
@args = $class->NORMALIZE_SINGLE_ARG_BUILDARGS( @args );
return $class->$orig( @args );
};
sub NORMALIZE_SINGLE_ARG_BUILDARGS {
my ($class, @args) = @_;
# Force force_single_arg to be set as we want it immutable
# on this class once the first object has been instantiated.
$class->force_single_arg( 0 ) if !defined $class->force_single_arg();
croak "No single_arg was declared for the $class class" unless $class->has_single_arg();
return( @args ) if @args!=1;
return( @args ) unless ref($args[0]) ne 'HASH' or $class->force_single_arg();
return( $class->single_arg() => $args[0] );
}
=head1 CLASS ARGUMENTS
=head2 single_arg
__PACKAGE__->single_arg( 'foo' );
Use this to declare the C<init_arg> of the single argument.
=cut
sub single_arg {
my ($class, $value) = @_;
install_modifier(
$class, 'around', 'single_arg' => sub{
if (@_>2) { croak "single_arg has already been set to $value on $class" }
return $value;
},
) if defined $value;
return $value;
}
=head2 force_single_arg
__PACKAGE__->force_single_arg( 1 );
Causes single-argument processing to happen even if a hashref
is passed in as the single argument.
=cut
sub force_single_arg {
my ($class, $value) = @_;
install_modifier(
$class, 'around', 'force_single_arg' => sub{
if (@_>2) { croak "force_single_arg has already been set to $value on $class" }
return $value;
},
) if defined $value;
return $value;
}
=head1 CLASS METHODS
=head2 has_single_arg
Returns true if L</single_arg> has been called.
=cut
sub has_single_arg {
my $class = shift;
return defined( $class->single_arg() ) ? 1 : 0;
}
1;
__END__
=head1 SEE ALSO
=over
=item *
L<MooX::BuildArgs>
=item *
L<MooX::BuildArgsHooks>
=item *
L<MooX::MethodProxyArgs>
=item *
L<MooX::Rebuild>
=back
=head1 AUTHOR
Aran Clary Deltac <bluefeetE<64>gmail.com>
=head1 CONTRIBUTORS
=over
=item *
Peter Pentchev <roamE<64>ringlet.net>
=back
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
|