From: Vincent Pit Date: Sun, 29 Jun 2008 16:50:15 +0000 (+0200) Subject: Importing with-0.02.tar.gz X-Git-Tag: v0.02 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=f24bbeaff03a3cb20b043ef55819c20fe7f2a2ed;p=perl%2Fmodules%2Fwith.git Importing with-0.02.tar.gz --- diff --git a/Changes b/Changes index 770f607..41339f1 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,17 @@ 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. diff --git a/MANIFEST b/MANIFEST index 7aca9a6..3daca8b 100644 --- a/MANIFEST +++ b/MANIFEST @@ -10,6 +10,7 @@ t/10-with.t 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 diff --git a/META.yml b/META.yml index aa8ddee..2dc82b3 100644 --- a/META.yml +++ b/META.yml @@ -1,6 +1,6 @@ --- #YAML:1.0 name: with -version: 0.01 +version: 0.02 abstract: Lexically call methods with a default object. license: perl author: @@ -12,7 +12,6 @@ requires: 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 diff --git a/Makefile.PL b/Makefile.PL index af17077..e0c4222 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -32,7 +32,6 @@ WriteMakefile( 'Scalar::Util' => 0, 'Sub::Prototype::Util' => 0.08, 'Text::Balanced' => 0, - 'Test::More' => 0, }, dist => { PREOP => 'pod2text lib/with.pm > $(DISTVNAME)/README; ' diff --git a/README b/README index b90723b..e7b0b28 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME with - Lexically call methods with a default object. VERSION - Version 0.01 + Version 0.02 SYNOPSIS package Deuce; @@ -47,19 +47,19 @@ DESCRIPTION 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" @@ -67,15 +67,15 @@ HOW DOES IT WORK 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 @@ -90,6 +90,16 @@ CAVEATS 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. diff --git a/lib/with.pm b/lib/with.pm index 11bf4aa..f07c3e0 100644 --- a/lib/with.pm +++ b/lib/with.pm @@ -10,7 +10,7 @@ use Filter::Util::Call; 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 @@ -18,11 +18,11 @@ with - Lexically call methods with a default object. =head1 VERSION -Version 0.01 +Version 0.02 =cut -our $VERSION = '0.01'; +our $VERSION = '0.02'; =head1 SYNOPSIS @@ -97,32 +97,36 @@ my %skip; $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; @@ -160,10 +164,10 @@ sub corewrap { } } # 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->(@_) }; @@ -202,17 +206,17 @@ sub subwrap { } } # 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'; @@ -238,7 +242,7 @@ sub defer { $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 = $@; @@ -300,20 +304,20 @@ sub unimport { =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 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 is part of Perl 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. +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. -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" 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 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. =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 @@ -328,6 +332,10 @@ Most likely slow. Almost surely non thread-safe. Contains source filters, hence Don't put anything on the same line of C or C. +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. + +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 5.9.4. diff --git a/samples/funcs.pl b/samples/funcs.pl index 5bcfeb9..94a4147 100755 --- a/samples/funcs.pl +++ b/samples/funcs.pl @@ -11,7 +11,7 @@ die "no functions" unless $f; 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/"; @@ -31,6 +31,7 @@ for (@f) { } else { $l = length($base) - 1; $out .= "\n" . (' ' x $l); + redo; } } $out .= "/;\n"; diff --git a/t/12-keywords.t b/t/12-keywords.t index f2daaff..84b2c6f 100644 --- a/t/12-keywords.t +++ b/t/12-keywords.t @@ -5,24 +5,20 @@ package main; 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); @@ -30,24 +26,27 @@ my $x = pop @a; 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'; diff --git a/t/14-defer.t b/t/14-defer.t new file mode 100644 index 0000000..efbca6d --- /dev/null +++ b/t/14-defer.t @@ -0,0 +1,36 @@ +#!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'; +