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