X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2Fwith.pm;h=cbc8f3df3c69d23abacd6c332f44666bed3cd582;hb=HEAD;hp=11bf4aa46dfaf6386aaab5c36612c057f5c0f3b4;hpb=7d694e6f49e219b9c5f62d323666ca2854d51f50;p=perl%2Fmodules%2Fwith.git

diff --git a/lib/with.pm b/lib/with.pm
index 11bf4aa..cbc8f3d 100644
--- a/lib/with.pm
+++ b/lib/with.pm
@@ -1,16 +1,16 @@
 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
 
@@ -18,11 +18,17 @@ with - Lexically call methods with a default object.
 
 =head1 VERSION
 
-Version 0.01
+Version 0.03
 
 =cut
 
-our $VERSION = '0.01';
+our $VERSION = '0.03';
+
+=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
 
@@ -47,7 +53,7 @@ our $VERSION = '0.01';
      use with \$deuce;
      hlagh;        # Deuce::hlagh 1
      Pants::hlagh; # Pants::hlagh
- 
+
      {
       use with \Deuce->new(2);
       hlagh;       # Deuce::hlagh 2
@@ -63,7 +69,9 @@ our $VERSION = '0.01';
 
 =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
 
@@ -94,35 +102,39 @@ my $extractor = [
 ];
 
 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;
@@ -160,10 +172,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 +214,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 +250,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 = $@;
@@ -287,7 +299,7 @@ sub import {
               : exists $core{$1} ? corewrap $1, $2
                                  : subwrap $1, $2, prototype($caller.'::'.$1)
    /sexg;
-  s/\Q$;\E(\C{4})\Q$;\E/${$components[unpack('N',$1)]}/g;
+  s/\Q$;\E([\x00-\xff]{4})\Q$;\E/${$components[unpack('N',$1)]}/g;
   $_ .= $lastline if defined $lastline;
   return $count;
  }
@@ -300,20 +312,27 @@ 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<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
@@ -324,10 +343,20 @@ No function or constant is exported by this pragma.
 
 =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.
@@ -342,11 +371,12 @@ L<Sub::Prototype::Util> 0.08.
 
 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
 
@@ -360,7 +390,7 @@ A fair part of this module is widely inspired from L<Filter::Simple> (especially
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2008 Vincent Pit, all rights reserved.
+Copyright 2008,2017 Vincent Pit, all rights reserved.
 
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself.