Mercurial > pub > Impl

changeset 60:b0c068da93ac

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Lazy activation for the configuration objects (final concept) small fixes
author wizard
date Tue, 09 Mar 2010 19:47:39 +0300
parents 0f3e369553bd
children 8d0ae27d15c1
files Lib/IMPL/Class/Property/Accessor.pm Lib/IMPL/Class/Property/Base.pm Lib/IMPL/Class/Property/Direct.pm Lib/IMPL/Class/PropertyInfo.pm Lib/IMPL/Config.pm Lib/IMPL/Config/Activator.pm Lib/IMPL/Config/Link.pm Lib/IMPL/Object/Accessor.pm Lib/IMPL/Object/PublicSerializable.pm Lib/IMPL/Serialization.pm Lib/IMPL/Web/Application.pm _test/Resources/app.xml _test/Test/Web/Application.pm _test/Test/Web/TDocument.pm _test/Web.t
diffstat 15 files changed, 234 insertions(+), 74 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Class/Property/Accessor.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -0,0 +1,35 @@
+package IMPL::Class::Property::Accessor;
+use strict;
+use base qw(IMPL::Class::Property::Base);
+
+sub factoryParams {
+	$_[0]->SUPER::factoryParams, qw($field);
+}
+
+sub RemapFactoryParams {
+	my ($self,$propInfo) = @_;
+	
+	return $self->SUPER::RemapFactoryParams($propInfo),$propInfo->Name;
+}
+
+sub GenerateGet {
+	'return $this->get($field);';
+}
+
+sub GenerateSet {
+	'return $this->set($field,@_);';
+}
+
+sub GenerateSetList {
+	'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] );
+	$this->set($field,$val);	
+	return(	wantarray ?	@{ $val } : $val );';
+}
+
+sub GenerateGetList {
+	'my $val = $this->get($field);
+	$this->set($field,$val = IMPL::Object::List->new()) unless $val;
+	return(	wantarray ?	@{ $val	} : $val );';
+}
+
+1;
\ No newline at end of file
--- a/Lib/IMPL/Class/Property/Base.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Class/Property/Base.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -5,7 +5,7 @@
 
 require IMPL::Class::Member;
 
-our @factoryParams = qw($class $name $set $get $validator);
+sub factoryParams { qw($class $name $set $get $validator) };
 
 my %factoryCache;
 
@@ -56,20 +56,20 @@
 }
 
 sub GenerateSet {
-	die new IMPL::Exception("Standard accessors not supported");
+	die new IMPL::Exception("Standard accessors not supported",'Set');
 }
 	
 sub GenerateGet {
-	die new IMPL::Exception("Standard accessors not supported");
+	die new IMPL::Exception("Standard accessors not supported",'Get');
 }
 
 sub GenerateGetList {
-	die new IMPL::Exception("Standard accessors not supported");
+	die new IMPL::Exception("Standard accessors not supported",'GetList');
 }
 
 sub GenerateSetList {
 	my ($self) = @_;
-	die new IMPL::Exception("Standard accessors not supported");
+	die new IMPL::Exception("Standard accessors not supported",'SetList');
 }
 
 sub Make {
@@ -101,9 +101,11 @@
 	if (ref $mutators) {
 		$propInfo->canGet( $mutators->{get} ? 1 : 0 );
 		$propInfo->canSet( $mutators->{set} ? 1 : 0 );
+		$propInfo->ownerSet(0);
 	} else {
 		$propInfo->canGet( $mutators & prop_get );
 		$propInfo->canSet( $mutators & prop_set );
+		$propInfo->ownerSet( ($mutators & owner_set) == owner_set );
 	}
 }
 
@@ -133,7 +135,10 @@
 	
 	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 ?
@@ -146,7 +151,7 @@
 sub CreateFactory {
 	my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_;
 	
-	my $strParams = join(',',@factoryParams);
+	my $strParams = join(',',$self->factoryParams);
 	
 	my $factory = <<FACTORY;
 	
--- a/Lib/IMPL/Class/Property/Direct.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Class/Property/Direct.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -10,7 +10,9 @@
 
 __PACKAGE__->mk_accessors qw(ExportField);
 
-push @IMPL::Class::Property::Base::factoryParams, qw($field);
+sub factoryParams {
+	$_[0]->SUPER::factoryParams, qw($field);
+}
 
 sub _direct($) {
     my ($prop_info) = @_;
--- a/Lib/IMPL/Class/PropertyInfo.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Class/PropertyInfo.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -3,7 +3,7 @@
 
 use base qw(IMPL::Class::MemberInfo);
 
-__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet));
+__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet ownerSet));
 __PACKAGE__->PassThroughArgs;
 
 my %LoadedModules;
