# HG changeset patch # User cin # Date 1443758184 -10800 # Node ID ec6f2d389d1e6c8b0e29a56d7b9f09a523407164 # Parent af8d359ee4ccdac3fce8917361c7926a34a7db27 working on IMPL::Config::Bag diff -r af8d359ee4cc -r ec6f2d389d1e _test/temp.pl --- 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; diff -r af8d359ee4cc -r ec6f2d389d1e lib/IMPL/Config/Bag.pm --- 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; diff -r af8d359ee4cc -r ec6f2d389d1e lib/IMPL/Config/Container.pm --- 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 { diff -r af8d359ee4cc -r ec6f2d389d1e lib/IMPL/Config/Hierarchy.pm --- 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;