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