--- a/Lib/IMPL/Config.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Config.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 
-use base qw(IMPL::Object IMPL::Object::Serializable IMPL::Object::Autofill);
+use base qw(IMPL::Object::Accessor IMPL::Object::Serializable IMPL::Object::Autofill);
 
 __PACKAGE__->PassThroughArgs;
 
@@ -13,6 +13,8 @@
 use IMPL::Serialization;
 use IMPL::Serialization::XmlFormatter;
 
+
+
 sub LoadXMLFile {
     my ($self,$file) = @_;
     
@@ -79,14 +81,36 @@
         next if $info->Access != IMPL::Class::Member::MOD_PUBLIC; # save only public properties
 
         my $name = $info->Name;
-        $ctx->AddVar($name => $this->$name()) if $this->$name();
+        $ctx->AddVar($name => $this->rawGet($name)) if $this->rawGet($name);
     }
+    
 }
 
 sub spawn {
 	goto &LoadXMLFile;
 }
 
+sub get {
+	my $this = shift;
+	
+	if (@_ == 1) {
+		my $obj = $this->SUPER::get(@_);
+		return UNIVERSAL::isa($obj,'IMPL::Config::Activator') ? $obj->activate : $obj;
+	} else {
+		my @objs = $this->SUPER::get(@_);	
+		return map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @objs ;	
+	}
+}
+
+sub rawGet {
+	my $this = shift;
+	return $this->SUPER::get(@_);
+}
+
+sub Exists {
+	$_[0]->SUPER::get($_[1]) ? 1 : 0;
+}
+
 1;
 __END__
 
@@ -103,14 +127,22 @@
 BEGIN {
     public property SimpleString => prop_all;
     public property MyClass => prop_all;
-    public lazy property DataSource => prop_all, {type => 'App::DataSource', factory => sub {}}; 
+    public property DataSource => prop_all; 
 }
 
 sub CTOR {
     my $this = shift;
-    $this->superCTOR(@_);
 
-    $this->MyClass(new IMPL::Config::Class(Type => MyClass)) unless $this->MyClass;
+    $this->MyClass(new IMPL::Config::Class(Type => 'MyClass'')) unless $this->MyClass;
+    $this->DataSource(
+    	new IMPL::Config::Activator(
+    		type => 'MyDataSource',
+    		args=>{
+    			host => 'localhost',
+    			user => 'dbuser'
+    		}
+    	)
+    ) unless $this->Exists('DataSource');
 }
 
 # in some script
@@ -129,15 +161,22 @@
 
 =over
 
-=item static LoadXMLFile($fileName)
+=item C<< IMPL::Config->LoadXMLFile($fileName) >>
+
 Создает из XML файла экземпляр приложения
 
-=item SaveXMLFile($fileName)
+=item C<< $instance->SaveXMLFile($fileName) >>
+
 Сохраняет приложение в файл
 
-=item xml
+=item C<< xml >>
+
 Сохраняет конфигурацию приложения в XML строку
 
+=item C<< IMPL::Config->spawn($file) >>
+
+Синоним для C<LoadXMLFile>
+
 =back
 
 =cut
--- a/Lib/IMPL/Config/Activator.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Config/Activator.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -1,21 +1,22 @@
 package IMPL::Config::Activator;
 use strict;
 
-use base qw(IMPL::Object IMPL::Object::Autofill);
+use base qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::PublicSerializable);
 use IMPL::Class::Property;
 
 BEGIN {
 	public property factory => prop_all;
-	public property args => prop_all;
-	private property _object => prop_all;
+	public property parameters => prop_all;
+	public property depends => prop_all | prop_list;
+	public property object => prop_get | owner_set;
 }
 
 __PACKAGE__->PassThroughArgs;
 
 sub CTOR {
     my $this = shift;
-    
-    die new IMPL::Exception("A Type parameter is required") unless $this->Type;
+
+    die new IMPL::Exception("A Type parameter is required") unless $this->factory;
     
 }
 
@@ -24,19 +25,31 @@
     scalar keys %{"$_[0]::"} ? 1 : 0;
 }
 
