File Coverage

blib/lib/Sub/Lexical.pm

Criterion	Covered	Total	%
statement	39	42	92.8
branch	4	10	40.0
condition	2	5	40.0
subroutine	8	9	88.8
pod	3	3	100.0
total	56	69	81.1

#!/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>
              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{ (?
              {$lexname->(\@_)}xg;

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

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

use Filter::Simple;

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

q(package activated);

__END__