view Lib/IMPL/Class/Property/Direct.pm @ 196:a705e848dcc7

added IMPL::Config::Reference
author cin
date Mon, 16 Apr 2012 17:42:54 +0400
parents 4d0e1962161c
children 6253872024a4
line wrap: on
line source

package IMPL::Class::Property::Direct;
use strict;

use parent qw(Exporter IMPL::Object::Accessor IMPL::Class::Property::Base);
our @EXPORT = qw(_direct);

require IMPL::Object::List;
use IMPL::Class::Property;
require IMPL::Exception;

__PACKAGE__->mk_accessors( qw(ExportField) );

sub factoryParams {
    $_[0]->SUPER::factoryParams, qw($field);
}

my $default = __PACKAGE__->new({ExportField => 1});

sub _direct($) {
    my ($prop_info) = @_;
    $prop_info->Implementor( $default );
    return $prop_info;
}


sub GenerateGet {
    'return ($this->{$field});';
}

sub GenerateSet {
    'return ($this->{$field} = $_[0])';
}

sub GenerateSetList {
    'return(
        wantarray ?
        @{ $this->{$field} = IMPL::Object::List->new(
            (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]  
        )} : 
        ($this->{$field} = IMPL::Object::List->new(
            (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]  
        ))
    );';
}

sub GenerateGetList {
    'return(
        wantarray ?
        @{ $this->{$field} ?
            $this->{$field} :
            ( $this->{$field} = IMPL::Object::List->new() )
        } :
        ( $this->{$field} ?
            $this->{$field} :
            ( $this->{$field} = IMPL::Object::List->new() )
        )
    );';
}

sub RemapFactoryParams {
    my ($self,$propInfo) = @_;
    
    return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo);
}

sub Make {
    my ($self,$propInfo) = @_;
    
    $self->SUPER::Make($propInfo);
    
    {
        no strict 'refs';
        if (ref $self and $self->ExportField) {
            my $field = $self->FieldName($propInfo);
            *{$propInfo->Class.'::'.$propInfo->Name} = \$field;
        }
    }
}

sub FieldName {
    my ($self,$propInfo) = @_;
    
    my ($class,$name) = $propInfo->get( qw(Class Name) );
    (my $field = "${class}_$name") =~ s/::/_/g;
    return $field;
}

1;