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
|
package MooX::SingleArg;
our $VERSION = '0.08';
=encoding utf8
=head1 NAME
MooX::SingleArg - Support single-argument instantiation.
=head1 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 SUPPORT
See L<MooX::BuildArgs/SUPPORT>.
=head1 AUTHORS
See L<MooX::BuildArgs/AUTHORS>.
=head1 LICENSE
See L<MooX::BuildArgs/LICENSE>.
=cut
|
