changeset 406:f23fcb19d3c1 ref20150831

implemented ServicesBag
author cin
date Mon, 31 Aug 2015 20:22:16 +0300
parents cd6c6e61d442
children c6e90e02dd17
files Lib/IMPL/Config/ServicesBag.pm Lib/IMPL/DOM/Node.pm Lib/IMPL/DOM/Schema.pm Lib/IMPL/Object/List.pm _test/temp.pl
diffstat 5 files changed, 149 insertions(+), 44 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/Config/ServicesBag.pm	Mon Aug 31 10:23:42 2015 +0300
+++ b/Lib/IMPL/Config/ServicesBag.pm	Mon Aug 31 20:22:16 2015 +0300
@@ -1,47 +1,126 @@
 package IMPL::Config::ServicesBag;
 
+require v5.9.5;
+
+use mro;
+
 use IMPL::Const qw(:prop);
 use IMPL::declare {
-	base => {
+	base => [
 		'IMPL::Object' => undef
-	},
-	props => {
+	],
+	props => [
 		_prototype => PROP_RW,
-		_nameMap => PROP_RW,
-		_typeMap => PROP_RW,
-		_props => PROP_RW,
-	}
+		_nameMap   => PROP_RW,
+		_typeMap   => PROP_RW,
+		_props     => PROP_RW,
+	]
 };
 
+sub CTOR {
+	my ( $this, $prototype ) = @_;
+
+	$this->_prototype($prototype) if $prototype;
+	$this->_nameMap( {} );
+	$this->_typeMap( {} );
+}
+
 sub GetDescriptorByName {
-	my ($this, $name) = @_;
-	
-	my $d = $this->_namedMap->{$name};
-	if ($d && $d->{valid})
-		return $d;
-	
+	my ( $this, $name ) = @_;
+
+	my $d = $this->_nameMap->{$name};
+	return $d if $d and $d->{valid};
+
 	my $parent = $this->_prototype;
-	if ($parent && $d = $parent->GetDescriptorByName($name))
-		return $this->_namedMap->{$name} = $d;
-		
+
+	if ( $parent and $d = $parent->GetDescriptorByName($name) ) {
+		return $this->_nameMap->{$name} = $d;
+	}
+
 	return undef;
 }
 
 sub GetDescriptorByType {
-	my ($this, $type) = @_;
-	
-	my $d = $this->_typeMap->{$name};
-	if ($d && $d->{valid})
-		return $d;
-	
+	my ( $this, $type ) = @_;
+
+	my $d = $this->_typeMap->{$type};
+	return $d if $d and $d->{valid};
+
 	my $parent = $this->_prototype;
-	if ($parent && $d = $parent->GetDescriptorByType($name))
-		return $this->_typeMap->{$name} = $d;
-		
-	return undef;	
+	if ( $parent and $d = $parent->GetDescriptorByType($type) ) {
+		return $this->_typeMap->{$type} = $d;
+	}
+
+	return undef;
 }
 
-sub Register
+sub RegisterValue {
+	my ( $this, $value, $name, $type ) = @_;
+
+	my $d = { owner => $this, value => $value, valid => 1 };
+
+	if ($type) {
+		my $map = $this->_typeMap;
+		my $isa = mro::get_linear_isa($type);
+		$d->{isa} = $isa;
+
+		# the service record which is superseded by the current one
+		my $replaces = $this->GetDescriptorByType($type);
+
+		foreach my $t (@$isa) {
+			if ( my $prev = $this->GetDescriptorByType($t) ) {
+
+				# keep previous registrations if they are valid
+				next if not $replaces or $prev != $replaces;
+			}
+
+			$map->{$t} = $d;
+		}
+
+		if ($replaces) {
+
+			# invalidate cache
+			$replaces->{owner}->UpdateDescriptor($replaces);
+		}
+	}
+
+	if ($name) {
+		my $prev = $this->_nameMap->{$name};
+		$d->{name} = $name;
+		$this->_nameMap->{$name} = $d;
+		$prev->{owner}->UpdateDescriptor($prev) if $prev;
+	}
+
+	return $d;
+}
+
+sub UpdateDescriptor {
+	my ( $this, $d ) = @_;
+
+	my $d2 = {};
+
+	# copy descriptor
+	while ( my ( $k, $v ) = each %$d ) {
+		$d2->{$k} = $v;
+	}
+
+	# update named entries
+	my $name = $d->{name};
+	if ( $name and $this->_nameMap->{$name} == $d ) {
+		$this->_nameMap->{$name} = $d2;
+	}
+
+	# update type entries
+	if ( my $isa = $d->{isa} ) {
+		my $map = $this->_typeMap;
+		foreach my $t (@$isa) {
+			next unless $map->{$t} == $d;
+			$map->{$t} = $d2;
+		}
+	}
+
+	$d->{valid} = 0;
+}
 
 1;
 
