line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package with; |
2
|
|
|
|
|
|
|
|
3
|
6
|
|
|
6
|
|
463074
|
use 5.009_004; |
|
6
|
|
|
|
|
24
|
|
4
|
|
|
|
|
|
|
|
5
|
6
|
|
|
6
|
|
35
|
use strict; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
150
|
|
6
|
6
|
|
|
6
|
|
32
|
use warnings; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
192
|
|
7
|
|
|
|
|
|
|
|
8
|
6
|
|
|
6
|
|
32
|
use Carp qw; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
419
|
|
9
|
6
|
|
|
6
|
|
3694
|
use Filter::Util::Call; |
|
6
|
|
|
|
|
5906
|
|
|
6
|
|
|
|
|
413
|
|
10
|
6
|
|
|
6
|
|
4008
|
use Text::Balanced qw; |
|
6
|
|
|
|
|
129871
|
|
|
6
|
|
|
|
|
809
|
|
11
|
6
|
|
|
6
|
|
69
|
use Scalar::Util qw; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
413
|
|
12
|
|
|
|
|
|
|
|
13
|
6
|
|
|
6
|
|
3807
|
use Sub::Prototype::Util qw; |
|
6
|
|
|
|
|
15094
|
|
|
6
|
|
|
|
|
3981
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 NAME |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
with - Lexically call methods with a default object. |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 VERSION |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
Version 0.03 |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
=cut |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=head1 WARNING |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
This module was an early experiment which turned out to be completely unpractical. |
30
|
|
|
|
|
|
|
Therefore its use is officially B. |
31
|
|
|
|
|
|
|
Please don't use it, and don't hesitate to contact me if you want to reuse the namespace. |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 SYNOPSIS |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
package Deuce; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub new { my $class = shift; bless { id = > shift }, $class } |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub hlagh { my $self = shift; print "Deuce::hlagh $self->{id}\n" } |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
package Pants; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub hlagh { print "Pants::hlagh\n" } |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
our @ISA; |
47
|
|
|
|
|
|
|
push @ISA, 'Deuce'; |
48
|
|
|
|
|
|
|
my $deuce = new Deuce 1; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
hlagh; # Pants::hlagh |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
{ |
53
|
|
|
|
|
|
|
use with \$deuce; |
54
|
|
|
|
|
|
|
hlagh; # Deuce::hlagh 1 |
55
|
|
|
|
|
|
|
Pants::hlagh; # Pants::hlagh |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
{ |
58
|
|
|
|
|
|
|
use with \Deuce->new(2); |
59
|
|
|
|
|
|
|
hlagh; # Deuce::hlagh 2 |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
hlagh; # Deuce::hlagh 1 |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
no with; |
65
|
|
|
|
|
|
|
hlagh; # Pants::hlagh |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
hlagh; # Pants::hlagh |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=head1 DESCRIPTION |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
This pragma lets you define a default object against with methods will be called in the current scope when possible. |
73
|
|
|
|
|
|
|
It is enabled by the C |
74
|
|
|
|
|
|
|
If you C |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=cut |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my $EOP = qr/\n+|\Z/; |
79
|
|
|
|
|
|
|
my $CUT = qr/\n=cut.*$EOP/; |
80
|
|
|
|
|
|
|
my $pod_or_DATA = qr/ |
81
|
|
|
|
|
|
|
^=(?:head[1-4]|item) .*? $CUT |
82
|
|
|
|
|
|
|
| ^=pod .*? $CUT |
83
|
|
|
|
|
|
|
| ^=for .*? $EOP |
84
|
|
|
|
|
|
|
| ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP |
85
|
|
|
|
|
|
|
| ^__(DATA|END)__\r?\n.* |
86
|
|
|
|
|
|
|
/smx; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my $extractor = [ |
89
|
|
|
|
|
|
|
{ 'with::COMMENT' => qr/(?
|
90
|
|
|
|
|
|
|
{ 'with::PODDATA' => $pod_or_DATA }, |
91
|
|
|
|
|
|
|
{ 'with::QUOTELIKE' => sub { |
92
|
|
|
|
|
|
|
extract_quotelike $_[0], qr/(?=(?:['"]|\bq.|<<\w+))/ |
93
|
|
|
|
|
|
|
} }, |
94
|
|
|
|
|
|
|
{ 'with::VARIABLE' => sub { |
95
|
|
|
|
|
|
|
extract_variable $_[0], qr/(?=\\?[\$\@\%\&\*])/ |
96
|
|
|
|
|
|
|
} }, |
97
|
|
|
|
|
|
|
{ 'with::HASHKEY' => qr/\w+\s*=>/ }, |
98
|
|
|
|
|
|
|
{ 'with::QUALIFIED' => qr/\w+(?:::\w+)+(?:::)?/ }, |
99
|
|
|
|
|
|
|
{ 'with::SUB' => qr/sub\s+\w+(?:::\w+)*/ }, |
100
|
|
|
|
|
|
|
{ 'with::FILEHANDLE' => qr/<[\$\*]?[^\W>]*>/ }, |
101
|
|
|
|
|
|
|
{ 'with::USE' => qr/(?:use|no)\s+\S+/ }, |
102
|
|
|
|
|
|
|
]; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
my %skip; |
105
|
|
|
|
|
|
|
$skip{$_} = 1 for qw
|
106
|
|
|
|
|
|
|
if else elsif unless given when or and |
107
|
|
|
|
|
|
|
while until for foreach next redo last continue |
108
|
|
|
|
|
|
|
eq ne lt gt le ge cmp |
109
|
|
|
|
|
|
|
map grep system exec sort print say |
110
|
|
|
|
|
|
|
new |
111
|
|
|
|
|
|
|
STDIN STDOUT STDERR>; |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
my @core = qw
|
114
|
|
|
|
|
|
|
chomp chop chown chr chroot close closedir connect cos crypt |
115
|
|
|
|
|
|
|
dbmclose dbmopen defined delete die do dump each endgrent |
116
|
|
|
|
|
|
|
endhostent endnetent endprotoent endpwent endservent eof eval |
117
|
|
|
|
|
|
|
exec exists exit exp fcntl fileno flock fork format formline |
118
|
|
|
|
|
|
|
getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname |
119
|
|
|
|
|
|
|
gethostent getlogin getnetbyaddr getnetbyname getnetent |
120
|
|
|
|
|
|
|
getpeername getpgrp getppid getpriority getprotobyname |
121
|
|
|
|
|
|
|
getprotobynumber getprotoent getpwent getpwnam getpwuid |
122
|
|
|
|
|
|
|
getservbyname getservbyport getservent getsockname getsockopt |
123
|
|
|
|
|
|
|
glob gmtime goto grep hex index int ioctl join keys kill last lc |
124
|
|
|
|
|
|
|
lcfirst length link listen local localtime lock log lstat map |
125
|
|
|
|
|
|
|
mkdir msgctl msgget msgrcv msgsnd my next no oct open opendir |
126
|
|
|
|
|
|
|
ord our pack package pipe pop pos print printf prototype push |
127
|
|
|
|
|
|
|
quotemeta rand read readdir readline readlink recv redo ref |
128
|
|
|
|
|
|
|
rename require reset return reverse rewinddir rindex rmdir |
129
|
|
|
|
|
|
|
scalar seek seekdir select semctl semget semop send setgrent |
130
|
|
|
|
|
|
|
sethostent setnetent setpgrp setpriority setprotoent setpwent |
131
|
|
|
|
|
|
|
setservent setsockopt shift shmctl shmget shmread shmwrite |
132
|
|
|
|
|
|
|
shutdown sin sleep socket socketpair sort splice split sprintf |
133
|
|
|
|
|
|
|
sqrt srand stat study sub substr symlink syscall sysopen sysread |
134
|
|
|
|
|
|
|
sysseek system syswrite tell telldir tie tied time times |
135
|
|
|
|
|
|
|
truncate uc ucfirst umask undef unlink unpack unshift untie use |
136
|
|
|
|
|
|
|
utime values vec wait waitpid wantarray warn write>; |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
my %core; |
139
|
|
|
|
|
|
|
$core{$_} = prototype "CORE::$_" for @core; |
140
|
|
|
|
|
|
|
undef @core; |
141
|
|
|
|
|
|
|
# Fake prototypes |
142
|
|
|
|
|
|
|
$core{'not'} = '$'; |
143
|
|
|
|
|
|
|
$core{'defined'} = '_'; |
144
|
|
|
|
|
|
|
$core{'undef'} = ';\[$@%&*]'; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
my %hints; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub code { |
149
|
6
|
|
|
6
|
|
61
|
no strict 'refs'; |
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
2925
|
|
150
|
66
|
50
|
|
66
|
0
|
191
|
my $name = @_ > 1 ? join '::', @_ |
151
|
|
|
|
|
|
|
: $_[0]; |
152
|
66
|
|
|
|
|
112
|
return *{$name}{CODE}; |
|
66
|
|
|
|
|
493
|
|
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub corewrap { |
156
|
14
|
|
|
14
|
0
|
48
|
my ($name, $par) = @_; |
157
|
14
|
50
|
|
|
|
38
|
return '' unless $name; |
158
|
14
|
|
|
|
|
32
|
my $wrap = 'with::core::' . $name; |
159
|
14
|
50
|
|
|
|
42
|
if (not code $wrap) { |
160
|
14
|
|
|
|
|
37
|
my $proto = $core{$name}; |
161
|
14
|
|
|
|
|
67
|
my $func = wrap { 'CORE::' . $name => $proto }, compile => 1; |
162
|
|
|
|
|
|
|
my $code = set_prototype sub { |
163
|
13
|
|
|
13
|
|
6915
|
my ($caller, $H) = (caller 0)[0, 10]; |
164
|
13
|
|
50
|
|
|
83
|
my $id = ($H || {})->{with}; |
165
|
13
|
|
|
|
|
30
|
my $obj; |
166
|
|
|
|
|
|
|
# Try method call. |
167
|
13
|
50
|
33
|
|
|
118
|
if ($id and $obj = $hints{$id}) { |
168
|
13
|
100
|
|
|
|
140
|
if (my $meth = $$obj->can($name)) { |
169
|
1
|
50
|
|
|
|
7
|
@_ = flatten $proto, @_ if defined $proto; |
170
|
1
|
|
|
|
|
33
|
unshift @_, $$obj; |
171
|
1
|
|
|
|
|
7
|
goto &$meth; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
# Try function call in caller namescape. |
175
|
12
|
|
|
|
|
52
|
my $qname = $caller . '::' . $name; |
176
|
12
|
100
|
|
|
|
39
|
if (code $qname) { |
177
|
1
|
50
|
|
|
|
7
|
@_ = flatten $proto, @_ if defined $proto; |
178
|
1
|
|
|
|
|
59
|
goto &$qname; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
# Try core function call. |
181
|
11
|
|
|
|
|
35
|
my @ret = eval { $func->(@_) }; |
|
11
|
|
|
|
|
394
|
|
182
|
11
|
50
|
|
|
|
226
|
if ($@) { |
183
|
|
|
|
|
|
|
# Produce a correct error in regard of the caller. |
184
|
0
|
|
|
|
|
0
|
my $msg = $@; |
185
|
0
|
|
|
|
|
0
|
$msg =~ s/(called)\s+at.*/$1/s; |
186
|
0
|
|
|
|
|
0
|
croak $msg; |
187
|
|
|
|
|
|
|
} |
188
|
11
|
100
|
|
|
|
77
|
return wantarray ? @ret : $ret[0]; |
189
|
14
|
|
|
|
|
2912
|
}, $proto; |
190
|
|
|
|
|
|
|
{ |
191
|
6
|
|
|
6
|
|
118
|
no strict 'refs'; |
|
6
|
|
|
|
|
27
|
|
|
6
|
|
|
|
|
1757
|
|
|
14
|
|
|
|
|
29
|
|
192
|
14
|
|
|
|
|
46
|
*$wrap = $code; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
} |
195
|
14
|
|
|
|
|
96
|
return $wrap . ' ' . $par; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub subwrap { |
199
|
47
|
|
|
47
|
0
|
178
|
my ($name, $par, $proto) = @_; |
200
|
47
|
50
|
|
|
|
158
|
return '' unless $name; |
201
|
47
|
100
|
|
|
|
286
|
return "with::defer $par'$name'," unless defined $proto; |
202
|
14
|
|
|
|
|
46
|
my $wrap = 'with::sub::' . $name; |
203
|
14
|
100
|
|
|
|
29
|
if (not code $wrap) { |
204
|
|
|
|
|
|
|
my $code = set_prototype sub { |
205
|
14
|
|
|
14
|
|
1840
|
my ($caller, $H) = (caller 0)[0, 10]; |
206
|
14
|
|
100
|
|
|
99
|
my $id = ($H || {})->{with}; |
207
|
14
|
|
|
|
|
28
|
my $obj; |
208
|
|
|
|
|
|
|
# Try method call. |
209
|
14
|
100
|
66
|
|
|
91
|
if ($id and $obj = $hints{$id}) { |
210
|
13
|
50
|
|
|
|
82
|
if (my $meth = $$obj->can($name)) { |
211
|
0
|
|
|
|
|
0
|
@_ = flatten $proto, @_; |
212
|
0
|
|
|
|
|
0
|
unshift @_, $$obj; |
213
|
0
|
|
|
|
|
0
|
goto &$meth; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
# Try function call in caller namescape. |
217
|
14
|
|
|
|
|
47
|
my $qname = $caller . '::' . $name; |
218
|
14
|
50
|
|
|
|
43
|
goto &$qname if code $qname; |
219
|
|
|
|
|
|
|
# This call won't succeed, but it'll throw an exception we should propagate. |
220
|
6
|
|
|
6
|
|
51
|
eval { no strict 'refs'; $qname->(@_) }; |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
859
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
221
|
0
|
0
|
|
|
|
0
|
if ($@) { |
222
|
|
|
|
|
|
|
# Produce a correct 'Undefined subroutine' error in regard of the caller. |
223
|
0
|
|
|
|
|
0
|
my $msg = $@; |
224
|
0
|
|
|
|
|
0
|
$msg =~ s/(called)\s+at.*/$1/s; |
225
|
0
|
|
|
|
|
0
|
croak $msg; |
226
|
|
|
|
|
|
|
} |
227
|
0
|
|
|
|
|
0
|
croak "$qname didn't exist and yet the call succeeded\n"; |
228
|
4
|
|
|
|
|
51
|
}, $proto; |
229
|
|
|
|
|
|
|
{ |
230
|
6
|
|
|
6
|
|
44
|
no strict 'refs'; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
1265
|
|
|
4
|
|
|
|
|
12
|
|
231
|
4
|
|
|
|
|
19
|
*$wrap = $code; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
} |
234
|
14
|
|
|
|
|
76
|
return $wrap . ' '. $par; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub defer { |
238
|
30
|
|
|
30
|
0
|
26303
|
my $name = shift; |
239
|
30
|
|
|
|
|
254
|
my ($caller, $H) = (caller 0)[0, 10]; |
240
|
30
|
|
100
|
|
|
193
|
my $id = ($H || {})->{with}; |
241
|
30
|
|
|
|
|
77
|
my $obj; |
242
|
|
|
|
|
|
|
# Try method call. |
243
|
30
|
100
|
66
|
|
|
190
|
if ($id and $obj = $hints{$id}) { |
244
|
27
|
100
|
|
|
|
172
|
if (my $meth = $$obj->can($name)) { |
245
|
18
|
|
|
|
|
54
|
unshift @_, $$obj; |
246
|
18
|
|
|
|
|
93
|
goto &$meth; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
# Try function call in caller namescape. |
250
|
12
|
|
|
|
|
42
|
$name = $caller . '::' . $name; |
251
|
12
|
100
|
|
|
|
43
|
goto &$name if code $name; |
252
|
|
|
|
|
|
|
# This call won't succeed, but it'll throw an exception we should propagate. |
253
|
6
|
|
|
6
|
|
42
|
eval { no strict 'refs'; $name->(@_) }; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
5379
|
|
|
2
|
|
|
|
|
8
|
|
|
2
|
|
|
|
|
44
|
|
254
|
2
|
50
|
|
|
|
13
|
if ($@) { |
255
|
|
|
|
|
|
|
# Produce a correct 'Undefined subroutine' error in regard of the caller. |
256
|
2
|
|
|
|
|
7
|
my $msg = $@; |
257
|
2
|
|
|
|
|
23
|
$msg =~ s/(called)\s+at.*/$1/s; |
258
|
2
|
|
|
|
|
362
|
croak $msg; |
259
|
|
|
|
|
|
|
} |
260
|
0
|
|
|
|
|
0
|
croak "$name didn't exist and yet the call succeeded\n"; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub import { |
264
|
7
|
100
|
66
|
7
|
|
223
|
return unless defined $_[1] and ref $_[1]; |
265
|
6
|
|
|
|
|
77
|
my $caller = (caller 0)[0]; |
266
|
6
|
|
|
|
|
50
|
my $id = refaddr $_[1]; |
267
|
6
|
|
|
|
|
66
|
$hints{$^H{with} = $id} = $_[1]; |
268
|
|
|
|
|
|
|
filter_add sub { |
269
|
24
|
|
|
24
|
|
268
|
my ($status, $lastline); |
270
|
24
|
|
|
|
|
69
|
my ($data, $count) = ('', 0); |
271
|
24
|
|
|
|
|
162
|
while ($status = filter_read) { |
272
|
143
|
50
|
|
|
|
336
|
return $status if $status < 0; |
273
|
143
|
100
|
100
|
|
|
640
|
return $status unless defined $^H{with} && $^H{with} == $id; |
274
|
131
|
100
|
100
|
|
|
649
|
if (/^__(?:DATA)__\r?$/ || /\b(?:use|no)\s+with\b/) { |
275
|
4
|
|
|
|
|
11
|
$lastline = $_; |
276
|
4
|
|
|
|
|
8
|
last; |
277
|
|
|
|
|
|
|
} |
278
|
127
|
|
|
|
|
299
|
$data .= $_; |
279
|
127
|
|
|
|
|
202
|
++$count; |
280
|
127
|
|
|
|
|
500
|
$_ = ''; |
281
|
|
|
|
|
|
|
} |
282
|
12
|
100
|
|
|
|
6421
|
return $count if not $count; |
283
|
8
|
|
|
|
|
20
|
my $instr; |
284
|
|
|
|
|
|
|
my @components; |
285
|
8
|
|
|
|
|
52
|
for (extract_multiple($data, $extractor)) { |
286
|
340
|
100
|
|
|
|
2749
|
if (ref) { push @components, $_; $instr = 0 } |
|
166
|
50
|
|
|
|
315
|
|
|
166
|
|
|
|
|
272
|
|
287
|
0
|
|
|
|
|
0
|
elsif ($instr) { $components[-1] .= $_ } |
288
|
174
|
|
|
|
|
363
|
else { push @components, $_; $instr = 1 } |
|
174
|
|
|
|
|
291
|
|
289
|
|
|
|
|
|
|
} |
290
|
8
|
|
|
|
|
44
|
my $i = 0; |
291
|
|
|
|
|
|
|
$_ = join '', |
292
|
8
|
100
|
|
|
|
35
|
map { (ref) ? $; . pack('N', $i++) . $; : $_ } |
|
340
|
|
|
|
|
1089
|
|
293
|
|
|
|
|
|
|
@components; |
294
|
8
|
|
|
|
|
119
|
@components = grep ref, @components; |
295
|
8
|
|
|
|
|
131
|
s/ |
296
|
|
|
|
|
|
|
\b &? ([^\W\d]\w+) \s* (?!=>) (\(?) |
297
|
|
|
|
|
|
|
/ |
298
|
|
|
|
|
|
|
$skip{$1} ? "$1 $2" |
299
|
91
|
100
|
|
|
|
605
|
: exists $core{$1} ? corewrap $1, $2 |
|
|
100
|
|
|
|
|
|
300
|
|
|
|
|
|
|
: subwrap $1, $2, prototype($caller.'::'.$1) |
301
|
|
|
|
|
|
|
/sexg; |
302
|
8
|
|
|
|
|
203
|
s/\Q$;\E([\x00-\xff]{4})\Q$;\E/${$components[unpack('N',$1)]}/g; |
|
166
|
|
|
|
|
684
|
|
303
|
8
|
100
|
|
|
|
48
|
$_ .= $lastline if defined $lastline; |
304
|
8
|
|
|
|
|
3905
|
return $count; |
305
|
|
|
|
|
|
|
} |
306
|
6
|
|
|
|
|
79
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub unimport { |
309
|
1
|
|
|
1
|
|
18
|
$^H{with} = undef; |
310
|
1
|
|
|
|
|
11
|
filter_del; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head1 HOW DOES IT WORK |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
The main problem to address is that lexical scoping and source modification can only occur at compile time, while object creation and method resolution happen at run-time. |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
The C |
318
|
|
|
|
|
|
|
It also starts a source filter that replaces function calls with calls to C, passing the name of the original function as the first argument. |
319
|
|
|
|
|
|
|
When the replaced function has a prototype or is part of the core, the call is deferred to a corresponding wrapper generated in the C namespace. |
320
|
|
|
|
|
|
|
Some keywords that couldn't possibly be replaced are also completely skipped. |
321
|
|
|
|
|
|
|
C undefines the hint and deletes the source filter, stopping any subsequent modification in the current scope. |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
When the script is executed, deferred calls first fetch the default object back from the address stored into the hint. |
324
|
|
|
|
|
|
|
If the object C<< ->can >> the original function name, a method call is issued. |
325
|
|
|
|
|
|
|
If not, the calling namespace is inspected for a subroutine with the proper name, and if it's present the program Cs into it. |
326
|
|
|
|
|
|
|
If that fails too, the core function with the same name is recalled if possible, or an "Undefined subroutine" error is thrown. |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=head1 IGNORED KEYWORDS |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
A call will never be dispatched to a method whose name is one of : |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
my our local sub do eval goto return |
333
|
|
|
|
|
|
|
if else elsif unless given when or and |
334
|
|
|
|
|
|
|
while until for foreach next redo last continue |
335
|
|
|
|
|
|
|
eq ne lt gt le ge cmp |
336
|
|
|
|
|
|
|
map grep system exec sort print say |
337
|
|
|
|
|
|
|
new |
338
|
|
|
|
|
|
|
STDIN STDOUT STDERR |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
=head1 EXPORT |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
No function or constant is exported by this pragma. |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=head1 CAVEATS |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
Most likely slow. |
347
|
|
|
|
|
|
|
Almost surely non thread-safe. |
348
|
|
|
|
|
|
|
Contains source filters, hence brittle. |
349
|
|
|
|
|
|
|
Messes with the dreadful prototypes. |
350
|
|
|
|
|
|
|
Crazy. |
351
|
|
|
|
|
|
|
Will have bugs. |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
Don't put anything on the same line of C |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
When there's a function in the caller namespace that has a core function name, and when no method with the same name is present, the ambiguity is resolved in favor of the caller namespace. |
356
|
|
|
|
|
|
|
That's different from the usual perl semantics where C gets resolved to CORE::push. |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
If a method has the same name as a prototyped function in the caller namespace, and if a called is deferred to the method, it will have its arguments passed by value. |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
=head1 DEPENDENCIES |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
L 5.9.4. |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
L (core module since perl 5). |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
L, L and L (core since 5.7.3). |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
L 0.08. |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
=head1 AUTHOR |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
Vincent Pit, C<< >>, L. |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
You can contact me by mail or on C (vincent). |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
=head1 BUGS |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through the web interface at L. |
379
|
|
|
|
|
|
|
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=head1 SUPPORT |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
perldoc with |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
A fair part of this module is widely inspired from L (especially C), but a complete integration was needed in order to add hints support and more placeholder patterns. |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
Copyright 2008,2017 Vincent Pit, all rights reserved. |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
396
|
|
|
|
|
|
|
under the same terms as Perl itself. |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
=cut |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
1; # End of with |