view Lib/IMPL/Class/Property/Direct.pm @ 165:76515373dac0

Added Class::Template, Rewritten SQL::Schema 'use parent' directive instead of 'use base'
author wizard
date Sat, 23 Apr 2011 23:06:48 +0400
parents 05df123a2ff1
children b3d91ff7aea9
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);
}

sub _direct($) {
    my ($prop_info) = @_;
    $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) );
    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;