view Lib/IMPL/Class/Property/Base.pm @ 134:44977efed303

Significant performance optimizations Fixed recursion problems due converting objects to JSON Added cache support for the templates Added discovery feature for the web methods
author wizard
date Mon, 21 Jun 2010 02:39:53 +0400
parents a07a66fd8d5c
children d1676be8afcc
line wrap: on
line source

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

use IMPL::Class::Property;

require IMPL::Class::Member;

sub factoryParams { qw($class $name $set $get $validator) };

my %factoryCache;

my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;';
my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;';

my $custom_accessor_get = 'unshift @_, $this and goto &$get;';
my $custom_accessor_set = 'unshift @_, $this and goto &$set;';

my $validator_code = '$this->$validator(@_);'; 

my %access_code = (
	IMPL::Class::Member::MOD_PUBLIC , "",
	IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
	IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" 
);

my $virtual_call = q(
		my $method = $this->can($name);
        return $this->$method(@_) unless $method == $accessor or caller->isa($class);
);

my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;";

sub GenerateAccessors {
	my ($self,$param,@params) = @_;
	
	my %accessors;
	
	if (not ref $param) {
		if ($param & prop_list) {
			$accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef;
			$accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef;
		} else {
			$accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef;
			$accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef;
		}
		$accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : "";
	} elsif (UNIVERSAL::isa($param,'HASH')) {
		$accessors{get} = $param->{get} ? $custom_accessor_get : undef;
		$accessors{set} = $param->{set} ? $custom_accessor_set : undef;
		$accessors{owner} = "";
	} else {
		die new IMPL::Exception('The unsupported accessor/mutators supplied',$param);
	}
	
	return \%accessors;
}

sub GenerateSet {
	die new IMPL::Exception("Standard accessors not supported",'Set');
}
	
sub GenerateGet {
	die new IMPL::Exception("Standard accessors not supported",'Get');
}

sub GenerateGetList {
	die new IMPL::Exception("Standard accessors not supported",'GetList');
}

sub GenerateSetList {
	my ($self) = @_;
	die new IMPL::Exception("Standard accessors not supported",'SetList');
}

sub Make {
	my ($self,$propInfo) = @_;
	
	my $key = $self->MakeFactoryKey($propInfo);
	
	my $factoryInfo = $factoryCache{$key};
	
	unless ($factoryInfo) {
		my $mutators = $self->GenerateAccessors($propInfo->Mutators);
		$factoryInfo = {
			factory => $self->CreateFactory(
				$access_code{ $propInfo->Access },
				$propInfo->Attributes->{validator} ? $validator_code : "",
				$mutators->{owner},
				$mutators->{get} || $accessor_get_no,
				$mutators->{set} || $accessor_set_no
			),
			mutators => $mutators
		};
		$factoryCache{$key} = $factoryInfo; 
	}
	
	{
		no strict 'refs';
		*{ $propInfo->Class.'::'.$propInfo->Name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo));
	}
	
	my $mutators = $factoryInfo->{mutators};
	
	$propInfo->canGet( $mutators->{get} ? 1 : 0 );
	$propInfo->canSet( $mutators->{set} ? 1 : 0 );
	$propInfo->ownerSet( $mutators->{owner} );
	
	1;
}

# extract from property info: class, name, get_accessor, set_accessor, validator
sub RemapFactoryParams {
	my ($self,$propInfo) = @_;
	
	my $mutators = $propInfo->Mutators;
	my $class = $propInfo->Class;
	my $validator = $propInfo->Attributes->{validator};
	
	die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator);

	return (
		$propInfo->get(qw(Class Name)),
		(ref $mutators?
			($mutators->{set},$mutators->{get})
			:
			(undef,undef)
		),
		$validator
	);
}

sub MakeFactoryKey {
	my ($self,$propInfo) = @_;
	
	my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator});
	
	my $implementor = ref $self || $self;
	
	return join ('',
		$implementor,
		$access,
		$validator ? 'v' : 'n',
		ref $mutators ?
			('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0)
			:
			('s',$mutators) 
	); 
}

sub CreateFactory {
	my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_;
	
	my $strParams = join(',',$self->factoryParams);
	
	my $factory = <<FACTORY;
	
sub {
    my ($strParams) = \@_;
    my \$accessor;
    \$accessor = sub {
        my \$this = shift;
        $codeAccessCheck
        if (\@_) {
        	$codeOwnerCheck
        	$codeValidator
        	$codeSet
        } else {
        	$codeGet
        }
    }
}
FACTORY

	return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
}

1;

__END__

=pod

=head1 DESCRIPTION

Базовый класс для реализации свойств.

По существу свойства состоят из двух методов для установки и получения значений. Также
существует несколько вариантов доступа к свойству, и метод верификации значения. Еще
свойства могут быть виртуальными.

Для создания реализатора свойств достаточно унаследовать от этого класса и описать
методы для генерации кода получения и установки значения.

=head1 MEMBERS

=over

=item C<Make($propertyInfo)>

Создает свойство у класса, на основе C<$propertyInfo>, описывающего свойство. C<IMPL::Class::PropertyInfo>.

=back 

=cut