# HG changeset patch
# User cin
# Date 1445315575 -10800
# Node ID 3d24b10dd0d5a35782badcd8de9c65694722119f
# Parent  ec6f2d389d1e6c8b0e29a56d7b9f09a523407164
working on IMPL::Config::Container

diff -r ec6f2d389d1e -r 3d24b10dd0d5 _test/temp.pl
--- a/_test/temp.pl	Fri Oct 02 06:56:24 2015 +0300
+++ b/_test/temp.pl	Tue Oct 20 07:32:55 2015 +0300
@@ -2,10 +2,12 @@
 use strict;
 use Carp;
 use Time::HiRes qw(gettimeofday tv_interval);
-use Scalar::Util qw(blessed);
-
-my $data = [1,2,3];
+use Scalar::Util qw(blessed refaddr);
+use YAML::XS qw(Dump);
 
-print foreach @$data, 4;
-
+print Dump {
+	services => [
+	   { role => 'db', type => 'My::Data::Context', params => { '-ref' => 'some-role' } }
+	]
+};
 1;
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/ActivationContext.pm
--- a/lib/IMPL/Config/ActivationContext.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/ActivationContext.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -10,40 +10,49 @@
 		'IMPL::Object' => '@_'
 	},
 	props => {
+		container => PROP_RW,
 		_services => PROP_RW,
-		_cache => PROP_RW,
-		_stack => PROP_RW
+		_cache    => PROP_RW,
+		_stack    => PROP_RW
 	}
 };
 
