line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright (c) 2014 Paul Evans . All rights reserved. |
2
|
|
|
|
|
|
|
# This program is free software; you can redistribute it and/or |
3
|
|
|
|
|
|
|
# modify it under the same terms as Perl itself. |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Sub::Util; |
6
|
|
|
|
|
|
|
|
7
|
4
|
|
|
4
|
|
121070
|
use strict; |
|
4
|
|
|
|
|
29
|
|
|
4
|
|
|
|
|
110
|
|
8
|
4
|
|
|
4
|
|
17
|
use warnings; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
635
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
require Exporter; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our @ISA = qw( Exporter ); |
13
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
14
|
|
|
|
|
|
|
prototype set_prototype |
15
|
|
|
|
|
|
|
subname set_subname |
16
|
|
|
|
|
|
|
); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $VERSION = "1.63"; |
19
|
|
|
|
|
|
|
$VERSION =~ tr/_//d; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
require List::Util; # as it has the XS |
22
|
|
|
|
|
|
|
List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863) |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 NAME |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
Sub::Util - A selection of utility subroutines for subs and CODE references |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head1 SYNOPSIS |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
use Sub::Util qw( prototype set_prototype subname set_subname ); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 DESCRIPTION |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
C contains a selection of utility subroutines that are useful for |
35
|
|
|
|
|
|
|
operating on subs and CODE references. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
The rationale for inclusion in this module is that the function performs some |
38
|
|
|
|
|
|
|
work for which an XS implementation is essential because it cannot be |
39
|
|
|
|
|
|
|
implemented in Pure Perl, and which is sufficiently-widely used across CPAN |
40
|
|
|
|
|
|
|
that its popularity warrants inclusion in a core module, which this is. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=cut |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
=head1 FUNCTIONS |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=cut |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=head2 prototype |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
my $proto = prototype( $code ) |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
I |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
Returns the prototype of the given C<$code> reference, if it has one, as a |
55
|
|
|
|
|
|
|
string. This is the same as the C operator; it is included |
56
|
|
|
|
|
|
|
here simply for symmetry and completeness with the other functions. |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=cut |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub prototype |
61
|
|
|
|
|
|
|
{ |
62
|
0
|
|
|
0
|
1
|
|
my ( $code ) = @_; |
63
|
0
|
|
|
|
|
|
return CORE::prototype( $code ); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=head2 set_prototype |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
my $code = set_prototype $prototype, $code; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
I |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
Sets the prototype of the function given by the C<$code> reference, or deletes |
73
|
|
|
|
|
|
|
it if C<$prototype> is C. Returns the C<$code> reference itself. |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
I: This function takes arguments in a different order to the previous |
76
|
|
|
|
|
|
|
copy of the code from C. This is to match the order of |
77
|
|
|
|
|
|
|
C, and other potential additions in this file. This order has |
78
|
|
|
|
|
|
|
been chosen as it allows a neat and simple chaining of other |
79
|
|
|
|
|
|
|
C functions as might become available, such as: |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
my $code = |
82
|
|
|
|
|
|
|
set_subname name_here => |
83
|
|
|
|
|
|
|
set_prototype '&@' => |
84
|
|
|
|
|
|
|
set_attribute ':lvalue' => |
85
|
|
|
|
|
|
|
sub { ...... }; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=cut |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head2 subname |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
my $name = subname( $code ) |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
I |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
Returns the name of the given C<$code> reference, if it has one. Normal named |
96
|
|
|
|
|
|
|
subs will give a fully-qualified name consisting of the package and the |
97
|
|
|
|
|
|
|
localname separated by C<::>. Anonymous code references will give C<__ANON__> |
98
|
|
|
|
|
|
|
as the localname. If the package the code was compiled in has been deleted |
99
|
|
|
|
|
|
|
(e.g. using C from L), C<__ANON__> will be returned as |
100
|
|
|
|
|
|
|
the package name. If a name has been set using L, this name will be |
101
|
|
|
|
|
|
|
returned instead. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
This function was inspired by C from L. The |
104
|
|
|
|
|
|
|
remaining functions that C implements can easily be emulated |
105
|
|
|
|
|
|
|
using regexp operations, such as |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.*?)$/ } |
108
|
|
|
|
|
|
|
sub sub_name { return (get_code_info $_[0])[0] } |
109
|
|
|
|
|
|
|
sub stash_name { return (get_code_info $_[0])[1] } |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
I: This function is B the same as |
112
|
|
|
|
|
|
|
C; it returns the existing name of the sub rather than |
113
|
|
|
|
|
|
|
changing it. To set or change a name, see instead L. |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=cut |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=head2 set_subname |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
my $code = set_subname $name, $code; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
I |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
Sets the name of the function given by the C<$code> reference. Returns the |
124
|
|
|
|
|
|
|
C<$code> reference itself. If the C<$name> is unqualified, the package of the |
125
|
|
|
|
|
|
|
caller is used to qualify it. |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
This is useful for applying names to anonymous CODE references so that stack |
128
|
|
|
|
|
|
|
traces and similar situations, to give a useful name rather than having the |
129
|
|
|
|
|
|
|
default of C<__ANON__>. Note that this name is only used for this situation; |
130
|
|
|
|
|
|
|
the C will not install it into the symbol table; you will have to |
131
|
|
|
|
|
|
|
do that yourself if required. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
However, since the name is not used by perl except as the return value of |
134
|
|
|
|
|
|
|
C, for stack traces or similar, there is no actual requirement that |
135
|
|
|
|
|
|
|
the name be syntactically valid as a perl function name. This could be used to |
136
|
|
|
|
|
|
|
attach extra information that could be useful in debugging stack traces. |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
This function was copied from C and renamed to the naming |
139
|
|
|
|
|
|
|
convention of this module. |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=cut |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=head1 AUTHOR |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
The general structure of this module was written by Paul Evans |
146
|
|
|
|
|
|
|
. |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
The XS implementation of L was copied from L by |
149
|
|
|
|
|
|
|
Matthijs van Duin |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=cut |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
1; |