changeset 414:ec6f2d389d1e ref20150831

working on IMPL::Config::Bag
author cin
date Fri, 02 Oct 2015 06:56:24 +0300
parents af8d359ee4cc
children 3d24b10dd0d5
files _test/temp.pl lib/IMPL/Config/Bag.pm lib/IMPL/Config/Container.pm lib/IMPL/Config/Hierarchy.pm
diffstat 4 files changed, 127 insertions(+), 117 deletions(-) [+]
line wrap: on
line diff
--- a/_test/temp.pl	Thu Sep 24 12:19:30 2015 +0300
+++ b/_test/temp.pl	Fri Oct 02 06:56:24 2015 +0300
@@ -3,46 +3,9 @@
 use Carp;
 use Time::HiRes qw(gettimeofday tv_interval);
 use Scalar::Util qw(blessed);
-my $slot;
-my $ref = bless \$slot, 'Wrapper';
-sub is {
-	my $slot = shift;
-	bless \$slot, 'Wrapper';
-}
-
-sub instanceOf {
-	carp "A typename can't be undefined" unless $_[1];
-	blessed($_[0]) and $_[0]->isa($_[1])
-}
-
-my $bar = Bar->new();
-
-my $t = [gettimeofday];
-
-for(my $i =0; $i< 1000000; $i++) {
-    is($bar)->instanceOf('Bar');
-}
 
-print "Is: ",tv_interval($t,[gettimeofday]),"\n";
-
-$t = [gettimeofday];
-
-for(my $i =0; $i< 1000000; $i++) {
-    instanceOf($bar, 'Bar');
-}
-
-print "Is: ",tv_interval($t,[gettimeofday]),"\n";
-
+my $data = [1,2,3];
 
-package Wrapper;
-use Scalar::Util qw(blessed);
-sub instanceOf {
-	blessed(${$_[0]}) and ${$_[0]}->isa($_[1]);
-}
-
-package Bar;
-use IMPL::declare {
-	base => ['IMPL::Object' => undef]
-};
+print foreach @$data, 4;
 
 1;
--- a/lib/IMPL/Config/Bag.pm	Thu Sep 24 12:19:30 2015 +0300
+++ b/lib/IMPL/Config/Bag.pm	Fri Oct 02 06:56:24 2015 +0300
@@ -1,104 +1,151 @@
 package IMPL::Config::Bag;
 use strict;
 
+use IMPL::lang qw(:base);
 use IMPL::declare {
 	base => [
 		'IMPL::Object' => undef
 	],
 	props => [
-	   parent => '*r',
-	   _cache => '*rw',
-	   _entries => '*rw'
+		_parents   => '*rw',    # array of parent bags
+		_state     => '*rw',    #array of previous timestamps
+		_cache     => '*rw',    # own or cached entries
+		_timestamp => '*rw',
+		_entries   => '*rw',    # each entry is represented by hash
+		  # { isa => linear_isa_hash, owner => owner_of_the_entry, value => value }
 	]
 };
 
 sub CTOR {
-	my ($this, $p) = @_;
-	
-	$this->{$parent} = $p;
-	$this->{$_cache} = {};
-	$this->{$_entries} = [];
+	my ( $this, $p ) = @_;
+
+	if ($p) {
+		my @parents;
+		push @parents, @{ $p->{$_parents} } if $p->{$_parents};
+		push @parents, $p;
+		$this->{$_parents} = \@parents;
+		$this->{$_state} = [ map $_->{$_timestamp}, @parents ];
+	}
+
+	$this->{$_timestamp} = 0;
+	$this->{$_cache}     = {};
+	$this->{$_entries}   = [];
+}
+
+sub GetParent {
+	$_[0]->{$_parents} && $_[0]->{$_parents}[0];
+}
+
+sub _Validate {
+	my ($this) = @_;
+
+	my $parents = $this->{$_parents}
+	  or return;
+	my $state = $this->{$_state};
+	my $len   = @$parents;
+	my $flush;
+
+	for ( my $i = 0 ; $i < $len ; $i++ ) {
+		if ($flush) {
+			$parents->[$i]{$_cache} = {};
+			$state->[$i] = $parents->[$i]{$_timestamp};
+		}
+		else {
+			$flush = ( $parents->[$i]{$_timestamp} != $state->[$i] );
+		}
+	}
+
+	if ($flush) {
+		$this->{$_cache} = {};
+		return 0;
+	}
+
+	return 1;
 }
 
 sub Resolve {
-	my ($this,$role) = @_;
-	
-	my $d = $this->GetDescriptor();
+	my ( $this, $role ) = @_;
+
+	if ( my $d = $this->GetDescriptor() ) {
+		return $d->{value};
+	}
+	else {
+		return;
+	}
 }
 
 sub GetDescriptor {
-	my ($this, $role) = @_;
-	
+	my ( $this, $role ) = @_;
+
 	my $d = $this->{$_cache}{$role};
-	return $d if $d and $d->{valid};
-	
-	my @entries = @{$this->{$_entries}};
-	
-	if(my $t = $this->{$parent} && $this->{$parent}->GetDescriptor($role)) {
-		push @entries, $t;
+
+# return descriptor if this is own descriptor and its level is 1 (i.e. it can't be overriden by the parent cache)
+# otherwise the cache must be validated
+	return $d
+	  if $d
+	  and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 )
+		or $this->_Validate() );
+
+	# the cache chain is valid
+	# $d is not a valid descriptor
+
+	$d = undef;
+	my $prev;
+
+	if ( my $parents = $this->{$_parents} ) {
+		foreach my $bag ( @$parents, $this ) {
+
+			# check the cache;
+			unless ( my $t = $bag->{$_cache}{$role} ) {
+
+	  # no cached entry this may be due cache flush
+	  # go through own entries and find better entry than inherited from parents
+				foreach my $entry ( @{ $bag->{$_entries} } ) {
+					my $level = $entry->{isa}{$role};
+					if ( $level and ( not($prev) or $level <= $prev ) ) {
+						$d    = $entry;
+						$prev = $level;
+					}
+				}
+
+				#cache it
+				$bag->{$_cache}{$role} = $d if $d;
+			}
+			else {
+				$d    = $t;
+				$prev = $d->{isa}{$role};
+			}
+		}
 	}
