Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/Sub/Exporter/Util.pm |
Statements | Executed 15 statements in 1.21ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.31ms | 3.48ms | BEGIN@332 | Sub::Exporter::Util::
1 | 1 | 1 | 626µs | 9.47ms | BEGIN@6 | Sub::Exporter::Util::
1 | 1 | 1 | 28µs | 33µs | BEGIN@1.5 | Getopt::Long::Descriptive::
1 | 1 | 1 | 17µs | 27µs | BEGIN@2.6 | Getopt::Long::Descriptive::
1 | 1 | 1 | 11µs | 34µs | BEGIN@252 | Sub::Exporter::Util::
1 | 1 | 1 | 7µs | 7µs | BEGIN@73 | Sub::Exporter::Util::
1 | 1 | 1 | 6µs | 6µs | BEGIN@7 | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:135] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:136] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:220] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:272] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:329] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:69] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:70] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __mixin_class_for | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | curry_chain | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | curry_method | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | like | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | merge_col | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | mixin_exporter | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | mixin_installer | Sub::Exporter::Util::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | 2 | 30µs | 2 | 38µs | # spent 33µs (28+5) within Getopt::Long::Descriptive::BEGIN@1.5 which was called:
# once (28µs+5µs) by Getopt::Long::Descriptive::BEGIN@259 at line 1 # spent 33µs making 1 call to Getopt::Long::Descriptive::BEGIN@1.5
# spent 5µs making 1 call to strict::import |
2 | 2 | 37µs | 2 | 36µs | # spent 27µs (17+9) within Getopt::Long::Descriptive::BEGIN@2.6 which was called:
# once (17µs+9µs) by Getopt::Long::Descriptive::BEGIN@259 at line 2 # spent 27µs making 1 call to Getopt::Long::Descriptive::BEGIN@2.6
# spent 9µs making 1 call to warnings::import |
3 | |||||
4 | package Sub::Exporter::Util; | ||||
5 | |||||
6 | 2 | 131µs | 1 | 9.47ms | # spent 9.47ms (626µs+8.84) within Sub::Exporter::Util::BEGIN@6 which was called:
# once (626µs+8.84ms) by Getopt::Long::Descriptive::BEGIN@259 at line 6 # spent 9.47ms making 1 call to Sub::Exporter::Util::BEGIN@6 |
7 | 2 | 135µs | 1 | 6µs | # spent 6µs within Sub::Exporter::Util::BEGIN@7 which was called:
# once (6µs+0s) by Getopt::Long::Descriptive::BEGIN@259 at line 7 # spent 6µs making 1 call to Sub::Exporter::Util::BEGIN@7 |
8 | |||||
9 | =head1 NAME | ||||
10 | |||||
11 | Sub::Exporter::Util - utilities to make Sub::Exporter easier | ||||
12 | |||||
13 | =head1 VERSION | ||||
14 | |||||
15 | version 0.982 | ||||
16 | |||||
17 | =cut | ||||
18 | |||||
19 | 1 | 2µs | our $VERSION = '0.982'; | ||
20 | |||||
21 | =head1 DESCRIPTION | ||||
22 | |||||
23 | This module provides a number of utility functions for performing common or | ||||
24 | useful operations when setting up a Sub::Exporter configuration. All of the | ||||
25 | utilites may be exported, but none are by default. | ||||
26 | |||||
27 | =head1 THE UTILITIES | ||||
28 | |||||
29 | =head2 curry_method | ||||
30 | |||||
31 | exports => { | ||||
32 | some_method => curry_method, | ||||
33 | } | ||||
34 | |||||
35 | This utility returns a generator which will produce an invocant-curried version | ||||
36 | of a method. In other words, it will export a method call with the exporting | ||||
37 | class built in as the invocant. | ||||
38 | |||||
39 | A module importing the code some the above example might do this: | ||||
40 | |||||
41 | use Some::Module qw(some_method); | ||||
42 | |||||
43 | my $x = some_method; | ||||
44 | |||||
45 | This would be equivalent to: | ||||
46 | |||||
47 | use Some::Module; | ||||
48 | |||||
49 | my $x = Some::Module->some_method; | ||||
50 | |||||
51 | If Some::Module is subclassed and the subclass's import method is called to | ||||
52 | import C<some_method>, the subclass will be curried in as the invocant. | ||||
53 | |||||
54 | If an argument is provided for C<curry_method> it is used as the name of the | ||||
55 | curried method to export. This means you could export a Widget constructor | ||||
56 | like this: | ||||
57 | |||||
58 | exports => { widget => curry_method('new') } | ||||
59 | |||||
60 | This utility may also be called as C<curry_class>, for backwards compatibility. | ||||
61 | |||||
62 | =cut | ||||
63 | |||||
64 | sub curry_method { | ||||
65 | my $override_name = shift; | ||||
66 | sub { | ||||
67 | my ($class, $name) = @_; | ||||
68 | $name = $override_name if defined $override_name; | ||||
69 | sub { $class->$name(@_); }; | ||||
70 | } | ||||
71 | } | ||||
72 | |||||
73 | 1 | 373µs | 1 | 7µs | # spent 7µs within Sub::Exporter::Util::BEGIN@73 which was called:
# once (7µs+0s) by Getopt::Long::Descriptive::BEGIN@259 at line 73 # spent 7µs making 1 call to Sub::Exporter::Util::BEGIN@73 |
74 | |||||
75 | =head2 curry_chain | ||||
76 | |||||
77 | C<curry_chain> behaves like C<L</curry_method>>, but is meant for generating | ||||
78 | exports that will call several methods in succession. | ||||
79 | |||||
80 | exports => { | ||||
81 | reticulate => curry_chain([ | ||||
82 | new => gather_data => analyze => [ detail => 100 ] => results | ||||
83 | ]), | ||||
84 | } | ||||
85 | |||||
86 | If imported from Spliner, calling the C<reticulate> routine will be equivalent | ||||
87 | to: | ||||
88 | |||||
89 | Splinter->new->gather_data->analyze(detail => 100)->results; | ||||
90 | |||||
91 | If any method returns something on which methods may not be called, the routine | ||||
92 | croaks. | ||||
93 | |||||
94 | The arguments to C<curry_chain> form an optlist. The names are methods to be | ||||
95 | called and the arguments, if given, are arrayrefs to be dereferenced and passed | ||||
96 | as arguments to those methods. C<curry_chain> returns a generator like those | ||||
97 | expected by Sub::Exporter. | ||||
98 | |||||
99 | B<Achtung!> at present, there is no way to pass arguments from the generated | ||||
100 | routine to the method calls. This will probably be solved in future revisions | ||||
101 | by allowing the opt list's values to be subroutines that will be called with | ||||
102 | the generated routine's stack. | ||||
103 | |||||
104 | =cut | ||||
105 | |||||
106 | sub curry_chain { | ||||
107 | # In the future, we can make \%arg an optional prepend, like the "special" | ||||
108 | # args to the default Sub::Exporter-generated import routine. | ||||
109 | my (@opt_list) = @_; | ||||
110 | |||||
111 | my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY'); | ||||
112 | |||||
113 | sub { | ||||
114 | my ($class) = @_; | ||||
115 | |||||
116 | sub { | ||||
117 | my $next = $class; | ||||
118 | |||||
119 | for my $i (0 .. $#$pairs) { | ||||
120 | my $pair = $pairs->[ $i ]; | ||||
121 | |||||
122 | unless (Params::Util::_INVOCANT($next)) { ## no critic Private | ||||
123 | my $str = defined $next ? "'$next'" : 'undef'; | ||||
124 | Carp::croak("can't call $pair->[0] on non-invocant $str") | ||||
125 | } | ||||
126 | |||||
127 | my ($method, $args) = @$pair; | ||||
128 | |||||
129 | if ($i == $#$pairs) { | ||||
130 | return $next->$method($args ? @$args : ()); | ||||
131 | } else { | ||||
132 | $next = $next->$method($args ? @$args : ()); | ||||
133 | } | ||||
134 | } | ||||
135 | }; | ||||
136 | } | ||||
137 | } | ||||
138 | |||||
139 | # =head2 name_map | ||||
140 | # | ||||
141 | # This utility returns an list to be used in specify export generators. For | ||||
142 | # example, the following: | ||||
143 | # | ||||
144 | # exports => { | ||||
145 | # name_map( | ||||
146 | # '_?_gen' => [ qw(fee fie) ], | ||||
147 | # '_make_?' => [ qw(foo bar) ], | ||||
148 | # ), | ||||
149 | # } | ||||
150 | # | ||||
151 | # is equivalent to: | ||||
152 | # | ||||
153 | # exports => { | ||||
154 | # name_map( | ||||
155 | # fee => \'_fee_gen', | ||||
156 | # fie => \'_fie_gen', | ||||
157 | # foo => \'_make_foo', | ||||
158 | # bar => \'_make_bar', | ||||
159 | # ), | ||||
160 | # } | ||||
161 | # | ||||
162 | # This can save a lot of typing, when providing many exports with similarly-named | ||||
163 | # generators. | ||||
164 | # | ||||
165 | # =cut | ||||
166 | # | ||||
167 | # sub name_map { | ||||
168 | # my (%groups) = @_; | ||||
169 | # | ||||
170 | # my %map; | ||||
171 | # | ||||
172 | # while (my ($template, $names) = each %groups) { | ||||
173 | # for my $name (@$names) { | ||||
174 | # (my $export = $template) =~ s/\?/$name/ | ||||
175 | # or Carp::croak 'no ? found in name_map template'; | ||||
176 | # | ||||
177 | # $map{ $name } = \$export; | ||||
178 | # } | ||||
179 | # } | ||||
180 | # | ||||
181 | # return %map; | ||||
182 | # } | ||||
183 | |||||
184 | =head2 merge_col | ||||
185 | |||||
186 | exports => { | ||||
187 | merge_col(defaults => { | ||||
188 | twiddle => \'_twiddle_gen', | ||||
189 | tweak => \&_tweak_gen, | ||||
190 | }), | ||||
191 | } | ||||
192 | |||||
193 | This utility wraps the given generator in one that will merge the named | ||||
194 | collection into its args before calling it. This means that you can support a | ||||
195 | "default" collector in multipe exports without writing the code each time. | ||||
196 | |||||
197 | You can specify as many pairs of collection names and generators as you like. | ||||
198 | |||||
199 | =cut | ||||
200 | |||||
201 | sub merge_col { | ||||
202 | my (%groups) = @_; | ||||
203 | |||||
204 | my %merged; | ||||
205 | |||||
206 | while (my ($default_name, $group) = each %groups) { | ||||
207 | while (my ($export_name, $gen) = each %$group) { | ||||
208 | $merged{$export_name} = sub { | ||||
209 | my ($class, $name, $arg, $col) = @_; | ||||
210 | |||||
211 | my $merged_arg = exists $col->{$default_name} | ||||
212 | ? { %{ $col->{$default_name} }, %$arg } | ||||
213 | : $arg; | ||||
214 | |||||
215 | if (Params::Util::_CODELIKE($gen)) { ## no critic Private | ||||
216 | $gen->($class, $name, $merged_arg, $col); | ||||
217 | } else { | ||||
218 | $class->$$gen($name, $merged_arg, $col); | ||||
219 | } | ||||
220 | } | ||||
221 | } | ||||
222 | } | ||||
223 | |||||
224 | return %merged; | ||||
225 | } | ||||
226 | |||||
227 | =head2 mixin_installer | ||||
228 | |||||
229 | use Sub::Exporter -setup => { | ||||
230 | installer => Sub::Exporter::Util::mixin_installer, | ||||
231 | exports => [ qw(foo bar baz) ], | ||||
232 | }; | ||||
233 | |||||
234 | This utility returns an installer that will install into a superclass and | ||||
235 | adjust the ISA importing class to include the newly generated superclass. | ||||
236 | |||||
237 | If the target of importing is an object, the hierarchy is reversed: the new | ||||
238 | class will be ISA the object's class, and the object will be reblessed. | ||||
239 | |||||
240 | B<Prerequisites>: This utility requires that Package::Generator be installed. | ||||
241 | |||||
242 | =cut | ||||
243 | |||||
244 | sub __mixin_class_for { | ||||
245 | my ($class, $mix_into) = @_; | ||||
246 | require Package::Generator; | ||||
247 | my $mixin_class = Package::Generator->new_package({ | ||||
248 | base => "$class\:\:__mixin__", | ||||
249 | }); | ||||
250 | |||||
251 | ## no critic (ProhibitNoStrict) | ||||
252 | 2 | 349µs | 2 | 58µs | # spent 34µs (11+24) within Sub::Exporter::Util::BEGIN@252 which was called:
# once (11µs+24µs) by Getopt::Long::Descriptive::BEGIN@259 at line 252 # spent 34µs making 1 call to Sub::Exporter::Util::BEGIN@252
# spent 24µs making 1 call to strict::unimport |
253 | if (ref $mix_into) { | ||||
254 | unshift @{"$mixin_class" . "::ISA"}, ref $mix_into; | ||||
255 | } else { | ||||
256 | unshift @{"$mix_into" . "::ISA"}, $mixin_class; | ||||
257 | } | ||||
258 | return $mixin_class; | ||||
259 | } | ||||
260 | |||||
261 | sub mixin_installer { | ||||
262 | sub { | ||||
263 | my ($arg, $to_export) = @_; | ||||
264 | |||||
265 | my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into}); | ||||
266 | bless $arg->{into} => $mixin_class if ref $arg->{into}; | ||||
267 | |||||
268 | Sub::Exporter::default_installer( | ||||
269 | { %$arg, into => $mixin_class }, | ||||
270 | $to_export, | ||||
271 | ); | ||||
272 | }; | ||||
273 | } | ||||
274 | |||||
275 | sub mixin_exporter { | ||||
276 | Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically"; | ||||
277 | return mixin_installer; | ||||
278 | } | ||||
279 | |||||
280 | =head2 like | ||||
281 | |||||
282 | It's a collector that adds imports for anything like given regex. | ||||
283 | |||||
284 | If you provide this configuration: | ||||
285 | |||||
286 | exports => [ qw(igrep imap islurp exhausted) ], | ||||
287 | collectors => { -like => Sub::Exporter::Util::like }, | ||||
288 | |||||
289 | A user may import from your module like this: | ||||
290 | |||||
291 | use Your::Iterator -like => qr/^i/; # imports igre, imap, islurp | ||||
292 | |||||
293 | or | ||||
294 | |||||
295 | use Your::Iterator -like => [ qr/^i/ => { -prefix => 'your_' } ]; | ||||
296 | |||||
297 | The group-like prefix and suffix arguments are respected; other arguments are | ||||
298 | passed on to the generators for matching exports. | ||||
299 | |||||
300 | =cut | ||||
301 | |||||
302 | sub like { | ||||
303 | sub { | ||||
304 | my ($value, $arg) = @_; | ||||
305 | Carp::croak "no regex supplied to regex group generator" unless $value; | ||||
306 | |||||
307 | # Oh, qr//, how you bother me! See the p5p thread from around now about | ||||
308 | # fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25 | ||||
309 | my @values = eval { $value->isa('Regexp') } ? ($value, undef) | ||||
310 | : @$value; | ||||
311 | |||||
312 | while (my ($re, $opt) = splice @values, 0, 2) { | ||||
313 | Carp::croak "given pattern for regex group generater is not a Regexp" | ||||
314 | unless eval { $re->isa('Regexp') }; | ||||
315 | my @exports = keys %{ $arg->{config}->{exports} }; | ||||
316 | my @matching = grep { $_ =~ $re } @exports; | ||||
317 | |||||
318 | my %merge = $opt ? %$opt : (); | ||||
319 | my $prefix = (delete $merge{-prefix}) || ''; | ||||
320 | my $suffix = (delete $merge{-suffix}) || ''; | ||||
321 | |||||
322 | for my $name (@matching) { | ||||
323 | my $as = $prefix . $name . $suffix; | ||||
324 | push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ]; | ||||
325 | } | ||||
326 | } | ||||
327 | |||||
328 | 1; | ||||
329 | } | ||||
330 | } | ||||
331 | |||||
332 | 1 | 556µs | # spent 3.48ms (2.31+1.18) within Sub::Exporter::Util::BEGIN@332 which was called:
# once (2.31ms+1.18ms) by Getopt::Long::Descriptive::BEGIN@259 at line 341 # spent 556µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:756] | ||
333 | exports => [ qw( | ||||
334 | like | ||||
335 | name_map | ||||
336 | merge_col | ||||
337 | curry_method curry_class | ||||
338 | curry_chain | ||||
339 | mixin_installer mixin_exporter | ||||
340 | ) ] | ||||
341 | 2 | 148µs | 1 | 3.48ms | }; # spent 3.48ms making 1 call to Sub::Exporter::Util::BEGIN@332 |
342 | |||||
343 | =head1 AUTHOR | ||||
344 | |||||
345 | Ricardo SIGNES, C<< <rjbs@cpan.org> >> | ||||
346 | |||||
347 | =head1 BUGS | ||||
348 | |||||
349 | Please report any bugs or feature requests through the web interface at | ||||
350 | L<http://rt.cpan.org>. I will be notified, and then you'll automatically be | ||||
351 | notified of progress on your bug as I make changes. | ||||
352 | |||||
353 | =head1 COPYRIGHT | ||||
354 | |||||
355 | Copyright 2006-2007, Ricardo SIGNES. This program is free software; you can | ||||
356 | redistribute it and/or modify it under the same terms as Perl itself. | ||||
357 | |||||
358 | =cut | ||||
359 | |||||
360 | 1 | 3µs | 1; |