-sub GetService {
-	my ($this,$serviceId) = @_;
-	
-	$this->_services->
+sub CTOR {
+	my ( $this, $container ) = @_;
+
+	$this->container($container)
+	  or die IMPL::InvalidArgumentException('container');
 }
 
 sub EnterScope {
-	my ($this, $name, $localize) = @_;
-	
+	my ( $this, $name, $services ) = @_;
+
 	my $info = { name => $name };
-	
-	if ($localize) {
+
+	if ($services) {
 		$info->{services} = $this->_services;
-		
-		$this->_services(PropertyBag->new($this->_services));
+
+		$this->_services( $services );
 	}
-	
+
 	$this->_stack->Push($info);
 }
 
 sub LeaveScope {
 	my ($this) = @_;
-	
+
 	my $info = $this->_stack->Pop()
-		or die IMPL::InvalidOperationException();
-	
-	if ($info->{services})	
-		$this->_services($info->{services});
+	  or die IMPL::InvalidOperationException();
+
+	if ( $info->{services} ) $this->_services( $info->{services} );
+}
+
+sub Resolve {
+	my ($this, $role, %opts) = @_;
+}
+
+sub Clone {
+	my ($this) = @_;
 }
 
 1;
@@ -65,4 +74,4 @@
 
 =head3 GetService($serviceId)
 
-=cut
\ No newline at end of file
+=cut
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/Bag.pm
--- a/lib/IMPL/Config/Bag.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/Bag.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -8,7 +8,8 @@
 	],
 	props => [
 		_parents   => '*rw',    # array of parent bags
-		_state     => '*rw',    #array of previous timestamps
+		_parentRev => '*rw',    # the timestamp of the parent
+		_sealed    => '*rw',    # the bag has descendants
 		_cache     => '*rw',    # own or cached entries
 		_timestamp => '*rw',
 		_entries   => '*rw',    # each entry is represented by hash
@@ -20,11 +21,12 @@
 	my ( $this, $p ) = @_;
 
 	if ($p) {
+		$p->_Seal();
 		my @parents;
 		push @parents, @{ $p->{$_parents} } if $p->{$_parents};
 		push @parents, $p;
-		$this->{$_parents} = \@parents;
-		$this->{$_state} = [ map $_->{$_timestamp}, @parents ];
+		$this->{$_parents}   = \@parents;
+		$this->{$_parentRev} = $p->{$_timestamp};
 	}
 
 	$this->{$_timestamp} = 0;
@@ -33,40 +35,47 @@
 }
 
 sub GetParent {
-	$_[0]->{$_parents} && $_[0]->{$_parents}[0];
+	my ($this) = @_;
+
+	$this->{$_parents} && $this->{$_parents}[ @{ $this->{$_parents} } - 1 ];
+}
+
+sub _Seal {
+	unless ($_[0]->{$_sealed}) {
+		$_[0]->{$_sealed} = 1;
+		$_[0]->{$_timestamp} = 0; # from now the timestamp is important
+	}
 }
 
 sub _Validate {
 	my ($this) = @_;
 
-	my $parents = $this->{$_parents}
-	  or return;
-	my $state = $this->{$_state};
-	my $len   = @$parents;
-	my $flush;
+	my $chain = $this->{$_parents}
+	  or return 1;
 
-	for ( my $i = 0 ; $i < $len ; $i++ ) {
-		if ($flush) {
-			$parents->[$i]{$_cache} = {};
-			$state->[$i] = $parents->[$i]{$_timestamp};
-		}
-		else {
-			$flush = ( $parents->[$i]{$_timestamp} != $state->[$i] );
-		}
+	my $rev = 0; # rev 0 means that parent was never modified
+	            # this allows to made more efficient checks
+	my $flush;
+	
+	foreach my $bag (@$chain, $this) {
+		# we need to updated all bags after the first change was detected;
+        if ($flush ||= $rev and $bag->{$_parentRev} != $rev) {
+            $bag->{$_cache} = {};
+            $bag->{$_parentRev} = $rev;
+        }
+        $rev = $bag->{$_timestamp};
 	}
-
-	if ($flush) {
-		$this->{$_cache} = {};
-		return 0;
-	}
-
-	return 1;
+	
+	return $flush ? 0 : 1;
 }
 
 sub Resolve {
 	my ( $this, $role ) = @_;
 
-	if ( my $d = $this->GetDescriptor() ) {
+	die IMPL::InvalidArgumentException->new('role')
+	  unless defined $role;
+
+	if ( my $d = $this->_GetDescriptor($role) ) {
 		return $d->{value};
 	}
 	else {
@@ -74,7 +83,7 @@
 	}
 }
 
-sub GetDescriptor {
+sub _GetDescriptor {
 	my ( $this, $role ) = @_;
 
 	my $d = $this->{$_cache}{$role};
@@ -86,6 +95,10 @@
 	  and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 )
 		or $this->_Validate() );
 
+	# if there were no descriptor in cache we need to ensure that the cache
+	# chain is valid before reolving starts
+	$this->_Validate() unless $d;
+
 	# the cache chain is valid
 	# $d is not a valid descriptor
 
@@ -127,7 +140,7 @@
 	return [
 		map $_->{value},
 		grep $_->{isa}{$role},
-		map $_->{$_entries},
+		map @{$_->{$_entries}},
 		@{ $this->{$_parents} || [] },
 		$this
 	];
@@ -137,7 +150,7 @@
 sub Register {
 	my ( $this, $isa, $value ) = @_;
 
-	$isa = { $isa, 1 } unless isHash($isa);
+	$isa = { $isa, 1 } unless ishash($isa);
 
 	push @{ $this->{$_entries} },
 	  { owner => $this, isa => $isa, value => $value };
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/Container.pm
--- a/lib/IMPL/Config/Container.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/Container.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -9,7 +9,8 @@
 		ValueDescriptor   => 'IMPL::Config::ValueDescriptor',
 		ActivationContext => 'IMPL::Config::ActivationContext',
 		Hierarchy         => 'IMPL::Config::Hierarchy',
-		Bag               => 'IMPL::Config::Bag'
+		Bag               => 'IMPL::Config::Bag',
+		Loader            => 'IMPL::Code::Loader'
 	},
 	base => [
 		'IMPL::Object' => undef
@@ -18,36 +19,48 @@
 		roles     => 'r',
 		services  => 'r',
 		instances => 'r',
-		parent    => 'r'
+		parent    => 'r',
+		root      => 'r',
+		loader    => 'r'
 	]
 };
 
 my $nextRoleId = 1;
 
 sub CTOR {
-	my ( $this, $parent ) = @_;
+	my ( $this, $parent, %opts ) = @_;
 
 	$this->instances( {} );
 
+	$this->loader( $opts{loader} || Loader->safe );
+
 	if ($parent) {
 		$this->roles( Hierarchy->new( $parent->roles ) );
 		$this->services( Bag->new( $parent->services ) );
 		$this->parent($parent);
+		$this->root( $parent->root );
 	}
 	else {
 		$this->roles( Hierarchy->new() );
 		$this->services( Bag->new() );
+		$this->root($this);
 	}
 }
 
 sub Register {
 	my ( $this, $role, $service ) = @_;
 
+	die IMPL::InvalidArgumentException->new('service')
+	  unless is( $service, Descriptor );
+	$this->services->Register( $this->GetLinearRoleHash($role), $service );
+}
+
+sub GetLinearRoleHash {
+	my ( $this, $role ) = @_;
+
 	die IMPL::InvalidArgumentException->new(
 		role => 'The argument is required' )
 	  unless $role;
-	die IMPL::InvalidArgumentException->new('service')
-	  unless is( $service, Descriptor );
 
 	if ( isarray($role) ) {
 		my $tempRole = "unnamed-" . $nextRoleId++;
@@ -55,10 +68,7 @@
 		$role = $tempRole;
 	}
 
-	$service = ValueDescriptor->new( value => $service )
-	  unless is( $service, Descriptor );
-
-	$this->services->Register( $this->roles->GetLinearRoleHash($role), $service );
+	$this->roles->GetLinearRoleHash($role);
 }
 
 sub Resolve {
@@ -105,21 +115,10 @@
 
 =head2 METHODS
 
-=head3 GetService($serviceId)
-
-=over
-
-=item * $serviceId
+=head3 Resolve($role)
 
-A string indetifier of the service, it can be in two forms: class name or service name,
-for the class name it should be prefixed with C<@>, for example: C<@Foo::Bar>.
-
-=back
+=head3 ResolveAll($role, shared => $useSharedContext)
 
-The activation container maintains two maps, one for classes and the other for names.
-The first one is useful when we searching for an implementation the second one when
-we need a particular service. 
-
-=head3 RegisterService($descriptor)
+=head3 Register($role, $service)
 
 =cut
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/Descriptor.pm
--- a/lib/IMPL/Config/Descriptor.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/Descriptor.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -1,12 +1,46 @@
 package IMPL::Config::Descriptor;
 use strict;
 use IMPL::Exception();
+use Scalar::Util qw(looks_like_number);
+
+sub ACTIVATE_SINGLETON() { 1 }
+sub ACTIVATE_CONTAINER() { 2 }
+sub ACTIVATE_CONTEXT()   { 3 }
+sub ACTIVATE_CALL()      { 4 }
+
+my %activateNames = (
+	singleton => ACTIVATE_SINGLETON,
+	container => ACTIVATE_CONTAINER,
+	context   => ACTIVATE_CONTEXT,
+	call      => ACTIVATE_CALL
+);
+
+my %activateNamesLookup = map { $activateNames{$_}, $_ } keys %activateNames;
 
 sub Activate {
-	my ($this, $context) = @_;
+	my ( $this, $context ) = @_;
 	die IMPL::NotImplementedException->new();
 }
 
+sub ParseActivation {
+	my $val = pop @_;
+
+	return ACTIVATE_CALL unless $val;
+
+	return grep $_ == $val,
+	  ACTIVATE_SINGLETON,
+	  ACTIVATE_CONTAINER,
+	  ACTIVATE_CONTEXT, ACTIVATE_CALL ? $val : ACTIVATE_CALL
+	  if looks_like_number($val);
+
+	return $activateNames{ lc($val) } || ACTIVATE_CALL;
+}
+
+sub ActivationToString {
+	my $val = pop @_;
+
+	return ( $val && $activateNamesLookup{$val} ) || '';
+}
 
 1;
 
@@ -54,4 +88,4 @@
 
 =back
 
-=cut
\ No newline at end of file
+=cut
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/Hierarchy.pm
--- a/lib/IMPL/Config/Hierarchy.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/Hierarchy.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -8,10 +8,10 @@
 	base => {
 		'IMPL::Object' => undef
 	},
-	props => {
+	props => [
 		roles  => '*rw',
 		_cache => '*rw'
-	}
+	]
 };
 
 sub CTOR {
@@ -21,10 +21,13 @@
 		$this->roles( clone( $roles->roles ) );
 	}
 	elsif ( ishash($roles) ) {
-		$this->roles($roles);
+		$this->roles({});
+		while(my ($n, $p) = each %$roles) {
+			$this->AddRole($n,$p);
+		}
 	}
 	elsif ( isarray($roles) ) {
-		$this->roles( { map { $_, 1 } @$roles } );
+		$this->roles( { map { $_, undef } @$roles } );
 	}
 	else {
 		$this->roles( {} );
@@ -52,7 +55,7 @@
 	unless ($cache) {
 		$cache = { $role, 1 };
 
-		my @roles = [$role, 1];
+		my @roles = ([$role, 1]);
 		
 		while (my $r = shift @roles ) {
 			my ($name, $level) = @$r;
@@ -60,8 +63,8 @@
 			$cache->{$name} = $level;
 			if(my $parents = $this->{$roles}{$name}) {
 				foreach my $p (@$parents) {
-					next if $cache{$p};
-					push @roles, [$p, $cache{$p} = $level + 1]; 
+					next if $cache->{$p};
+					push @roles, [$p, $cache->{$p} = $level + 1]; 
 				}
 			}
 		}
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/ReferenceDescriptor.pm
--- a/lib/IMPL/Config/ReferenceDescriptor.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/ReferenceDescriptor.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -0,0 +1,52 @@
+package IMPL::Config::ReferenceDescriptor;
+use strict;
+
+use IMPL::Exception();
+use IMPL::declare {
+	base => [
+		'IMPL::Object'             => undef,
+		'IMPL::Config::Descriptor' => undef
+	],
+	props => [
+		reference => 'ro',
+		services  => 'ro',
+		lazy      => 'ro',
+		optional  => 'ro',
+		default   => 'ro',
+		_name     => 'rw'
+	]
+};
+
+sub CTOR {
+	my ( $this, $ref, %opts ) = @_;
+
+	$this->reference($ref)
+	  or die IMPL::InvalidArgumentException->new('ref');
+
+	$this->_name( 'ref ' . $ref );
+}
+
+sub Activate {
+	my ( $this, $context ) = @_;
+
+	$this->EnterScope( $this->_name, $this->services );
+
+	my $ref = $this->reference;
+	my %opts;
+	$opts{default} = $this->default
+	  if $this->optional;
+
+	if ( $this->lazy ) {
+		my $clone = $context->Clone();
+		return sub {
+			$clone->Resolve( $ref, %opts );
+		};
+	}
+	else {
+		return $context->Resolve( $ref, %opts );
+	}
+
+	$this->LeaveScope();
+}
+
+1;
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/ServiceDescriptor.pm
--- a/lib/IMPL/Config/ServiceDescriptor.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/ServiceDescriptor.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -0,0 +1,95 @@
+package IMPL::Config::ServiceDescriptor;
+use strict;
+
+use IMPL::lang qw(:base);
+use IMPL::Exception();
+use IMPL::declare {
+	require => {
+		Bag => 'IMPL::Config::Bag'
+	},
+	base => [
+		'IMPL::Object'             => undef,
+		'IMPL::Config::Descriptor' => undef
+	],
+	props => [
+		type       => 'ro',
+		activation => 'ro',
+		args       => 'ro',
+		services   => 'ro',
+		_name      => 'rw',
+		_loaded    => 'rw'
+	]
+};
+
+sub CTOR {
+	my ( $this, %opts ) = @_;
+
+	$this->type( $opts{type} )
+	  or die IMPL::InvalidArgumentException->new('type');
+
+	$this->activation(
+		IMPL::Config::Descriptor::ParseActivation( $opts{activation} ) );
+	$this->args( $opts{args} )         if exists $opts{args};
+	$this->services( $opts{services} ) if exists $opts{services};
+
+	$this->_name( 'new {'
+		  . IMPL::Config::Descriptor::ActivationToString( $this->activation )
+		  . '} '
+		  . $this->type );
+}
+
+sub Activate {
+	my ( $this, $context ) = @_;
+
+	$context->EnterScope( $this->_name, $this->services );
+
+	my $activation = $this->activation;
+	my $cache;
+
+	if ( $activation == IMPL::Config::Descriptor::ACTIVATE_SINGLETON ) {
+		$cache = $context->container->root->instances;
+	}
+	elsif ( $activation == IMPL::Config::Descriptor::ACTIVATE_CONTAINER ) {
+		$cache = $context->container->instances;
+	}
+	elsif ( $activation == IMPL::Config::Descriptor::ACTIVATE_CONTEXT ) {
+		$cache = $context->instances;
+	}
+
+	my $instance = $cache->{ ref($this) } if $cache;
+
+	unless ($instance) {
+		$instance = $this->CreateInstance($context);
+	}
+
+	$cache->{ ref($this) } = $instance if $cache;
+
+	$context->LeaveScope();
+
+	return $instance;
+}
+
+sub CreateInstance {
+	my ( $this, $context ) = @_;
+
+	my $class = $context > container->Require( $this->type );
+
+	my $args = $this->args ? $this->args->Activate($context) : undef;
+
+	if ( defined $args ) {
+		if ( isarray($args) ) {
+			return $class->new(@$args);
+		}
+		elsif ( ishash($args) ) {
+			return $class->new(%$args);
+		}
+		else {
+			return $class->new($args);
+		}
+	}
+	else {
+		return $class->new();
+	}
+}
+
+1;
diff -r ec6f2d389d1e -r 3d24b10dd0d5 lib/IMPL/Config/ValueDescriptor.pm
--- a/lib/IMPL/Config/ValueDescriptor.pm	Fri Oct 02 06:56:24 2015 +0300
+++ b/lib/IMPL/Config/ValueDescriptor.pm	Tue Oct 20 07:32:55 2015 +0300
@@ -0,0 +1,54 @@
+package IMPL::Config::ValueDescriptor;
+use strict;
+
+use IMPL::lang qw(:base);
+use IMPL::declare {
+	require => {
+		Descriptor => 'IMPL::Config::Descriptor'
+	},
+	base => [
+		'IMPL::Object' => undef,
+		'Descriptor'   => undef
+	],
+	props => [
+		value => 'rw',
+		raw   => 'rw'
+	]
+};
+
+sub CTOR {
+	my ( $this, $value, $raw ) = @_;
+
+	$this->value($value);
+	$this->raw($raw);
+}
+
+sub Activate {
+	my ( $this, $context ) = @_;
+
+	return $this->raw
+	  ? $this->value
+	  : $this->_ActivateValue( $this->value, $context );
+}
+
+sub _ActivateValue {
+	my ( $this, $value, $context ) = @_;
+
+	if ( is( $value, Descriptor ) ) {
+		return $value->Activate($context);
+	}
+	elsif ( isarray($value) ) {
+		return [ map $this->_ActivateValue($_), @$value ];
+	}
+	elsif ( ishash($value) ) {
+		return {
+			map { $_, $this->_ActivateValue( $value->{$_} ) }
+			  keys %$value
+		};
+	}
+	else {
+		return $value;
+	}
+}
+
+1;