Mercurial > pub > Impl
changeset 422:b0481c071bea ref20150831
IMPL::Config::Container tests, YAMLConfiguration now works and tested
author | cin |
---|---|
date | Sun, 20 Aug 2017 00:20:41 +0300 |
parents | 7798345304bc |
children | 60c2892a577c |
files | _test/Resources/container1.yaml _test/Resources/inc/base1.yaml _test/Test/Config/Container.pm _test/config.t _test/defaults.yaml _test/sample.yaml _test/secrets.yaml _test/temp.pl _test/test_transform.pl lib/IMPL/AppException.pm lib/IMPL/Config/ActivationContext.pm lib/IMPL/Config/Bag.pm lib/IMPL/Config/Container.pm lib/IMPL/Config/Descriptor.pm lib/IMPL/Config/ReferenceDescriptor.pm lib/IMPL/Config/ServiceDescriptor.pm lib/IMPL/Config/ServicesBag.pm lib/IMPL/Config/ValueDescriptor.pm lib/IMPL/Config/YAMLConfig.pm lib/IMPL/Debug.pm lib/IMPL/declare.pm lib/IMPL/require.pm |
diffstat | 20 files changed, 699 insertions(+), 629 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Resources/container1.yaml Sun Aug 20 00:20:41 2017 +0300 @@ -0,0 +1,25 @@ +include: +- inc/base1.yaml +services: +- name: + - foo + - jiz + $type: Test::Config::Foo + params: simple Foo + activation: container +- name: bar + $type: Test::Config::Bar + params: + $value: simple Bar + activation: context +- name: baz + $type: Test::Config::Foo + params: + $value: + - $ref: foo + - $ref: foo +- name: zoo + $type: Test::Config::Foo + params: + - $ref: jiz + - $ref: foo \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Resources/inc/base1.yaml Sun Aug 20 00:20:41 2017 +0300 @@ -0,0 +1,6 @@ +include: +- ../container1.yaml +services: +- name: base + $type: Test::Config::Foo + params: base \ No newline at end of file
--- a/_test/Test/Config/Container.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/_test/Test/Config/Container.pm Sun Aug 20 00:20:41 2017 +0300 @@ -1,17 +1,21 @@ package Test::Config::Container; use strict; +sub true() { 1 } +sub false() { 0 } + { + package Test::Config::Container::Baz; use IMPL::declare { base => { 'IMPL::Object' => undef }, props => [ - value => 'r' + value => 'r' ] }; - + sub CTOR { my $this = shift; $this->value(shift); @@ -19,35 +23,138 @@ } use IMPL::declare { - require => { - Container => 'IMPL::Config::Container', - - }, - base => { - 'IMPL::Test::Unit' => '@_' - } + require => { + Container => 'IMPL::Config::Container', + Service => 'IMPL::Config::ServiceDescriptor', + Value => 'IMPL::Config::ValueDescriptor', + Reference => 'IMPL::Config::ReferenceDescriptor', + YAMLConfig => 'IMPL::Config::YAMLConfig' + }, + base => { + 'IMPL::Test::Unit' => '@_' + } }; +use File::Spec(); use IMPL::Test qw(test assert failed); +use IMPL::lang qw(:base); test CreateContainer => sub { - my $c1 = Container->new(); -}; - -test RegisterServices => sub { - my $c1 = Container->new(); - - $c1->Register( 'db' => Service->new( - type => 'Foo::Data', - norequire => 1, - activation => 'container' - )); - - return $c1; -}; - -test ResolveServices => sub { - + my $c1 = Container->new(); + $c1->Dispose(); }; -1; \ No newline at end of file + +sub RegisterServices { + my $c1 = Container->new(); + + my %config = ( + 'db' => Service->new( + type => 'Foo::Data', + norequire => 1, + activation => 'container' + ), + foo => Service->new( + type => 'Test::Config::Foo', + activation => 'container' + ), + bar => Service->new( + type => 'Test::Config::Bar', + activation => 'context' + ), + boogie => Value->new( + { + foo => Reference->new('foo'), + bar => Reference->new('bar'), + lazyb => Reference->new( 'bar', lazy => 1 ), + opt => Reference->new( + 'no-such-ref', + optional => 1, + default => 'def-opt' + ) + } + ) + ); + + while(my ($name, $d) = each %config) { + $c1->Register($name, $d); + } + + return $c1->AutoPtr(); +}; + +test RegisterServices => \&RegisterServices; + +test ResolveServices => sub { + my $this = shift; + my $c = $this->RegisterServices(); + + my $foo = $c->Resolve('foo'); + assert(is($foo, "Test::Config::Foo"), "foo is: $foo"); + + my $foo2 = $c->Resolve('foo'); + assert($foo == $foo2); + + my $bar = $c->Resolve('bar'); + assert(is($bar, "Test::Config::Bar")); + + my $bar2 = $c->Resolve('bar'); + + assert($bar != $bar2); + + my $boogie = $c->Resolve('boogie'); + assert(ishash($boogie)); + assert(is($boogie->{foo}, "Test::Config::Foo")); + + $bar = $boogie->{bar}; + my $lazyb = $boogie->{lazyb}; + assert(ref $lazyb eq 'CODE'); + $bar2 = $lazyb->(); + my $bar3 = $lazyb->(); + + #test context activation with lazy + assert($bar == $bar2); + assert($bar == $bar3); + + my $bar4 = $c->Resolve('bar'); + #new context, new bar + assert($bar != $bar4); + + my $opt = $boogie->{opt}; + assert($opt eq 'def-opt'); +}; + +sub LoadYamlConfig { + my $config = YAMLConfig->new(); + $config->Load(File::Spec->catfile('Resources', 'container1.yaml')); + my $container = Container->new(); + $config->ConfigureContainer($container); + return $container->AutoPtr(); +} + +test LoadYamlConfig => \&LoadYamlConfig; +test ResolveYamlConfig => sub { + my $this = shift; + + my $c = $this->LoadYamlConfig(); + + my $foo = $c->Resolve('foo'); + assert(is($foo, "Test::Config::Foo"), "foo is: $foo"); + + my $foo2 = $c->Resolve('foo'); + assert($foo == $foo2); + + my $bar = $c->Resolve('bar'); + assert(is($bar, "Test::Config::Bar")); + + my $bar2 = $c->Resolve('bar'); + + assert($bar != $bar2); + + my $baz = $c->Resolve('baz'); + assert(is($baz, "Test::Config::Foo")); + assert(isarray($baz->value)); + assert($baz->value->[0] == $baz->value->[1]); +}; + +1;
--- a/_test/config.t Sun Jul 16 22:59:39 2017 +0300 +++ b/_test/config.t Sun Aug 20 00:20:41 2017 +0300 @@ -3,8 +3,18 @@ use lib '../Lib'; use lib '.'; +use IMPL::Debug(); use IMPL::Test qw(run_plan); +$IMPL::Debug::ENABLE{'IMPL::Config::YAMLConfig'} = 1; + +IMPL::Debug->subscribe(sub { + my $text = join('', @_); + + $text =~ s/^/# /gm; + print "$text\n"; +}); + run_plan( qw( Test::Config::Container ) );
--- a/_test/sample.yaml Sun Jul 16 22:59:39 2017 +0300 +++ b/_test/sample.yaml Sun Aug 20 00:20:41 2017 +0300 @@ -13,8 +13,6 @@ - name: security-provider $type: My::SecureCookies params: - users: - $ref: users-provider - roles: - $ref: roles-provider + users: { $ref: users-provider } + roles: { $ref: roles-provider } persistent: 0 \ No newline at end of file
--- a/_test/temp.pl Sun Jul 16 22:59:39 2017 +0300 +++ b/_test/temp.pl Sun Aug 20 00:20:41 2017 +0300 @@ -4,30 +4,34 @@ use Time::HiRes qw(gettimeofday tv_interval); use Scalar::Util qw(blessed refaddr); use YAML::XS qw(Dump Load); - +use Data::Dumper; +use URI; use IMPL::require { Container => 'IMPL::Config::Container', Service => 'IMPL::Config::ServiceDescriptor', Reference => 'IMPL::Config::ReferenceDescriptor', - Value => 'IMPL::Config::ValueDescriptor' + Value => 'IMPL::Config::ValueDescriptor', + YAMLConfig => 'IMPL::Config::YAMLConfig' }; -my $data; -{ - open my $h, "<", "sample.yaml" or die; - print "H: ", *{$h}{IO}, "\n"; - binmode $h; - local $/; - $data = <$h>; -} my $t = [gettimeofday]; +my $config = YAMLConfig->new(load => 'sample.yaml'); +print "Loaded: ",tv_interval($t,[gettimeofday]),"\n"; -print Dump Load($data); +my $container = Container->new()->AutoPtr; +$config->ConfigureContainer($container); -print "Activated: ",tv_interval($t,[gettimeofday]),"\n"; +print "Configured: ",tv_interval($t,[gettimeofday]),"\n"; +#print Data::Dumper->Dump([$container]); +#$container->Dispose(); + +my $base = URI->new('some/path'); +my $rel = URI->new('../other/path')->abs($base)->rel('/'); +print $rel,"\n"; + 1;
--- a/_test/test_transform.pl Sun Jul 16 22:59:39 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,131 +0,0 @@ -use strict; -package Person; -use IMPL::lang qw(:declare); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ] -}; - -BEGIN { - public property name => PROP_ALL; - public property age => PROP_ALL; - public property addresses => PROP_ALL | PROP_LIST; -} - -package Address; -use IMPL::lang qw(:declare); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ] -}; - -BEGIN { - public property country => PROP_ALL; - public property city => PROP_ALL; -} - -package main; - -my $data = { - name => 'Peter', - age => '99', - addresses => { - address => [ - { - country => 'Airot', - city => 'Torhiq', - street => 'avenu1' - }, - { - country => 'Olkson', - city => 'Zoxs', - street => 'av2' - } - ] - } -}; - -use Carp qw(confess); - -sub Rule(&) { - my ($block) = @_; - - return sub { - local $_ = shift; - $block->(); - } -} - -sub Inspect($$) { - my ($path,$block) = @_; - my $data = $_; - - foreach my $name (@$path) { - $data = ref $data ? $data->{$name} : undef; - print "$name = $data\n"; - } - - local $_ = $data; - $block->($data); -} - -sub Required(@); - -sub Required(@) { - if(@_) { - Inspect([@_],Rule { Required }); - } else { - confess "required" unless $_; - } -} - -sub Regexp($) { - my $rx = shift; - die "Regular expression doesn't match" unless m/$rx/; -} - -my $validate = Rule { - Required('name'); - - Inspect ['age'] => Rule { - Regexp(qr/^\d+$/); - die "invalid person age" unless $_ > 0 && $_ < 200; - }; - - Inspect ['addresses', 'address'] => Rule { - Required; - foreach(@{$_}) { - Required('street'); - } - } -}; - -$validate->($data); - -my ($person) = - map { - Person->new( - name => $_->{name}, - age => $_->{age}, - addresses => [ - map { - Address->new( - country => $_->{country}, - city => $_->{city} - ) - } as_list( $_->{addresses}{address} ) - ] - ) - } $data; - -use Data::Dumper; -print Dumper($person); - -sub as_list { - return @{ $_[0] } if ref $_[0] eq 'ARRAY'; - return @_; -}
--- a/lib/IMPL/AppException.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/AppException.pm Sun Aug 20 00:20:41 2017 +0300 @@ -31,7 +31,7 @@ $instance->source(shortmess); $instance->callStack(longmess); - + return $instance; } @@ -44,7 +44,7 @@ sub throw { my $self = shift; - die $self->new(@_); + die ref $self ? $self : $self->new(@_); } 1;
--- a/lib/IMPL/Config/ActivationContext.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/ActivationContext.pm Sun Aug 20 00:20:41 2017 +0300 @@ -1,21 +1,23 @@ package IMPL::Config::ActivationContext; use IMPL::lang qw(:base); -use IMPL::Const qw(:prop); use IMPL::Exception(); use IMPL::declare { require => { - Bag => 'IMPL::Config::ServicesBag', + Bag => 'IMPL::Config::Bag', ServiceNotFoundException => 'IMPL::Config::ServiceNotFoundException', + Descriptor => '-IMPL::Config::Descriptor' }, base => { 'IMPL::Object' => '@_' }, props => [ - container => PROP_RW, - instances => PROP_RW, - _services => PROP_RW, - _stack => PROP_RW + container => 'rw', + owner => 'rw', + instances => 'rw', + name => 'rw', + _services => 'rw', + _stack => 'rw' ] }; @@ -24,15 +26,23 @@ $this->container($container) or die IMPL::InvalidArgumentException->new('container'); + $this->owner($container); $this->_services( $container->services ); $this->instances( {} ); $this->_stack( [] ); } sub EnterScope { - my ( $this, $name, $services ) = @_; + my ( $this, $name, $services, $container ) = @_; + + my $info = { name => $this->name }; - my $info = { name => $name }; + $this->name($name); + + if ( $container && $this->container != $container ) { + $info->{container} = $this->container; + $this->container($container); + } if ($services) { die IMPL::InvalidArgumentException->new( @@ -42,12 +52,11 @@ my $bag = $this->container->serviceCache->{ ref($services) }; unless ($bag) { - my $container = $this->container; $bag = Bag->new( $this->_services ); + $bag->tag( $container || $this->container ); - # - $bag->Register( - $container->GetLinearRoleHash( $_->{role}, $_->{descriptor} ) ) + $bag->Register( $container->GetLinearRoleHash( $_->{role} ), + $_->{descriptor} ) foreach @$services; $container->serviceCache->{ ref($services) } = $bag; @@ -66,30 +75,45 @@ my $info = pop @{ $this->_stack } or die IMPL::InvalidOperationException->new(); - $this->_services( $info->{services} ) if $info->{services}; + $this->name( $info->{name} ); + $this->_services( $info->{services} ) if $info->{services}; + $this->conatiner( $info->{container} ) if $info->{container}; } sub Resolve { my ( $this, $role, %opts ) = @_; - my $d = $this->_services->Resolve($role); + #change of the container may occur only due resolution of the dependency + my ( $d, $bag ) = $this->_services->Resolve($role); unless ($d) { - die ServiceNotFoundException->new($role) unless $opts{optional}; + die ServiceNotFoundException->new(serviceName => $role) unless $opts{optional}; return $opts{default}; } else { - return $d->Activate($this); + $this->EnterScope( $d->GetName(), $d->services(), $bag->tag() ); + my $instance = $d->Activate($this); + $this->LeaveScope(); + return $instance; } } +sub Activate { + my ( $this, $d ) = @_; + $this->EnterScope( $d->GetName(), $d->services() ); + my $instance = $d->Activate($this); + $this->LeaveScope(); + return $instance; +} + sub Clone { my ($this) = @_; - my $clone = SELF->new( $this->container ); - + my $clone = SELF->new( $this->owner ); + $clone->name($this->name); + $clone->container( $this->container ); $clone->_services( $this->_services ); - $clone->instances( { %{ $this->instances } } ); + $clone->instances( $this->instances ); $clone->_stack( [ @{ $this->_stack } ] ); return $clone; @@ -110,8 +134,33 @@ =head1 MEMBERS +=head2 PROPERTIES + +=head3 [get] container + +Current container for the activation context, this container changes +during resolution process to match the one in which the resulting +descriptor were defined. Descriptors can use this property to +access the cache of theirs container. + +=head3 [get] owner + +The container which created this context. Descriptors can use this +property during theirs activation. + +=head3 [get] instances + +The activation cache which can be used to store instances during +single resolution process. + =head2 METHODS -=head3 Resolve($serviceId) +=head3 Resolve($serviceId): $instance + +Activates and returns an instance specified by C<$serviceId> + +=head3 Activate($descriptor): $instance + +Activates and returns an instance of the services for the specified descriptor/ =cut
--- a/lib/IMPL/Config/Bag.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/Bag.pm Sun Aug 20 00:20:41 2017 +0300 @@ -3,164 +3,165 @@ use IMPL::lang qw(:base); use IMPL::declare { - base => [ - 'IMPL::Object' => undef - ], - props => [ - _parents => '*rw', # array of parent bags - _parentRev => '*rw', # the timestamp of the parent - _sealed => '*rw', # the bag has descendants - _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 } - ] + base => [ + 'IMPL::Object' => undef + ], + props => [ + _parents => '*rw', # array of parent bags + _parentRev => '*rw', # the timestamp of the parent + _sealed => '*rw', # the bag has descendants + _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 } + tag => 'rw' # used to store additional information + ] }; sub CTOR { - my ( $this, $p ) = @_; + my ( $this, $p ) = @_; - if ($p) { - $p->_Seal(); - my @parents; - push @parents, @{ $p->{$_parents} } if $p->{$_parents}; - push @parents, $p; - $this->{$_parents} = \@parents; - $this->{$_parentRev} = $p->{$_timestamp}; - } + if ($p) { + $p->_Seal(); + my @parents; + push @parents, @{ $p->{$_parents} } if $p->{$_parents}; + push @parents, $p; + $this->{$_parents} = \@parents; + $this->{$_parentRev} = $p->{$_timestamp}; + } - $this->{$_timestamp} = 0; - $this->{$_cache} = {}; - $this->{$_entries} = []; + $this->{$_timestamp} = 0; + $this->{$_cache} = {}; + $this->{$_entries} = []; } sub GetParent { - my ($this) = @_; + my ($this) = @_; - $this->{$_parents} && $this->{$_parents}[ @{ $this->{$_parents} } - 1 ]; + $this->{$_parents} && $this->{$_parents}[ @{ $this->{$_parents} } - 1 ]; } sub _Seal { - unless ( $_[0]->{$_sealed} ) { - $_[0]->{$_sealed} = 1; - $_[0]->{$_timestamp} = 0; # from now the timestamp is important - } + unless ( $_[0]->{$_sealed} ) { + $_[0]->{$_sealed} = 1; + $_[0]->{$_timestamp} = 0; # from now the timestamp is important + } } sub _Validate { - my ($this) = @_; + my ($this) = @_; - my $chain = $this->{$_parents} - or return 1; + my $chain = $this->{$_parents} + or return 1; - my $rev = 0; # rev 0 means that parent was never modified - # this allows to made more efficient checks - my $flush; + my $rev = 0; # rev 0 means that parent was never modified + # this allows to made more efficient checks + my $flush; - foreach my $bag ( @$chain, $this ) { + foreach my $bag ( @$chain, $this ) { - # we need to updated all bags after the first change was detected; - if ( $flush ||= $rev and $bag->{$_parentRev} != $rev ) { - $bag->{$_cache} = {}; - $bag->{$_parentRev} = $rev; - } - $rev = $bag->{$_timestamp}; - } + # we need to updated all bags after the first change was detected; + if ( $flush ||= $rev and $bag->{$_parentRev} != $rev ) { + $bag->{$_cache} = {}; + $bag->{$_parentRev} = $rev; + } + $rev = $bag->{$_timestamp}; + } - return $flush ? 0 : 1; + return $flush ? 0 : 1; } sub Resolve { - my ( $this, $role ) = @_; + my ( $this, $role ) = @_; - die IMPL::InvalidArgumentException->new('role') - unless defined $role; + die IMPL::InvalidArgumentException->new('role') + unless defined $role; - if ( my $d = $this->_GetDescriptor($role) ) { - return $d->{value}; - } - else { - return; - } + if ( my $d = $this->_GetDescriptor($role) ) { + return wantarray ? @{$d}{'value', 'owner'} : $d->{value}; + } + else { + return; + } } sub _GetDescriptor { - my ( $this, $role ) = @_; + my ( $this, $role ) = @_; - my $d = $this->{$_cache}{$role}; + my $d = $this->{$_cache}{$role}; # 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() ); + return $d + if $d + and ( ( $d->{owner} == $this and $d->{isa}{$role} == 1 ) + or $this->_Validate() ); - # if there were no descriptor in cache we need to ensure that the cache - # chain is valid before reolving starts - $this->_Validate() unless $d; + # if there were no descriptor in cache we need to ensure that the cache + # chain is valid before reolving starts + $this->_Validate() unless $d; - # the cache chain is valid - # $d is not a valid descriptor + # the cache chain is valid + # $d is not a valid descriptor - $d = undef; - my $prev; + $d = undef; + my $prev; - my $parents = $this->{$_parents}; - my @bags = $parents ? ( @$parents, $this ) : ($this); + my $parents = $this->{$_parents}; + my @bags = $parents ? ( @$parents, $this ) : ($this); - foreach my $bag (@bags) { + foreach my $bag (@bags) { - # check the cache; - unless ( my $t = $bag->{$_cache}{$role} ) { + # 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; - } - } + # 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}; - } - } + #cache it + $bag->{$_cache}{$role} = $d if $d; + } + else { + $d = $t; + $prev = $d->{isa}{$role}; + } + } - return $d; + return $d; } sub ResolveAll { - my ( $this, $role ) = @_; + my ( $this, $role ) = @_; - return [ - map $_->{value}, - grep $_->{isa}{$role}, - map @{ $_->{$_entries} }, - @{ $this->{$_parents} || [] }, - $this - ]; + return [ + map $_->{value}, + grep $_->{isa}{$role}, + map @{ $_->{$_entries} }, + @{ $this->{$_parents} || [] }, + $this + ]; } sub Register { - my ( $this, $isa, $value ) = @_; + my ( $this, $isa, $value ) = @_; - $isa = { $isa, 1 } unless ishash($isa); + $isa = { $isa, 1 } unless ishash($isa); - push @{ $this->{$_entries} }, - { owner => $this, isa => $isa, value => $value }; - $this->{$_timestamp}++; + push @{ $this->{$_entries} }, + { owner => $this, isa => $isa, value => $value }; + $this->{$_timestamp}++; - delete $this->{$_cache}{$_} foreach keys %$isa; + delete $this->{$_cache}{$_} foreach keys %$isa; - return $this; + return $this; } 1;
--- a/lib/IMPL/Config/Container.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/Container.pm Sun Aug 20 00:20:41 2017 +0300 @@ -1,6 +1,6 @@ package IMPL::Config::Container; use strict; - +use mro; use Scalar::Util qw(blessed); use IMPL::Exception(); use IMPL::lang qw(:base); @@ -17,12 +17,13 @@ 'IMPL::Object::Disposable' => undef ], props => [ - roles => 'r', - services => 'r', - instances => 'r', - parent => 'r', - root => 'r', - loader => 'r' + roles => 'r', + services => 'r', + serviceCache => 'r', + instances => 'r', + parent => 'r', + root => 'r', + loader => 'r' ] }; @@ -46,6 +47,8 @@ $this->services( Bag->new() ); $this->root($this); } + + $this->services->tag($this); } sub Dispose { @@ -57,6 +60,8 @@ &$d($v); } } + + $this->next::method(); } sub Require { @@ -90,14 +95,12 @@ } sub Resolve { - my ( $this, $role, %opts ) = @_; + my ( $this, $role ) = @_; my $descriptor = $this->services->Resolve($role); - return $descriptor->Activate( ActivationContext->new($this) ) + return ActivationContext->new($this)->Activate($descriptor) if $descriptor; - - return $opts{default} if exists $opts{default}; } sub ResolveAll { @@ -113,7 +116,7 @@ $context = ActivationContext->new($this) unless $context && $opts{shared}; - push @result, $service->Activate($context); + push @result, $context->Activate($service); } return \@result;
--- a/lib/IMPL/Config/Descriptor.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/Descriptor.pm Sun Aug 20 00:20:41 2017 +0300 @@ -24,6 +24,14 @@ die IMPL::NotImplementedException->new(); } +sub services { + +} + +sub GetName { + die IMPL::NotImplementedException->new(); +} + sub ParseActivation { my $val = pop @_;
--- a/lib/IMPL/Config/ReferenceDescriptor.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/ReferenceDescriptor.pm Sun Aug 20 00:20:41 2017 +0300 @@ -3,57 +3,54 @@ use IMPL::Exception(); use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Config::Descriptor' => undef - ], - props => [ - reference => 'ro', - services => 'ro', - lazy => 'ro', - optional => 'ro', - default => 'ro', - _name => 'rw' - ] + base => [ + 'IMPL::Object' => undef, + 'IMPL::Config::Descriptor' => undef + ], + props => [ + reference => 'ro', + services => 'ro', + lazy => 'ro', + optional => 'ro', + default => 'ro', + _name => 'rw' + ] }; sub CTOR { - my ( $this, $ref, %opts ) = @_; + my ( $this, $ref, %opts ) = @_; - $this->reference($ref) - or die IMPL::InvalidArgumentException->new('ref'); + $this->reference($ref) + or die IMPL::InvalidArgumentException->new('ref'); - $this->lazy( $opts{lazy} ) if $opts{lazy}; - $this->optional( $opts{optional} ) if $opts{optional}; - $this->default( $opts{default} ) - if $opts{optional} and exists $opts{default}; + $this->lazy( $opts{lazy} ) if $opts{lazy}; + $this->optional( $opts{optional} ) if $opts{optional}; + $this->default( $opts{default} ) + if $opts{optional} and exists $opts{default}; - $this->_name( 'ref ' . $ref ); + $this->_name( 'ref ' . $ref ); } sub Activate { - my ( $this, $context ) = @_; - - $context->EnterScope( $this->_name, $this->services ); + my ( $this, $context ) = @_; - my $ref = $this->reference; - my %opts; - my $inst; - $opts{default} = $this->default - if $this->optional; + my $ref = $this->reference; + my %opts; + my $inst; + if ( $this->optional ) { + $opts{optional} = 1; + $opts{default} = $this->default; + } - if ( $this->lazy ) { - my $clone = $context->Clone(); - $inst = sub { - $clone->Resolve( $ref, %opts ); - }; - } - else { - $inst = $context->Resolve( $ref, %opts ); - } - - $context->LeaveScope(); - return $inst; + if ( $this->lazy ) { + my $clone = $context->Clone(); + return sub { + $clone->Resolve( $ref, %opts ); + }; + } + else { + return $context->Resolve( $ref, %opts ); + } } 1;
--- a/lib/IMPL/Config/ServiceDescriptor.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/ServiceDescriptor.pm Sun Aug 20 00:20:41 2017 +0300 @@ -18,7 +18,6 @@ args => 'r', services => 'r', norequire => 'r', - owner => 'r', _name => 'rw', _loaded => 'rw' ] @@ -29,8 +28,6 @@ $this->type( $opts{type} ) or die IMPL::InvalidArgumentException->new('type'); - $this->owner( $opts{owner} ) - or die IMPL::InvalidArgumentException->new('owner'); $this->activation( SELF->ParseActivation( $opts{activation} ) ); $this->args( $opts{args} ) if exists $opts{args}; @@ -43,11 +40,9 @@ } sub Activate { - my ( $this, $context ) = @_; + my ( $this, $context) = @_; my $instance; - $context->EnterScope( $this->_name, $this->services ); - my $activation = $this->activation; my $cache; @@ -55,10 +50,10 @@ $cache = $context->container->root->instances; } elsif ( $activation == SELF->ACTIVATE_CONTAINER ) { - $cache = $this->owner->instances; + $cache = $context->container->instances; } elsif ( $activation == SELF->ACTIVATE_HIERARCHY ) { - $cache = $context->container->instances; + $cache = $context->owner->instances; } elsif ( $activation == SELF->ACTIVATE_CONTEXT ) { $cache = $context->instances; @@ -70,35 +65,39 @@ $cache->{ ref($this) } = $instance if $cache; } - $context->LeaveScope(); - return $instance; } sub CreateInstance { - my ( $this, $context ) = @_; + my ( $this, $context) = @_; my $class = $this->norequire ? $this->type : $context->container->Require( $this->type ); - - my $args = $this->args ? $this->args->Activate($context) : undef; - - if ( defined $args ) { - if ( isarray($args) ) { - return $class->new(@$args); + + + # determine how to pass arguments + if (isarray($this->args)) { + # if args is an array ref, pass it as list + return $class->new(map $context->Activate($_), @{$this->args}); + } elsif (ishash($this->args)) { + # if args is a hash ref, pass it as list + my %args; + while(my ($k,$v) = each %{$this->args}) { + $args{$k} = $context->Activate($v); } - elsif ( ishash($args) ) { - return $class->new(%$args); - } - else { - return $class->new($args); - } - } - else { + return $class->new(%args); + } elsif(defined $this->args) { + # otherwise pass it as a single argument + return $class->new($context->Activate($this->args)); + } else { return $class->new(); } } +sub GetName { + shift->_name; +} + 1;
--- a/lib/IMPL/Config/ServicesBag.pm Sun Jul 16 22:59:39 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -package IMPL::Config::ServicesBag; - -require v5.9.5; - -use mro; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Entry => '-IMPL::Config::ServicesBag::Entry' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - _prototype => 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->_nameMap->{$name}; - return $d if $d and $d->{valid}; - - my $parent = $this->_prototype; - - if ( $parent and $d = $parent->GetDescriptorByName($name) ) { - return $this->_nameMap->{$name} = $d; - } - - return undef; -} - -sub GetDescriptorByType { - my ( $this, $type ) = @_; - - my $d = $this->_typeMap->{$type}; - return $d if $d and $d->{valid}; - - my $parent = $this->_prototype; - if ( $parent and $d = $parent->GetDescriptorByType($type) ) { - return $this->_typeMap->{$type} = $d; - } - - return undef; -} - -sub RegisterValue { - my ( $this, $value, $name, $type ) = @_; - - my $d = Entry->new( {owner => $this, value => $value} ); - - 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; - } - - # invalidate cache - $replaces->Invalidate() if $replaces; - - } - - if ($name) { - my $prev = $this->_nameMap->{$name}; - $d->{name} = $name; - $this->_nameMap->{$name} = $d; - $prev->Invalidate() if $prev; - } - - return $d; -} - -sub _UpdateDescriptor { - my ( $this, $d ) = @_; - - my $d2 = Entry->new($d); - - # 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; -} - -package IMPL::Config::ServicesBag::Entry; -use IMPL::Exception(); -use IMPL::declare { - base => [ - 'IMPL::Object::Fields' => undef - ] -}; - -my @fields = qw(owner type isa valid value); -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; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Коллекция сервисов построена на прототиптровании экземпляров, т.е. при создании -новой коллекции может указваться базовая коллекция в которой будет происходить -поиск сервисов в случае их отсутсвия в основной. Для оптимизации данного процесса -сервисы кешируются, чтобы избежать можестрвенных операций поиска по иерархии -коллекций, для этого каждый сервис описывается дескриптором: - -=over - -=item * isa массив типов сервиса, если он регистрировался как сервис - -=item * value значение - -=item * valid признак того, что дескриптор действителен - -=item * owner коллекция, которая создала данный дескриптор - -=back - -Если запрашиваемый десриптор не найден это является ошибкой, поэтому негативные -ответы не кешируются - -=cut
--- a/lib/IMPL/Config/ValueDescriptor.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/ValueDescriptor.pm Sun Aug 20 00:20:41 2017 +0300 @@ -29,12 +29,7 @@ my ( $this, $context ) = @_; return $this->value if $this->raw; - my $services = $this->services; - - $context->EnterScope( '$value: ' . $this->value, $services ) if $services; - my $value = $this->_ActivateValue( $this->value, $context ); - $context->LeaveScope() if $services; - return $value; + return $this->_ActivateValue( $this->value, $context ); } sub _ActivateValue { @@ -57,4 +52,8 @@ } } +sub GetName { + return '$value: ' . shift->value; +} + 1;
--- a/lib/IMPL/Config/YAMLConfig.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/Config/YAMLConfig.pm Sun Aug 20 00:20:41 2017 +0300 @@ -1,49 +1,142 @@ + +=head1 NAME + +C<IMPL::Condig::YAMLConfig> - YAML configuration parser for the container + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + YAMLConfig => 'IMPL::Config::YAMLConfig', + Container => 'IMPL::Config::Container' +}; + +my $config = YAMLConfig->new('config.yaml'); +$config->Load('additional.yaml'); +my $container = Container->new($parent); +$config->ConfigureContainer($container); + +=end code + +=head1 DESCRIPTION + +This module load YAML configuration and applies it to the container. + +=head1 MEMBERS + +=cut + package IMPL::Config::YAMLConfig; use strict; +use IMPL::Debug; use IMPL::lang qw(:base); use IMPL::Exception(); use YAML::XS(); +use Sub::Util; +use File::Spec(); +use URI::file(); use IMPL::declare { require => { ReferenceDescriptor => 'IMPL::Config::ReferenceDescriptor', ServiceDescriptor => 'IMPL::Config::ServiceDescriptor', - ValueDescriptor => 'IMPL::Config::ValueDescriptor' + ValueDescriptor => 'IMPL::Config::ValueDescriptor', + Descriptor => '-IMPL::Config::Descriptor' }, base => [ 'IMPL::Object' => undef ], props => [ - container => 'ro' + _services => 'ro', + _stack => 'ro', + _visited => 'ro', + _current => 'ro' ] }; sub CTOR { - my ( $this, $container ) = @_; - die IMPL::InvalidArgumentException('container') - unless $container; - $this->container($container); + my ( $this, %args ) = @_; + $this->_services( {} ); + $this->_stack( [] ); + $this->_visited( {} ); + $this->Load( $args{load} ) if ( $args{load} ); +} + +sub Load { + my ( $this, $file ) = @_; + + dbg_log("Load $file"); + my $prev = $this->_current; + push @{ $this->_stack }, "$file"; + + dbg_log( "base: ", $prev || '' ); + + $this->_current( $prev ? URI::file->new($file)->abs($prev) : URI::file->new_abs($file)) + unless ref $file; + + dbg_log( "translated: ", $this->_current); + + my $config; + + if ( isscalar($file) ) { + $this->LoadConfiguration( YAML::XS::Load( ${$file} ) ); + } + else { + if ( not ref $file and defined $file ) { + if ( not $this->_visited->{$this->_current} ) { + $this->_visited->{$this->_current} = 1; + + dbg_log("Loading YAML from file ", $this->_current->file); + + $config = YAML::XS::LoadFile($this->_current->file); + } else { + dbg_warn("recursive includes: \n\t", join("\n\t", reverse @{$this->_stack})); + } + } + else { + $config = YAML::XS::LoadFile($file); + } + } + + $this->LoadConfiguration($config) if defined $config; + + $this->_current($prev); + pop @{ $this->_stack }; + + return 1; } sub LoadConfiguration { - my ( $this, $file ) = @_; + my ( $this, $config ) = @_; - $this->Configure( - isscalar($file) - ? YAML::XS::Load( ${$file} ) - : YAML::XS::LoadFile($file) - ); + die IMPL::InvalidArgumentException->new('config') + unless ishash($config); + + $this->Include( $config->{include} ); + + $this->_services( $this->ParseServices( $config->{services} ) ); } -sub Configure { - my ( $this, $config ) = @_; +sub Include { + my ( $this, $inc ) = @_; + if ( isarray($inc) ) { + $this->Include($_) foreach @$inc; + } + elsif ( defined $inc and not ref $inc ) { + dbg_log("include: $inc"); + $this->Load( $inc ); + } +} - die IMPL::InvalidArgumentException('config') - unless ishash($config); +sub ConfigureContainer { + my ( $this, $container ) = @_; - my $container = $this->container; - foreach my $item ( @{ $this->ParseServices( $config->{services} ) } ) { + die IMPL::InvalidArgumentException->new($container) + unless $container; + + foreach my $item ( @{ $this->_services } ) { $container->Register( $item->{role}, $item->{descriptor} ); } @@ -68,40 +161,68 @@ sub ParseDescriptor { my ( $this, $data ) = @_; - my %opts = ( onwer => $this->container() ); + my %opts; + if ( ref $data ) { + if ( my $type = $data->{'$type'} ) { + $opts{services} = $this->ParseServices( $data->{services} ); + $opts{type} = $type; + $opts{args} = $this->ParseParams( $data->{params} ) + if $data->{params}; + $opts{norequire} = $data->{norequire}; + $opts{activation} = $data->{activation}; - if ( my $type = $data->{'$type'} ) { - $opts{services} = $this->ParseServices( $data->{services} ); - $opts{type} = $type; - $opts{args} = $this->ParseDescriptor( $data->{params} ) - if $data->{params}; - $opts{norequire} = $data->{norequire}; - $opts{activation} = $data->{activation}; + return ServiceDescriptor->new(%opts); + } + elsif ( my $dep = $data->{'$ref'} ) { + $opts{services} = $this->ParseServices( $data->{services} ); + $opts{lazy} = $data->{lazy}; + $opts{optional} = $data->{optional}; + $opts{default} = $this->ParseDescriptor( $data->{default} ) + if exists $data->{default}; - return ServiceDescriptor->new(%opts); + return ReferenceDescriptor->new( $dep, %opts ); + } + elsif ( my $value = $data->{'$value'} ) { + my ( $parsed, $raw ) = $this->ParseValue($value); + $opts{services} = $this->ParseServices( $data->{services} ); + $opts{raw} = $raw; + return ValueDescriptor->new( $parsed, %opts ); + } + } - elsif ( my $dep = $data->{'$ref'} ) { - $opts{services} = $this->ParseServices( $data->{services} ); - $opts{lazy} = $data->{lazy}; - $opts{optional} = $data->{optional}; - $opts{default} = $this->ParseDescriptor( $data->{default} ) - if exists $data->{default}; - return ReferenceDesriptor->new( $dep, %opts ); - } - elsif ( my $value = $data->{'$value'} ) { - my ( $parsed, $raw ) = $this->ParseValue($value); - $opts{services} = $this->ParseServices( $data->{services} ); - $opts{raw} = $raw; - return ValueDescriptor->new( $parsed, %opts ); - } - else { - my ( $parsed, $raw ) = $this->ParseValue($value); - $opts{raw} = $raw; - return ValueDescriptor->new( $parsed, %opts ); - } + my ( $parsed, $raw ) = $this->ParseValue($data); + $opts{raw} = $raw; + return is( $parsed, Descriptor ) + ? $parsed + : ValueDescriptor->new( $parsed, %opts ); } +sub IsDescriptorSpec { + my ( $this, $spec ) = @_; + return ( ishash($spec) and grep exists $spec->{$_}, qw($type $ref $value) ); +} + +sub ParseParams { + my ( $this, $params ) = @_; + + if ( isarray($params) ) { + return [ map $this->ParseDescriptor($_), @$params ]; + } + elsif ( ishash($params) and not $this->IsDescriptorSpec($params) ) { + return { + map { $_, $this->ParseDescriptor( $params->{$_} ) } + keys %$params + }; + } + return $this->ParseDescriptor($params); +} + +# parses value and returns a reference to the parsed value, i.e. descriptors +# are recognized and instantinated. +# returns ($parsed, $raw) +# $parsed - the parsed value +# $raw - the parsed value doesn't contain descriptors sub ParseValue { my ( $this, $value ) = @_; @@ -109,7 +230,7 @@ if ( ishash($value) ) { return ( $this->ParseDescriptor($value), 0 ) - if grep exists $value->{$_}, qw($type $ref $value); + if $this->IsDescriptorSpec($value); my %res; while ( my ( $k, $v ) = each %$value ) { @@ -125,27 +246,15 @@ map { my ( $parsed, $flag ) = $this->ParseValue($_); $raw &&= $flag; - return $parsed; + $parsed; } @$value ], $raw ); } else { - return ($value, 1); + return ( $value, 1 ); } } 1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -= - -=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Debug.pm Sun Aug 20 00:20:41 2017 +0300 @@ -0,0 +1,66 @@ +package IMPL::Debug; +use strict; +use warnings; + +our $ENABLE = 0; +our %ENABLE; + +my %subscriptions; +my @subscriptions; + +sub stub { } + +sub import { + my ( $self, @args ) = @_; + + my $caller = caller; + no strict 'refs'; + + my $enabled = exists $ENABLE{$caller} ? $ENABLE{$caller} : $ENABLE; + + *{"${caller}::dbg_log"} = $enabled + ? sub { + $self->log( $caller, @_ ); + } + : \&stub; + + *{"${caller}::dbg_error"} = $enabled + ? sub { + $self->log( $caller, @_ ); + } + : \&stub; + + *{"${caller}::dbg_warn"} = $enabled + ? sub { + $self->log( $caller, @_ ); + } + : \&stub; +} + +sub log { + my $self = shift; + my $channel = shift; + $_->(@_) foreach @{ $subscriptions{$channel} || [] }; + $_->(@_) foreach @subscriptions; +} + +sub subscribe { + my ( $self, $channel, $callback ) = @_; + + if ( @_ == 2 ) { + $callback = $channel; + $channel = undef; + } + + die IMPL::InvalidArgumentException->new('callback') + unless ref $callback eq 'CODE'; + + if ($channel) { + push @{ $subscriptions{$channel} }, $callback; + } + else { + push @subscriptions, $callback; + } +} + +1;
--- a/lib/IMPL/declare.pm Sun Jul 16 22:59:39 2017 +0300 +++ b/lib/IMPL/declare.pm Sun Aug 20 00:20:41 2017 +0300 @@ -30,8 +30,9 @@ _trace("declare $caller"); $IMPL::require::level++; + my $tcaller = $caller; *{"${caller}::SELF"} = sub () { - $caller; + $tcaller; }; while ( my ( $alias, $class ) = each %$aliases ) {