| 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 | Sub::Exporter::Util::BEGIN@332 |
| 1 | 1 | 1 | 626µs | 9.47ms | Sub::Exporter::Util::BEGIN@6 |
| 1 | 1 | 1 | 28µs | 33µs | Getopt::Long::Descriptive::BEGIN@1.5 |
| 1 | 1 | 1 | 17µs | 27µs | Getopt::Long::Descriptive::BEGIN@2.6 |
| 1 | 1 | 1 | 11µs | 34µs | Sub::Exporter::Util::BEGIN@252 |
| 1 | 1 | 1 | 7µs | 7µs | Sub::Exporter::Util::BEGIN@73 |
| 1 | 1 | 1 | 6µs | 6µs | Sub::Exporter::Util::BEGIN@7 |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:135] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:136] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:220] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:272] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:329] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:69] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__ANON__[:70] |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::__mixin_class_for |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::curry_chain |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::curry_method |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::like |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::merge_col |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::mixin_exporter |
| 0 | 0 | 0 | 0s | 0s | Sub::Exporter::Util::mixin_installer |
| 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; |