File Coverage

blib/lib/Getargs/Mixed.pm
Criterion Covered Total %
statement 65 65 100.0
branch 44 44 100.0
condition 12 12 100.0
subroutine 6 6 100.0
pod 2 2 100.0
total 129 129 100.0


line stmt bran cond sub pod time code
1             package Getargs::Mixed;
2              
3 18     18   1230354 use 5.006;
  18         201  
4 18     18   102 use strict;
  18         33  
  18         564  
5 18     18   113 use warnings;
  18         44  
  18         603  
6 18     18   137 use Carp;
  18         53  
  18         16172  
7              
8             require Exporter;
9              
10             our @ISA = qw(Exporter);
11              
12             our @EXPORT = qw( parameters );
13              
14             our $VERSION = '1.06';
15              
16             =head1 NAME
17              
18             Getargs::Mixed - Perl extension allowing subs to handle mixed parameter lists
19              
20             =head1 SYNOPSIS
21              
22             use Getargs::Mixed;
23              
24             sub foo {
25             my %args = parameters([ qw( x y z ) ], @_);
26              
27             # Do stuff with @args{qw(x y z)}
28             }
29              
30             # OR if you have object-oriented syntax
31             sub bar {
32             my ($self, %args) = parameters('self', [ qw( x y z ) ], @_);
33              
34             # Do stuff with @args{qw(x y z)}
35             }
36              
37             # OR if you have mixed OO and function syntax
38             sub baz {
39             my ($self, %args) = parameters('My::Class', [ qw( x y z ) ], @_);
40              
41             # Do stuff with @args{qw(x y z)}
42             }
43              
44             # Calling foo:
45             foo($x, $y, $z);
46             foo($x, -z => $z, -y => $y);
47             foo(-z => $z, -x => $x, -y => $y);
48              
49             # ERRORS! calling foo:
50             foo(-z => $z, $x, $y); ### <-- ERROR!
51             foo(x => $x, y => $y, z => $z); ### <-- ERROR!
52             foo($x, -y => $y, $z); ### <-- ERROR!
53             foo($x, $y, $z, -x => $blah); ### <-- ERROR!
54              
55             # Calling bar:
56             $obj->bar($x, $y, $z);
57             $obj->bar($x, -z => $z, -y => $y);
58             My::Class->bar(-z => $z, -x => $x, -y => $y); # etc...
59              
60             # Calling baz is slightly dangerous! UNIVERSAL::isa($x, 'My::Class') better
61             # not be true in the last case or problems may arise!
62             $obj->baz($x, $y, $z);
63             My::Class->baz($x, -z => $z, -y => $y);
64             baz($x, -z => $z, -y => $y); # etc...
65              
66             =head1 FUNCTIONAL INTERFACE
67              
68             =head2 parameters
69              
70             This allows for the handling mixed argument lists to subroutines. It is meant
71             to be flexible and lightweight. It doesn't do any "type-checking", it simply
72             turns your parameter lists into hash according to a simple specification.
73              
74             The main function in this module is C and it handles all the work
75             of figuring out which parameters have been sent and which have not. When it
76             detects an error, it will die with L.
77              
78             The C function takes either two or three arguments. If the first
79             argument is a string, it takes at least two arguments: invocant and
80             specification. For example:
81              
82             parameters('invocant', [qw(specification)], @_);
83              
84             If the first argument is an array reference, it takes at least one argument:
85             the specification. For example:
86              
87             parameters([qw(specification)], @_);
88              
89             In either case, the specification is followed by any arguments to be parsed
90             (C<@_> in the examples above).
91              
92             =head3 Invocant
93              
94             If the first parameter is a string, it should either be a package name or the
95             special string C<"self">. Passing C<"self"> in this argument will cause the
96             C function to require an invocant on the method--that is, it must
97             be called like this:
98              
99             $obj->foo($a, $b, $c); # OR
100             foo $obj ($a, $b, $c); # often seen as new My::Class (...)
101              
102             where C<$obj> is either a blessed reference, package name, or a scalar
103             containing a package name.
104              
105             If, instead, the first parameter is a string, but not equal to C<"self">. The
106             string is considered to be a package name. In this case, C tries to
107             guess how the method is being called. This has a lot of potential caveats, so
108             B! Essentially, C will check to see if the first argument is
109             a subclass of the given package name (i.e., according to
110             L. If so, it will I (pronounced
111             Ass-You-Me) that the argument is the invocant. Otherwise, it will I
112             that the argument is the first parameter. In this case, the returned list will
113             contain the given package name as the first element before the list of pairs
114             even though no invocant was actually used.
115              
116             =head3 Specification
117              
118             The array reference argument to C contains a list of variable names
119             that the caller accepts. The parameter list is ordered so that if the user
120             passes positional parameters, the same order the parameters are placed, will be
121             the order used to set the variables in the returned hash. The list may contain
122             a single semicolon, which tells C that all parameters up to that
123             point are required and all following are optional. If no semicolon exists, then
124             C will consider all to be required and die when one of the required
125             parameters is missing.
126              
127             Finally, the list may end with a C<'*'> which will cause C to
128             collect any extra unexpected named or positional parameters. Extra named
129             parameters will be inserted into the returned arguments list. Extra positional
130             parameters will be placed in array reference and assigned to the '*' key of the
131             returned arguments list. If '*' is not specified and extra arguments are found
132             C will die.
133              
134             =head3 The arguments to be parsed
135              
136             The final argument to C is always the list of arguments passed to
137             the caller, usually C<@_>.
138              
139             =head3 The results of a parameters() call
140              
141             The result returned from the C function depends on whether there
142             are two arguments or three. If C is called with two arguments,
143             then a list of pairs (a hash) is returned. If C is called with
144             three arguments, then an invocant is prepended to the list of pairs first.
145             If the first argument is not C<"self">, then the invocant will be set to the
146             first argument if C doesn't detect any invocant.
147              
148             =head1 ARGUMENT PARSING
149              
150             The way C handles arguments is relatively flexible. However, the
151             format must always specify all positional parameters first, if any, followed by
152             all positional parameters. The C function switches from positional
153             to named parameters when it encounters the first string preceded with a hypen
154             ('-'). This may have the unfortunate side effect of causing normal parameters to
155             be misinterpreted as named parameters. If this may be the case with your usage,
156             I suggest finding another solution--or modifying this module to suit. A safe
157             solution to this is to always use named parameters--at which point you might
158             as well not use this module anyway.
159              
160             =cut
161              
162             sub parameters {
163 154     154 1 106040 my $me = {}; # parsing options applicable to this run
164 154 100       700 $me = shift if UNIVERSAL::isa($_[0], __PACKAGE__);
165              
166 154         289 my ($invocant, $spec);
167 154 100       452 if (ref $_[0] eq 'ARRAY') {
    100          
168 90         157 $spec = shift;
169             } elsif (ref $_[0]) {
170 4         448 croak "Getopt::Mixed doesn't handle a ",ref $_[0]," as a parameter.";
171             } else {
172 60         89 $invocant = shift;
173 60         92 $spec = shift;
174             }
175              
176 150 100       917 croak "Getopt::Mixed specification contains more than one semicolon."
177             if grep(/;/, @$spec) > 1;
178              
179             # Extract invocant
180 148         236 my $self;
181 148 100       362 if (defined $invocant) {
182 60 100       106 if ($invocant eq 'self') {
183 20         36 $self = shift;
184             } else {
185 40 100       130 if (UNIVERSAL::isa($_[0], $invocant)) {
186 20         30 $self = shift;
187             } else {
188 20         33 $self = $invocant;
189             }
190             }
191             }
192              
193             # This works because I break-out when I modify $spec
194 148         266 my @required;
195 148         444 for (0 .. $#$spec) {
196 409 100       799 last if $$spec[$_] eq '*';
197              
198 387 100       922 if ($$spec[$_] eq ';') {
    100          
199 11         23 splice(@$spec, $_, 1);
200              
201 11         24 last;
202              
203             } elsif ($$spec[$_] =~ /;/) {
204 22         102 $$spec[$_] =~ s/(^\s+)|(\s+$)//g; # Trim whitespace
205 22         95 my @els = split /;/, $$spec[$_], -1; # -1 => keep empty fields
206 22 100       228 croak "Getopt::Mixed specification contains multiple semicolons."
207             if @els > 2;
208              
209 20 100       63 shift @els if $els[0] eq ''; # semicolon first.
210             # @els is always nonempty because $$spec[$_] contains a
211             # semicolon (the regex matched) and so split /;/...-1
212             # gives us at least one field.
213              
214 20 100       135 push @required, $els[0] unless $$spec[$_] =~ /^;/;
215 20         65 splice(@$spec, $_, 1, @els);
216              
217 20         61 last;
218             }
219              
220 354         648 push @required, $$spec[$_];
221             } #foreach element of @$spec
222              
223 146         267 my %result;
224              
225             # Scan for positional parameters
226 146         364 while (@_ > 0) {
227 244 100 100     1286 last if defined $_[0] and $_[0] =~ /^-/; # stop if named
228              
229             # Trap, e.g., [qw(;)], which leaves an empty element in the spec.
230 127 100 100     974 croak "I have a positional parameter but no name for it"
231             unless @$spec && $$spec[0];
232              
233 121 100       269 if ($$spec[0] eq '*') {
234 2         41 push @{$result{'*'}}, shift;
  2         11  
235             } else {
236 119         409 $result{shift @$spec} = shift;
237             }
238             }
239              
240             # Scan for named parameters
241 140         502 my %named = @_;
242 140         534 while (my ($k, $v) = each %named) {
243 291 100       1013 confess "Illegal switch back to positional arguments."
244             if $k !~ /^-/;
245              
246 289         537 my $name = substr $k, 1;
247              
248             confess "Illegal argument: $name specified twice."
249 289 100       948 if exists $result{$name};
250             confess "Illegal argument: $name unknown."
251 287 100 100     1328 unless (@$spec > 0 and @$spec[-1] eq '*') or grep { $name eq $_ } @$spec;
  602   100     1340  
252              
253 285         964 $result{$name} = $v;
254             }
255              
256             my @missing = $me->{-undef_ok} ?
257 2         8 grep { !exists $result{$_} } @required :
258 134 100       409 grep { !defined $result{$_} } @required;
  338         794  
259              
260 134 100       319 if (@missing) {
261 4         430 confess "Missing these required arguments: ",join(', ',@missing);
262             }
263              
264 130 100       893 return defined $self ? ($self, %result) : %result;
265             } #parameters()
266              
267             =head1 EXPORT
268              
269             Always exports C by default. If you do not want this, use:
270              
271             use Getargs::Mixed ();
272             # OR
273             require Getargs::Mixed;
274              
275             # ...
276             my %args = Getargs::Mixed::parameters([ qw( x y z ) ], @_);
277              
278             =head1 OBJECT-ORIENTED INTERFACE
279              
280             Getargs::Mixed supports an object-oriented interface that permits you
281             to adjust how the parameters are processed. For example:
282              
283             my $getargs = Getargs::Mixed->new([options...]);
284             my %args = $getargs->parameters([ qw( x y z ) ], @_);
285              
286             The arguments to the C method are exactly the same as when
287             C is called as a function. This includes the invocant,
288             since C<$getargs> is not the invocant of the function that is invoking
289             C<< $getargs->parameters() >>.
290              
291             =head2 new
292              
293             Create a new instance with the given options. For example:
294              
295             my $getargs = Getargs::Mixed->new(-undef_ok => 1);
296              
297             Currently known options are:
298              
299             =over
300              
301             =item -undef_ok
302              
303             The option C<< -undef_ok => 1 >> permits the value of a parameter to be
304             C. For example,
305              
306             my %args = parameters(['foo'], -foo => undef);
307              
308             will fail with a message that required argument C was not provided, but
309              
310             my %args = Getargs::Mixed->new(-undef_ok => 1)
311             ->parameters(['foo'], -foo => undef);
312              
313             will succeed, and set C<< $args{foo} >> to C.
314              
315             =back
316              
317             =cut
318              
319             sub new {
320 78     78 1 107891 my $class = shift;
321 78         360 bless {@_}, $class;
322             }
323              
324             =head1 SEE ALSO
325              
326             Other similar modules to this one that I'm aware of include:
327             L, L, and L.
328              
329             =head1 AUTHOR
330              
331             Andrew Sterling Hanenkamp, Ehanenkamp@users.sourceforge.netE
332             (HANENKAMP). Additional code by Christopher White (CXW).
333              
334             =head1 COPYRIGHT AND LICENSE
335              
336             Copyright 2003--2019 by Andrew Sterling Hanenkamp and Christopher White.
337             All rights reserved.
338              
339             This library is free software; you can redistribute it and/or modify
340             it under the same terms as Perl itself.
341              
342             =cut