-sub instance {
+sub activate {
     my $this = shift;
     
-    my $factory = $this->fatory;
-    
-    if (my $obj = $this->_object) {
-        return $obj;
+    unless ($this->object) {
+        my @args;
+        
+        my $params = $this->parameters;
+        if (UNIVERSAL::isa($params,'HASH')) {
+        	while ( my ($key,$value) = each %$params ) {
+        		push @args,$key, UNIVERSAL::isa($value,'IMPL::Config::Activator') ? $value->activate : $value;
+        	}
+        } elsif (UNIVERSAL::isa($params,'ARRAY')) {
+        	push @args, map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @$params;
+        } else {
+        	push @args, UNIVERSAL::isa($params,'IMPL::Config::Activator') ? $params->activate : $params;
+        }
+        
+        push @args,  map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @_ if @_;
+        
+        my $factory = $this->factory;
+        eval "require $factory; 1;" unless not ref $factory and _is_class($factory);
+        
+        return $this->object($factory->new(@args));
     } else {
-        my %args = (%{$this->args || {}},@_);
-        eval "require $factory" unless not ref $factory and _is_class($factory);
-        my $inst = $factory->new(%args);
-        $this->_object($inst);
-        return $inst;
+    	return $this->object;
     }
 }
 
--- a/Lib/IMPL/Config/Link.pm	Tue Mar 09 02:50:45 2010 +0300
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
-package IMPL::Config::Link;
-
-use strict;
-
-require IMPL::Exception;
-
-require Tie::Scalar;
-our @ISA = qw(Tie::StdScalar);
-
-sub FETCH {
-	return ${$_[0]} = ${$_[0]}->instance() if UNIVERSAL::isa(${$_[0]},'IMPL::Config::Activator');
-}
-
-sub surrogate {
-	die new IMPL::Exception("You can't create a forward declarations of the link");
-}
-
-sub restore {
-	my ($self,$data,$surrogate) = @_;
-
-	my %args = @$data;
-	
-	die new IMPL::Exception('A target is required for the link') unless exists $args{target};
-	my $val;
-	tie $val, $self, $args{target};
-	return $val;
-}
\ No newline at end of file
--- a/Lib/IMPL/Object/Accessor.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Object/Accessor.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -12,4 +12,8 @@
 sub surrogate {
     $_[0]->Class::Accessor::new;
 }
+
+sub _PropertyImplementor {
+	'IMPL::Class::Property::Accessor'
+}
 1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Object/PublicSerializable.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -0,0 +1,35 @@
+package IMPL::Object::PublicSerializable;
+use strict;
+
+use IMPL::Class::Member;
+
+sub restore {
+    my ($class,$data,$refSurrogate) = @_;
+    
+    if ($refSurrogate) {
+        $refSurrogate->callCTOR(@$data);
+        return $refSurrogate;
+    } else {
+        return $class->new(@$data);
+    }
+}
+
+sub save {
+	my ($this,$ctx) = @_;
+	
+	my %seen;
+	
+	$ctx->AddVar($_,$this->$_()) foreach
+		map $_->Name,$this->get_meta(
+			'IMPL::Class::PropertyInfo',
+			sub {
+				$_->Access == IMPL::Class::Member::MOD_PUBLIC and
+				$_->canGet and
+				not $_->ownerSet and
+				not $seen{$_->Name} ++
+			},
+			1
+		);
+}
+
+1;
\ No newline at end of file
--- a/Lib/IMPL/Serialization.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Serialization.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -220,7 +220,11 @@
                           Id => $rhProps->{'id'},
                           refId => $rhProps->{'refid'}
                           };
-    $this->{$Context}->{$rhProps->{'id'}} = $this->{$SurogateHelper} ? $this->{$SurogateHelper}->($rhProps->{'type'}) : DefaultSurogateHelper($rhProps->{'type'}) if defined $rhProps->{'id'};
+
+	if (defined $rhProps->{'id'}) {                          
+    	die new IMPL::Exception("Trying to create a simple object instead of a reference, type is missing.",$name,$rhProps->{id}) unless $rhProps->{'type'} ;
+    	$this->{$Context}->{$rhProps->{'id'}} = $this->{$SurogateHelper} ? $this->{$SurogateHelper}->($rhProps->{'type'}) : DefaultSurogateHelper($rhProps->{'type'});
+	}
   }
   
   return 1;
