File Coverage

lib/AutoCode/AccessorMaker.pm

Criterion	Covered	Total	%
statement	260	273	95.2
branch	66	86	76.7
condition	8	17	47.0
subroutine	41	44	93.1
pod	0	5	0.0
total	375	425	88.2

###
# 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::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 @_;

        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;
    };
}

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

    $slot="$pkg\::$singular\_\%";
    my $add_method="$pkg\::add_$singular";
    my $get_method="$pkg\::get_$plural";
    my $remove_method="$pkg\::remove_$plural";
    {
        no strict 'refs';
        foreach $typeglob($add_method, $get_method, $remove_method){
            return if defined &$typeglob;
        }
    }

    $self->_make_hash_add($add_method, $slot);
    $self->_make_hash_get($get_method, $slot);
    $self->_make_hash_remove($remove_method, $slot, $get_method);
}

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

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

sub _make_hash_remove {
    my ($self, $glob, $slot)=@_;
    no strict 'refs';
    *$glob=sub{
        my $self=shift;
        if(@_){
            delete $self->{$slot}->{shift} while @_;
        }else{
            $self->{$slot}={};
        }
    };
}

sub make_initialize {
    my $self=shift;
    my %args=@_;
    my $scalar_accessors=$args{'$'} if exists $args{'$'};
    my $array_accessors=$args{'@'} if exists $args{'@'};
    AutoCode::Initialzer->make_initialize_by_hash(\@_);
}

### From Initializer

sub _compose_source {
    my ($self, $hash, $pkg)=@_;
#    $self->throw('pkg is required') unless defined $pkg;
    my @scalar_attrs;
    if(exists $hash->{'$'}){
        push @scalar_attrs, @{$hash->{'$'}};
    }
    my @array_attrs;
    if(exists $hash->{'@'}){
        push @array_attrs, @{$hash->{'@'}};
    }

    my $source = 'sub { my($dummy, @args)=@_;'."\n";
# The line below is for debug. It will run only when the made module is working
#    $source .= "print 'I am in _init of '. ref(\$dummy) . '_____';";

#    $source .= "\$dummy->SUPER::_initialize(\@args);\n";
    if(@scalar_attrs || @array_attrs){
        $source .= 'my ('. join ',',  map{"\$$_"} @scalar_attrs;
        $source .= ', ' unless @scalar_attrs == 0;
        $source .= join ',', map{
            '$'. ($self->_deref_plural($_))[1]}@array_attrs;
#            "\$$_"} @array_attrs_plural;
        $source .= ')='."\n".'$dummy->_rearrange([qw(';
        $source .= join ' ', @scalar_attrs;
        $source .= ' '. join ' ', map{
            ($self->_deref_plural($_))[1]}@array_attrs;
# @array_attrs_plural;
        $source .= ')], @args);'."\n";
        map {$source .=
            "defined \$$_ and \$dummy->$_(\$$_);\n"} @scalar_attrs;

    # if the array ref is defined, assign the dereferenced into array,
    # otherwise initialize the array by invoking remove_$plural
        map {
            my ($singular, $plural)= $self->_deref_plural($_);
# ($_, $schema->get_plural($_));
            $source .= <
if(ref(\$$plural) eq'ARRAY'){
    \$dummy->add_$singular(\$_) foreach (\@{\$$plural});
}else{
    \$dummy->remove_$plural;
}
END_ACCESSORS
        }@array_attrs;
    }
# The following 3 lines are to replace 'the not-working SUPER with eval'
# It spends almost a whole afternoon of the second day of 2004.
    $source .= "no strict 'refs';\n";
    $source .= 'my $super=AutoCode::Root::_find_super("'. $pkg .'", "_initialize");'."\n";
    $source .= '&{$super. "::_initialize"}($dummy, @args);'."\n";

#    $source .= "\$dummy->SUPER::_initialize(\@args);\n";
#    $source .= "print '______' \. *{\$dummy->SUPER::_initialize} \. \"\\n\"";
    $source .= '};'."\n";
    $self->debug("$source");
    return $source;
}

sub _make_initialize_by_hash {
    my ($self, $hash, $pkg, $method)=@_;
    my $source = $self->_compose_source($hash, $pkg);
    $method ||= '_initialize';
    no strict 'refs';
    *{"$pkg\::$method"} = eval $source;
    $self->throw( "Error when eval'ing _initialize\n$@") if($@);
}

sub _make_digest_args_by_hash {
    my ($self, $hash, $pkg)=@_;
    $self->_make_initialize_by_hash($hash, $pkg, '_digest_args');
}

sub make_initialize_by_model {
    my ($class, $model, $pkg)=@_;
    my $schema=$model->schema;
    my @scalar_attrs = $model->get_scalar_attributes;
    my @array_attrs  = $model->get_array_attributes;
    my @array_attrs_plural= map {$schema->get_plural($_)} @array_attrs;
    my %args=('$'=>\@scalar_attrs);
    my @array_ones;
    for(my $i=0; $i<@array_attrs; $i++){
        push @array_ones, [$array_attrs[$i], $array_attrs_plural[$i]];
        }
    my %args=('$'=>\@scalar_attrs, '@'=> \@array_ones);
    $class->_make_initialize_by_hash(\%args, $pkg);
}

1;
__END__