CPPish.pm

#!perl
package CPPish;
use Devel::LexAlias;
use Attribute::Handlers;
use strict;
use warnings;

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

my %vnames;
sub import {
  my ($class, @vnames) = @_;
  my $caller = caller;
  die if grep !/^([$%@][^a-z][a-z0-9]*)\z/i, @vnames;
  for( @vnames ) {
    my ($sigil, $rest) = /(.)(.*)/;
    my $glob = do { no strict 'refs'; *{ $package . '::' . $rest } };
    if( $sigil eq '$' ) {
      *$glob = \undef unless *{$glob}{SCALAR};
    } elsif( $sigil eq '@' ) {
      *$glob = [] unless *{$glob}{ARRAY};
    } else {
      *$glob = {} unless *{$glob}{HASH};
    }
  }
  $vnames{$caller} = \@vnames;
}

sub UNIVERSAL::CPPish : ATTR(RAW,CODE,CHECK) {
  my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
  die if defined $data;
  my @vars = @{$vnames{$package}};
  my ($sigil) = substr $vars[0], 0, 1;
  die if $sigil eq '$' and @vars > 1;

  my $src = do {
    local $processing = $package;
    $deparser->coderef2text( $referent );
  };

  my $at = 1+index $src, '{' or die;
  substr $src, $at, 0, sprintf 'Devel::LexAlias::alias_r( shift, \my %s );', $vars[0];
  $at = 1+index $src, ';', $at;
  if( $sigil eq '%' ) {
    my $name = shift @vars;
    my $scalar = '$' . substr $name, 1;
    for my $name2 (@vars) {
      my ($sigil2, $bare) = $name2 =~ /(.)(.*)/;
      my $r = $sigil2 eq '$' ? '\\' : '';
      my $s = sprintf 'Devel::LexAlias::alias_r( %s%s{\'%s\'}, \\my %s );', $r, $scalar, $bare, $name2;
      substr $src, $at, 0, $s;
      $at += length $s;
    }
  } elsif( $sigil eq '@' ) {
    my $name = shift @vars;
    my $scalar = '$' . substr $name, 1;
    for (0 .. $#vars) {
      my $sigil2 = substr $vars[$_], 0, 1;
      my $r = $sigil2 eq '$' ? '\\' : '';
      my $s = sprintf 'Devel::LexAlias::alias_r( %s%s[%d], \\my %s ) ;', $r, $scalar, $_, $vars[$_];
      substr $src, $at, 0, $s;
      $at += length $s;
    }
  }
  
  my $sub_name = *{$symbol}{NAME};
  eval qq{
    package $package;
    no warnings 'redefine';
    sub $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;
}

'Inspired by Attribute::Method';
__END__
Useage:
  package MyClass;
  use CPPish qw(%self $bar @quux);
  sub new { my $c = shift; bless {@_}, $c }
  sub foo :CPPIsh {
    ++$bar;
    push @quux, $bar;
  }
  1;
This sub gets decompiled, modifed to the following, then recompiled:
  sub foo {
    Devel::LexAlias::alias_r( shift, \my %self );
    Devel::LexAlias::alias_r( \$self->{'bar'}, \my $bar );
    Devel::LexAlias::alias_r( $self->{'quux'}, \my @quux );
    ++$bar;
    push @quux, $bar+1;
  }
When we alias \$bar to \$self->{bar}, it means that modifying $bar
will modify $self->{bar}.  When we alias \@quux to $self->{quux}
(notice the lack of a second \), changing @quux changes @{$self->{quux}}.