@@ -306,9 +310,9 @@
     return [];
   } elsif ($Type eq 'HASH') {
     return {};
-  } else {
+  } elsif ($Type) {
     eval "require $Type" unless _is_class($Type);
-    if ($Type->UNIVERSAL::can('surrogate')) {
+    if (UNIVERSAL::can($Type,'surrogate')) {
       return $Type->surrogate();
     } else {
       return bless {}, $Type;
--- a/Lib/IMPL/Web/Application.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/Lib/IMPL/Web/Application.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 
-use base qw(IMPL::Object IMPL::Object::Singleton);
+use base qw(IMPL::Config IMPL::Object::Singleton);
 
 require IMPL::Web::Application::Action;
 require IMPL::Web::Application::Response;
@@ -10,10 +10,13 @@
 use IMPL::Class::Property;
 use CGI;
 
+__PACKAGE__->PassThroughArgs;
+
 BEGIN {
     public property handlerError => prop_all;
     public property factoryAction => prop_all;
     public property handlersQuery => prop_all | prop_list;
+    public property configuration => prop_all;
 }
 
 # custom factory
--- a/_test/Resources/app.xml	Tue Mar 09 02:50:45 2010 +0300
+++ b/_test/Resources/app.xml	Tue Mar 09 19:47:39 2010 +0300
@@ -1,23 +1,21 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<Application id='app' type="Test::Config::Application">
-	<name>Sample application</name>
-	<options type="HASH">
-		<One>value one</One>
-		<Two>value two</Two>
-	</options>
+<Application id='app' type="Test::Web::Application::Instance">
+	<name type='SCALAR' id='appName'>Sample application</name>
 	<dataSource type='IMPL::Config::Activator' id='ds'>
-		<type>Test::Config::DataSource</type>
+		<factory>Test::Config::DataSource</factory>
 		<parameters type='HASH'>
 			<db>data</db>
 			<user>nobody</user>
 		</parameters>
 	</dataSource>
 	<securityMod type='IMPL::Config::Activator'>
-		<type>Test::Config::Security</type>
+		<factory>Test::Config::Security</factory>
 		<parameters type='HASH'>
-			<ds type='IMPL::Config::Link'>
-				<target ref='ds'/>
-			</ds>
-		</paremeters>
+			<ds refid='ds'/>
+		</parameters>
 	</securityMod>
+	<options type="HASH">
+		<appName refid='appName'/>
+		<dataSource refid='ds'/>
+	</options>
 </Application>
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/Web/Application.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -0,0 +1,44 @@
+package Test::Web::Application::Instance;
+package Test::Web::Application;
+use strict;
+use base qw(IMPL::Test::Unit);
+
+use IMPL::Test qw(test failed);
+require IMPL::Web::Application;
+
+__PACKAGE__->PassThroughArgs;
+
+sub CTOR {
+	# simulate CGI environment
+}
+
+test SpawnApp => sub {
+	my $instance = spawn Test::Web::Application::Instance('Resources/app.xml');
+	
+	return 1;
+};
+
+test ActivateOnDemand => sub {
+	my $instance = spawn Test::Web::Application::Instance('Resources/app.xml');
+	
+	my $ds = $instance->dataSource;
+	
+	return 1;
+};
+
+package Test::Web::Application::Instance;
+use base qw(IMPL::Web::Application);
+
+__PACKAGE__->PassThroughArgs;
+
+use IMPL::Class::Property;
+
+BEGIN {
+	public property name => prop_all;
+	public property options => prop_all;
+	public property dataSource => prop_all;
+	public property securityMod => prop_all;
+}
+
+
+1;
\ No newline at end of file
--- a/_test/Test/Web/TDocument.pm	Tue Mar 09 02:50:45 2010 +0300
+++ b/_test/Test/Web/TDocument.pm	Tue Mar 09 19:47:39 2010 +0300
@@ -12,6 +12,8 @@
     my $document = new IMPL::Web::TDocument();
     
     failed "Failed to create document" unless $document;
+    
+    $document->Dispose();
 };
 
 test SimpleTemplate => sub {
@@ -28,6 +30,8 @@
     my $eta = <$hFile>;
     
     failed "Rendered data doesn't match the etalon data","Expected:\n$eta","Actual:\n$out" if $out ne $eta;
+    
+    $document->Dispose();
 };
 
 
--- a/_test/Web.t	Tue Mar 09 02:50:45 2010 +0300
+++ b/_test/Web.t	Tue Mar 09 19:47:39 2010 +0300
@@ -8,6 +8,7 @@
 
 my $plan = new IMPL::Test::Plan qw(
     Test::Web::TDocument
+    Test::Web::Application
 );
 
 $plan->AddListener(new IMPL::Test::TAPListener);