-	
-	my $level;
-	foreach my $entry (@entries) {
-		my $t = $entry->{isa}{$role};
-		next unless defined $t;
-		if (defined($level) && $level > $t) {
-			$d = $entry;
-			$level = $t;
-		}  
-	}
-	
-	if ($d and $d->{valid}) {
-		$this->{$_cache}{$role} = $d;
-		return $d;
-	} else {
-		return;
-	} 
+
+	return $d;
 }
 
 sub ResolveAll {
-	my ($this, $role) = @_;
-	
-	my $result = $this->{$parent} ? $this->{$parent}->ResolveAll() : [];
-	
-	push @$result, map $_->{value}, grep $_->{isa}{$role}, @{$this->{$_entries}};
-	
-	return $result;
+	my ( $this, $role ) = @_;
+
+	return [
+		map $_->{value},
+		grep $_->{isa}{$role},
+		map $_->{$_entries},
+		@{ $this->{$_parents} || [] },
+		$this
+	];
+
 }
 
 sub Register {
-	my ($this, $role, $isa, $value) = @_;
-}
+	my ( $this, $isa, $value ) = @_;
+
+	$isa = { $isa, 1 } unless isHash($isa);
 
-sub _UpdateDescriptor {
-	
+	push @{ $this->{$_entries} },
+	  { owner => $this, isa => $isa, value => $value };
+	$this->{$_timestamp}++;
+
+	delete $this->{$_cache}{$_} foreach keys %$isa;
+
+	return $this;
 }
 
-package IMPL::Config::Bag::Entry;
-use IMPL::Exception();
-use IMPL::declare {
-    base => [
-       'IMPL::Object::Fields' => undef
-    ]
-};
-
-my @fields = qw(owner type isa valid value index); 
-use fields @fields;
-
-sub CTOR {
-    my SELF $this = shift;
-    my $args = shift;
-    
-    $this->{valid} = 1;
-    $this->{owner} = $args->{owner} or die IMPL::InvalidArgumentException->new("owner");
-    $this->{value} = $args->{value} if exists $args->{value};
-    $this->{isa} = $args->{isa} if $args->{isa};
-}
-
-sub Invalidate {
-    my SELF $this = shift;
-    
-    $this->{owner}->_UpdateDescriptor($this);
-}
-
-1;
\ No newline at end of file
+1;
--- a/lib/IMPL/Config/Container.pm	Thu Sep 24 12:19:30 2015 +0300
+++ b/lib/IMPL/Config/Container.pm	Fri Oct 02 06:56:24 2015 +0300
@@ -58,7 +58,7 @@
 	$service = ValueDescriptor->new( value => $service )
 	  unless is( $service, Descriptor );
 
-	$this->services->Register( $role, $this->roles->GetLinearRoleHash($role), $service );
+	$this->services->Register( $this->roles->GetLinearRoleHash($role), $service );
 }
 
 sub Resolve {
--- a/lib/IMPL/Config/Hierarchy.pm	Thu Sep 24 12:19:30 2015 +0300
+++ b/lib/IMPL/Config/Hierarchy.pm	Fri Oct 02 06:56:24 2015 +0300
@@ -50,9 +50,9 @@
 	my $cache = $this->{$_cache}{$role};
 
 	unless ($cache) {
-		$cache = { $role, 0 };
+		$cache = { $role, 1 };
 
-		my @roles = [$role, 0];
+		my @roles = [$role, 1];
 		
 		while (my $r = shift @roles ) {
 			my ($name, $level) = @$r;