view release on metacpan or  search on metacpan

lib/with.pm  view on Meta::CPAN

   my $obj;
   # Try method call.
   if ($id and $obj = $hints{$id}) {
    if (my $meth = $$obj->can($name)) {
     @_ = flatten $proto, @_;
     unshift @_, $$obj;
     goto &$meth;
    }
   }
   # Try function call in caller namescape.
   my $qname = $caller . '::' . $name;
   goto &$qname if code $qname;
   # This call won't succeed, but it'll throw an exception we should propagate.
   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 "$qname didn't exist and yet the call succeeded\n";
  }, $proto;
  {
   no strict 'refs';
   *$wrap = $code;
  }
 }
 return $wrap . ' '. $par;
}

sub defer {
 my $name = shift;
 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)) {
   unshift @_, $$obj;
   goto &$meth;
  }
 }
 # Try function call in caller namescape.
 $name = $caller . '::' . $name;
 goto &$name if code $name;
 # This call won't succeed, but it'll throw an exception we should propagate.
 eval { no strict 'refs'; $name->(@_) };
 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";
}

sub import {
 return unless defined $_[1] and ref $_[1];
 my $caller = (caller 0)[0];
 my $id = refaddr $_[1];
 $hints{$^H{with} = $id} = $_[1];
 filter_add sub {
  my ($status, $lastline);
  my ($data, $count) = ('', 0);
  while ($status = filter_read) {
   return $status if $status < 0;
   return $status unless defined $^H{with} && $^H{with} == $id;
   if (/^__(?:DATA)__\r?$/ || /\b(?:use|no)\s+with\b/) {
    $lastline = $_;
    last;
   }
   $data .= $_;
   ++$count;
   $_ = '';
  }
  return $count if not $count;
  my $instr;
  my @components;
  for (extract_multiple($data, $extractor)) {
   if (ref)       { push @components, $_; $instr = 0 }
   elsif ($instr) { $components[-1] .= $_ }
   else           { push @components, $_; $instr = 1 }
  }
  my $i = 0;
  $_ = join '',
        map { (ref) ? $; . pack('N', $i++) . $; : $_ }
         @components;
  @components = grep ref, @components;
  s/
    \b &? ([^\W\d]\w+) \s* (?!=>) (\(?)
   /
    $skip{$1} ? "$1 $2"
              : exists $core{$1} ? corewrap $1, $2
                                 : subwrap $1, $2, prototype($caller.'::'.$1)
   /sexg;
  s/\Q$;\E([\x00-\xff]{4})\Q$;\E/${$components[unpack('N',$1)]}/g;
  $_ .= $lastline if defined $lastline;
  return $count;
 }
}

sub unimport {
 $^H{with} = undef;
 filter_del;
}

=head1 HOW DOES IT WORK

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 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" error is thrown.