view release on metacpan or  search on metacpan

lib/AutoXS/Accessor.pm  view on Meta::CPAN

package AutoXS::Accessor;

use 5.008;
use strict;
use warnings;

require Exporter;

our $VERSION = '0.03';

BEGIN { require AutoXS; }
use base 'AutoXS';

use B qw( svref_2object );
use B::Utils qw( opgrep op_or );
use Class::XSAccessor;

CHECK {
  warn "Running AutoXS scanner of " . __PACKAGE__ if $AutoXS::Debug;
  __PACKAGE__->scan_package_accessor($_) for keys %{$AutoXS::ScanClasses{"".__PACKAGE__}};
}

sub scan_package_accessor {
  my $selfclass = shift;
  my $edit_pkg = shift;
  warn "Scanning package '$edit_pkg'" if $AutoXS::Debug;

  my $sym = $selfclass->get_symbol($edit_pkg);

  my @to_be_replaced;

  foreach my $function (sort keys %$sym) {
    next if $function =~ /^BEGIN|END|CHECK|UNITCHECK|INIT|import$/;
    warn "Scanning function '${edit_pkg}::$function'" if $AutoXS::Debug;

    local *symbol = $sym->{$function};
    my $coderef = *symbol{CODE} or next;

    my $codeobj = svref_2object($coderef);
    next unless ref $codeobj eq 'B::CV';
    if ($codeobj->XSUB) {
      #print *symbol, " is XS\n";
    }
    else {
      my $r = $codeobj->ROOT;
      my $glob_array_dereference = {
        name => 'rv2av',
        first => { name => 'gv', },
      };

      my $array_hash_access_or_shift = {
        name => 'helem',
        first => {
          name => 'rv2hv',
          first => op_or(
            { name => 'aelem',
              first => $glob_array_dereference,
              'last' => { name => 'const', },
            },
            { name => 'shift',
              first => $glob_array_dereference,
            },
          ),
        },
        'last' => { name => 'const', },
      };
      my $simple_structure = {
        name => 'lineseq',
        kids => [
          { name => 'nextstate', },
          op_or(
            { name => 'return',
              first => {name => 'pushmark'},
              'last' => $array_hash_access_or_shift,
            },
            $array_hash_access_or_shift,
          ),
        ],
      };
      my $hash_access_pad = {
        name => 'helem',
        first => {
          name => 'rv2hv',
          first => { name => 'padsv' },              
        },
        last => {
          name => 'const',
          capture => 'hash_key',
        },
      };

      my $self_shift_structure = {
        name => 'lineseq',