Method::LexicalFields.pm

package Method::LexicalFields;
use fields ();
use strict;
use warnings;
use Devel::LexAlias;
use Attribute::Handlers;
use Scalar::Util::Hash qw(lock_value);

my $vname_re = qr[[%$@][[:alpha:]]\w*]i;
my $field_re = qr[_?$vname_re];
my %selfname;
sub import {
  my $package = shift;
  die "The first name must be a hash\n" unless $_[0] =~ /^%/;
  for my $field (@_) {
    $field =~ /^$field_re\z/ or die "Each field name must match $field_re"
    my ($sigil, $bare) = $field =~ /^_?(.)(.*)/;
    my $glob = do { no strict 'refs'; *{ $package . '::' . $bare } };
    *$glob = $sigil eq '$' ? \$$glob :
      $sigil eq '@' ? \@$glob : \%$glob;
  }
  my $c = caller;
  mknew($c);
  
  $selfname{$c} = shift;
  unshift @_, 'fields';
  goto &fields::import;
}

sub mknew {
  my $package = shift;
  eval sprintf( q{
    package %s;
    sub new {
      my $self = &fields::new;
      for (keys %FIELDS) {
        /^$field_re\z/ and /^_?([%@])/ or next;
        $self->{$_} = \$1 eq '@' ? [] : {};
        &Scalar::Util::lock_value( $self, $_ );
      }
      $self;
    }
    'ok';
  }, $package) or die;
}

my $deparser = CPPish::D->new(-1);
our $processing;

sub fieldlexes :ATTR(CODE,RAW,CHECK) {
  my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
  my @fields;
  my $f = do { no strict 'refs'; \%{$package '::FIELDS'} };
  if( defined $data ) {
    my $d = $data;
    push @fields, $1 while $d =~ s/^($fname_re)\s*//;
    $d and die "The argument to :findlexes(...) must match ^($fname_re\s*)+\z\n";
    my @bad = grep !exists $f->{$_}, @vars;
    die "No fields named @bad exist" if @bad;
  } else {
    no strict 'refs';
    @fields = grep $field_re, keys %$f;
  }
  
  my $src = do { local $processing = $package; $deparser->coderef2text( $referent ); };
  my $at = 1 + index( $str, '{' ) or die "Couldn't find { in the code!";

  my $name = $selfname{$package};
  my $insert = "Devel::LexAlias::alias_r( shift, \\my $package $name );"
  substr( $src, $at, 0, $insert );
  $at += length $insert;
  
  my $access = '$' . substr $name, 1;
  for my $field (@fields) {
    (my $vname = $field) =~ s/^_//;
    my $r = '$' eq substr($vname, 0, 1) ? '\\' : '';
    $insert = "Devel::LexAlias::alias_r( $r $access { $field }, \my $vname );";
    substr( $src, $at, 0, $insert );
    $at += length $insert;
  }
  undef &$symbol;
  eval qq{ package $package; sub $name { $src }; 1 } or die;
}

package CPPish::D;
use parent 'B::Deparse';
sub maybe_qualify {
    my $ret = SUPER::maybe_qualify{@_};
    my ($pack,$name) = $ret =~ /(.*)::(.+)/;
    length $pack && $pack eq $proccessing and return $name;
    $ret;
}
 
'True?';
__END__
Usage:
  package Fiz;
  use Method::LexicalFields qw(%self $foo _@bar %baz);
  *new = \&fields::new;
  sub foo :fieldlexes($foo %baz) {
    $foo += shift;
    ++$baz{quux};
    \%self;
  }
  sub baz :fieldlexes(_@bar) {
    push @bar, 42 + shift;
  }

The import statement does several important things.

First, it creates package variables of similar names it it's arguments,
with any _ before the sigil removed.  This lets your code compile correctly,
before the :fieldlexes attribute processing gets handled.

Second, it registers it's first argument (which must be a hash) as the name
you want to use for the variable which will contain your object.

Third, it creates in the your namespace a 'new' method.

Fourth, it passes the other arguments, verbatim, to fields::import.

The :fieldlexes decompiles your code, inserts some stuff, then recompiles
your code.  In the case of the above example, our code becomes:
  sub foo {
    Devel::LexAlias::alias_r( shift, \my Fiz %self );
    Devel::LexAlias::alias_r( \$self{'$foo'}, \my $foo );
    Devel::LexAlias::alias_r( $self{'%baz'}, \my %baz );
    $foo += shift;
    ++$baz{quux};
    \%self;
  }
  sub baz {
    Devel::LexAlias::alias_r( shift, \my Fiz %self );
    Devel::LexAlias::alias_r( \$self{'_@bar'}, \my @bar );
    push @bar, 42 + shift;
  }
If you use :fieldlexes() on a sub (empty ()), it will only provide %self.
If you use :fieldlexes on a sub (notice the lack of ()),
it will provide lexicals for all of the field names.

The 'new' method that is created for you will first call fields::new,
then create initial values for any array or hash members, then locks
those keys, then return the blessed, restricted, hashref.  This makes
my use of alias_r less likely to blow up.