line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package exact; |
2
|
|
|
|
|
|
|
# ABSTRACT: Perl pseudo pragma to enable strict, warnings, features, mro, filehandle methods |
3
|
|
|
|
|
|
|
|
4
|
9
|
|
|
9
|
|
2108620
|
use 5.014; |
|
9
|
|
|
|
|
105
|
|
5
|
9
|
|
|
9
|
|
47
|
use strict; |
|
9
|
|
|
|
|
21
|
|
|
9
|
|
|
|
|
191
|
|
6
|
9
|
|
|
9
|
|
37
|
use warnings; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
199
|
|
7
|
9
|
|
|
9
|
|
4193
|
use namespace::autoclean; |
|
9
|
|
|
|
|
163169
|
|
|
9
|
|
|
|
|
38
|
|
8
|
9
|
|
|
9
|
|
4708
|
use Import::Into; |
|
9
|
|
|
|
|
4714
|
|
|
9
|
|
|
|
|
299
|
|
9
|
9
|
|
|
9
|
|
58
|
use Sub::Util 'set_subname'; |
|
9
|
|
|
|
|
28
|
|
|
9
|
|
|
|
|
629
|
|
10
|
9
|
|
|
9
|
|
4478
|
use Syntax::Keyword::Try; |
|
9
|
|
|
|
|
21359
|
|
|
9
|
|
|
|
|
53
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '1.21'; # VERSION |
13
|
|
|
|
|
|
|
|
14
|
9
|
|
|
9
|
|
992
|
use feature (); |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
137
|
|
15
|
9
|
|
|
9
|
|
38
|
use utf8 (); |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
195
|
|
16
|
9
|
|
|
9
|
|
43
|
use mro (); |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
193
|
|
17
|
9
|
|
|
9
|
|
42
|
use Carp qw( croak carp confess cluck ); |
|
9
|
|
|
|
|
24
|
|
|
9
|
|
|
|
|
511
|
|
18
|
9
|
|
|
9
|
|
4478
|
use IO::File (); |
|
9
|
|
|
|
|
78716
|
|
|
9
|
|
|
|
|
229
|
|
19
|
9
|
|
|
9
|
|
61
|
use IO::Handle (); |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
126
|
|
20
|
9
|
|
|
9
|
|
39
|
use Try::Tiny (); |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
109
|
|
21
|
9
|
|
|
9
|
|
4307
|
use PerlX::Maybe (); |
|
9
|
|
|
|
|
22076
|
|
|
9
|
|
|
|
|
8354
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
my ($perl_version) = $^V =~ /^v5\.(\d+)/; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my $features_available = ( %feature::feature_bundle and $feature::feature_bundle{all} ) |
26
|
|
|
|
|
|
|
? $feature::feature_bundle{all} |
27
|
|
|
|
|
|
|
: [ qw( say state switch unicode_strings ) ]; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
my $functions_available = [ qw( |
30
|
|
|
|
|
|
|
nostrict nowarnings |
31
|
|
|
|
|
|
|
nofeatures nobundle noskipexperimentalwarnings |
32
|
|
|
|
|
|
|
noutf8 noc3 nocarp notry trytiny nomaybe noautoclean |
33
|
|
|
|
|
|
|
) ]; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
my $functions_deprecated = ['noexperiments']; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my ( $no_parent, $late_parent ); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub import { |
40
|
17
|
|
|
17
|
|
3367
|
my ( $self, $caller ) = ( shift, caller() ); |
41
|
|
|
|
|
|
|
|
42
|
17
|
|
|
|
|
37
|
my ( @features, @nofeatures, @functions, @bundles, @classes ); |
43
|
17
|
|
|
|
|
40
|
for (@_) { |
44
|
7
|
|
|
|
|
17
|
( my $opt = $_ ) =~ s/^\-//; |
45
|
|
|
|
|
|
|
|
46
|
7
|
50
|
66
|
|
|
36
|
if ( $opt eq 'class' ) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
47
|
0
|
|
|
|
|
0
|
push( @classes, $opt ); |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
elsif ( $opt eq 'cor' ) { |
50
|
0
|
|
|
|
|
0
|
push( @features, 'class' ); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
elsif ( $opt eq 'nocor' ) { |
53
|
0
|
|
|
|
|
0
|
push( @nofeatures, 'class' ); |
54
|
|
|
|
|
|
|
} |
55
|
98
|
|
|
|
|
145
|
elsif ( grep { $_ eq $opt } @$features_available ) { |
56
|
2
|
|
|
|
|
4
|
push( @features, $opt ); |
57
|
|
|
|
|
|
|
} |
58
|
70
|
|
|
|
|
127
|
elsif ( my ($nofeature) = grep { 'no' . $_ eq $opt } @$features_available ) { |
59
|
1
|
|
|
|
|
6
|
push( @nofeatures, $nofeature ); |
60
|
|
|
|
|
|
|
} |
61
|
52
|
|
|
|
|
115
|
elsif ( grep { $_ eq $opt } @$functions_available, @$functions_deprecated ) { |
62
|
2
|
50
|
|
|
|
4
|
push( @functions, $opt ) if ( grep { $_ eq $opt } @$functions_available ); |
|
24
|
|
|
|
|
39
|
|
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
elsif ( $opt =~ /^:?v?5?\.?(\d+)/ and $1 >= 10 ) { |
65
|
1
|
|
|
|
|
6
|
push( @bundles, $1 ); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
else { |
68
|
1
|
50
|
|
|
|
4
|
push( @classes, $opt ) if ( $opt !~ /^no[a-z]{2}/ ); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
17
|
50
|
|
|
|
119
|
strict ->import unless ( grep { $_ eq 'nostrict' } @functions ); |
|
2
|
|
|
|
|
14
|
|
73
|
17
|
50
|
|
|
|
196
|
warnings->import unless ( grep { $_ eq 'nowarnings' } @functions ); |
|
2
|
|
|
|
|
26
|
|
74
|
|
|
|
|
|
|
|
75
|
17
|
100
|
66
|
|
|
159
|
if (@bundles) { |
|
|
100
|
|
|
|
|
|
76
|
1
|
|
|
|
|
109
|
feature->import( ':5.' . $_ ) for (@bundles); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
elsif ( |
79
|
|
|
|
|
|
|
not grep { $_ eq 'nofeatures' } @functions and |
80
|
|
|
|
|
|
|
not grep { $_ eq 'nobundle' } @functions |
81
|
|
|
|
|
|
|
) { |
82
|
15
|
50
|
|
|
|
1779
|
feature->import( $perl_version >= 16 ? ':all' : ':5.' . $perl_version ); |
83
|
|
|
|
|
|
|
} |
84
|
17
|
|
|
|
|
152
|
feature->import($_) for (@features); |
85
|
17
|
|
|
|
|
44
|
feature->unimport($_) for (@nofeatures); |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
warnings->unimport('experimental') |
88
|
17
|
50
|
33
|
|
|
278
|
unless ( $perl_version < 18 or grep { $_ eq 'noskipexperimentalwarnings' } @functions ); |
|
2
|
|
|
|
|
43
|
|
89
|
|
|
|
|
|
|
|
90
|
17
|
50
|
|
|
|
52
|
unless ( grep { $_ eq 'noutf8' } @functions ) { |
|
2
|
|
|
|
|
9
|
|
91
|
17
|
|
|
|
|
90
|
utf8->import; |
92
|
17
|
|
|
|
|
185
|
binmode( $_, ':utf8' ) for ( *STDIN, *STDERR, *STDOUT ); |
93
|
17
|
|
|
|
|
97
|
'open'->import::into( $caller, ':std', ':utf8' ); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
17
|
50
|
|
|
|
21128
|
mro::set_mro( $caller, 'c3' ) unless ( grep { $_ eq 'noc3' } @functions ); |
|
2
|
|
|
|
|
18
|
|
97
|
|
|
|
|
|
|
|
98
|
68
|
|
|
|
|
92
|
monkey_patch( $self, $caller, ( map { $_ => \&{ 'Carp::' . $_ } } qw( croak carp confess cluck ) ) ) |
|
68
|
|
|
|
|
205
|
|
99
|
17
|
50
|
|
|
|
64
|
unless ( grep { $_ eq 'nocarp' } @functions ); |
|
2
|
|
|
|
|
7
|
|
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
feature->unimport('try') if ( |
102
|
238
|
|
|
|
|
373
|
grep { $_ eq 'try' } @$features_available and |
103
|
|
|
|
|
|
|
( |
104
|
|
|
|
|
|
|
grep { $_ eq 'notry' } @functions or |
105
|
17
|
0
|
0
|
|
|
45
|
grep { $_ eq 'trytiny' } @functions |
|
|
|
33
|
|
|
|
|
106
|
|
|
|
|
|
|
) |
107
|
|
|
|
|
|
|
); |
108
|
|
|
|
|
|
|
Syntax::Keyword::Try->import_into($caller) if ( |
109
|
|
|
|
|
|
|
$perl_version < 36 and |
110
|
2
|
|
|
|
|
9
|
not grep { $_ eq 'notry' } @functions and |
111
|
17
|
50
|
33
|
|
|
190
|
not grep { $_ eq 'trytiny' } @functions |
|
2
|
|
33
|
|
|
16
|
|
112
|
|
|
|
|
|
|
); |
113
|
|
|
|
|
|
|
eval qq{ |
114
|
|
|
|
|
|
|
package $caller { |
115
|
|
|
|
|
|
|
use Try::Tiny; |
116
|
|
|
|
|
|
|
}; |
117
|
17
|
50
|
|
|
|
761
|
} if ( grep { $_ eq 'trytiny' } @functions ); |
|
2
|
|
|
|
|
8
|
|
118
|
|
|
|
|
|
|
|
119
|
68
|
|
|
|
|
84
|
monkey_patch( $self, $caller, ( map { $_ => \&{ 'PerlX::Maybe::' . $_ } } qw( |
|
68
|
|
|
|
|
197
|
|
120
|
|
|
|
|
|
|
maybe provided provided_deref provided_deref_with_maybe |
121
|
17
|
50
|
|
|
|
55
|
) ) ) unless ( grep { $_ eq 'nomaybe' } @functions ); |
|
2
|
|
|
|
|
9
|
|
122
|
|
|
|
|
|
|
|
123
|
17
|
|
|
|
|
32
|
my @late_parents = (); |
124
|
|
|
|
|
|
|
my $use = sub { |
125
|
1
|
|
|
1
|
|
3
|
my ( $class, $pm, $caller, $params ) = @_; |
126
|
|
|
|
|
|
|
|
127
|
1
|
|
|
|
|
1
|
my $failed_require; |
128
|
|
|
|
|
|
|
try { |
129
|
|
|
|
|
|
|
require "$pm" unless ( do { |
130
|
9
|
|
|
9
|
|
77
|
no strict 'refs'; |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
397
|
|
131
|
9
|
|
|
9
|
|
57
|
no warnings 'once'; |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
5179
|
|
132
|
|
|
|
|
|
|
${"${caller}::INC"}{$pm}; |
133
|
|
|
|
|
|
|
} ); |
134
|
|
|
|
|
|
|
} |
135
|
1
|
|
|
|
|
3
|
catch { |
136
|
|
|
|
|
|
|
croak($@) unless ( index( $@, q{Can't locate } ) == 0 ); |
137
|
|
|
|
|
|
|
return 0; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
1
|
|
|
|
|
3
|
( $no_parent, $late_parent ) = ( undef, undef ); |
141
|
|
|
|
|
|
|
|
142
|
1
|
50
|
|
|
|
8
|
"$class"->import( $caller, @$params ) if ( "$class"->can('import') ); |
143
|
|
|
|
|
|
|
|
144
|
1
|
50
|
33
|
|
|
16
|
if ($late_parent) { |
|
|
50
|
|
|
|
|
|
145
|
0
|
|
|
|
|
0
|
push( @late_parents, [ $class, $caller ] ); |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
elsif ( not $no_parent and index( $class, 'exact::' ) != 0 ) { |
148
|
0
|
|
|
|
|
0
|
$self->add_isa( $class, $caller ); |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
1
|
|
|
|
|
8
|
return 1; |
152
|
17
|
|
|
|
|
74
|
}; |
153
|
17
|
|
|
|
|
39
|
for my $class (@classes) { |
154
|
1
|
50
|
|
|
|
5
|
my $params = ( $class =~ s/\(([^\)]+)\)// ) ? [$1] : []; |
155
|
1
|
|
|
|
|
6
|
( my $pm = $class ) =~ s{::|'}{/}g; |
156
|
1
|
|
|
|
|
3
|
$pm .= '.pm'; |
157
|
|
|
|
|
|
|
|
158
|
1
|
50
|
33
|
|
|
4
|
$use->( |
159
|
|
|
|
|
|
|
'exact::' . $class, |
160
|
|
|
|
|
|
|
'exact/' . $pm, |
161
|
|
|
|
|
|
|
$caller, |
162
|
|
|
|
|
|
|
$params, |
163
|
|
|
|
|
|
|
) or $use->( |
164
|
|
|
|
|
|
|
$class, |
165
|
|
|
|
|
|
|
$pm, |
166
|
|
|
|
|
|
|
$caller, |
167
|
|
|
|
|
|
|
$params, |
168
|
|
|
|
|
|
|
) or croak( |
169
|
|
|
|
|
|
|
"Can't locate exact/$pm or $pm in \@INC " . |
170
|
|
|
|
|
|
|
"(you may need to install the exact::$class or $class module)" . |
171
|
|
|
|
|
|
|
'(@INC contains: ' . join( ' ', @INC ) . ')' |
172
|
|
|
|
|
|
|
); |
173
|
|
|
|
|
|
|
} |
174
|
17
|
|
|
|
|
31
|
$self->add_isa(@$_) for @late_parents; |
175
|
|
|
|
|
|
|
|
176
|
17
|
100
|
|
|
|
98
|
namespace::autoclean->import( -cleanee => $caller ) unless ( grep { $_ eq 'noautoclean' } @functions ); |
|
2
|
|
|
|
|
2065
|
|
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub monkey_patch { |
180
|
39
|
|
|
39
|
1
|
138
|
my ( $self, $class, %patch ) = @_; |
181
|
|
|
|
|
|
|
{ |
182
|
9
|
|
|
9
|
|
74
|
no strict 'refs'; |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
315
|
|
|
39
|
|
|
|
|
54
|
|
183
|
9
|
|
|
9
|
|
76
|
no warnings 'redefine'; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
1411
|
|
184
|
39
|
|
|
|
|
355
|
*{"${class}::$_"} = set_subname( "${class}::$_", $patch{$_} ) for ( keys %patch ); |
|
142
|
|
|
|
|
880
|
|
185
|
|
|
|
|
|
|
} |
186
|
39
|
|
|
|
|
115
|
return; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub add_isa { |
190
|
2
|
|
|
2
|
1
|
7029
|
my ( $self, $parent, $child ) = @_; |
191
|
|
|
|
|
|
|
{ |
192
|
9
|
|
|
9
|
|
66
|
no strict 'refs'; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
5334
|
|
|
2
|
|
|
|
|
3
|
|
193
|
2
|
100
|
|
|
|
4
|
push( @{"${child}::ISA"}, $parent ) unless ( grep { $_ eq $parent } @{"${child}::ISA"} ); |
|
1
|
|
|
|
|
25
|
|
|
1
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
9
|
|
194
|
|
|
|
|
|
|
} |
195
|
2
|
|
|
|
|
8
|
return; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub no_parent { |
199
|
0
|
|
|
0
|
1
|
0
|
$no_parent = 1; |
200
|
0
|
|
|
|
|
0
|
return; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
sub late_parent { |
204
|
0
|
|
|
0
|
1
|
0
|
$late_parent = 1; |
205
|
0
|
|
|
|
|
0
|
return; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
sub _patch_import { |
209
|
2
|
|
|
2
|
|
8
|
my ( $type, $self, @names ) = @_; |
210
|
|
|
|
|
|
|
|
211
|
2
|
|
|
|
|
24
|
my $target = ( caller(1) )[0]; |
212
|
2
|
|
|
|
|
26
|
my $original_import = $target->can('import'); |
213
|
|
|
|
|
|
|
|
214
|
2
|
|
|
|
|
5
|
my %groups; |
215
|
2
|
100
|
|
|
|
8
|
if ( $type eq 'provide' ) { |
216
|
1
|
|
|
|
|
3
|
%groups = map { %$_ } grep { ref $_ eq 'HASH' } @names; |
|
1
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
9
|
|
217
|
1
|
|
|
|
|
3
|
@names = grep { not ref $_ } @names; |
|
3
|
|
|
|
|
7
|
|
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
monkey_patch( |
221
|
|
|
|
|
|
|
$self, |
222
|
|
|
|
|
|
|
$target, |
223
|
|
|
|
|
|
|
import => sub { |
224
|
3
|
|
|
3
|
|
20
|
my ( $package, @exports ) = @_; |
|
|
|
|
3
|
|
|
|
|
|
|
|
3
|
|
|
|
225
|
|
|
|
|
|
|
|
226
|
3
|
100
|
|
|
|
11
|
$original_import->(@_) if ($original_import); |
227
|
|
|
|
|
|
|
|
228
|
3
|
100
|
|
|
|
15
|
if ( $type eq 'force' ) { |
|
|
50
|
|
|
|
|
|
229
|
1
|
|
|
|
|
3
|
@exports = @names; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
elsif ( $type eq 'provide' ) { |
232
|
3
|
|
|
|
|
7
|
@exports = grep { defined } map { |
233
|
2
|
|
|
|
|
4
|
my $name = $_; |
|
2
|
|
|
|
|
4
|
|
234
|
|
|
|
|
|
|
|
235
|
4
|
|
|
|
|
14
|
( grep { $name eq $_ } @names ) ? $name : |
236
|
2
|
50
|
|
|
|
3
|
( exists $groups{$name} ) ? ( @{ $groups{$name} } ) : undef; |
|
1
|
100
|
|
|
|
4
|
|
237
|
|
|
|
|
|
|
} @exports; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
monkey_patch( |
241
|
|
|
|
|
|
|
$package, |
242
|
|
|
|
|
|
|
( caller(0) )[0], |
243
|
3
|
|
|
|
|
32
|
map { $_ => \&{ $package . '::' . $_ } } @exports |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
20
|
|
244
|
|
|
|
|
|
|
); |
245
|
|
|
|
|
|
|
|
246
|
3
|
|
|
|
|
12
|
return; |
247
|
|
|
|
|
|
|
}, |
248
|
2
|
|
|
|
|
13
|
); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub export { |
252
|
1
|
|
|
1
|
1
|
92
|
_patch_import( 'force', @_ ); |
253
|
1
|
|
|
|
|
2
|
return; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub exportable { |
257
|
1
|
|
|
1
|
1
|
7554
|
_patch_import( 'provide', @_ ); |
258
|
1
|
|
|
|
|
3
|
return; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
1; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
__END__ |