# HG changeset patch # User cin # Date 1446418613 -10800 # Node ID 3ed0c58e9da3d2cf7996f8458dad5103dd41a146 # Parent cc2cf8c0edc205844da65584373de4c9bd2b6b19 working on di container, tests diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 _test/Test/Config/Bar.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Config/Bar.pm Mon Nov 02 01:56:53 2015 +0300 @@ -0,0 +1,18 @@ +package Test::Config::Bar; +use strict; +use IMPL::declare { + base => [ + 'IMPL::Object' => undef + ], + props => [ + value => 'r' + ] +}; + +sub CTOR { + my $this = shift; + + $this->value(shift) if @_; +} + +1; \ No newline at end of file diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 _test/Test/Config/Container.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Config/Container.pm Mon Nov 02 01:56:53 2015 +0300 @@ -0,0 +1,40 @@ +package Test::Config::Container; +use strict; + +{ + package Test::Config::Container::Baz; + use IMPL::declare { + base => { + 'IMPL::Object' => undef + }, + props => [ + value => 'r' + ] + }; + + sub CTOR { + my $this = shift; + $this->value(shift); + } +} + +use IMPL::declare { + require => { + Container => 'IMPL::Config::Container' + }, + base => { + 'IMPL::Test::Unit' => '@_' + } +}; +use IMPL::Test qw(test assert failed); + +test CreateContainer => sub { + my $c1 = Container->new(); +}; + +sub RegisterServices { + my $c1 = Container->new(); +} + + +1; \ No newline at end of file diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 _test/Test/Config/Foo.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Config/Foo.pm Mon Nov 02 01:56:53 2015 +0300 @@ -0,0 +1,18 @@ +package Test::Config::Foo; +use strict; +use IMPL::declare { + base => [ + 'IMPL::Object' => undef + ], + props => [ + value => 'r' + ] +}; + +sub CTOR { + my $this = shift; + + $this->value(shift) if @_; +} + +1; \ No newline at end of file diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 _test/config.t --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/config.t Mon Nov 02 01:56:53 2015 +0300 @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test qw(run_plan); + +run_plan( qw( + Test::Config::Container +) ); + +1; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 _test/temp.pl --- a/_test/temp.pl Thu Oct 29 03:50:25 2015 +0300 +++ b/_test/temp.pl Mon Nov 02 01:56:53 2015 +0300 @@ -5,9 +5,45 @@ use Scalar::Util qw(blessed refaddr); use YAML::XS qw(Dump); -print Dump { - services => [ - { role => 'db', type => 'My::Data::Context', params => { '-ref' => 'some-role' } } +my $t = [gettimeofday]; + +use IMPL::require { + Container => 'IMPL::Config::Container', + Service => 'IMPL::Config::ServiceDescriptor', + Reference => 'IMPL::Config::ReferenceDescriptor', + Value => 'IMPL::Config::ValueDescriptor' +}; + +my $c1 = Container->new(); + +$c1->Register('db', Service->new( + type => 'Foo::Data', + norequire => 1, + activation => 'container' +) ); + +$c1->Register(['sec', 'ldap'], Reference->new('db') ); + +$c1->Register('mixed', Value->new([ + Reference->new('db'), + Reference->new('sec'), + Reference->new('ldap') +])); + +my $c2 = Container->new($c1); + +my $data = [ $c1->Resolve('mixed')] ; + +print "Activated: ",tv_interval($t,[gettimeofday]),"\n"; + +print Dump($data); + + +package Foo::Data; +use IMPL::declare { + base => [ + 'IMPL::Object' => undef ] }; + 1; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Code/BasePropertyImplementor.pm --- a/lib/IMPL/Code/BasePropertyImplementor.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Code/BasePropertyImplementor.pm Mon Nov 02 01:56:53 2015 +0300 @@ -53,8 +53,8 @@ } elsif ($spec =~ /(\*)?(r)?(w)?/) { return { get => $2 ? 1 : 0, - set => $3 ? 1 : 0, - ownerSet => $2 ? 1 : 0, + set => 1, + ownerSet => not($3), direct => $1 ? 1 : 0 }; } else { diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Config/ActivationContext.pm --- a/lib/IMPL/Config/ActivationContext.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Config/ActivationContext.pm Mon Nov 02 01:56:53 2015 +0300 @@ -5,18 +5,18 @@ use IMPL::Exception(); use IMPL::declare { require => { - Bag => 'IMPL::Config::ServicesBag', + Bag => 'IMPL::Config::ServicesBag', ServiceNotFoundException => 'IMPL::Config::ServiceNotFoundException', }, base => { 'IMPL::Object' => '@_' }, - props => { + props => [ container => PROP_RW, + instances => PROP_RW, _services => PROP_RW, - _cache => PROP_RW, _stack => PROP_RW - } + ] }; sub CTOR { @@ -24,8 +24,9 @@ $this->container($container) or die IMPL::InvalidArgumentException->new('container'); - $this->_cache({}); - $this->_stack([]); + $this->_services( $container->services ); + $this->instances( {} ); + $this->_stack( [] ); } sub EnterScope { @@ -44,6 +45,7 @@ my $container = $this->container; $bag = Bag->new( $this->_services ); + # $bag->Register( $container->GetLinearRoleHash( $_->{role}, $_->{descriptor} ) ) foreach @$services; @@ -55,46 +57,42 @@ $this->_services($bag); } - push @{$this->_stack}, $info; + push @{ $this->_stack }, $info; } sub LeaveScope { my ($this) = @_; - my $info = pop @{$this->_stack} + my $info = pop @{ $this->_stack } or die IMPL::InvalidOperationException->new(); $this->_services( $info->{services} ) if $info->{services}; } -sub GuardScope { - my ( $this, $name, $services, $action ) = @_; - - $this->EnterScope( $name, $service ); - eval { $action ($this) if $action; } my $err = $@; - $this->LeaveScope(); - die $err if $err; -} - sub Resolve { my ( $this, $role, %opts ) = @_; - - my $d = $this->_services->Reolve($role); - - unless($d) { + + my $d = $this->_services->Resolve($role); + + unless ($d) { die ServiceNotFoundException->new($role) unless $opts{optional}; return $opts{default}; - } else { + } + else { return $d->Activate($this); } } sub Clone { my ($this) = @_; - - my $clone = SELF->new($this->container); - - $clone->_ + + my $clone = SELF->new( $this->container ); + + $clone->_services( $this->_services ); + $clone->instances( { %{ $this->instances } } ); + $clone->_stack( [ @{ $this->_stack } ] ); + + return $clone; } 1; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Config/Bag.pm --- a/lib/IMPL/Config/Bag.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Config/Bag.pm Mon Nov 02 01:56:53 2015 +0300 @@ -41,9 +41,9 @@ } 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 } } @@ -53,19 +53,20 @@ 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 $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}; + if ( $flush ||= $rev and $bag->{$_parentRev} != $rev ) { + $bag->{$_cache} = {}; + $bag->{$_parentRev} = $rev; + } + $rev = $bag->{$_timestamp}; } - + return $flush ? 0 : 1; } @@ -105,29 +106,30 @@ $d = undef; my $prev; - if ( my $parents = $this->{$_parents} ) { - foreach my $bag ( @$parents, $this ) { + my $parents = $this->{$_parents}; + my @bags = $parents ? ( @$parents, $this ) : ($this); - # check the cache; - unless ( my $t = $bag->{$_cache}{$role} ) { + foreach my $bag (@bags) { + + # 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; - } + 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}; } } @@ -140,7 +142,7 @@ return [ map $_->{value}, grep $_->{isa}{$role}, - map @{$_->{$_entries}}, + map @{ $_->{$_entries} }, @{ $this->{$_parents} || [] }, $this ]; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Config/Container.pm --- a/lib/IMPL/Config/Container.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Config/Container.pm Mon Nov 02 01:56:53 2015 +0300 @@ -47,6 +47,12 @@ } } +sub Require { + my ($this, $class) = @_; + + return $this->loader->Require($class); +} + sub Register { my ( $this, $role, $service ) = @_; @@ -64,7 +70,7 @@ if ( isarray($role) ) { my $tempRole = "unnamed-" . $nextRoleId++; - $this->role->AddRole( $tempRole, $role ); + $this->roles->AddRole( $tempRole, $role ); $role = $tempRole; } @@ -77,7 +83,7 @@ my $descriptor = $this->services->Resolve($role); return $descriptor->Activate( ActivationContext->new($this) ) - if $descirptor; + if $descriptor; return $opts{default} if exists $opts{default}; } diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Config/ReferenceDescriptor.pm --- a/lib/IMPL/Config/ReferenceDescriptor.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Config/ReferenceDescriptor.pm Mon Nov 02 01:56:53 2015 +0300 @@ -34,7 +34,7 @@ sub Activate { my ( $this, $context ) = @_; - $this->EnterScope( $this->_name, $this->services ); + $context->EnterScope( $this->_name, $this->services ); my $ref = $this->reference; my %opts; @@ -51,7 +51,7 @@ return $context->Resolve( $ref, %opts ); } - $this->LeaveScope(); + $context->LeaveScope(); } 1; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Config/ServiceDescriptor.pm --- a/lib/IMPL/Config/ServiceDescriptor.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Config/ServiceDescriptor.pm Mon Nov 02 01:56:53 2015 +0300 @@ -13,10 +13,11 @@ 'IMPL::Config::Descriptor' => undef ], props => [ - type => 'ro', - activation => 'ro', - args => 'ro', - services => 'ro', + type => 'r', + activation => 'r', + args => 'r', + services => 'r', + norequire => 'r', _name => 'rw', _loaded => 'rw' ] @@ -30,8 +31,9 @@ $this->activation( IMPL::Config::Descriptor::ParseActivation( $opts{activation} ) ); - $this->args( $opts{args} ) if exists $opts{args}; - $this->services( $opts{services} ) if exists $opts{services}; + $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 {' . IMPL::Config::Descriptor::ActivationToString( $this->activation ) @@ -43,35 +45,29 @@ my ( $this, $context ) = @_; my $instance; - $context->GuardScope( - $this->_name, - $this->services, - sub { + $context->EnterScope( $this->_name, $this->services ); - my $activation = $this->activation; - my $cache; + my $activation = $this->activation; + my $cache; - if ( $activation == IMPL::Config::Descriptor::ACTIVATE_SINGLETON ) { - $cache = $context->container->root->instances; - } - elsif ( - $activation == IMPL::Config::Descriptor::ACTIVATE_CONTAINER ) - { - $cache = $context->container->instances; - } - elsif ( $activation == IMPL::Config::Descriptor::ACTIVATE_CONTEXT ) - { - $cache = $context->instances; - } + if ( $activation == IMPL::Config::Descriptor::ACTIVATE_SINGLETON ) { + $cache = $context->container->root->instances; + } + elsif ( $activation == IMPL::Config::Descriptor::ACTIVATE_CONTAINER ) { + $cache = $context->container->instances; + } + elsif ( $activation == IMPL::Config::Descriptor::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(); return $instance; } @@ -79,7 +75,10 @@ sub CreateInstance { my ( $this, $context ) = @_; - my $class = $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; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/Config/ValueDescriptor.pm --- a/lib/IMPL/Config/ValueDescriptor.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/Config/ValueDescriptor.pm Mon Nov 02 01:56:53 2015 +0300 @@ -38,11 +38,11 @@ return $value->Activate($context); } elsif ( isarray($value) ) { - return [ map $this->_ActivateValue($_), @$value ]; + return [ map $this->_ActivateValue($_, $context), @$value ]; } elsif ( ishash($value) ) { return { - map { $_, $this->_ActivateValue( $value->{$_} ) } + map { $_, $this->_ActivateValue( $value->{$_}, $context ) } keys %$value }; } diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/SQL/Schema.pm --- a/lib/IMPL/SQL/Schema.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/SQL/Schema.pm Mon Nov 02 01:56:53 2015 +0300 @@ -12,7 +12,6 @@ base => [ 'IMPL::Object' => undef, 'IMPL::Object::Disposable' => undef, - 'IMPL::Object::Autofill' => '@_', 'IMPL::Object::Clonable' => undef, ], props => [ @@ -22,6 +21,12 @@ ] }; +sub CTOR { + my ($this,%args) = @_; + + $this->$_($args{$_}) foreach grep exists $args{$_}, qw(name version); +} + sub AddTable { my ($this,$table) = @_; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/SQL/Schema/Column.pm --- a/lib/IMPL/SQL/Schema/Column.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/SQL/Schema/Column.pm Mon Nov 02 01:56:53 2015 +0300 @@ -1,75 +1,78 @@ use strict; + package IMPL::SQL::Schema::Column; -use IMPL::lang qw( :DEFAULT :compare :hash ); +use IMPL::lang qw( :base :compare :hash ); use IMPL::Exception(); use IMPL::Const qw(:prop); use IMPL::declare { - require => { - SchemaType => '-IMPL::SQL::Schema::Type' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - name => PROP_RO | PROP_DIRECT, - type => PROP_RO | PROP_DIRECT, - isNullable => PROP_RO | PROP_DIRECT, - defaultValue => PROP_RO | PROP_DIRECT, - tag => PROP_RO | PROP_DIRECT - ] + require => { + SchemaType => '-IMPL::SQL::Schema::Type' + }, + base => [ + 'IMPL::Object' => undef, + ], + props => [ + name => PROP_RO | PROP_DIRECT, + type => PROP_RO | PROP_DIRECT, + isNullable => PROP_RO | PROP_DIRECT, + defaultValue => PROP_RO | PROP_DIRECT, + tag => PROP_RO | PROP_DIRECT + ] }; sub CTOR { - my $this = shift; - - $this->{$name} or - die new IMPL::InvalidArgumentException('A column name is required'); - - $this->{$isNullable} ||= 0; # if not exists $this->{$isNullable}; - - is( $this->{$type}, SchemaType) or - die new IMPL::InvalidArgumentException('a type is required for the column',$this->{$name}); + my ( $this, %args ) = @_; + + $this->$_( $args{$_} ) + foreach grep exists $args{$_}, qw( name type isNullable defaultValue tag); + + $this->{$name} or + die new IMPL::InvalidArgumentException('A column name is required'); + + $this->{$isNullable} ||= 0; # if not exists $this->{$isNullable}; + + is( $this->{$type}, SchemaType ) + or die new IMPL::InvalidArgumentException( + 'a type is required for the column', + $this->{$name} ); } sub SameValue { - my ($this,$other) = @_; - - return ( - $this->{$name} eq $other->{$name} - and $this->{$isNullable} == $other->{$isNullable} - and equals_s($this->{$defaultValue}, $other->{$defaultValue}) - and $this->{$type}->SameValue($other->{$type}) - ); + my ( $this, $other ) = @_; + + return ( $this->{$name} eq $other->{$name} + and $this->{$isNullable} == $other->{$isNullable} + and equals_s( $this->{$defaultValue}, $other->{$defaultValue} ) + and $this->{$type}->SameValue( $other->{$type} ) ); } sub SetType { - my ($this,$newType) = @_; - - $this->{$type} = $newType; + my ( $this, $newType ) = @_; + + $this->{$type} = $newType; } sub SetDefaultValue { - my ($this,$value) = @_; - - $this->{$defaultValue} = $value; + my ( $this, $value ) = @_; + + $this->{$defaultValue} = $value; } sub SetNullable { - my ($this, $value) = @_; - - $this->{$isNullable} = $value; + my ( $this, $value ) = @_; + + $this->{$isNullable} = $value; } sub SetOptions { - my ($this,$diff) = @_; - - return unless ref $diff eq 'HASH'; - - $this->tag({}) unless $this->tag; - - hashApply($this->tag,$diff); + my ( $this, $diff ) = @_; + + return unless ref $diff eq 'HASH'; + + $this->tag( {} ) unless $this->tag; + + hashApply( $this->tag, $diff ); } -1; +1; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/SQL/Schema/Constraint.pm --- a/lib/IMPL/SQL/Schema/Constraint.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/SQL/Schema/Constraint.pm Mon Nov 02 01:56:53 2015 +0300 @@ -20,7 +20,7 @@ sub CTOR { my ($this,%args) = @_; - is( $args{table}, typeof IMPL::SQL::Schema::Table ) or + is( $args{table}, 'IMPL::SQL::Schema::Table' ) or die new IMPL::InvalidArgumentException("table argument must be a table object"); $this->{$name} = $args{'name'}; $this->{$table} = $args{'table'}; @@ -75,13 +75,13 @@ sub ResolveAlias { my ($self,$alias) = @_; - return isclass($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; + return isclass($alias, 'IMPL::SQL::Schema::Constraint') ? $alias : $aliases{$alias}; } sub RegisterAlias { my ($self,$alias) = @_; - $aliases{$alias} = typeof($self); + $aliases{$alias} = ref $self ? typeof($self) : $self; } 1; diff -r cc2cf8c0edc2 -r 3ed0c58e9da3 lib/IMPL/declare.pm --- a/lib/IMPL/declare.pm Thu Oct 29 03:50:25 2015 +0300 +++ b/lib/IMPL/declare.pm Mon Nov 02 01:56:53 2015 +0300 @@ -2,6 +2,7 @@ use strict; use Carp qw(carp); +use IMPL::lang qw( :base ); use IMPL::Class::PropertyInfo(); use IMPL::Const qw(:access); use IMPL::require(); @@ -16,7 +17,7 @@ return unless $args; - die "A hash reference is required" unless ref $args eq 'HASH'; + die "A hash reference is required" unless ishash($args); no strict 'refs'; no warnings 'once'; @@ -49,7 +50,7 @@ my %ctor; my @isa; - if ( ref $base eq 'ARRAY' ) { + if ( isarray($base) ) { carp "Odd elements number in require" unless scalar(@$base) % 2 == 0; while ( my ( $class, $mapper ) = splice @$base, 0, 2 ) { @@ -62,7 +63,7 @@ $ctor{$class} = $mapper; } } - elsif ( ref $base eq 'HASH' ) { + elsif ( ishash($base) ) { while ( my ( $class, $mapper ) = each %$base ) { _trace("parent $class"); $IMPL::require::level++; @@ -77,18 +78,18 @@ %{"${caller}::CTOR"} = %ctor; push @{"${caller}::ISA"}, @isa; - if ( ref( $args->{meta} ) eq 'ARRAY' ) { + if ( isarray( $args->{meta} ) ) { $caller->SetMeta($_) foreach @{ $args->{meta} }; } my $props = $args->{props} || []; - if ( $props eq 'HASH' ) { + if ( ishash($props) ) { $props = [%$props]; } die "A hash or an array reference is required in the properties list" - unless ref $props eq 'ARRAY'; + unless isarray($props); carp "Odd elements number in properties declaration of $caller" unless scalar(@$props) % 2 == 0;