Filename | /usr/local/share/perl/5.18.2/Sub/Exporter/Util.pm |
Statements | Executed 16 statements in 859µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 14µs | 348µs | BEGIN@198 | Sub::Exporter::Util::
1 | 1 | 1 | 12µs | 24µs | BEGIN@1.18 | Getopt::Long::Descriptive::
1 | 1 | 1 | 7µs | 11µs | BEGIN@2.19 | Getopt::Long::Descriptive::
1 | 1 | 1 | 6µs | 16µs | BEGIN@139 | Sub::Exporter::Util::
1 | 1 | 1 | 3µs | 3µs | BEGIN@9 | Sub::Exporter::Util::
1 | 1 | 1 | 3µs | 3µs | BEGIN@22 | Sub::Exporter::Util::
1 | 1 | 1 | 2µs | 2µs | BEGIN@10 | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:123] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:159] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:18] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:195] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:19] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:54] | Sub::Exporter::Util::
0 | 0 | 0 | 0s | 0s | __ANON__[:55] | 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 | 21µs | 2 | 36µs | # spent 24µs (12+12) within Getopt::Long::Descriptive::BEGIN@1.18 which was called:
# once (12µs+12µs) by Getopt::Long::Descriptive::BEGIN@267 at line 1 # spent 24µs making 1 call to Getopt::Long::Descriptive::BEGIN@1.18
# spent 12µs making 1 call to strict::import |
2 | 2 | 38µs | 2 | 14µs | # spent 11µs (7+4) within Getopt::Long::Descriptive::BEGIN@2.19 which was called:
# once (7µs+4µs) by Getopt::Long::Descriptive::BEGIN@267 at line 2 # spent 11µs making 1 call to Getopt::Long::Descriptive::BEGIN@2.19
# spent 4µs making 1 call to warnings::import |
3 | package Sub::Exporter::Util; | ||||
4 | { | ||||
5 | 2 | 900ns | $Sub::Exporter::Util::VERSION = '0.987'; | ||
6 | } | ||||
7 | # ABSTRACT: utilities to make Sub::Exporter easier | ||||
8 | |||||
9 | 2 | 18µs | 1 | 3µs | # spent 3µs within Sub::Exporter::Util::BEGIN@9 which was called:
# once (3µs+0s) by Getopt::Long::Descriptive::BEGIN@267 at line 9 # spent 3µs making 1 call to Sub::Exporter::Util::BEGIN@9 |
10 | 2 | 83µs | 1 | 2µs | # spent 2µs within Sub::Exporter::Util::BEGIN@10 which was called:
# once (2µs+0s) by Getopt::Long::Descriptive::BEGIN@267 at line 10 # spent 2µs making 1 call to Sub::Exporter::Util::BEGIN@10 |
11 | |||||
12 | |||||
13 | sub curry_method { | ||||
14 | my $override_name = shift; | ||||
15 | sub { | ||||
16 | my ($class, $name) = @_; | ||||
17 | $name = $override_name if defined $override_name; | ||||
18 | sub { $class->$name(@_); }; | ||||
19 | } | ||||
20 | } | ||||
21 | |||||
22 | 1 | 351µs | 1 | 3µs | # spent 3µs within Sub::Exporter::Util::BEGIN@22 which was called:
# once (3µs+0s) by Getopt::Long::Descriptive::BEGIN@267 at line 22 # spent 3µs making 1 call to Sub::Exporter::Util::BEGIN@22 |
23 | |||||
24 | |||||
25 | sub curry_chain { | ||||
26 | # In the future, we can make \%arg an optional prepend, like the "special" | ||||
27 | # args to the default Sub::Exporter-generated import routine. | ||||
28 | my (@opt_list) = @_; | ||||
29 | |||||
30 | my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY'); | ||||
31 | |||||
32 | sub { | ||||
33 | my ($class) = @_; | ||||
34 | |||||
35 | sub { | ||||
36 | my $next = $class; | ||||
37 | |||||
38 | for my $i (0 .. $#$pairs) { | ||||
39 | my $pair = $pairs->[ $i ]; | ||||
40 | |||||
41 | unless (Params::Util::_INVOCANT($next)) { ## no critic Private | ||||
42 | my $str = defined $next ? "'$next'" : 'undef'; | ||||
43 | Carp::croak("can't call $pair->[0] on non-invocant $str") | ||||
44 | } | ||||
45 | |||||
46 | my ($method, $args) = @$pair; | ||||
47 | |||||
48 | if ($i == $#$pairs) { | ||||
49 | return $next->$method($args ? @$args : ()); | ||||
50 | } else { | ||||
51 | $next = $next->$method($args ? @$args : ()); | ||||
52 | } | ||||
53 | } | ||||
54 | }; | ||||
55 | } | ||||
56 | } | ||||
57 | |||||
58 | # =head2 name_map | ||||
59 | # | ||||
60 | # This utility returns an list to be used in specify export generators. For | ||||
61 | # example, the following: | ||||
62 | # | ||||
63 | # exports => { | ||||
64 | # name_map( | ||||
65 | # '_?_gen' => [ qw(fee fie) ], | ||||
66 | # '_make_?' => [ qw(foo bar) ], | ||||
67 | # ), | ||||
68 | # } | ||||
69 | # | ||||
70 | # is equivalent to: | ||||
71 | # | ||||
72 | # exports => { | ||||
73 | # name_map( | ||||
74 | # fee => \'_fee_gen', | ||||
75 | # fie => \'_fie_gen', | ||||
76 | # foo => \'_make_foo', | ||||
77 | # bar => \'_make_bar', | ||||
78 | # ), | ||||
79 | # } | ||||
80 | # | ||||
81 | # This can save a lot of typing, when providing many exports with similarly-named | ||||
82 | # generators. | ||||
83 | # | ||||
84 | # =cut | ||||
85 | # | ||||
86 | # sub name_map { | ||||
87 | # my (%groups) = @_; | ||||
88 | # | ||||
89 | # my %map; | ||||
90 | # | ||||
91 | # while (my ($template, $names) = each %groups) { | ||||
92 | # for my $name (@$names) { | ||||
93 | # (my $export = $template) =~ s/\?/$name/ | ||||
94 | # or Carp::croak 'no ? found in name_map template'; | ||||
95 | # | ||||
96 | # $map{ $name } = \$export; | ||||
97 | # } | ||||
98 | # } | ||||
99 | # | ||||
100 | # return %map; | ||||
101 | # } | ||||
102 | |||||
103 | |||||
104 | sub merge_col { | ||||
105 | my (%groups) = @_; | ||||
106 | |||||
107 | my %merged; | ||||
108 | |||||
109 | while (my ($default_name, $group) = each %groups) { | ||||
110 | while (my ($export_name, $gen) = each %$group) { | ||||
111 | $merged{$export_name} = sub { | ||||
112 | my ($class, $name, $arg, $col) = @_; | ||||
113 | |||||
114 | my $merged_arg = exists $col->{$default_name} | ||||
115 | ? { %{ $col->{$default_name} }, %$arg } | ||||
116 | : $arg; | ||||
117 | |||||
118 | if (Params::Util::_CODELIKE($gen)) { ## no critic Private | ||||
119 | $gen->($class, $name, $merged_arg, $col); | ||||
120 | } else { | ||||
121 | $class->$$gen($name, $merged_arg, $col); | ||||
122 | } | ||||
123 | } | ||||
124 | } | ||||
125 | } | ||||
126 | |||||
127 | return %merged; | ||||
128 | } | ||||
129 | |||||
130 | |||||
131 | sub __mixin_class_for { | ||||
132 | my ($class, $mix_into) = @_; | ||||
133 | require Package::Generator; | ||||
134 | my $mixin_class = Package::Generator->new_package({ | ||||
135 | base => "$class\:\:__mixin__", | ||||
136 | }); | ||||
137 | |||||
138 | ## no critic (ProhibitNoStrict) | ||||
139 | 2 | 316µs | 2 | 26µs | # spent 16µs (6+10) within Sub::Exporter::Util::BEGIN@139 which was called:
# once (6µs+10µs) by Getopt::Long::Descriptive::BEGIN@267 at line 139 # spent 16µs making 1 call to Sub::Exporter::Util::BEGIN@139
# spent 10µs making 1 call to strict::unimport |
140 | if (ref $mix_into) { | ||||
141 | unshift @{"$mixin_class" . "::ISA"}, ref $mix_into; | ||||
142 | } else { | ||||
143 | unshift @{"$mix_into" . "::ISA"}, $mixin_class; | ||||
144 | } | ||||
145 | return $mixin_class; | ||||
146 | } | ||||
147 | |||||
148 | sub mixin_installer { | ||||
149 | sub { | ||||
150 | my ($arg, $to_export) = @_; | ||||
151 | |||||
152 | my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into}); | ||||
153 | bless $arg->{into} => $mixin_class if ref $arg->{into}; | ||||
154 | |||||
155 | Sub::Exporter::default_installer( | ||||
156 | { %$arg, into => $mixin_class }, | ||||
157 | $to_export, | ||||
158 | ); | ||||
159 | }; | ||||
160 | } | ||||
161 | |||||
162 | sub mixin_exporter { | ||||
163 | Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically"; | ||||
164 | return mixin_installer; | ||||
165 | } | ||||
166 | |||||
167 | |||||
168 | sub like { | ||||
169 | sub { | ||||
170 | my ($value, $arg) = @_; | ||||
171 | Carp::croak "no regex supplied to regex group generator" unless $value; | ||||
172 | |||||
173 | # Oh, qr//, how you bother me! See the p5p thread from around now about | ||||
174 | # fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25 | ||||
175 | my @values = eval { $value->isa('Regexp') } ? ($value, undef) | ||||
176 | : @$value; | ||||
177 | |||||
178 | while (my ($re, $opt) = splice @values, 0, 2) { | ||||
179 | Carp::croak "given pattern for regex group generater is not a Regexp" | ||||
180 | unless eval { $re->isa('Regexp') }; | ||||
181 | my @exports = keys %{ $arg->{config}->{exports} }; | ||||
182 | my @matching = grep { $_ =~ $re } @exports; | ||||
183 | |||||
184 | my %merge = $opt ? %$opt : (); | ||||
185 | my $prefix = (delete $merge{-prefix}) || ''; | ||||
186 | my $suffix = (delete $merge{-suffix}) || ''; | ||||
187 | |||||
188 | for my $name (@matching) { | ||||
189 | my $as = $prefix . $name . $suffix; | ||||
190 | push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ]; | ||||
191 | } | ||||
192 | } | ||||
193 | |||||
194 | 1; | ||||
195 | } | ||||
196 | } | ||||
197 | |||||
198 | 1 | 8µs | 1 | 334µs | # spent 348µs (14+334) within Sub::Exporter::Util::BEGIN@198 which was called:
# once (14µs+334µs) by Getopt::Long::Descriptive::BEGIN@267 at line 207 # spent 334µs making 1 call to Sub::Exporter::__ANON__[Sub/Exporter.pm:337] |
199 | exports => [ qw( | ||||
200 | like | ||||
201 | name_map | ||||
202 | merge_col | ||||
203 | curry_method curry_class | ||||
204 | curry_chain | ||||
205 | mixin_installer mixin_exporter | ||||
206 | ) ] | ||||
207 | 1 | 21µs | 1 | 348µs | }; # spent 348µs making 1 call to Sub::Exporter::Util::BEGIN@198 |
208 | |||||
209 | 1 | 2µs | 1; | ||
210 | |||||
211 | __END__ |