view release on metacpan or  search on metacpan

lib/with.pm  view on Meta::CPAN

     hlagh;        # Deuce::hlagh 1

     no with;
     hlagh;        # Pants::hlagh
    }

    hlagh;         # Pants::hlagh

=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.

=cut

my $EOP = qr/\n+|\Z/;
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
              ^=(?:head[1-4]|item) .*? $CUT
            | ^=pod .*? $CUT
            | ^=for .*? $EOP
            | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
            | ^__(DATA|END)__\r?\n.*
            /smx;

my $extractor = [
 { 'with::COMMENT'    => qr/(?<![\$\@%])#.*/ },
 { 'with::PODDATA'    => $pod_or_DATA },
 { 'with::QUOTELIKE'  => sub {
      extract_quotelike $_[0], qr/(?=(?:['"]|\bq.|<<\w+))/
 } },
 { 'with::VARIABLE'   => sub {
      extract_variable $_[0], qr/(?=\\?[\$\@\%\&\*])/
 } },
 { 'with::HASHKEY'    => qr/\w+\s*=>/ },
 { 'with::QUALIFIED'  => qr/\w+(?:::\w+)+(?:::)?/ },
 { 'with::SUB'        => qr/sub\s+\w+(?:::\w+)*/ },
 { 'with::FILEHANDLE' => qr/<[\$\*]?[^\W>]*>/ },
 { 'with::USE'        => qr/(?:use|no)\s+\S+/ },
];

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 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
              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
              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
              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;
# Fake prototypes
$core{'not'}        = '$';
$core{'defined'}    = '_';
$core{'undef'}      = ';\[$@%&*]';

my %hints;

sub code {
 no strict 'refs';
 my $name = @_ > 1 ? join '::', @_
                   : $_[0];
 return *{$name}{CODE};
}

sub corewrap {
 my ($name, $par) = @_;
 return '' unless $name;
 my $wrap = 'with::core::' . $name;
 if (not code $wrap) {
  my $proto = $core{$name};
  my $func = wrap { 'CORE::' . $name => $proto }, compile => 1;
  my $code = set_prototype sub {
   my ($caller, $H) = (caller 0)[0, 10];
   my $id = ($H || {})->{with};
   my $obj;
   # Try method call.
   if ($id and $obj = $hints{$id}) {
    if (my $meth = $$obj->can($name)) {
     @_ = flatten $proto, @_ if defined $proto;
     unshift @_, $$obj;
     goto &$meth;
    }
   }
   # Try function call in caller namescape.
   my $qname = $caller . '::' . $name;
   if (code $qname) {
    @_ = flatten $proto, @_ if defined $proto;
    goto &$qname;
   }
   # Try core function call.
   my @ret = eval { $func->(@_) };