# HG changeset patch # User cin # Date 1441041736 -10800 # Node ID f23fcb19d3c1b2684289a42539580b2a84e2998d # Parent cd6c6e61d442319e775e4dff39172c4e0af420b9 implemented ServicesBag diff -r cd6c6e61d442 -r f23fcb19d3c1 Lib/IMPL/Config/ServicesBag.pm --- a/Lib/IMPL/Config/ServicesBag.pm Mon Aug 31 10:23:42 2015 +0300 +++ b/Lib/IMPL/Config/ServicesBag.pm Mon Aug 31 20:22:16 2015 +0300 @@ -1,47 +1,126 @@ package IMPL::Config::ServicesBag; +require v5.9.5; + +use mro; + use IMPL::Const qw(:prop); use IMPL::declare { - base => { + base => [ 'IMPL::Object' => undef - }, - props => { + ], + props => [ _prototype => PROP_RW, - _nameMap => PROP_RW, - _typeMap => PROP_RW, - _props => PROP_RW, - } + _nameMap => PROP_RW, + _typeMap => PROP_RW, + _props => PROP_RW, + ] }; +sub CTOR { + my ( $this, $prototype ) = @_; + + $this->_prototype($prototype) if $prototype; + $this->_nameMap( {} ); + $this->_typeMap( {} ); +} + sub GetDescriptorByName { - my ($this, $name) = @_; - - my $d = $this->_namedMap->{$name}; - if ($d && $d->{valid}) - return $d; - + my ( $this, $name ) = @_; + + my $d = $this->_nameMap->{$name}; + return $d if $d and $d->{valid}; + my $parent = $this->_prototype; - if ($parent && $d = $parent->GetDescriptorByName($name)) - return $this->_namedMap->{$name} = $d; - + + if ( $parent and $d = $parent->GetDescriptorByName($name) ) { + return $this->_nameMap->{$name} = $d; + } + return undef; } sub GetDescriptorByType { - my ($this, $type) = @_; - - my $d = $this->_typeMap->{$name}; - if ($d && $d->{valid}) - return $d; - + my ( $this, $type ) = @_; + + my $d = $this->_typeMap->{$type}; + return $d if $d and $d->{valid}; + my $parent = $this->_prototype; - if ($parent && $d = $parent->GetDescriptorByType($name)) - return $this->_typeMap->{$name} = $d; - - return undef; + if ( $parent and $d = $parent->GetDescriptorByType($type) ) { + return $this->_typeMap->{$type} = $d; + } + + return undef; } -sub Register +sub RegisterValue { + my ( $this, $value, $name, $type ) = @_; + + my $d = { owner => $this, value => $value, valid => 1 }; + + if ($type) { + my $map = $this->_typeMap; + my $isa = mro::get_linear_isa($type); + $d->{isa} = $isa; + + # the service record which is superseded by the current one + my $replaces = $this->GetDescriptorByType($type); + + foreach my $t (@$isa) { + if ( my $prev = $this->GetDescriptorByType($t) ) { + + # keep previous registrations if they are valid + next if not $replaces or $prev != $replaces; + } + + $map->{$t} = $d; + } + + if ($replaces) { + + # invalidate cache + $replaces->{owner}->UpdateDescriptor($replaces); + } + } + + if ($name) { + my $prev = $this->_nameMap->{$name}; + $d->{name} = $name; + $this->_nameMap->{$name} = $d; + $prev->{owner}->UpdateDescriptor($prev) if $prev; + } + + return $d; +} + +sub UpdateDescriptor { + my ( $this, $d ) = @_; + + my $d2 = {}; + + # copy descriptor + while ( my ( $k, $v ) = each %$d ) { + $d2->{$k} = $v; + } + + # update named entries + my $name = $d->{name}; + if ( $name and $this->_nameMap->{$name} == $d ) { + $this->_nameMap->{$name} = $d2; + } + + # update type entries + if ( my $isa = $d->{isa} ) { + my $map = $this->_typeMap; + foreach my $t (@$isa) { + next unless $map->{$t} == $d; + $map->{$t} = $d2; + } + } + + $d->{valid} = 0; +} 1; @@ -63,17 +142,17 @@ =over -=item * name название под которым сервис зарегистрирован +=item * isa массив типов сервиса, если он регистрировался как сервис -=item * type тип сервиса - -=item * service фабрика сервиса +=item * value значение =item * valid признак того, что дескриптор действителен +=item * owner коллекция, которая создала данный дескриптор + =back Если запрашиваемый десриптор не найден это является ошибкой, поэтому негативные ответы не кешируются -=cut \ No newline at end of file +=cut diff -r cd6c6e61d442 -r f23fcb19d3c1 Lib/IMPL/DOM/Node.pm --- a/Lib/IMPL/DOM/Node.pm Mon Aug 31 10:23:42 2015 +0300 +++ b/Lib/IMPL/DOM/Node.pm Mon Aug 31 20:22:16 2015 +0300 @@ -75,7 +75,7 @@ $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); my $children = $this->childNodes; - $children->Append($node); + $children->Push($node); $node->_setParent( $this ); @@ -96,7 +96,7 @@ $node->_setParent( $this ); } - $this->childNodes->Append(@range); + $this->childNodes->Push(@range); return $this; } diff -r cd6c6e61d442 -r f23fcb19d3c1 Lib/IMPL/DOM/Schema.pm --- a/Lib/IMPL/DOM/Schema.pm Mon Aug 31 10:23:42 2015 +0300 +++ b/Lib/IMPL/DOM/Schema.pm Mon Aug 31 20:22:16 2015 +0300 @@ -118,7 +118,7 @@ my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file)); - $this->baseSchemas->Append( $schema ); + $this->baseSchemas->Push( $schema ); } sub LoadSchema { diff -r cd6c6e61d442 -r f23fcb19d3c1 Lib/IMPL/Object/List.pm --- a/Lib/IMPL/Object/List.pm Mon Aug 31 10:23:42 2015 +0300 +++ b/Lib/IMPL/Object/List.pm Mon Aug 31 20:22:16 2015 +0300 @@ -2,7 +2,7 @@ use strict; use warnings; -use Carp qw(confess); +use Carp qw(carp); use parent qw(IMPL::Object::ArrayObject); require IMPL::Exception; @@ -20,7 +20,7 @@ } sub Append { - confess "Appen method is obsolete use Push instead"; + carp "Appen method is obsolete use Push instead"; push @{$_[0]}, @_[1 .. $#_]; } @@ -29,7 +29,7 @@ } sub AddLast { - confess "Appen method is obsolete use Push instead"; + carp "Appen method is obsolete use Push instead"; push @{$_[0]}, @_[1 .. $#_]; } diff -r cd6c6e61d442 -r f23fcb19d3c1 _test/temp.pl --- a/_test/temp.pl Mon Aug 31 10:23:42 2015 +0300 +++ b/_test/temp.pl Mon Aug 31 20:22:16 2015 +0300 @@ -1,11 +1,37 @@ #!/usr/bin/perl use strict; -my $p = 'sometype'; -my $c = 'My::App::aSomeType'; +use YAML::XS; +$YAML::XS::DumpCode = 1; -my $suffix = substr($c, -length($p)); -my $prefix = substr($c, 0, -length($p)); -print join ("\n",$suffix,$prefix,$p,$c), "\n"; +my $conf = { + '@include' => [qw(security view)], + runtime => { + type => 'IMPL::Web::Application', + params => { + handlers => {depdendency => 'filters'} + } + }, + filters => [ + { type => 'IMPL::Web::CookieAuth' }, + { type => 'IMPL::Web::Security' }, + { type => 'IMPL::Web::LocaleHandler', + params => { + locales => [ + 'en-US', + 'ru-RU' + ], + default => 'en-US' + } + }, + { type => 'IMPL::Web::ContentNegotiation' }, + { type => 'IMPL::Web::RestController' } + ], + custom => { + factory => sub { return "hi!" } + } +}; -print $prefix && not(substr($prefix,-2) eq '::') ? 'corrupted' : 'class' ; \ No newline at end of file +print Dump($conf); + +1; \ No newline at end of file