File Coverage

blib/lib/Build/Hopen/Arrrgs.pm
Criterion Covered Total %
statement 44 58 75.8
branch 18 38 47.3
condition 7 9 77.7
subroutine 5 5 100.0
pod 0 1 0.0
total 74 111 66.6


line stmt bran cond sub pod time code
1             package Build::Hopen::Arrrgs; # A tweaked version of Getopt::Mixed
2              
3 10     10   187 use 5.008;
  10         46  
4 10     10   94 use strict;
  10         25  
  10         252  
5 10     10   65 use warnings;
  10         22  
  10         249  
6              
7 10     10   50 use Carp;
  10         23  
  10         7946  
8              
9             require Exporter;
10              
11             our @ISA = qw(Exporter);
12              
13             our @EXPORT = qw( parameters );
14              
15             our $VERSION = '0.000008'; # TRIAL
16              
17             =head1 NAME
18              
19             Build::Hopen::Arrrgs - Perl extension allowing subs to handle mixed parameter lists
20              
21             =head1 SYNOPSIS
22              
23             This is a tweaked version of L. See
24             L.
25              
26             use Build::Hopen::Arrrgs;
27              
28             sub foo {
29             my %args = parameters([ qw( x y z ) ], @_);
30              
31             # Do stuff with @args{qw(x y z)}
32             }
33              
34             # OR if you have object-oriented syntax
35             sub bar {
36             my ($self, %args) = parameters('self', [ qw( x y z ) ], @_);
37              
38             # Do stuff with @args{qw(x y z)}
39             }
40              
41             # OR if you have mixed OO and function syntax
42             sub baz {
43             my ($self, %args) = parameters('My::Class', [ qw( x y z ) ], @_);
44              
45             # Do stuff with @args{qw(x y z)}
46             }
47              
48             # Calling foo:
49             foo($x, $y, $z);
50             foo($x, -z => $z, -y => $y);
51             foo(-z => $z, -x => $x, -y => $y);
52              
53             # ERRORS! calling foo:
54             foo(-z => $z, $x, $y); ### <-- ERROR!
55             foo(x => $x, y => $y, z => $z); ### <-- ERROR!
56             foo($x, -y => $y, $z); ### <-- ERROR!
57             foo($x, $y, $z, -x => $blah); ### <-- ERROR!
58              
59             # Calling bar:
60             $obj->bar($x, $y, $z);
61             $obj->bar($x, -z => $z, -y => $y);
62             My::Class->bar(-z => $z, -x => $x, -y => $y); # etc...
63              
64             # Calling baz is slight dangerous! UNIVERSAL::isa($x, 'My::Class') better not
65             # be true in the last case or problems may arrise!
66             $obj->baz($x, $y, $z);
67             My::Class->baz($x, -z => $z, -y => $y);
68             baz($x, -z => $z, -y => $y); # etc...
69              
70             =head1 DESCRIPTION
71              
72             This allows for the handling mixed argument lists to subroutines. It is meant
73             to be flexible and lightweight. It doesn't do any "type-checking", it simply
74             turns your parameter lists into hash according to a simple specification.
75              
76             The only function in this module is C and it handles all the work
77             of figuring out which parameters have been sent and which have not. When it
78             detects an error, it will die with L.
79              
80             =head2 ARGUMENTS
81              
82             The C function takes either two or three arguments. If the first
83             argument is a string, it takes three arguments. If the first argument is
84             an array reference, it takes just two.
85              
86             =head3 INVOCANT
87              
88             If the first parameter is a string, it should either be a package name or the
89             special string C<"self">. Passing C<"self"> in this argument will cause the
90             C function to require an invocant on the method--that is, it must
91             be called like this:
92              
93             $obj->foo($a, $b, $c); # OR
94             foo $obj ($a, $b, $c); # often seen as new My::Class (...)
95              
96             where C<$obj> is either a blessed reference, package name, or a scalar
97             containing a package name.
98              
99             If, instead, the first parameter is a string, but not equal to C<"self">. The
100             string is considered to be a package name. In this case, C tries to
101             guess how the method is being called. This has a lot of potential caveats, so
102             B! Essentially, C will check to see if the first argument is
103             a subclass of the given package name (i.e., according to
104             L. If so, it will I (pronounced
105             Ass-You-Me) that the argument is the invocant. Otherwise, it will I
106             that the argument is the first parameter. In this case, the returned list will
107             contain the given package name as the first element before the list of pairs
108             even though no invocant was actually used.
109              
110             =head3 SPECIFICATION
111              
112             The array reference argument to C contains a list of variable names
113             that the caller accepts. The parameter list is ordered so that if the user
114             passes positional parameters, the same order the parameters are placed, will be
115             the order used to set the variables in the returned hash. The list may contain
116             a single semicolon, which tells C that all parameters up to that
117             point are required and all following are optional. If no semicolon exists, then
118             C will consider all to be required and die when one of the required
119             parameters is missing.
120              
121             Finally, the list may end with a '*' which will cause C to collect
122             any extra unexpected named or positional parameters. Extra named parameters
123             will be inserted into the returned arguments list. Extra positional parameters
124             will be placed in array reference and assigned to the '*' key of the returned
125             arguments list. If '*' is not specified and extra arguments are found
126             C will die.
127              
128             =head3 ARGUMENTS
129              
130             The final argument to C is always the list of arguments passed to
131             the caller.
132              
133             =head2 RESULTS
134              
135             The result returned from the C function depends on whether there
136             are two arguments or three. If C is called with two arguments,
137             then a list of pairs (a hash) is returned. If C is called with
138             three arguments, then an invocant is prepended to the list of pairs first.
139             If the first argument is not C<"self">, then the invocant will be set to the
140             first argument if C doesn't detect any invocant.
141              
142             =head2 ARGUMENT PARSING
143              
144             The way C handles arguments is relatively flexible. However, the
145             format must always specify all positional parameters first, if any, followed by
146             all positional parameters. The C function switches from positional
147             to named parameters when it encounters the first string preceded with a hypen
148             ('-'). This may have the unfortunate side effect of causing normal parameters to
149             be misinterpreted as named parameters. If this may be the case with your usage,
150             I suggest finding another solution--or modifying this module to suit. A safe
151             solution to this is to always use named parameters--at which point you might
152             as well not use this module anyway.
153              
154             =cut
155              
156             sub parameters {
157 345     345 0 567 my ($invocant, $spec);
158 345 50       873 if (ref $_[0] eq 'ARRAY') {
    50          
159 0         0 $spec = shift;
160             } elsif (ref $_[0]) {
161 0         0 croak "Getopt::Mixed doesn't handle a ",ref $_[0]," as a parameter.";
162             } else {
163 345         535 $invocant = shift;
164 345         462 $spec = shift;
165             }
166              
167 345 50       1106 croak "Getopt::Mixed specification contains more than one semicolon."
168             if grep /;/, @$spec > 1;
169              
170             # Extract invocant
171 345         494 my $self;
172 345 50       624 if (defined $invocant) {
173 345 50       620 if ($invocant eq 'self') {
174 345         499 $self = shift;
175             } else {
176 0 0       0 if (UNIVERSAL::isa($_[0], $invocant)) {
177 0         0 $self = shift;
178             } else {
179 0         0 $self = $invocant;
180             }
181             }
182             }
183              
184             # This works because I break-out when I modify $spec
185 345         485 my @required;
186 345         797 for (0 .. $#$spec) {
187 631 100       1206 last if $$spec[$_] eq '*';
188 617 100       1290 if ($$spec[$_] eq ';') {
    50          
189 265         477 splice(@$spec, $_, 1);
190              
191 265         482 last;
192             } elsif ($$spec[$_] =~ /;/) {
193 0         0 my @els = split /;/, $$spec[$_];
194 0 0       0 shift @els if $els[0] eq '';
195              
196 0 0       0 croak "Getopt::Mixed specification contains more than one semicolon."
197             if @els > 2;
198              
199 0 0       0 push @required, $els[0] unless $$spec[$_] =~ /^;/;
200 0         0 splice(@$spec, $_, 1, @els);
201              
202 0         0 last;
203             }
204              
205 352         654 push @required, $$spec[$_];
206             }
207              
208              
209 345         518 my %result;
210              
211             # Scan for positional parameters
212 345         693 while (@_ > 0) {
213 474 100 100     1772 last if defined $_[0] and $_[0] =~ /^-/; # stop if named
214 342 50       6357 if ($$spec[0] eq '*') {
215 0         0 push @{$result{'*'}}, shift;
  0         0  
216             } else {
217 342         932 $result{shift @$spec} = shift;
218             }
219             }
220              
221             # Scan for named parameters
222 345         754 my %named = @_;
223 345         917 while (my ($k, $v) = each %named) {
224 212 50       601 confess "Illegal switch back to positional arguments."
225             if $k !~ /^-/;
226              
227 212         419 my $name = substr $k, 1;
228              
229             confess "Illegal argument: $name specified twice."
230 212 50       406 if exists $result{$name};
231             confess "Illegal argument: $name unknown."
232 212 50 66     805 unless (@$spec > 0 and @$spec[-1] eq '*') or grep { $name eq $_ } @$spec;
  484   66     1165  
233              
234 212         838 $result{$name} = $v;
235             }
236              
237 345         566 my @missing = grep { !exists $result{$_} } @required;
  352         835  
238 345 50       677 if (@missing) {
239 0         0 confess "Missing these required arguments: ",join(', ',@missing);
240             }
241              
242 345 50       1819 return defined $self ? ($self, %result) : %result;
243             }
244              
245             =head2 EXPORT
246              
247             Always exports C by default. If you do not want this, use:
248              
249             use Build::Hopen::Arrrgs ();
250             # OR
251             require Build::Hopen::Arrrgs;
252              
253             # ...
254             my %args = Build::Hopen::Arrrgs::parameters([ qw( x y z ) ], @_);
255              
256             =head1 SEE ALSO
257              
258             Other similar modules to this one that I'm aware of include:
259             L, L, and L.
260              
261             =head1 BUGS
262              
263             This is probably backwards compatible to Perl 5.6 and even earlier but no
264             attempt has been made to test this theory.
265              
266             I suspect this is rather slower than it could be. I hacked this together in an
267             afternoon without a whole lot of planning.
268              
269             =head1 AUTHOR
270              
271             Andrew Sterling Hanenkamp, Ehanenkamp@users.sourceforge.netE. Contact
272             me at this address for support.
273              
274             =head1 COPYRIGHT AND LICENSE
275              
276             Copyright 2003 by Andrew Sterling Hanenkamp
277              
278             This library is free software; you can redistribute it and/or modify
279             it under the same terms as Perl itself.
280              
281             =cut