view release on metacpan or  search on metacpan

lib/AutoCode/AccessorMaker.pm  view on Meta::CPAN

our $VERSION='0.01';
use AutoCode::Root0;
our @ISA=qw(AutoCode::Root0);
# use AutoCode::Initializer;
use AutoCode::SymbolTableUtils;
our %AUTO_ACCESSORS;

our $VALID_ACCESSOR_NAME='[_a-z][_a-z0-9]+';
$VALID_ACCESSOR_NAME='[_a-zA-Z][_a-zA-Z0-9]+';

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

    if(exists $args{'@'}){
        foreach($class->_scalar_to_array($args{'@'})){
            $self->make_array_accessor($_, $caller);
        }
    }

    if(exists $args{'%'}){
        foreach($class->_scalar_to_array($args{'%'})){
            $self->make_hash_accessor($_, $caller);
        }
    }

    if(exists $args{_initialize} or exists $args{_digest_args}){
        my $initializer=$self;
    
        if(exists $args{_initialize}){
            $initializer->_make_initialize_by_hash(\%args, $caller);
        }
        if(exists $args{_digest_args}){
            $initializer->_make_digest_args_by_hash(\%args, $caller);
        }
    }
}

sub _scalar_to_array {
    my ($class, $scalar)=@_;
    my $ref=ref($scalar);
    if($ref eq'ARRAY'){
        return @$scalar;
    }elsif($ref eq ''){
        return ($scalar);
    }else{
        $class->throw("ref [$ref] is neither nothing nor ARRAY");
    }
}

# 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 /^$VALID_ACCESSOR_NAME\$/")
        unless $singular =~ /^$VALID_ACCESSOR_NAME$/;
    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} keys %AUTO_ACCESSORS){
        # push @{$self->{AUTO_ACCESSORS_SLOT}}, $typeglob;
        $AUTO_ACCESSORS{$typeglob}=1;
    }
    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(@_);
    
    $typeglob="$pkg\::$accessor";
    $slot="$pkg\::$accessor\_\$";
    $self->debug("making a scalar accessor [$typeglob]");

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

sub _deref_plural {
    my ($self, $accessor)=@_;
    (ref($accessor) eq 'ARRAY')? @$accessor: ($accessor, "${accessor}s");
}

sub make_array_accessor {
    my $self=shift;
    my ($accessor, $pkg, $typeglob, $slot)=$self->__accessor_to_glob(@_);
    my ($singular, $plural) = $self->_deref_plural($accessor);
    # $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));
    }
    $slot="$pkg\::$singular\_\%";
    $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 @_;