@@ -63,17 +142,17 @@
 
 =over
 
-=item * name название под которым сервис зарегистрирован
+=item * isa массив типов сервиса, если он регистрировался как сервис
 
-=item * type тип сервиса
-
-=item * service фабрика сервиса
+=item * value значение
 
 =item * valid признак того, что дескриптор действителен
 
+=item * owner коллекция, которая создала данный дескриптор
+
 =back
 
 Если запрашиваемый десриптор не найден это является ошибкой, поэтому негативные
 ответы не кешируются
 
-=cut
\ No newline at end of file
+=cut
--- a/Lib/IMPL/DOM/Node.pm	Mon Aug 31 10:23:42 2015 +0300
+++ b/Lib/IMPL/DOM/Node.pm	Mon Aug 31 20:22:16 2015 +0300
@@ -75,7 +75,7 @@
     $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
     
     my $children = $this->childNodes;
-    $children->Append($node);
+    $children->Push($node);
     
     $node->_setParent( $this );
     
@@ -96,7 +96,7 @@
         $node->_setParent( $this );
     }
     
-    $this->childNodes->Append(@range);
+    $this->childNodes->Push(@range);
     
     return $this;
 }
--- a/Lib/IMPL/DOM/Schema.pm	Mon Aug 31 10:23:42 2015 +0300
+++ b/Lib/IMPL/DOM/Schema.pm	Mon Aug 31 20:22:16 2015 +0300
@@ -118,7 +118,7 @@
     
     my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file));
     
-    $this->baseSchemas->Append( $schema );
+    $this->baseSchemas->Push( $schema );
 }
 
 sub LoadSchema {
--- a/Lib/IMPL/Object/List.pm	Mon Aug 31 10:23:42 2015 +0300
+++ b/Lib/IMPL/Object/List.pm	Mon Aug 31 20:22:16 2015 +0300
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 
-use Carp qw(confess);
+use Carp qw(carp);
 use parent qw(IMPL::Object::ArrayObject);
 require IMPL::Exception;
 
@@ -20,7 +20,7 @@
 }
 
 sub Append {
-	confess "Appen method is obsolete use Push instead";
+	carp "Appen method is obsolete use Push instead";
     push @{$_[0]}, @_[1 .. $#_];
 }
 
@@ -29,7 +29,7 @@
 }
 
 sub AddLast {
-	confess "Appen method is obsolete use Push instead";
+	carp "Appen method is obsolete use Push instead";
     push @{$_[0]}, @_[1 .. $#_];
 }
 
--- a/_test/temp.pl	Mon Aug 31 10:23:42 2015 +0300
+++ b/_test/temp.pl	Mon Aug 31 20:22:16 2015 +0300
@@ -1,11 +1,37 @@
 #!/usr/bin/perl
 use strict;
 
-my $p = 'sometype';
-my $c = 'My::App::aSomeType';
+use YAML::XS;
+$YAML::XS::DumpCode = 1;
 
-my $suffix = substr($c, -length($p));
-my $prefix = substr($c, 0, -length($p));
-print join ("\n",$suffix,$prefix,$p,$c), "\n";
+my $conf = {
+	'@include' => [qw(security view)],
+	runtime => {
+		type => 'IMPL::Web::Application',
+		params => {
+			handlers => {depdendency => 'filters'}
+		} 
+	},
+	filters => [
+		{ type => 'IMPL::Web::CookieAuth' },
+		{ type => 'IMPL::Web::Security' },
+		{ type => 'IMPL::Web::LocaleHandler',
+			params => {
+				locales => [
+					'en-US',
+					'ru-RU'
+				],
+				default => 'en-US'
+			}
+		},
+		{ type => 'IMPL::Web::ContentNegotiation' },
+		{ type => 'IMPL::Web::RestController' }
+	],
+	custom => {
+		factory => sub { return "hi!" }
+	}
+};
 
-print $prefix && not(substr($prefix,-2) eq '::') ? 'corrupted' : 'class' ;
\ No newline at end of file
+print Dump($conf);
+
+1;
\ No newline at end of file