Revision history for with
+0.02 2008-05-14 21:40 UTC
+ + Doc : Added a few caveats.
+ + Doc : POD quirks.
+ + Fix : scripts/func.pl wasn't printing all the functions it found, so
+ all those core functions were not listed (and hence handled) :
+ chomp dbmopen endprotoent flock gethostbyaddr getnetent
+ getprotobynumber getservbyport index local my printf recv
+ rmdir sethostent setsockopt socketpair symlink tied untie
+ + Fix : Missing 'cmp' operator in the exclude list.
+ + Fix : A wrapped core function call wrongly resulted into a method call
+ when repeated at least two times.
+
0.01 2008-05-08 22:35 UTC
First version, released on an unsuspecting world.
t/11-skip.t
t/12-keywords.t
t/13-scope.t
+t/14-defer.t
t/90-boilerplate.t
t/91-pod.t
t/92-pod-coverage.t
--- #YAML:1.0
name: with
-version: 0.01
+version: 0.02
abstract: Lexically call methods with a default object.
license: perl
author:
Filter::Util::Call: 0
Scalar::Util: 0
Sub::Prototype::Util: 0.08
- Test::More: 0
Text::Balanced: 0
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
'Scalar::Util' => 0,
'Sub::Prototype::Util' => 0.08,
'Text::Balanced' => 0,
- 'Test::More' => 0,
},
dist => {
PREOP => 'pod2text lib/with.pm > $(DISTVNAME)/README; '
with - Lexically call methods with a default object.
VERSION
- Version 0.01
+ Version 0.02
SYNOPSIS
package Deuce;
will be the last specified one.
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
+ 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 "use with \$obj" statement stores an address to the variable $obj in
the "with" field of the hints hash "%^H". It also starts a source filter
that replaces function calls with calls to "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 "with" namespace. Some keywords that couldn't
- possibly be replaced are also completely skipped. "no with" undefines
- the hint and deletes the source filter, stopping any subsequent
- modification in the current scope.
+ function has a prototype or is part of the core, the call is deferred to
+ a corresponding wrapper generated in the "with" namespace. Some keywords
+ that couldn't possibly be replaced are also completely skipped. "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 "->can"
namespace is inspected for a subroutine with the proper name, and if
it's present the program "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.
+ subroutine" error is thrown.
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
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
Don't put anything on the same line of "use with \$obj" or "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 "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.
+
DEPENDENCIES
perl 5.9.4.
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 SYNOPSIS
$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
+ 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
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
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.
my @f = $f =~ /C<([^<>]+)>/g;
my %dup;
@f = sort
- grep { eval { () = prototype "CORE::$_" }; !$@ }
+ grep { eval { () = prototype "CORE::$_"; 1 } }
grep !$dup{$_}++, @f;
my $c = 10;
my $base = "my \@core = qw/";
} else {
$l = length($base) - 1;
$out .= "\n" . (' ' x $l);
+ redo;
}
}
$out .= "/;\n";
use strict;
use warnings;
-use Test::More 'no_plan';
-
-sub with::Mock::right { pass $_[1] }
-sub with::Mock::wrong { fail $_[1] }
-sub with::Mock::test { is_deeply $_[1], $_[2], $_[3] }
+use Test::More tests => 10;
use with \bless {}, 'with::Mock';
my $c = 0;
++$c for 1 .. 10;
-test $c, 10, 'for';
+is $c, 10, 'for';
$c = 0;
while ($c < 5) { ++$c; }
-test $c, 5, 'while';
+is $c, 5, 'while';
$c = undef;
-test !defined($c), 1, 'undef, defined';
+is !defined($c), 1, 'undef, defined';
my @a = (1, 2);
my $y = shift @a;
push @a, $y;
unshift @a, $x;
-test \@a, [ 2, 1 ], 'pop/shift/push/unshift';
+is_deeply \@a, [ 2, 1 ], 'pop/shift/push/unshift';
@a = reverse @a;
-test \@a, [ 1, 2 ], 'reverse';
+is_deeply \@a, [ 1, 2 ], 'reverse';
open my $fh, '<', $0 or die "$!";
my $d = do { local $/; <$fh> };
$d =~ s/^(\S+).*/$1/s;
-test $d, '#!perl', 'open/do/local';
+is $d, '#!perl', 'open/do/local';
@a = map { $_ + 1 } 0 .. 5;
-test \@a, [ 1 .. 6 ], 'map';
+is_deeply \@a, [ 1 .. 6 ], 'map';
@a = grep { $_ > 2 } 0 .. 5;
-test \@a, [ 3 .. 5 ], 'grep';
+is_deeply \@a, [ 3 .. 5 ], 'grep';
my %h = (foo => 1, bar => 2);
@a = sort { $h{$a} <=> $h{$b} } keys %h;
-test \@a, [ 'foo', 'bar' ], 'sort/keys';
+is_deeply \@a, [ 'foo', 'bar' ], 'sort/keys';
print STDERR "# boo" if 0;
+$y = "foo\n";
+chomp $y;
+is $y, 'foo', 'chomp';
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+use with \bless {}, 'with::Mock';
+
+sub shift { }
+sub with::Mock::pop { }
+sub durrr () { 79 }
+sub dongs () { 53 }
+sub with::Mock::dongs { CORE::shift; $_[0] + $_[1] }
+sub hlagh { 2 * $_[0] + $_[1] }
+sub with::Mock::boner { CORE::shift; $_[0] + 2 * $_[1] }
+
+my @a;
+@a = 1;
+push @a, 2; # with::corewrap, defaulting to CORE
+is $a[1], 2, 'CORE::push';
+shift @a; # with::corewrap, function in caller namespace
+is $a[1], 2, 'main::shift';
+pop @a; # with::corewrap, method call
+is $a[1], 2, 'with::Mock::pop';
+my $x = durrr @a; # with::subwrap, function in caller namespace
+is $x, 79, 'main::durrr';
+my $y = dongs @a; # with::subwrap, method call
+is $y, 3, 'with::Mock::dongs';
+my $z = hlagh @a; # with::defer, function in caller namespace
+is $z, 4, 'main::hlagh';
+my $t = boner @a; # with::defer, method call
+is $t, 5, 'with::Mock::boner';
+eval { zogzog @a }; # with::defer, no such fonction
+like $@, qr/Undefined\s+subroutine/, 'no zogzog';
+
projects / perl / modules / with.git / commitdiff