###
# POD documents at the end of the file
###
package AutoCode::AccessorMaker;
use strict;
our $VERSION='0.01';
use AutoCode::Root0;
our @ISA=qw(AutoCode::Root0);

use AutoCode::SymbolTableUtils;

sub import {
    my ($class, @args)=@_;
    my $self = $class->new;
    my $caller = ref(caller) || caller;
    my %args=@args;
    
    my $scalar_accessors=$args{'$'} if exists $args{'$'};
    foreach (@$scalar_accessors){
        $self->make_scalar_accessor($_, $caller);
    }

    my $array_accessors=$args{'@'} if exists $args{'@'};
    foreach(@$array_accessors){
        $self->make_array_accessor($_, $caller);
    }
}


use constant AUTO_ACCESSORS_SLOT => '_AUTO_ACCESSORS';
sub _auto_accessors {
    my $self=shift;
    return @{$self->{AUTO_ACCESSORS_SLOT}}
        if exists $self->{AUTO_ACCESSORS_SLOT};
    return ();
    
}

# This method is only invoked by make_scalar_accessor and make_array_accessor
# While subroutine defined the argument of those two method abovementioned.
# This most hacky part is caller(2); that mean the first immedicate package
# after this Module.
sub __accessor_to_glob {
    my ($self, $accessor, $pkg)=@_;
    defined $accessor or $self->throw("method_name needed as 2nd arg");
    my $singular = (ref($accessor) eq 'ARRAY')? $accessor->[0]: $accessor;
    # According to the specification of AutoCode, upper letter are not allowed
    # in the names of methods which are automatically generated by this system.
    $self->throw("$singular. method name must match /^[_a-z][_a-z0-9]+\$/")
        unless $singular =~ /^[_a-z][_a-z0-9]+$/;
    if(0){ # For debug
        print "$_\t". (caller($_))[0]."\n" foreach(0..3);
        $self->throw("");
    }
    $pkg ||= (caller(2))[0];   # This line will definitely assign a value.

    # This typeglob is meaningful for both scalar and array accessors.
    # For scalar, it means the same as the real typeglob;
    # for array, there is no such method with exact method, but a symbol for
    # these three methods.
    my $typeglob="$pkg\::$singular";
    unless(grep {$_ eq $typeglob} $self->_auto_accessors){
        push @{$self->{AUTO_ACCESSORS_SLOT}}, $typeglob;
    }
    my $slot="$pkg\::_auto_accessors::$singular";
    return ($accessor, $pkg, $typeglob, $slot);
    
}

sub make_scalar_accessor {
    my $self=shift;
    my ($accessor, $pkg, $typeglob, $slot) = $self->__accessor_to_glob(@_);

    $self->debug("making a scalar accessor [$typeglob]");

    return if(AutoCode::SymbolTableUtils::CODE_exists_in_ST($typeglob));
    no strict 'refs';
    *$typeglob =sub{
        my $self=shift;
        $self->{$slot}=shift if @_;
        return $self->{$slot};
    };
}

sub make_array_accessor {
    my $self=shift;
    my ($accessor, $pkg, $typeglob, $slot)=$self->__accessor_to_glob(@_);
    my ($singular, $plural) =
        (ref($accessor) eq 'ARRAY')? @$accessor: ($accessor, "${accessor}s");
    # $typeglob is useless here. So the 3 new method globs are composed here
    my $add_method="$pkg\::add_$singular";
    my $get_method="$pkg\::get_$plural";
    my $remove_method="$pkg\::remove_$plural";
    foreach $typeglob($add_method, $get_method, $remove_method){
        return if(AutoCode::SymbolTableUtils::CODE_exists_in_ST($typeglob));
    }

    $self->_make_array_add($add_method, $slot);
    $self->_make_array_get($get_method, $slot);
    $self->_make_array_remove($remove_method, $slot, $get_method);
}

sub _make_array_add {
    my ($self, $glob, $slot)=@_;
    no strict 'refs';
    *$glob=sub{
        my $self=shift; return unless @_;
        
        foreach my $value(@_){
            # Avoid duplicates
            next if grep /^$value$/, @{$self->{$slot}};
            push @{$self->{$slot}}, $value;
        }
    };
}

sub _make_array_get {
    my ($self, $glob, $slot)=@_;
    no strict 'refs';
    *$glob=sub{
        my $self=shift;
        return @{$self->{$slot}} if exists  $self->{$slot};
        return ();
    };
}

sub _make_array_remove {
    my ($self, $glob, $slot, $get_method)=@_;
    no strict 'refs';
    *$glob=sub{
        my $self=shift;
        my @olds=&{$get_method}($self);
        $self->{$slot}=[];
        return @olds;
    };
}

1;
__END__

=head1 NAME

AutoCode::AccessorMaker -- making the accessors in the traditional way.

=head1 SYNOPSIS

    use AutoCode::AccessMaker (
        '$' => [qw(first_name sex)],
        '@' => ['alias', ['child', 'children']
    );

    AutoCode::AccessorMaker->make_scalar_accessor('last_name', __PACKAGE__);
    # If the second argument is omitted, the caller is regarded as default
    
    AutoCode::AccessorMaker->make_array_accessor([qw(child children)]);

=head1 DESCRIPTION

This module is to save the developers to type the same code of accessor 
day in and day out.

There are two non-exclusive ways to generate the accessors for a module.

=over 

=item 1 using import method

'import' method is special for Perl module. 
It is called when the module get used, like Exporter. 
And the arguments listed behind the module name are passed into import method.

This import method requests a hash with limited keys as '$', '@'. 
The values in the argument hash are the array reference.

=head1 AUTHOR

Juguang Xiao, juguang at tll.org.sg

=cut

