Mercurial > pub > Impl
changeset 421:7798345304bc ref20150831
working on IMPL::Config, removed old stuff
author | cin |
---|---|
date | Sun, 16 Jul 2017 22:59:39 +0300 |
parents | df591e3afd10 |
children | b0481c071bea |
files | _test/sample.yaml lib/IMPL/Code/BasePropertyImplementor.pm lib/IMPL/Config/ActivationContext.pm lib/IMPL/Config/Activator.pm lib/IMPL/Config/Container.pm lib/IMPL/Config/Descriptor.pm lib/IMPL/Config/Include.pm lib/IMPL/Config/Path.pm lib/IMPL/Config/Reference.pm lib/IMPL/Config/ReferenceDescriptor.pm lib/IMPL/Config/Resolve.pm lib/IMPL/Config/ServiceDescriptor.pm lib/IMPL/Config/ValueDescriptor.pm lib/IMPL/Config/YAMLConfig.pm lib/IMPL/lang.pm |
diffstat | 15 files changed, 389 insertions(+), 653 deletions(-) [+] |
line wrap: on
line diff
--- a/_test/sample.yaml Sat Feb 25 22:35:26 2017 +0300 +++ b/_test/sample.yaml Sun Jul 16 22:59:39 2017 +0300 @@ -2,15 +2,15 @@ - secrets.yaml - defaults.yaml services: -- role: db +- name: db $type: My::Db::Context -- role: +- name: - auth - authz - users-provider - roles-provider $type: My::LDAP::Adapter -- role: security-provider +- name: security-provider $type: My::SecureCookies params: users:
--- a/lib/IMPL/Code/BasePropertyImplementor.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Code/BasePropertyImplementor.pm Sun Jul 16 22:59:39 2017 +0300 @@ -50,7 +50,7 @@ ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET), direct => $spec & PROP_DIRECT }; - } elsif ($spec =~ /(\*)?(r)?(w)?/) { + } elsif ($spec =~ /^(\*)?(ro?)?(w)?$/) { return { get => $2 ? 1 : 0, set => 1, @@ -58,7 +58,7 @@ direct => $1 ? 1 : 0 }; } else { - return die IMPL::Exception->new("Invalid property specification","$spec"); + die IMPL::Exception->new("Invalid property specification","$spec"); } }
--- a/lib/IMPL/Config/ActivationContext.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/ActivationContext.pm Sun Jul 16 22:59:39 2017 +0300 @@ -4,95 +4,95 @@ use IMPL::Const qw(:prop); use IMPL::Exception(); use IMPL::declare { - require => { - Bag => 'IMPL::Config::ServicesBag', - ServiceNotFoundException => 'IMPL::Config::ServiceNotFoundException', - }, - base => { - 'IMPL::Object' => '@_' - }, - props => [ - container => PROP_RW, - instances => PROP_RW, - _services => PROP_RW, - _stack => PROP_RW - ] + require => { + Bag => 'IMPL::Config::ServicesBag', + ServiceNotFoundException => 'IMPL::Config::ServiceNotFoundException', + }, + base => { + 'IMPL::Object' => '@_' + }, + props => [ + container => PROP_RW, + instances => PROP_RW, + _services => PROP_RW, + _stack => PROP_RW + ] }; sub CTOR { - my ( $this, $container ) = @_; + my ( $this, $container ) = @_; - $this->container($container) - or die IMPL::InvalidArgumentException->new('container'); - $this->_services( $container->services ); - $this->instances( {} ); - $this->_stack( [] ); + $this->container($container) + or die IMPL::InvalidArgumentException->new('container'); + $this->_services( $container->services ); + $this->instances( {} ); + $this->_stack( [] ); } sub EnterScope { - my ( $this, $name, $services ) = @_; + my ( $this, $name, $services ) = @_; - my $info = { name => $name }; + my $info = { name => $name }; - if ($services) { - die IMPL::InvalidArgumentException->new( - services => 'An array is required' ) - unless isarray($services); + if ($services) { + die IMPL::InvalidArgumentException->new( + services => 'An array is required' ) + unless isarray($services); - my $bag = $this->container->serviceCache->{ ref($services) }; + my $bag = $this->container->serviceCache->{ ref($services) }; - unless ($bag) { - my $container = $this->container; - $bag = Bag->new( $this->_services ); + unless ($bag) { + my $container = $this->container; + $bag = Bag->new( $this->_services ); - # - $bag->Register( - $container->GetLinearRoleHash( $_->{role}, $_->{descriptor} ) ) - foreach @$services; + # + $bag->Register( + $container->GetLinearRoleHash( $_->{role}, $_->{descriptor} ) ) + foreach @$services; - $container->serviceCache->{ ref($services) } = $bag; - } + $container->serviceCache->{ ref($services) } = $bag; + } - $info->{services} = $this->_services; - $this->_services($bag); - } + $info->{services} = $this->_services; + $this->_services($bag); + } - push @{ $this->_stack }, $info; + push @{ $this->_stack }, $info; } sub LeaveScope { - my ($this) = @_; + my ($this) = @_; - my $info = pop @{ $this->_stack } - or die IMPL::InvalidOperationException->new(); + my $info = pop @{ $this->_stack } + or die IMPL::InvalidOperationException->new(); - $this->_services( $info->{services} ) if $info->{services}; + $this->_services( $info->{services} ) if $info->{services}; } sub Resolve { - my ( $this, $role, %opts ) = @_; + my ( $this, $role, %opts ) = @_; - my $d = $this->_services->Resolve($role); + my $d = $this->_services->Resolve($role); - unless ($d) { - die ServiceNotFoundException->new($role) unless $opts{optional}; - return $opts{default}; - } - else { - return $d->Activate($this); - } + unless ($d) { + die ServiceNotFoundException->new($role) unless $opts{optional}; + return $opts{default}; + } + else { + return $d->Activate($this); + } } sub Clone { - my ($this) = @_; + my ($this) = @_; - my $clone = SELF->new( $this->container ); + my $clone = SELF->new( $this->container ); - $clone->_services( $this->_services ); - $clone->instances( { %{ $this->instances } } ); - $clone->_stack( [ @{ $this->_stack } ] ); + $clone->_services( $this->_services ); + $clone->instances( { %{ $this->instances } } ); + $clone->_stack( [ @{ $this->_stack } ] ); - return $clone; + return $clone; } 1;
--- a/lib/IMPL/Config/Activator.pm Sat Feb 25 22:35:26 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -package IMPL::Config::Activator; -use strict; - -use Scalar::Util qw(reftype); -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Loader => 'IMPL::Code::Loader', - Exception => 'IMPL::Exception' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::PublicSerializable' => undef - ], - props => [ - factory => PROP_RW, - parameters => PROP_RW, - singleCall => PROP_RW, - _object => PROP_RW - ] -}; - -use constant { - SELF_CLASS => __PACKAGE__, -}; - -sub CTOR { - my $this = shift; - - die Exception->new("A factory parameter is required") unless $this->factory; - -} - - -sub activate { - my $this = shift; - - unless ($this->_object) { - my @args; - - my $params = $this->parameters; - if (ref $params eq 'HASH') { - while ( my ($key,$value) = each %$params ) { - push @args,$key, is($value,SELF_CLASS) ? $value->activate : $value; - } - } elsif (ref $params eq 'ARRAY') { - push @args, map is($_,SELF_CLASS) ? $_->activate : $_, @$params; - } else { - push @args, is($params,SELF_CLASS) ? $params->activate : $params; - } - - push @args, map is($_,SELF_CLASS) ? $_->activate : $_, @_ if @_; - - my $factory = $this->factory; - Loader->default->Require($factory) - unless ref($factory); - - my $instance = $factory->new(@args); - - $this->_object($instance) - unless $this->singleCall; - - return $instance; - } else { - return $this->_object; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::Activator> - объект, используемый для получения других объектов. - -=head1 DESCRIPTION - -Служит дополнительным уровнем абстракции в тех случаях, когда нужный объект -заранее не известен или его создание должно происходить по требованию. -От обычной фабрики отличается также тем, что рассматривает формальные параметры -на наличие активаторов и выполняет их при активации. - -Кроме того можно указать, что процесс активации должен происходить при каждом -обращении. - -=cut
--- a/lib/IMPL/Config/Container.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/Container.pm Sun Jul 16 22:59:39 2017 +0300 @@ -111,7 +111,7 @@ foreach my $service (@$all) { $context = ActivationContext->new($this) - unless $context || $opts{shared}; + unless $context && $opts{shared}; push @result, $service->Activate($context); }
--- a/lib/IMPL/Config/Descriptor.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/Descriptor.pm Sun Jul 16 22:59:39 2017 +0300 @@ -10,39 +10,39 @@ sub ACTIVATE_CALL() { 5 } my %activateNames = ( - singleton => ACTIVATE_SINGLETON, - container => ACTIVATE_CONTAINER, - hierarchy => ACTIVATE_HIERARCHY, - context => ACTIVATE_CONTEXT, - call => ACTIVATE_CALL + singleton => ACTIVATE_SINGLETON, + container => ACTIVATE_CONTAINER, + hierarchy => ACTIVATE_HIERARCHY, + context => ACTIVATE_CONTEXT, + call => ACTIVATE_CALL ); -my %activateNamesLookup = map { $activateNames{$_}, $_ } keys %activateNames; +my %activateNamesLookup = reverse %activateNames; sub Activate { - my ( $this, $context ) = @_; - die IMPL::NotImplementedException->new(); + my ( $this, $context ) = @_; + die IMPL::NotImplementedException->new(); } sub ParseActivation { - my $val = pop @_; + my $val = pop @_; - return ACTIVATE_CALL unless $val; + return ACTIVATE_CALL unless $val; - return grep $_ == $val, - ACTIVATE_SINGLETON, - ACTIVATE_CONTAINER, - ACTIVATE_HIERARCHY, - ACTIVATE_CONTEXT, ACTIVATE_CALL ? $val : ACTIVATE_CALL - if looks_like_number($val); + return grep( $_ == $val, + ACTIVATE_SINGLETON, + ACTIVATE_CONTAINER, + ACTIVATE_HIERARCHY, + ACTIVATE_CONTEXT, ACTIVATE_CALL ) ? $val : ACTIVATE_CALL + if looks_like_number($val); - return $activateNames{ lc($val) } || ACTIVATE_CALL; + return $activateNames{ lc($val) } || ACTIVATE_CALL; } sub ActivationToString { - my $val = pop @_; + my $val = pop @_; - return ( $val && $activateNamesLookup{$val} ) || ''; + return ( $val && $activateNamesLookup{$val} ) || ''; } 1;
--- a/lib/IMPL/Config/Include.pm Sat Feb 25 22:35:26 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -package IMPL::Config::Include; -use strict; -use warnings; -use IMPL::require { - Conf => 'IMPL::Config', - Exception => 'IMPL::Exception' -}; - - -sub restore { - my ($self,$data) = @_; - - die Exception->new("A file name is required") if ref $data || not $data; - - return Conf->spawn($data); -} - -1; \ No newline at end of file
--- a/lib/IMPL/Config/Path.pm Sat Feb 25 22:35:26 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package IMPL::Config::Path; -use strict; -use IMPL::Config(); - -use IMPL::require { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException' -}; - -sub restore { - my ($self,$data,$surrogate) = @_; - - die OpException->new("Invalid content") unless ref $data eq 'ARRAY' && @$data == 2; - - my ($base,$path) = @$data; - - my %types = ( - appBase => 'AppDir', - configBase => 'ConfigDir' - ); - - my $method = $types{$base}; - - die OpException->new("Unsupported path type",$base) unless $method; - - return IMPL::Config->$method($path); -} - -1; \ No newline at end of file
--- a/lib/IMPL/Config/Reference.pm Sat Feb 25 22:35:26 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -package IMPL::Config::Reference; -use strict; - -use IMPL::Exception; - -sub restore { - my ($self,$data,$surrogate) = @_; - - my @path; - - my ($tagTarget,$target) = splice @$data, 0, 2; - - die new IMPL::Exception('A traget tag must be the first tag in the reference specification') unless $tagTarget eq 'target'; - while(my ($method,$args) = splice @$data, 0, 2 ) { - $target = $self->_InvokeMember($target,{ method => $method, args => $args}); - } - return $target; -} - -sub _InvokeMember { - my ($self,$object,$member) = @_; - - my $method = $member->{method}; - return - ref $object eq 'HASH' ? - $object->{$method} - : - $object->$method( - exists $member->{args} ? - _as_list($member->{args}) - : - () - ) - ; -} - -sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::Reference> - ссылка на внешний объект, вычисляемый на этапе десериализации данных. - -=head1 SYNOPSIS - -=begin code xml - -<Application> - <processingStack type="IMPL::Config::Reference"> - <target>IMPL::Config</target> - <LoadXMLFile>stdprocessing.xml</LoadXMLFile> - </processingStack> -</Application> - -=end code xml - -=head1 DESCRIPTION - -Позволяет на указвать ссылки на вычисляемые объекты, например, загружаемые из файлов. Ссылки такого рода -будут вычислены на этапе десериализации еще до того, как будет создан объект верхнего уровня, поэтому -следует избегать таких ссылок на сам (его свойства и методы) десериализуемый объект. - -=head1 MEMBERS - -=head2 C<restore($class,$data,$surrogate)> - -Использует данные переданные в параметре дата C<$data> для вычисления свойства. Данный метод - стандартный -метод для десериализации объекта, а параметр C<$data> содержит пары значений C<(имя_узла,значение_узла)>, -первая пара обязательно является узлом C<target>, а его значение - целевой объект, который будет -использован для вычисления конечного значения. - -=back - -=cut \ No newline at end of file
--- a/lib/IMPL/Config/ReferenceDescriptor.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/ReferenceDescriptor.pm Sun Jul 16 22:59:39 2017 +0300 @@ -38,20 +38,22 @@ my $ref = $this->reference; my %opts; + my $inst; $opts{default} = $this->default if $this->optional; if ( $this->lazy ) { my $clone = $context->Clone(); - return sub { + $inst = sub { $clone->Resolve( $ref, %opts ); }; } else { - return $context->Resolve( $ref, %opts ); + $inst = $context->Resolve( $ref, %opts ); } $context->LeaveScope(); + return $inst; } 1;
--- a/lib/IMPL/Config/Resolve.pm Sat Feb 25 22:35:26 2017 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -package IMPL::Config::Resolve; -use strict; -use parent qw(IMPL::Object IMPL::Object::Serializable); - -use IMPL::Class::Property; -use IMPL::Exception; -use Carp qw(carp); - -BEGIN { - public property path => prop_all|prop_list; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - my $list = $this->path; - - while(my $name = shift ) { - my $args = shift; - $list->Append({ method => $name, (defined $args ? (args => $args) : ()) }); - } - - #die new IMPL::InvalidArgumentException("The argument is mandatory","path") unless $this->path->Count; -} - -sub Invoke { - my ($this,$target,$default) = @_; - - my $result = $target; - $result = $this->_InvokeMember($result,$_) || return $default foreach $this->path; - - return $result; -} - -sub _InvokeMember { - my ($self,$object,$member) = @_; - - my $method = $member->{method}; - - local $@; - return eval { - ref $object eq 'HASH' ? - $object->{$method} - : - $object->$method( - exists $member->{args} ? - _as_list($member->{args}) - : - () - ) - }; -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar($_->{method},$_->{args}) foreach $this->path; -} - -sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); -} - -1;
--- a/lib/IMPL/Config/ServiceDescriptor.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/ServiceDescriptor.pm Sun Jul 16 22:59:39 2017 +0300 @@ -4,103 +4,101 @@ use IMPL::lang qw(:base); use IMPL::Exception(); use IMPL::declare { - require => { - Bag => 'IMPL::Config::Bag', - ActivationException => 'IMPL::Config::ActivationException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Config::Descriptor' => undef - ], - props => [ - type => 'r', - activation => 'r', - args => 'r', - services => 'r', - norequire => 'r', - owner => 'r', - _name => 'rw', - _loaded => 'rw' - ] + require => { + Bag => 'IMPL::Config::Bag', + ActivationException => 'IMPL::Config::ActivationException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Config::Descriptor' => undef + ], + props => [ + type => 'r', + activation => 'r', + args => 'r', + services => 'r', + norequire => 'r', + owner => 'r', + _name => 'rw', + _loaded => 'rw' + ] }; sub CTOR { - my ( $this, %opts ) = @_; + my ( $this, %opts ) = @_; - $this->type( $opts{type} ) - or die IMPL::InvalidArgumentException->new('type'); - $this->owner( $opts{owner} ) - or die IMPL::InvalidArgumentException->new('owner'); + $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}; - $this->services( $opts{services} ) if exists $opts{services}; - $this->norequire( $opts{norequire} ) if exists $opts{norequire}; + $this->activation( SELF->ParseActivation( $opts{activation} ) ); + $this->args( $opts{args} ) if exists $opts{args}; + $this->services( $opts{services} ) if exists $opts{services}; + $this->norequire( $opts{norequire} ) if exists $opts{norequire}; - $this->_name( 'new {' - . SELF->ActivationToString( $this->activation ) - . '} ' - . $this->type ); + $this->_name( 'new {' + . SELF->ActivationToString( $this->activation ) . '} ' + . $this->type ); } sub Activate { - my ( $this, $context ) = @_; + my ( $this, $context ) = @_; - my $instance; - $context->EnterScope( $this->_name, $this->services ); + my $instance; + $context->EnterScope( $this->_name, $this->services ); - my $activation = $this->activation; - my $cache; + my $activation = $this->activation; + my $cache; - if ( $activation == SELF->ACTIVATE_SINGLETON ) { - $cache = $context->container->root->instances; - } - elsif ( $activation == SELF->ACTIVATE_CONTAINER ) { - $cache = $this->owner->instances; - } - elsif ( $activation == SELF->ACTIVATE_HIERARCHY ) { - $cache = $context->container->instances; - } - elsif ( $activation == SELF->ACTIVATE_CONTEXT ) { - $cache = $context->instances; - } + if ( $activation == SELF->ACTIVATE_SINGLETON ) { + $cache = $context->container->root->instances; + } + elsif ( $activation == SELF->ACTIVATE_CONTAINER ) { + $cache = $this->owner->instances; + } + elsif ( $activation == SELF->ACTIVATE_HIERARCHY ) { + $cache = $context->container->instances; + } + elsif ( $activation == SELF->ACTIVATE_CONTEXT ) { + $cache = $context->instances; + } - $instance = $cache->{ ref($this) } if $cache; - unless ($instance) { - $instance = $this->CreateInstance($context); - } + $instance = $cache->{ ref($this) } if $cache; + unless ($instance) { + $instance = $this->CreateInstance($context); + $cache->{ ref($this) } = $instance if $cache; + } - $cache->{ ref($this) } = $instance if $cache; + $context->LeaveScope(); - $context->LeaveScope(); - - return $instance; + return $instance; } sub CreateInstance { - my ( $this, $context ) = @_; + my ( $this, $context ) = @_; - my $class = - $this->norequire - ? $this->type - : $context->container->Require( $this->type ); + my $class = + $this->norequire + ? $this->type + : $context->container->Require( $this->type ); - my $args = $this->args ? $this->args->Activate($context) : undef; + my $args = $this->args ? $this->args->Activate($context) : undef; - if ( defined $args ) { - if ( isarray($args) ) { - return $class->new(@$args); - } - elsif ( ishash($args) ) { - return $class->new(%$args); - } - else { - return $class->new($args); - } - } - else { - return $class->new(); - } + if ( defined $args ) { + if ( isarray($args) ) { + return $class->new(@$args); + } + elsif ( ishash($args) ) { + return $class->new(%$args); + } + else { + return $class->new($args); + } + } + else { + return $class->new(); + } } 1;
--- a/lib/IMPL/Config/ValueDescriptor.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/ValueDescriptor.pm Sun Jul 16 22:59:39 2017 +0300 @@ -3,52 +3,58 @@ use IMPL::lang qw(:base); use IMPL::declare { - require => { - Descriptor => 'IMPL::Config::Descriptor' - }, - base => [ - 'IMPL::Object' => undef, - 'Descriptor' => undef - ], - props => [ - value => 'rw', - raw => 'rw' - ] + require => { + Descriptor => 'IMPL::Config::Descriptor' + }, + base => [ + 'IMPL::Object' => undef, + 'Descriptor' => undef + ], + props => [ + value => 'rw', + raw => 'rw', + services => 'rw' + ] }; sub CTOR { - my ( $this, $value, $raw ) = @_; + my ( $this, $value, %opts) = @_; - $this->value($value); - $this->raw($raw); + $this->value($value); + $this->raw($opts{raw}) if exists $opts{raw}; + $this->services($opts{services}) if exists $opts{services}; } sub Activate { - my ( $this, $context ) = @_; + my ( $this, $context ) = @_; + return $this->value if $this->raw; + + my $services = $this->services; - return $this->raw - ? $this->value - : $this->_ActivateValue( $this->value, $context ); + $context->EnterScope( '$value: ' . $this->value, $services ) if $services; + my $value = $this->_ActivateValue( $this->value, $context ); + $context->LeaveScope() if $services; + return $value; } sub _ActivateValue { - my ( $this, $value, $context ) = @_; + my ( $this, $value, $context ) = @_; - if ( is( $value, Descriptor ) ) { - return $value->Activate($context); - } - elsif ( isarray($value) ) { - return [ map $this->_ActivateValue($_, $context), @$value ]; - } - elsif ( ishash($value) ) { - return { - map { $_, $this->_ActivateValue( $value->{$_}, $context ) } - keys %$value - }; - } - else { - return $value; - } + if ( is( $value, Descriptor ) ) { + return $value->Activate($context); + } + elsif ( isarray($value) ) { + return [ map $this->_ActivateValue( $_, $context ), @$value ]; + } + elsif ( ishash($value) ) { + return { + map { $_, $this->_ActivateValue( $value->{$_}, $context ) } + keys %$value + }; + } + else { + return $value; + } } 1;
--- a/lib/IMPL/Config/YAMLConfig.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/Config/YAMLConfig.pm Sun Jul 16 22:59:39 2017 +0300 @@ -5,19 +5,135 @@ use IMPL::Exception(); use YAML::XS(); -sub Load { - my ( $this, $container, $file ) = @_; +use IMPL::declare { + require => { + ReferenceDescriptor => 'IMPL::Config::ReferenceDescriptor', + ServiceDescriptor => 'IMPL::Config::ServiceDescriptor', + ValueDescriptor => 'IMPL::Config::ValueDescriptor' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + container => 'ro' + ] +}; - $this->Configure( isscalar($file) - ? YAML::XS::Load( ${$file} ) - : YAML::XS::LoadFile($file) ); +sub CTOR { + my ( $this, $container ) = @_; + die IMPL::InvalidArgumentException('container') + unless $container; + $this->container($container); +} + +sub LoadConfiguration { + my ( $this, $file ) = @_; + + $this->Configure( + isscalar($file) + ? YAML::XS::Load( ${$file} ) + : YAML::XS::LoadFile($file) + ); } sub Configure { - my ( $this, $container, $config ) = @_; - - + my ( $this, $config ) = @_; + + die IMPL::InvalidArgumentException('config') + unless ishash($config); + + my $container = $this->container; + foreach my $item ( @{ $this->ParseServices( $config->{services} ) } ) { + $container->Register( $item->{role}, $item->{descriptor} ); + } + + return $container; +} + +sub ParseServices { + my ( $this, $services ) = @_; + + return $services + ? [ + map { + { + role => delete $_->{name}, + descriptor => $this->ParseDescriptor($_) + }; + } @$services + ] + : undef; +} + +sub ParseDescriptor { + my ( $this, $data ) = @_; + + my %opts = ( onwer => $this->container() ); + + 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 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 ); + } +} + +sub ParseValue { + my ( $this, $value ) = @_; + + my $raw = 1; + + if ( ishash($value) ) { + return ( $this->ParseDescriptor($value), 0 ) + if grep exists $value->{$_}, qw($type $ref $value); + + my %res; + while ( my ( $k, $v ) = each %$value ) { + my ( $parsed, $flag ) = $this->ParseValue($v); + $res{$k} = $parsed; + $raw &&= $flag; + } + return ( \%res, $raw ); + } + elsif ( isarray($value) ) { + return ( + [ + map { + my ( $parsed, $flag ) = $this->ParseValue($_); + $raw &&= $flag; + return $parsed; + } @$value + ], + $raw + ); + } + else { + return ($value, 1); + } } 1; @@ -26,5 +142,10 @@ =pod +=head1 NAME + +=head1 SYNOPSIS + += =cut
--- a/lib/IMPL/lang.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/lang.pm Sun Jul 16 22:59:39 2017 +0300 @@ -22,29 +22,6 @@ &isglob ) ], - - declare => [ - qw( - &public - &protected - &private - &property - &static - &property - &_direct - &ACCESS_PUBLIC - &ACCESS_PROTECTED - &ACCESS_PRIVATE - &PROP_GET - &PROP_SET - &PROP_OWNERSET - &PROP_LIST - &PROP_ALL - &PROP_RO - &PROP_RW - &PROP_DIRECT - ) - ], compare => [ qw( &equals @@ -64,98 +41,45 @@ ] ); -our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; +our @EXPORT_OK = + keys %{ { map ( ( $_, 1 ), map ( @{$_}, values %EXPORT_TAGS ) ) } }; use IMPL::Const qw(:all); sub is { carp "A typename can't be undefined" unless $_[1]; - blessed($_[0]) and $_[0]->isa( $_[1] ); + blessed( $_[0] ) and $_[0]->isa( $_[1] ); } sub isclass { carp "A typename can't be undefined" unless $_[1]; local $@; - eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; + eval { not ref $_[0] and $_[0]->isa( $_[1] ) }; } sub typeof(*) { - blessed($_[0]); + blessed( $_[0] ); } sub isarray { - not blessed($_[0]) and ref $_[0] eq 'ARRAY'; + not blessed( $_[0] ) and ref $_[0] eq 'ARRAY'; } sub ishash { - not blessed($_[0]) and ref $_[0] eq 'HASH'; + not blessed( $_[0] ) and ref $_[0] eq 'HASH'; } sub isscalar { - not blessed($_[0]) and ref $_[0] eq 'SCALAR'; + not blessed( $_[0] ) and ref $_[0] eq 'SCALAR'; } sub isglob { - not blessed($_[0]) and ref $_[0] eq 'GLOB'; -} - -sub public($) { - my $info = shift; - $info->{access} = ACCESS_PUBLIC; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub private($) { - my $info = shift; - $info->{access} = ACCESS_PRIVATE; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub protected($) { - my $info = shift; - $info->{access} = ACCESS_PROTECTED; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub _direct ($) { - my $info = shift; - $info->{direct} = 1; - return $info; -} - -sub property($$) { - my ($propName,$attributes) = @_; - - $attributes = { - get => $attributes & PROP_GET, - set => $attributes & PROP_SET, - isList => $attributes & PROP_LIST - } unless ref $attributes; - - my $class = caller; - - return hashMerge ( - $attributes, - { - implementor => $class->ClassPropertyImplementor, - name => $propName, - class => scalar(caller), - } - ); -} - -sub static($$) { - my ( $name, $value ) = @_; - my $class = caller; - $class->static_accessor( $name, $value ); + not blessed( $_[0] ) and ref $_[0] eq 'GLOB'; } sub coarsen { - my ( $value, $resolution ) = @_; - return $resolution ? ceil( $value / $resolution ) * $resolution : $value; + my ( $value, $resolution ) = @_; + return $resolution ? ceil( $value / $resolution ) * $resolution : $value; } # datetime is DateTime object @@ -176,117 +100,109 @@ } sub equals { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - + if ( defined $_[0] ) { + return 0 if ( not defined $_[1] ); + return $_[0] == $_[1]; - } else { + } + else { return 0 if defined $_[1]; - + return 1; } } sub equals_s { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - + if ( defined $_[0] ) { + return 0 if ( not defined $_[1] ); + return $_[0] eq $_[1]; - } else { + } + else { return 0 if defined $_[1]; - + return 1; } } sub hashDiff { - my ($src,$dst) = @_; - - $dst = $dst ? { %$dst } : {} ; + my ( $src, $dst ) = @_; + + $dst = $dst ? {%$dst} : {}; $src ||= {}; - + my %result; - + foreach my $key ( keys %$src ) { - if (exists $dst->{$key}) { - $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); + if ( exists $dst->{$key} ) { + $result{"+$key"} = $dst->{$key} + unless equals_s( $dst->{$key}, $src->{$key} ); delete $dst->{$key}; - } else { + } + else { $result{"-$key"} = 1; } } - + $result{"+$_"} = $dst->{$_} foreach keys %$dst; - + return \%result; } sub hashMerge { - return hashApply( { %{$_[0] || {}} }, $_[1] ); + return hashApply( { %{ $_[0] || {} } }, $_[1] ); } sub hashApply { - my ($target,$diff) = @_; - + my ( $target, $diff ) = @_; + return $target unless ref $diff eq 'HASH'; - - while ( my ($key,$value) = each %$diff) { + + while ( my ( $key, $value ) = each %$diff ) { $key =~ /^(\+|-)?(.*)$/; my $op = $1 || '+'; $key = $2; - - if ($op eq '-') { + + if ( $op eq '-' ) { delete $target->{$key}; - } else { + } + else { $target->{$key} = $value; } } - + return $target; } sub hashCompare { - my ($l,$r,$cmp) = @_; - + my ( $l, $r, $cmp ) = @_; + $cmp ||= \&equals_s; - + return 0 unless scalar keys %$l == scalar keys %$r; - &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; - + &$cmp( $l->{$_}, $r->{$_} ) || return 0 foreach keys %$l; + return 1; } sub hashParse { - my ($s,$p,$d) = @_; - + my ( $s, $p, $d ) = @_; + $p = $p ? qr/$p/ : qr/\n+/; $d = $d ? qr/$d/ : qr/\s*=\s*/; - - return { - map split($d,$_,2), split($p,$s) - }; + + return { map split( $d, $_, 2 ), split( $p, $s ) }; } sub hashSave { - my ($hash,$p,$d) = @_; - + my ( $hash, $p, $d ) = @_; + return "" unless ref $hash eq 'HASH'; - + $p ||= "\n"; $d ||= " = "; - - return - join( - $p, - map( - join( - $d, - $_, - $hash->{$_} - ), - keys %$hash - ) - ); + + return join( $p, map( join( $d, $_, $hash->{$_} ), keys %$hash ) ); } 1;