Sub::Lexical - implements lexically scoped subroutines

  use Sub::Lexical;

  sub foo {
      my @vals = @_;

      my sub bar {
          my $arg = shift;
          print "\$arg is $arg\n";
          print "\$vals are @vals\n";
      }

      bar("just a string");

      my sub quux (@) {
          print "quux got args [@_]\n";
      }

      takesub(\&quux, qw(ichi ni san shi));
  }

  sub takesub { print "executing given sub\n\t"; shift->(@_[1..$#_]) }

  foo(qw(a bunch of args));

#!/usr/bin/perl

package Sub::Lexical;

$VERSION = 0.81;

use strict;
eval q(use warnings) or local $^W = 1;

use Regexp::Common;
use Carp qw(croak cluck);

use constant DEBUG  => 1;

sub new {
  my $class	= shift;
  croak('Sub::Lexical constructor must be called as a class method')
    if $class ne __PACKAGE__;

  cluck("arguments passed to new() aren't in pair form")
    if @_ % 2 != 0;

  ## don't stuff list in if it don't fit
  my $self	= { @_ % 2 == 0 ? @_ : () };

  bless($self, $class);
}

sub subs_found {
  my $self = shift;
  return [] unless defined $self->{info};
  return $self->{info};
}

my $brackets_re     = $RE{balanced}{-parens => '{}'};
my $paren_re        = $RE{balanced}{-parens => '()'};

## regex for fully qualified names which I don't want/need
# my $sub_fullname_re   = qr/[_a-zA-Z](?:(?:\w*)(?:(?:'|::)(?:\w+)+)?)*/;

my $sub_name_re     = qr{[_a-zA-Z](?:[\w_]+)?};
my $sub_proto_re    = qr{\([\$%\\@&\s]*\)};
my $sub_attrib_re   = qr{(?:\s*:\s*$sub_name_re\s*(?:$paren_re)?)*}o;
                      ## my sub foobar (proto) : attrib { "code" }
my $sub_match_re    = qr/    
                                                        my                      # literal 'my'
                                                        \s+                     # 1> whitespace
                                                        sub                     # literal 'my'
                                                        \s+                     # 1> whitespace
                                                        ($sub_name_re)          # group 1
                                                        \s*                     # 0> whitespace
                                                        (                       # group 2
                                                                $sub_proto_re  ?    # optional $sub_proto_re
                                                                $sub_attrib_re ?    # optional $sub_attrib_re
                                                        ) ?                     # optional group 2
                                                        \s*                     # 0> whitespace
                                                        (                       # group 3
                                                                $brackets_re        # match balanced brackets
                                                        ) ?                     # optional group 3
                                                        (?:
                                                                \s*                 # 0> whitespace
                                                                ;                   # optional literal ';'
                                                        ) ?
                                                /xo;

## core functions which may expect a function e.g goto &foo
my $core_funcs    = join '|', qw(do defined eval goto grep map sort undef);
## things that *can't* come before or go after a bareword
my $ops_before    = qr/(?<! \$ | % | @ ) | (?>! -> )/x;

sub filter_code {
  my $self = shift;
  croak('filter_code() must be called as an object method')
    if not defined $self or $self eq __PACKAGE__;

  my $code = shift;
  study $code;

  while(my($subname, $subextra, $subcode) = $code =~ /$sub_match_re/) {
    push @{$self->{info}}, {
        name    => $subname,
        extra   => $subextra,
        code    => $subcode
    };

    my $lexname = "\$LEXSUB_${subname}";
    ## 'my sub name {}' => 'my $name; $name = sub {};'
    $code =~ s<$sub_match_re>
                            <my \$LEXSUB_$1; \$LEXSUB_$1 = sub $2 $3;>g;

    ## '&name()' => '$name->()'
    $code =~ s<
                                &?               # optional &
                                $subname         # 'subname'
                                \s*              # 0+ whitespace
                                (                # group $1
                                        $paren_re    # balanced parens
                                )                # optional group $1
                          >{"$lexname->" . ($1 || '()')}exg;

    ## 'goto &name' => 'goto &$name'
    $code =~ s<($core_funcs) \s* &$subname\b>
                            {$1 &$lexname}xg;

    ## '&name' => '$name->(@_)'
    $code =~ s{ (?<!\\) \s* &$subname\b }
                            {$lexname->(\@_)}xg;

    ## '\&name' => '$name'
    $code =~ s<(?: \\ \s*)+ &($sub_name_re)\b>
                            <\$LEXSUB_$1>xg;

    ## 'name' => '$name->()'
    $code =~ s{(?: ^ | (?<! LEXSUB_) ( (?: $ops_before | \s+) \s* ) )
                              $subname \b }
                            {$1$lexname->()}xmg;
  }
  return $code;
}

use Filter::Simple;

FILTER_ONLY code => sub {
  $_ = Sub::Lexical->new()->filter_code($_);
};

q(package activated);

__END__