9 use Filter::Util::Call;
10 use Text::Balanced qw/extract_variable extract_quotelike extract_multiple/;
11 use Scalar::Util qw/refaddr set_prototype/;
13 use Sub::Prototype::Util qw/flatten wrap/;
17 with - Lexically call methods with a default object.
25 our $VERSION = '0.02';
31 sub new { my $class = shift; bless { id = > shift }, $class }
33 sub hlagh { my $self = shift; print "Deuce::hlagh $self->{id}\n" }
38 sub hlagh { print "Pants::hlagh\n" }
42 my $deuce = new Deuce 1;
48 hlagh; # Deuce::hlagh 1
49 Pants::hlagh; # Pants::hlagh
52 use with \Deuce->new(2);
53 hlagh; # Deuce::hlagh 2
56 hlagh; # Deuce::hlagh 1
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<use with \$obj> idiom (note that you must pass a reference to the object). If you C<use with> several times in the current scope, the default object will be the last specified one.
71 my $CUT = qr/\n=cut.*$EOP/;
73 ^=(?:head[1-4]|item) .*? $CUT
76 | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
77 | ^__(DATA|END)__\r?\n.*
81 { 'with::COMMENT' => qr/(?<![\$\@%])#.*/ },
82 { 'with::PODDATA' => $pod_or_DATA },
83 { 'with::QUOTELIKE' => sub {
84 extract_quotelike $_[0], qr/(?=(?:['"]|\bq.|<<\w+))/
86 { 'with::VARIABLE' => sub {
87 extract_variable $_[0], qr/(?=\\?[\$\@\%\&\*])/
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+/ },
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
103 STDIN STDOUT STDERR/;
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/;
131 $core{$_} = prototype "CORE::$_" for @core;
135 $core{'defined'} = '_';
136 $core{'undef'} = ';\[$@%&*]';
142 my $name = @_ > 1 ? join '::', @_
144 return *{$name}{CODE};
148 my ($name, $par) = @_;
149 return '' unless $name;
150 my $wrap = 'with::core::' . $name;
151 if (not code $wrap) {
152 my $proto = $core{$name};
153 my $func = wrap { 'CORE::' . $name => $proto }, compile => 1;
154 my $code = set_prototype sub {
155 my ($caller, $H) = (caller 0)[0, 10];
156 my $id = ($H || {})->{with};
159 if ($id and $obj = $hints{$id}) {
160 if (my $meth = $$obj->can($name)) {
161 @_ = flatten $proto, @_ if defined $proto;
166 # Try function call in caller namescape.
167 my $qname = $caller . '::' . $name;
169 @_ = flatten $proto, @_ if defined $proto;
172 # Try core function call.
173 my @ret = eval { $func->(@_) };
175 # Produce a correct error in regard of the caller.
177 $msg =~ s/(called)\s+at.*/$1/s;
180 return wantarray ? @ret : $ret[0];
187 return $wrap . ' ' . $par;
191 my ($name, $par, $proto) = @_;
192 return '' unless $name;
193 return "with::defer $par'$name'," unless defined $proto;
194 my $wrap = 'with::sub::' . $name;
195 if (not code $wrap) {
196 my $code = set_prototype sub {
197 my ($caller, $H) = (caller 0)[0, 10];
198 my $id = ($H || {})->{with};
201 if ($id and $obj = $hints{$id}) {
202 if (my $meth = $$obj->can($name)) {
203 @_ = flatten $proto, @_;
208 # Try function call in caller namescape.
209 my $qname = $caller . '::' . $name;
210 goto &$qname if code $qname;
211 # This call won't succeed, but it'll throw an exception we should propagate.
212 eval { no strict 'refs'; $qname->(@_) };
214 # Produce a correct 'Undefined subroutine' error in regard of the caller.
216 $msg =~ s/(called)\s+at.*/$1/s;
219 croak "$qname didn't exist and yet the call succeeded\n";
226 return $wrap . ' '. $par;
231 my ($caller, $H) = (caller 0)[0, 10];
232 my $id = ($H || {})->{with};
235 if ($id and $obj = $hints{$id}) {
236 if (my $meth = $$obj->can($name)) {
241 # Try function call in caller namescape.
242 $name = $caller . '::' . $name;
243 goto &$name if code $name;
244 # This call won't succeed, but it'll throw an exception we should propagate.
245 eval { no strict 'refs'; $name->(@_) };
247 # Produce a correct 'Undefined subroutine' error in regard of the caller.
249 $msg =~ s/(called)\s+at.*/$1/s;
252 croak "$name didn't exist and yet the call succeeded\n";
256 return unless defined $_[1] and ref $_[1];
257 my $caller = (caller 0)[0];
258 my $id = refaddr $_[1];
259 $hints{$^H{with} = $id} = $_[1];
261 my ($status, $lastline);
262 my ($data, $count) = ('', 0);
263 while ($status = filter_read) {
264 return $status if $status < 0;
265 return $status unless defined $^H{with} && $^H{with} == $id;
266 if (/^__(?:DATA)__\r?$/ || /\b(?:use|no)\s+with\b/) {
274 return $count if not $count;
277 for (extract_multiple($data, $extractor)) {
278 if (ref) { push @components, $_; $instr = 0 }
279 elsif ($instr) { $components[-1] .= $_ }
280 else { push @components, $_; $instr = 1 }
284 map { (ref) ? $; . pack('N', $i++) . $; : $_ }
286 @components = grep ref, @components;
288 \b &? ([^\W\d]\w+) \s* (?!=>) (\(?)
291 : exists $core{$1} ? corewrap $1, $2
292 : subwrap $1, $2, prototype($caller.'::'.$1)
294 s/\Q$;\E(\C{4})\Q$;\E/${$components[unpack('N',$1)]}/g;
295 $_ .= $lastline if defined $lastline;
305 =head1 HOW DOES IT WORK
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.
309 The C<use with \$obj> statement stores an address to the variable C<$obj> in the C<with> field of the hints hash C<%^H>. It also starts a source filter that replaces function calls with calls to C<with::defer>, 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<with> namespace. Some keywords that couldn't possibly be replaced are also completely skipped. C<no with> undefines the hint and deletes the source filter, stopping any subsequent modification in the current scope.
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 C<goto>s into it. If that fails too, the core function with the same name is recalled if possible, or an "Undefined subroutine" error is thrown.
313 =head1 IGNORED KEYWORDS
315 A call will never be dispatched to a method whose name is one of :
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
327 No function or constant is exported by this pragma.
331 Most likely slow. Almost surely non thread-safe. Contains source filters, hence brittle. Messes with the dreadful prototypes. Crazy. Will have bugs.
333 Don't put anything on the same line of C<use with \$obj> or C<no with>.
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<sub push; push @a, 1> gets resolved to CORE::push.
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.
343 L<Carp> (core module since perl 5).
345 L<Filter::Util::Call>, L<Scalar::Util> and L<Text::Balanced> (core since 5.7.3).
347 L<Sub::Prototype::Util> 0.08.
351 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
353 You can contact me by mail or on C<irc.perl.org> (vincent).
357 Please report any bugs or feature requests to C<bug-with at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=with>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
361 You can find documentation for this module with the perldoc command.
365 =head1 ACKNOWLEDGEMENTS
367 A fair part of this module is widely inspired from L<Filter::Simple> (especially C<FILTER_ONLY>), but a complete integration was needed in order to add hints support and more placeholder patterns.
369 =head1 COPYRIGHT & LICENSE
371 Copyright 2008 Vincent Pit, all rights reserved.
373 This program is free software; you can redistribute it and/or modify it
374 under the same terms as Perl itself.