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',
        kids => [
          { name => 'nextstate', },
          { name => 'sassign', # optionally match my $self = shift and friends
            first => {
              name => 'shift',
              first => $glob_array_dereference,
            },
          },
          { name => 'nextstate', },
          op_or(
            { name => 'return',
              first => {name => 'pushmark'},
              'last' => $hash_access_pad,
            },
            $hash_access_pad,
          ),
        ],
      };

      my $self_array_assign_structure = {
        name => 'lineseq',
        kids => [
          { name => 'nextstate', },
          { name => 'aassign',
            kids => [
              { name => 'null',
                first => {
                  name => 'pushmark',
                  sibling => op_or(
                    $glob_array_dereference,
                    { name => 'shift',
                      first => $glob_array_dereference,
                    },
                  ),
                },
              },
              { name => 'null',
                first => {
                  name => 'pushmark',
                  sibling => {name => 'padsv'}
                },
              },
            ],
          },
          { name => 'nextstate', },
          op_or(
            { name => 'return',
              first => {name => 'pushmark'},
              'last' => $hash_access_pad,
            },
            $hash_access_pad,
          ),
        ],
      };
      B::Utils::walkoptree_filtered(
        $r,
        sub { opgrep( {
          name => 'leavesub',
          first => op_or(
            $simple_structure,
            $self_shift_structure,
            $self_array_assign_structure,
          ),
        }, @_ ) },
        sub {
          my $op = shift;
          #print $op->name." " .$op->type." " .$op->first->name. "\n";
          #my $inner = $op->first->last;
          #$inner = $inner->last if $inner->name eq 'return';
          #$inner = $inner->last;
          #my $key_string = $inner->sv->PV;
          my $key_string = $op->{hash_key}->sv->PV;
          #warn $key;
          push @to_be_replaced, ["${edit_pkg}::$function", $key_string];
        },
      );
    }
  }

  foreach my $struct (@to_be_replaced) {
    my $function = $struct->[0];
    my $key = $struct->[1];
    if ($AutoXS::Debug) {
      warn "Replacing $function with XS accessor for key '$key'.\n";
    }
    Class::XSAccessor->import(
      replace => 1,
      getters => { $function => $key },
    );
  }

}

1;
__END__

=head1 NAME

AutoXS::Accessor - Identify accessors and replace them with XS

=head1 SYNOPSIS
  
  package MyClass;
  use AutoXS plugins => 'Accessor';
  
  # or load all installed optimizing plugins
  use AutoXS ':all';
  
  sub new {...}
  sub get_foo { $_[0]->{foo} }
  sub other_stuff {...}
  
  # get_foo will be auto-replaced with XS and faster

=head1 DESCRIPTION

This is an example plugin module for the L<AutoXS> module. It searches
the user package (C<MyClass> above) for read-only accessor methods of certain forms
and replaces them with faster XS code.

=head1 RECOGNIZED ACCESSORS

Note that whitespace, a trailing semicolon, and the method names don't matter.
Also please realize that this is B<not a source filter>.

  sub get_acc { $_[0]->{acc} }
  
  sub get_bcc {
    my $self = shift;
    $self->{bcc}
  }
  
  sub get_ccc {
    my $self = shift;
    return $self->{ccc};
  }
  
  sub get_dcc { return $_[0]->{dcc} }
  
  sub get_ecc { shift->{ecc} }
  
  sub get_fcc {
    my ($self) = @_;
    $self->{fcc}
  }
  
  sub get_gcc {
    my ($self) = @_;
    return $self->{gcc};
  }
  
  sub get_icc {
    my ($self) = shift;
    $self->{icc}
  }
  
  sub get_jcc {
    my ($self) = shift;
    return $self->{jcc};
  }

=head1 SEE ALSO

L<AutoXS>

L<Class::XSAccessor>

=head1 AUTHOR

Steffen Mueller, E<lt>smueller@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 by Steffen Mueller

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8 or,
at your option, any later version of Perl 5 you may have available.

=cut