Mercurial > pub > Impl

comparison lib/IMPL/Config/ServicesBag.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children ee36115f6a34
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
1 package IMPL::Config::ServicesBag;
2
3 require v5.9.5;
4
5 use mro;
6
7 use IMPL::Const qw(:prop);
8 use IMPL::declare {
9 base => [
10 'IMPL::Object' => undef
11 ],
12 props => [
13 _prototype => PROP_RW,
14 _nameMap => PROP_RW,
15 _typeMap => PROP_RW,
16 _props => PROP_RW,
17 ]
18 };
19
20 sub CTOR {
21 my ( $this, $prototype ) = @_;
22
23 $this->_prototype($prototype) if $prototype;
24 $this->_nameMap( {} );
25 $this->_typeMap( {} );
26 }
27
28 sub GetDescriptorByName {
29 my ( $this, $name ) = @_;
30
31 my $d = $this->_nameMap->{$name};
32 return $d if $d and $d->{valid};
33
34 my $parent = $this->_prototype;
35
36 if ( $parent and $d = $parent->GetDescriptorByName($name) ) {
37 return $this->_nameMap->{$name} = $d;
38 }
39
40 return undef;
41 }
42
43 sub GetDescriptorByType {
44 my ( $this, $type ) = @_;
45
46 my $d = $this->_typeMap->{$type};
47 return $d if $d and $d->{valid};
48
49 my $parent = $this->_prototype;
50 if ( $parent and $d = $parent->GetDescriptorByType($type) ) {
51 return $this->_typeMap->{$type} = $d;
52 }
53
54 return undef;
55 }
56
57 sub RegisterValue {
58 my ( $this, $value, $name, $type ) = @_;
59
60 my $d = { owner => $this, value => $value, valid => 1 };
61
62 if ($type) {
63 my $map = $this->_typeMap;
64 my $isa = mro::get_linear_isa($type);
65 $d->{isa} = $isa;
66
67 # the service record which is superseded by the current one
68 my $replaces = $this->GetDescriptorByType($type);
69
70 foreach my $t (@$isa) {
71 if ( my $prev = $this->GetDescriptorByType($t) ) {
72
73 # keep previous registrations if they are valid
74 next if not $replaces or $prev != $replaces;
75 }
76
77 $map->{$t} = $d;
78 }
79
80 if ($replaces) {
81
82 # invalidate cache
83 $replaces->{owner}->UpdateDescriptor($replaces);
84 }
85 }
86
87 if ($name) {
88 my $prev = $this->_nameMap->{$name};
89 $d->{name} = $name;
90 $this->_nameMap->{$name} = $d;
91 $prev->{owner}->UpdateDescriptor($prev) if $prev;
92 }
93
94 return $d;
95 }
96
97 sub UpdateDescriptor {
98 my ( $this, $d ) = @_;
99
100 my $d2 = {};
101
102 # copy descriptor
103 while ( my ( $k, $v ) = each %$d ) {
104 $d2->{$k} = $v;
105 }
106
107 # update named entries
108 my $name = $d->{name};
109 if ( $name and $this->_nameMap->{$name} == $d ) {
110 $this->_nameMap->{$name} = $d2;
111 }
112
113 # update type entries
114 if ( my $isa = $d->{isa} ) {
115 my $map = $this->_typeMap;
116 foreach my $t (@$isa) {
117 next unless $map->{$t} == $d;
118 $map->{$t} = $d2;
119 }
120 }
121
122 $d->{valid} = 0;
123 }
124
125 1;
126
127 __END__
128
129 =pod
130
131 =head1 NAME
132
133 =head1 SYNOPSIS
134
135 =head1 DESCRIPTION
136
137 Коллекция сервисов построена на прототиптровании экземпляров, т.е. при создании
138 новой коллекции может указваться базовая коллекция в которой будет происходить
139 поиск сервисов в случае их отсутсвия в основной. Для оптимизации данного процесса
140 сервисы кешируются, чтобы избежать можестрвенных операций поиска по иерархии
141 коллекций, для этого каждый сервис описывается дескриптором:
142
143 =over
144
145 =item * isa массив типов сервиса, если он регистрировался как сервис
146
147 =item * value значение
148
149 =item * valid признак того, что дескриптор действителен
150
151 =item * owner коллекция, которая создала данный дескриптор
152
153 =back
154
155 Если запрашиваемый десриптор не найден это является ошибкой, поэтому негативные
156 ответы не кешируются
157
158 =cut