Mercurial > pub > Impl

comparison lib/IMPL/Config/Bag.pm @ 414:ec6f2d389d1e ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
working on IMPL::Config::Bag
author cin
date Fri, 02 Oct 2015 06:56:24 +0300
parents af8d359ee4cc
children 3d24b10dd0d5
comparison
equal deleted inserted replaced
413:af8d359ee4cc 414:ec6f2d389d1e
1 package IMPL::Config::Bag; 1 package IMPL::Config::Bag;
2 use strict; 2 use strict;
3 3
4 use IMPL::lang qw(:base);
4 use IMPL::declare { 5 use IMPL::declare {
5 base => [ 6 base => [
6 'IMPL::Object' => undef 7 'IMPL::Object' => undef
7 ], 8 ],
8 props => [ 9 props => [
9 parent => '*r', 10 _parents => '*rw', # array of parent bags
10 _cache => '*rw', 11 _state => '*rw', #array of previous timestamps
11 _entries => '*rw' 12 _cache => '*rw', # own or cached entries
13 _timestamp => '*rw',
14 _entries => '*rw', # each entry is represented by hash
15 # { isa => linear_isa_hash, owner => owner_of_the_entry, value => value }
12 ] 16 ]
13 }; 17 };
14 18
15 sub CTOR { 19 sub CTOR {
16 my ($this, $p) = @_; 20 my ( $this, $p ) = @_;
17 21
18 $this->{$parent} = $p; 22 if ($p) {
19 $this->{$_cache} = {}; 23 my @parents;
20 $this->{$_entries} = []; 24 push @parents, @{ $p->{$_parents} } if $p->{$_parents};
25 push @parents, $p;
26 $this->{$_parents} = \@parents;
27 $this->{$_state} = [ map $_->{$_timestamp}, @parents ];
28 }
29
30 $this->{$_timestamp} = 0;
31 $this->{$_cache} = {};
32 $this->{$_entries} = [];
33 }
34
35 sub GetParent {
36 $_[0]->{$_parents} && $_[0]->{$_parents}[0];
37 }
38
39 sub _Validate {
40 my ($this) = @_;
41
42 my $parents = $this->{$_parents}
43 or return;
44 my $state = $this->{$_state};
45 my $len = @$parents;
46 my $flush;
47
48 for ( my $i = 0 ; $i < $len ; $i++ ) {
49 if ($flush) {
50 $parents->[$i]{$_cache} = {};
51 $state->[$i] = $parents->[$i]{$_timestamp};
52 }
53 else {
54 $flush = ( $parents->[$i]{$_timestamp} != $state->[$i] );
55 }
56 }
57
58 if ($flush) {
59 $this->{$_cache} = {};
60 return 0;
61 }
62
63 return 1;
21 } 64 }
22 65
23 sub Resolve { 66 sub Resolve {
24 my ($this,$role) = @_; 67 my ( $this, $role ) = @_;
25 68
26 my $d = $this->GetDescriptor(); 69 if ( my $d = $this->GetDescriptor() ) {
70 return $d->{value};
71 }
72 else {
73 return;
74 }
27 } 75 }
28 76
29 sub GetDescriptor { 77 sub GetDescriptor {
30 my ($this, $role) = @_; 78 my ( $this, $role ) = @_;
31 79
32 my $d = $this->{$_cache}{$role}; 80 my $d = $this->{$_cache}{$role};
33 return $d if $d and $d->{valid}; 81
34 82 # return descriptor if this is own descriptor and its level is 1 (i.e. it can't be overriden by the parent cache)
35 my @entries = @{$this->{$_entries}}; 83 # otherwise the cache must be validated
36 84 return $d
37 if(my $t = $this->{$parent} && $this->{$parent}->GetDescriptor($role)) { 85 if $d
38 push @entries, $t; 86 and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 )
87 or $this->_Validate() );
88
89 # the cache chain is valid
90 # $d is not a valid descriptor
91
92 $d = undef;
93 my $prev;
94
95 if ( my $parents = $this->{$_parents} ) {
96 foreach my $bag ( @$parents, $this ) {
97
98 # check the cache;
99 unless ( my $t = $bag->{$_cache}{$role} ) {
100
101 # no cached entry this may be due cache flush
102 # go through own entries and find better entry than inherited from parents
103 foreach my $entry ( @{ $bag->{$_entries} } ) {
104 my $level = $entry->{isa}{$role};
105 if ( $level and ( not($prev) or $level <= $prev ) ) {
106 $d = $entry;
107 $prev = $level;
108 }
109 }
110
111 #cache it
112 $bag->{$_cache}{$role} = $d if $d;
113 }
114 else {
115 $d = $t;
116 $prev = $d->{isa}{$role};
117 }
118 }
39 } 119 }
40 120
41 my $level; 121 return $d;
42 foreach my $entry (@entries) {
43 my $t = $entry->{isa}{$role};
44 next unless defined $t;
45 if (defined($level) && $level > $t) {
46 $d = $entry;
47 $level = $t;
48 }
49 }
50
51 if ($d and $d->{valid}) {
52 $this->{$_cache}{$role} = $d;
53 return $d;
54 } else {
55 return;
56 }
57 } 122 }
58 123
59 sub ResolveAll { 124 sub ResolveAll {
60 my ($this, $role) = @_; 125 my ( $this, $role ) = @_;
61 126
62 my $result = $this->{$parent} ? $this->{$parent}->ResolveAll() : []; 127 return [
63 128 map $_->{value},
64 push @$result, map $_->{value}, grep $_->{isa}{$role}, @{$this->{$_entries}}; 129 grep $_->{isa}{$role},
65 130 map $_->{$_entries},
66 return $result; 131 @{ $this->{$_parents} || [] },
132 $this
133 ];
134
67 } 135 }
68 136
69 sub Register { 137 sub Register {
70 my ($this, $role, $isa, $value) = @_; 138 my ( $this, $isa, $value ) = @_;
71 }
72 139
73 sub _UpdateDescriptor { 140 $isa = { $isa, 1 } unless isHash($isa);
74
75 }
76 141
77 package IMPL::Config::Bag::Entry; 142 push @{ $this->{$_entries} },
78 use IMPL::Exception(); 143 { owner => $this, isa => $isa, value => $value };
79 use IMPL::declare { 144 $this->{$_timestamp}++;
80 base => [
81 'IMPL::Object::Fields' => undef
82 ]
83 };
84 145
85 my @fields = qw(owner type isa valid value index); 146 delete $this->{$_cache}{$_} foreach keys %$isa;
86 use fields @fields;
87 147
88 sub CTOR { 148 return $this;
89 my SELF $this = shift;
90 my $args = shift;
91
92 $this->{valid} = 1;
93 $this->{owner} = $args->{owner} or die IMPL::InvalidArgumentException->new("owner");
94 $this->{value} = $args->{value} if exists $args->{value};
95 $this->{isa} = $args->{isa} if $args->{isa};
96 }
97
98 sub Invalidate {
99 my SELF $this = shift;
100
101 $this->{owner}->_UpdateDescriptor($this);
102 } 149 }
103 150
104 1; 151 1;