pub/Impl: lib/IMPL/Config/Bag.pm annotate

annotate lib/IMPL/Config/Bag.pm @ 425:c27434cdd611 ref20150831

sync

author	cin
date	Tue, 03 Apr 2018 19:30:01 +0300
parents	b0481c071bea
children

rev	line source
412 30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	1 package IMPL::Config::Bag;
30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	2 use strict;
30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	3
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	4 use IMPL::lang qw(:base);
412 30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	5 use IMPL::declare {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	6 base => [
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	7 'IMPL::Object' => undef
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	8 ],
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	9 props => [
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	10 _parents => '*rw', # array of parent bags
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	11 _parentRev => '*rw', # the timestamp of the parent
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	12 _sealed => '*rw', # the bag has descendants
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	13 _cache => '*rw', # own or cached entries
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	14 _timestamp => '*rw',
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	15 _entries => '*rw', # each entry is represented by hash
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	16 # { isa => linear_isa_hash, owner => owner_of_the_entry, value => value }
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	17 tag => 'rw' # used to store additional information
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	18 ]
412 30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	19 };
30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	20
413 af8d359ee4cc working on di container cin parents: 412 diff changeset	21 sub CTOR {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	22 my ( $this, $p ) = @_;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	23
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	24 if ($p) {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	25 $p->_Seal();
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	26 my @parents;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	27 push @parents, @{ $p->{$_parents} } if $p->{$_parents};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	28 push @parents, $p;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	29 $this->{$_parents} = \@parents;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	30 $this->{$_parentRev} = $p->{$_timestamp};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	31 }
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	32
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	33 $this->{$_timestamp} = 0;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	34 $this->{$_cache} = {};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	35 $this->{$_entries} = [];
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	36 }
ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	37
ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	38 sub GetParent {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	39 my ($this) = @_;
415 3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	40
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	41 $this->{$_parents} && $this->{$_parents}[ @{ $this->{$_parents} } - 1 ];
415 3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	42 }
3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	43
3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	44 sub _Seal {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	45 unless ( $_[0]->{$_sealed} ) {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	46 $_[0]->{$_sealed} = 1;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	47 $_[0]->{$_timestamp} = 0; # from now the timestamp is important
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	48 }
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	49 }
ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	50
ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	51 sub _Validate {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	52 my ($this) = @_;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	53
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	54 my $chain = $this->{$_parents}
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	55 or return 1;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	56
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	57 my $rev = 0; # rev 0 means that parent was never modified
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	58 # this allows to made more efficient checks
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	59 my $flush;
417 3ed0c58e9da3 working on di container, tests cin parents: 415 diff changeset	60
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	61 foreach my $bag ( @$chain, $this ) {
417 3ed0c58e9da3 working on di container, tests cin parents: 415 diff changeset	62
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	63 # we need to updated all bags after the first change was detected;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	64 if ( $flush \|\|= $rev and $bag->{$_parentRev} != $rev ) {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	65 $bag->{$_cache} = {};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	66 $bag->{$_parentRev} = $rev;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	67 }
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	68 $rev = $bag->{$_timestamp};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	69 }
417 3ed0c58e9da3 working on di container, tests cin parents: 415 diff changeset	70
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	71 return $flush ? 0 : 1;
413 af8d359ee4cc working on di container cin parents: 412 diff changeset	72 }
af8d359ee4cc working on di container cin parents: 412 diff changeset	73
412 30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	74 sub Resolve {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	75 my ( $this, $role ) = @_;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	76
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	77 die IMPL::InvalidArgumentException->new('role')
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	78 unless defined $role;
415 3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	79
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	80 if ( my $d = $this->_GetDescriptor($role) ) {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	81 return wantarray ? @{$d}{'value', 'owner'} : $d->{value};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	82 }
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	83 else {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	84 return;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	85 }
413 af8d359ee4cc working on di container cin parents: 412 diff changeset	86 }
af8d359ee4cc working on di container cin parents: 412 diff changeset	87
415 3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	88 sub _GetDescriptor {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	89 my ( $this, $role ) = @_;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	90
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	91 my $d = $this->{$_cache}{$role};
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	92
ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	93 # return descriptor if this is own descriptor and its level is 1 (i.e. it can't be overriden by the parent cache)
ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	94 # otherwise the cache must be validated
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	95 return $d
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	96 if $d
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	97 and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 )
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	98 or $this->_Validate() );
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	99
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	100 # if there were no descriptor in cache we need to ensure that the cache
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	101 # chain is valid before reolving starts
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	102 $this->_Validate() unless $d;
415 3d24b10dd0d5 working on IMPL::Config::Container cin parents: 414 diff changeset	103
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	104 # the cache chain is valid
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	105 # $d is not a valid descriptor
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	106
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	107 $d = undef;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	108 my $prev;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	109
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	110 my $parents = $this->{$_parents};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	111 my @bags = $parents ? ( @$parents, $this ) : ($this);
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	112
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	113 foreach my $bag (@bags) {
417 3ed0c58e9da3 working on di container, tests cin parents: 415 diff changeset	114
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	115 # check the cache;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	116 unless ( my $t = $bag->{$_cache}{$role} ) {
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	117
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	118 # no cached entry this may be due cache flush
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	119 # go through own entries and find better entry than inherited from parents
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	120 foreach my $entry ( @{ $bag->{$_entries} } ) {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	121 my $level = $entry->{isa}{$role};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	122 if ( $level and ( not($prev) or $level <= $prev ) ) {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	123 $d = $entry;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	124 $prev = $level;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	125 }
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	126 }
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	127
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	128 #cache it
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	129 $bag->{$_cache}{$role} = $d if $d;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	130 }
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	131 else {
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	132 $d = $t;
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	133 $prev = $d->{isa}{$role};
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	134 }
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	135 }
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	136
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	137 return $d;
413 af8d359ee4cc working on di container cin parents: 412 diff changeset	138 }
af8d359ee4cc working on di container cin parents: 412 diff changeset	139
af8d359ee4cc working on di container cin parents: 412 diff changeset	140 sub ResolveAll {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	141 my ( $this, $role ) = @_;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	142
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	143 return [
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	144 map $_->{value},
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	145 grep $_->{isa}{$role},
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	146 map @{ $_->{$_entries} },
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	147 @{ $this->{$_parents} \|\| [] },
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	148 $this
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	149 ];
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	150
413 af8d359ee4cc working on di container cin parents: 412 diff changeset	151 }
af8d359ee4cc working on di container cin parents: 412 diff changeset	152
af8d359ee4cc working on di container cin parents: 412 diff changeset	153 sub Register {
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	154 my ( $this, $isa, $value ) = @_;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	155
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	156 $isa = { $isa, 1 } unless ishash($isa);
413 af8d359ee4cc working on di container cin parents: 412 diff changeset	157
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	158 push @{ $this->{$_entries} },
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	159 { owner => $this, isa => $isa, value => $value };
b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	160 $this->{$_timestamp}++;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	161
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	162 delete $this->{$_cache}{$_} foreach keys %$isa;
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	163
422 b0481c071bea IMPL::Config::Container tests, YAMLConfiguration now works and tested cin parents: 417 diff changeset	164 return $this;
412 30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	165 }
30e8c6a74937 working on di container (role based registrations) cin parents: diff changeset	166
414 ec6f2d389d1e working on IMPL::Config::Bag cin parents: 413 diff changeset	167 1;

Mercurial > pub > Impl

annotate lib/IMPL/Config/Bag.pm @ 425:c27434cdd611 ref20150831