package with;
-use 5.009004;
+use 5.009_004;
use strict;
use warnings;
-use Carp qw/croak/;
+use Carp qw<croak>;
use Filter::Util::Call;
-use Text::Balanced qw/extract_variable extract_quotelike extract_multiple/;
-use Scalar::Util qw/refaddr set_prototype/;
+use Text::Balanced qw<extract_variable extract_quotelike extract_multiple>;
+use Scalar::Util qw<refaddr set_prototype>;
-use Sub::Prototype::Util qw/flatten recall wrap/;
+use Sub::Prototype::Util qw<flatten wrap>;
=head1 NAME
=head1 VERSION
-Version 0.01
+Version 0.02
=cut
-our $VERSION = '0.01';
+our $VERSION = '0.02';
+
+=head1 WARNING
+
+This module was an early experiment which turned out to be completely unpractical.
+Therefore its use is officially B<deprecated>.
+Please don't use it, and don't hesitate to contact me if you want to reuse the namespace.
=head1 SYNOPSIS
use with \$deuce;
hlagh; # Deuce::hlagh 1
Pants::hlagh; # Pants::hlagh
-
+
{
use with \Deuce->new(2);
hlagh; # Deuce::hlagh 2
=head1 DESCRIPTION
-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.
+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.
=cut
];
my %skip;
-$skip{$_} = 1 for qw/my our local sub do eval goto return
- if else elsif unless given when or and
+$skip{$_} = 1 for qw<my our local sub do eval goto return
+ if else elsif unless given when or and
while until for foreach next redo last continue
- eq ne lt gt le ge
+ eq ne lt gt le ge cmp
map grep system exec sort print say
new
- STDIN STDOUT STDERR/;
-
-my @core = qw/abs accept alarm atan2 bind binmode bless caller chdir chmod
- chop chown chr chroot close closedir connect cos crypt dbmclose
- defined delete die do dump each endgrent endhostent endnetent
- endpwent endservent eof eval exec exists exit exp fcntl fileno
- fork format formline getc getgrent getgrgid getgrnam
- gethostbyname gethostent getlogin getnetbyaddr getnetbyname
+ STDIN STDOUT STDERR>;
+
+my @core = qw<abs accept alarm atan2 bind binmode bless caller chdir chmod
+ chomp chop chown chr chroot close closedir connect cos crypt
+ dbmclose dbmopen defined delete die do dump each endgrent
+ endhostent endnetent endprotoent endpwent endservent eof eval
+ exec exists exit exp fcntl fileno flock fork format formline
+ getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname
+ gethostent getlogin getnetbyaddr getnetbyname getnetent
getpeername getpgrp getppid getpriority getprotobyname
- getprotoent getpwent getpwnam getpwuid getservbyname
- getservent getsockname getsockopt glob gmtime goto grep hex
- int ioctl join keys kill last lc lcfirst length link listen
- localtime lock log lstat map mkdir msgctl msgget msgrcv msgsnd
- next no oct open opendir ord our pack package pipe pop pos print
- prototype push quotemeta rand read readdir readline readlink
- redo ref rename require reset return reverse rewinddir rindex
+ getprotobynumber getprotoent getpwent getpwnam getpwuid
+ getservbyname getservbyport getservent getsockname getsockopt
+ glob gmtime goto grep hex index int ioctl join keys kill last lc
+ lcfirst length link listen local localtime lock log lstat map
+ mkdir msgctl msgget msgrcv msgsnd my next no oct open opendir
+ ord our pack package pipe pop pos print printf prototype push
+ quotemeta rand read readdir readline readlink recv redo ref
+ rename require reset return reverse rewinddir rindex rmdir
scalar seek seekdir select semctl semget semop send setgrent
- setnetent setpgrp setpriority setprotoent setpwent setservent
- shift shmctl shmget shmread shmwrite shutdown sin sleep socket
- sort splice split sprintf sqrt srand stat study sub substr
- syscall sysopen sysread sysseek system syswrite tell telldir tie
- time times truncate uc ucfirst umask undef unlink unpack unshift
- use utime values vec wait waitpid wantarray warn write/;
+ sethostent setnetent setpgrp setpriority setprotoent setpwent
+ setservent setsockopt shift shmctl shmget shmread shmwrite
+ shutdown sin sleep socket socketpair sort splice split sprintf
+ sqrt srand stat study sub substr symlink syscall sysopen sysread
+ sysseek system syswrite tell telldir tie tied time times
+ truncate uc ucfirst umask undef unlink unpack unshift untie use
+ utime values vec wait waitpid wantarray warn write>;
+
my %core;
$core{$_} = prototype "CORE::$_" for @core;
undef @core;
}
}
# Try function call in caller namescape.
- $name = $caller . '::' . $name;
- if (code $name) {
+ my $qname = $caller . '::' . $name;
+ if (code $qname) {
@_ = flatten $proto, @_ if defined $proto;
- goto &$name;
+ goto &$qname;
}
# Try core function call.
my @ret = eval { $func->(@_) };
}
}
# Try function call in caller namescape.
- $name = $caller . '::' . $name;
- goto &$name if code $name;
+ my $qname = $caller . '::' . $name;
+ goto &$qname if code $qname;
# This call won't succeed, but it'll throw an exception we should propagate.
- eval { $name->(@_) };
+ eval { no strict 'refs'; $qname->(@_) };
if ($@) {
# Produce a correct 'Undefined subroutine' error in regard of the caller.
my $msg = $@;
$msg =~ s/(called)\s+at.*/$1/s;
croak $msg;
}
- croak "$name didn't exist and yet the call succeeded\n";
+ croak "$qname didn't exist and yet the call succeeded\n";
}, $proto;
{
no strict 'refs';
$name = $caller . '::' . $name;
goto &$name if code $name;
# This call won't succeed, but it'll throw an exception we should propagate.
- eval { $name->(@_) };
+ eval { no strict 'refs'; $name->(@_) };
if ($@) {
# Produce a correct 'Undefined subroutine' error in regard of the caller.
my $msg = $@;
=head1 HOW DOES IT WORK
-The main problem to address is that lexical scope and source modifications can only occur at compile time, while object creation and method resolution happen at run-time.
+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.
-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 is part of Perl 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.
+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.
-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" warning is thrown.
+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.
=head1 IGNORED KEYWORDS
-A call will never dispatch to methods whose name is part of :
+A call will never be dispatched to a method whose name is one of :
my our local sub do eval goto return
- if else elsif unless given when or and
+ if else elsif unless given when or and
while until for foreach next redo last continue
- eq ne lt gt le ge
+ eq ne lt gt le ge cmp
map grep system exec sort print say
new
STDIN STDOUT STDERR
=head1 CAVEATS
-Most likely slow. Almost surely non thread-safe. Contains source filters, hence brittle. Messes with the dreadful prototypes. Crazy. Will have bugs.
+Most likely slow.
+Almost surely non thread-safe.
+Contains source filters, hence brittle.
+Messes with the dreadful prototypes.
+Crazy.
+Will have bugs.
Don't put anything on the same line of C<use with \$obj> or C<no with>.
+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.
+
+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.
+
=head1 DEPENDENCIES
L<perl> 5.9.4.
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
-You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+You can contact me by mail or on C<irc.perl.org> (vincent).
=head1 BUGS
-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.
+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.
=head1 SUPPORT
projects / perl / modules / with.git / blobdiff