Mercurial > pub > Impl
changeset 278:4ddb27ff4a0b
core refactoring
line wrap: on
line diff
--- a/Lib/IMPL/AppException.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/AppException.pm Mon Feb 04 02:10:37 2013 +0400 @@ -11,7 +11,7 @@ use IMPL::Const qw(:prop); use IMPL::Resources::Strings { - messageFormat => "Application exception" + message => "Application exception" }; use IMPL::declare { @@ -21,7 +21,6 @@ props => [ source => PROP_RO, callStack => PROP_RO, - _cachedMessage => PROP_RW ] }; @@ -36,18 +35,6 @@ return $instance; } - -sub message { - my ($this) = @_; - - if (my $msg = $this->_cachedMessage) { - return $msg; - } else { - my $formatter = $this->can('messageFormat'); - return $this->_cachedMessage($formatter->($this)); - } -} - sub ToString { my ($this) = @_; @@ -60,4 +47,98 @@ die $self->new(@_); } -1; \ No newline at end of file +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::AppException> - исключение приложения. + +=head1 SYNOPSIS + +=begin code + +package MyException; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::AppException' => undef + ], + props => [ + level => PROP_RO + ] +}; + +use IMPL::Resources::Strings { + message => "Something wrong at level %level%" +}; + +sub CTOR { + my ($this,$level) = @_; + + $this->level($level); +} + +=end code + +=head1 DESCRIPTION + +Для описания собственных исключений в качестве базового класса должен +использоваться C<IMPL::AppException> поскольку он позволяет использовать +C<IMPL::declare> и объявлять свойства. + +C<IMPL::Exception> также является классом для исключений, однако поскольку +он используется в базовых механизмах библиотеки, то в нем не реализованы +механизмы для описания свойсвт. + +Исключение имеет свойство C<message> которое возвращает текст с описанием +проблемы, данное свойство можно реализовать с использованием +C<IMPL::Resources::Strings> для реализации поддержки нескольких языков. + +Особенностью тсключений также является то, что при их создании автоматически +фиксируется место, где оно было создано и свойства C<source> и C<callStack> +заполняются автоматически. + +Для исключений переопределены операторы приведения к строке и к булевому +значению. + +=head1 MEMBERS + +=head2 C<[op]new(@args)> + +Оператор создающий новый экземпляр исключения, сначала создает экземпляр +исключения, затем заполняет свойства C<source>, C<callStack>. + +=head2 C<[op]throw(@args)> + +Создает объект исключения и бросает его. + +=begin code + +throw MyException(10); +MyException->throw(10); # ditto + +=end code + +=head2 C<[get]source> + +Строка с описанием в каком файле и где произошло исключение. см. C<Carp> + +=head2 C<[get]callStack> + +Строка со стеком вызовов в момент возникновения исключения. см. C<Carp> + +=head2 C<[get]message> + +Возвращает описание исключения. + +=head2 C<ToString()> + +Возвращает текстовое представление, как правило это C<message> и C<callStack>. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/AccessorPropertyInfo.pm Mon Feb 04 02:10:37 2013 +0400 @@ -0,0 +1,13 @@ +package IMPL::Class::AccessorPropertyInfo; +use strict; + +BEGIN { + our @ISA = qw(IMPL::Class::PropertyInfo); +} +require IMPL::Class::PropertyInfo; + +our %CTOR = ('IMPL::Class::PropertyInfo' => '@_'); + +__PACKAGE__->mk_accessors(qw(fieldName)); + +1; \ No newline at end of file
--- a/Lib/IMPL/Class/DirectPropertyInfo.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Class/DirectPropertyInfo.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,15 +1,10 @@ package IMPL::Class::DirectPropertyInfo; use strict; -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Class::PropertyInfo' => '@_' - ], - props => [ - fieldName => PROP_RW, - directAccess => PROP_RW - ] -}; +use parent 'IMPL::Class::PropertyInfo'; +our %CTOR = ('IMPL::Class::PropertyInfo' => '@_'); + +__PACKAGE__->mk_accessors(qw(fieldName directAccess)); + 1; \ No newline at end of file
--- a/Lib/IMPL/Class/Member.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Class/Member.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,7 +1,7 @@ package IMPL::Class::Member; use strict; use parent qw(Exporter); -our @EXPORT = qw(&public &private &protected); +our @EXPORT = qw(&public &private &protected &_direct); use IMPL::Const qw(:access); @@ -11,22 +11,28 @@ sub public($) { my $info = shift; $info->{access} = ACCESS_PUBLIC; - my ($class,$implementor) = delete $info->{'class','-implementor'}; - $class->$implementor($info); + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); } sub private($) { my $info = shift; $info->{access} = ACCESS_PRIVATE; - my ($class,$implementor) = delete $info->{'class','-implementor'}; - $class->$implementor($info); + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); } sub protected($) { my $info = shift; $info->{access} = ACCESS_PROTECTED; - my ($class,$implementor) = delete $info->{'class','-implementor'}; - $class->$implementor($info); + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub _direct($) { + my $info = shift; + $info->{direct} = 1; + return $info; } 1;
--- a/Lib/IMPL/Class/MemberInfo.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Class/MemberInfo.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,23 +1,33 @@ package IMPL::Class::MemberInfo; use strict; -use parent qw(IMPL::Object::Accessor); +use IMPL::Const qw(:prop); +BEGIN { + our @ISA = qw(IMPL::Object::Accessor); +} + +require IMPL::Object::Accessor; require IMPL::Exception; +# использовать ClassPropertyImplementor не получится, поскольку он будет +# создавать экземпляры PropertyInfo, который не доописан (в нем не определены +# члены) __PACKAGE__->mk_accessors( qw( name access class - implementor attributes ) ); -__PACKAGE__->PassThroughArgs; + +our %CTOR = ( + 'IMPL::Object::Accessor' => undef +); sub CTOR { my $this = shift; - + die new IMPL::Exception('The name is required for the member') unless $this->name; die new IMPL::Exception('The class is required for the member') unless $this->class; @@ -25,13 +35,6 @@ $this->access(3) unless $this->access; } -sub Implement { - my ($this) = @_; - $this->implementor->Make($this); - $this->class->set_meta($this); - return; -} - 1; __END__
--- a/Lib/IMPL/Class/Property.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Class/Property.pm Mon Feb 04 02:10:37 2013 +0400 @@ -9,7 +9,7 @@ use IMPL::lang qw(:hash); use IMPL::Const qw(:prop); use Carp qw(carp); -require IMPL::Class::Memeber; +require IMPL::Class::Member; sub import { __PACKAGE__->export_to_level(1,@_); @@ -26,16 +26,12 @@ 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, + $class->ClassPropertyImplementor->NormalizeSpecification($attributes), { - -implementor => 'ImplementProperty', + implementor => $class->ClassPropertyImplementor, name => $propName, class => scalar(caller), } @@ -43,11 +39,17 @@ } sub CreateProperty { - my ($class,$propName,$attributes) = @_; + my ($class,$propName,@attributes) = @_; - carp "Using create property is deprecated, use ImplementProperty instead"; - - $class->ImplementProperty($propName,$attributes); + $class + ->ClassPropertyImplementor + ->Implement( + @attributes, + { + name => $propName, + class => $class, + } + ); }; 1;
--- a/Lib/IMPL/Class/Property/Accessor.pm Fri Feb 01 16:37:59 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,35 +0,0 @@ -package IMPL::Class::Property::Accessor; -use strict; -use parent qw(IMPL::Class::Property::Base); - -sub factoryParams { - $_[0]->SUPER::factoryParams, qw($field); -} - -sub RemapFactoryParams { - my ($self,$propInfo) = @_; - - return $self->SUPER::RemapFactoryParams($propInfo),$propInfo->name; -} - -sub GenerateGet { - 'return $this->get($field);'; -} - -sub GenerateSet { - 'return $this->set($field,@_);'; -} - -sub GenerateSetList { - 'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] ); - $this->set($field,$val); - return( wantarray ? @{ $val } : $val );'; -} - -sub GenerateGetList { - 'my $val = $this->get($field); - $this->set($field,$val = IMPL::Object::List->new()) unless $val; - return( wantarray ? @{ $val } : $val );'; -} - -1;
--- a/Lib/IMPL/Class/Property/Base.pm Fri Feb 01 16:37:59 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,202 +0,0 @@ -package IMPL::Class::Property::Base; -use strict; - -use IMPL::Const qw(:all); - -sub factoryParams { qw($class $name $set $get $validator) }; - -my %factoryCache; - -my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; -my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; - -my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; -my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; - -my $validator_code = '$this->$validator(@_);'; - -my %access_code = ( - ACCESS_PUBLIC , "", - ACCESS_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", - ACCESS_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" -); - -my $virtual_call = q( - my $method = $this->can($name); - return $this->$method(@_) unless $method == $accessor or caller->isa($class); -); - -my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"; - -sub GenerateAccessors { - my ($self,$param,@params) = @_; - - my %accessors; - - if (not ref $param) { - if ($param & PROP_LIST) { - $accessors{get} = ($param & PROP_GET) ? $self->GenerateGetList(@params) : undef; - $accessors{set} = ($param & PROP_SET) ? $self->GenerateSetList(@params) : undef; - } else { - $accessors{get} = ($param & PROP_GET) ? $self->GenerateGet(@params) : undef; - $accessors{set} = ($param & PROP_SET) ? $self->GenerateSet(@params) : undef; - } - $accessors{owner} = (($param & PROP_OWNERSET) == PROP_OWNERSET) ? $owner_check : ""; - } elsif (UNIVERSAL::isa($param,'HASH')) { - $accessors{get} = $param->{get} ? $custom_accessor_get : undef; - $accessors{set} = $param->{set} ? $custom_accessor_set : undef; - $accessors{owner} = ""; - } else { - die new IMPL::Exception('The unsupported accessor/mutators supplied',$param); - } - - return \%accessors; -} - -sub GenerateSet { - die new IMPL::Exception("Standard accessors not supported",'Set'); -} - -sub GenerateGet { - die new IMPL::Exception("Standard accessors not supported",'Get'); -} - -sub GenerateGetList { - die new IMPL::Exception("Standard accessors not supported",'GetList'); -} - -sub GenerateSetList { - my ($self) = @_; - die new IMPL::Exception("Standard accessors not supported",'SetList'); -} - -sub Make { - my ($self,$propInfo) = @_; - - my $key = $self->MakeFactoryKey($propInfo); - - my $factoryInfo = $factoryCache{$key}; - - unless ($factoryInfo) { - my $mutators = $self->GenerateAccessors($propInfo->mutators); - $factoryInfo = { - factory => $self->CreateFactory( - $access_code{ $propInfo->access }, - $propInfo->attributes->{validator} ? $validator_code : "", - $mutators->{owner}, - $mutators->{get} || $accessor_get_no, - $mutators->{set} || $accessor_set_no - ), - mutators => $mutators - }; - $factoryCache{$key} = $factoryInfo; - } - - { - no strict 'refs'; - *{ $propInfo->class.'::'.$propInfo->name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo)); - } - - my $mutators = $factoryInfo->{mutators}; - - $propInfo->canGet( $mutators->{get} ? 1 : 0 ); - $propInfo->canSet( $mutators->{set} ? 1 : 0 ); - $propInfo->ownerSet( $mutators->{owner} ); - - 1; -} - -# extract from property info: class, name, get_accessor, set_accessor, validator -sub RemapFactoryParams { - my ($self,$propInfo) = @_; - - my $mutators = $propInfo->mutators; - my $class = $propInfo->class; - my $validator = $propInfo->attributes->{validator}; - - die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); - - return ( - $propInfo->get(qw(class name)), - (ref $mutators? - ($mutators->{set},$mutators->{get}) - : - (undef,undef) - ), - $validator - ); -} - -sub MakeFactoryKey { - my ($self,$propInfo) = @_; - - my ($access,$mutators,$validator) = ($propInfo->get(qw(access mutators)),$propInfo->attributes->{validator}); - - my $implementor = ref $self || $self; - - return join ('', - $implementor, - $access, - $validator ? 'v' : 'n', - ref $mutators ? - ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0) - : - ('s',$mutators) - ); -} - -sub CreateFactory { - my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_; - - my $strParams = join(',',$self->factoryParams); - - my $factory = <<FACTORY; - -sub { - my ($strParams) = \@_; - my \$accessor; - \$accessor = sub { - my \$this = shift; - $codeAccessCheck - if (\@_) { - $codeOwnerCheck - $codeValidator - $codeSet - } else { - $codeGet - } - } -} -FACTORY - - return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") ); -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Базовый класс для реализации свойств. - -По существу свойства состоят из двух методов для установки и получения значений. Также -существует несколько вариантов доступа к свойству, и метод верификации значения. Еще -свойства могут быть виртуальными. - -Для создания реализатора свойств достаточно унаследовать от этого класса и описать -методы для генерации кода получения и установки значения. - -=head1 MEMBERS - -=over - -=item C<Make($propertyInfo)> - -Создает свойство у класса, на основе C<$propertyInfo>, описывающего свойство. C<IMPL::Class::PropertyInfo>. - -=back - -=cut
--- a/Lib/IMPL/Class/Property/Direct.pm Fri Feb 01 16:37:59 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ -package IMPL::Class::Property::Direct; -use strict; - -use parent qw(Exporter IMPL::Object::Accessor IMPL::Class::Property::Base); -our @EXPORT = qw(_direct); - -require IMPL::Object::List; -use IMPL::Class::Property; -require IMPL::Exception; - -__PACKAGE__->mk_accessors( qw(ExportField) ); - -sub factoryParams { - $_[0]->SUPER::factoryParams, qw($field); -} - -my $default = __PACKAGE__->new({ExportField => 1}); - -sub _direct($) { - my ($prop_info) = @_; - $prop_info->implementor( $default ); - return $prop_info; -} - - -sub GenerateGet { - 'return ($this->{$field});'; -} - -sub GenerateSet { - 'return ($this->{$field} = $_[0])'; -} - -sub GenerateSetList { - 'return( - wantarray ? - @{ $this->{$field} = IMPL::Object::List->new( - (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] - )} : - ($this->{$field} = IMPL::Object::List->new( - (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] - )) - );'; -} - -sub GenerateGetList { - 'return( - wantarray ? - @{ $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - } : - ( $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - ) - );'; -} - -sub RemapFactoryParams { - my ($self,$propInfo) = @_; - - return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo); -} - -sub Make { - my ($self,$propInfo) = @_; - - $self->SUPER::Make($propInfo); - - { - no strict 'refs'; - if (ref $self and $self->ExportField) { - my $field = $self->FieldName($propInfo); - *{$propInfo->class.'::'.$propInfo->name} = \$field; - } - } -} - -sub FieldName { - my ($self,$propInfo) = @_; - - my ($class,$name) = $propInfo->get( qw(class name) ); - (my $field = "${class}_$name") =~ s/::/_/g; - return $field; -} - -1;
--- a/Lib/IMPL/Class/PropertyInfo.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Class/PropertyInfo.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,44 +1,23 @@ package IMPL::Class::PropertyInfo; use strict; -use parent qw(IMPL::Class::MemberInfo); +BEGIN { + our @ISA = qw(IMPL::Class::MemberInfo); +} + +require IMPL::Class::MemberInfo; our %CTOR = ( 'IMPL::Class::MemberInfo' => '@_' ); -__PACKAGE__->mk_accessors(qw(type mutators canGet canSet ownerSet isList)); - -my %LoadedModules; - -sub CTOR { - my $this = shift; - - if ( my $type = $this->attributes ? delete $this->attributes->{type} : undef ) { - $this->type($type); - } - - $this->mutators(0) unless defined $this->mutators; -} - -sub implementor { - my $this = shift; - - if (@_) { - $this->SUPER::implementor(@_); - } else { - my $implementor = $this->SUPER::implementor; - return $implementor if $implementor; - - $implementor = $this->SelectImplementor(); - - $this->implementor($implementor); - } - -} - -sub SelectImplementor { - eval {$_[0]->class->_PropertyImplementor} or die new IMPL::Exception('Can\'t find a property implementor for the specified class',$_[0]->Class); -} - +__PACKAGE__->mk_accessors( + qw( + type + getter + setter + ownerSet + isList + ) +); 1; __END__
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Code/AccessorPropertyImplementor.pm Mon Feb 04 02:10:37 2013 +0400 @@ -0,0 +1,84 @@ +package IMPL::Code::AccessorPropertyImplementor; +use strict; + +use IMPL::lang qw(:hash); +use IMPL::require { + Exception => '-IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + AccessorPropertyInfo => '-IMPL::Class::AccessorPropertyInfo' +}; + +require IMPL::Class::AccessorPropertyInfo; +require IMPL::Object::List; + +use parent qw(IMPL::Code::BasePropertyImplementor); + +use constant { + CodeGetAccessor => 'return $this->get($field);', + CodeSetAccessor => 'return $this->set($field,@_);', + CodeSetListAccessor => + 'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] ); + $this->set($field,$val); + return( wantarray ? @{ $val } : $val );', + CodeGetListAccessor => + 'my $val = $this->get($field); + $this->set($field,$val = IMPL::Object::List->new()) unless $val; + return( wantarray ? @{ $val } : $val );' +}; + +sub factoryParams { qw($class $name $get $set $validator $field) }; + +my %cache; + +sub Implement { + my $self = shift; + + my $spec = {}; + + map hashApply($spec,$self->NormalizeSpecification($_)), @_; + + my $name = $spec->{name} + or ArgException->new(name => "The name of the property is required"); + my $class = $spec->{class} + or ArgException->new(name => "The onwer class must be specified"); + + my $id = $self->CreateFactoryId($spec); + my $factory = $cache{$id}; + unless($factory) { + $factory = $self->CreateFactory($spec); + $cache{$id} = $factory; + } + + my $field = $name; + + my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field); + + my $args = { + getter => $spec->{get} ? $accessor : undef, + setter => $spec->{set} ? $accessor : undef, + ownetSet => $spec->{ownerSet} ? 1 : 0, + isList => $spec->{isList} ? 1 : 0, + name => $spec->{name}, + class => $spec->{class}, + type => $spec->{type}, + access => $spec->{access}, + fieldName => $field + }; + + delete @$spec{qw(get set ownerSet isList name class type access field direct)}; + + $args->{attributes} = $spec; + + my $propInfo = AccessorPropertyInfo->new($args); + + { + no strict 'refs'; + *{"${class}::$name"} = $accessor; + } + + $class->SetMeta($propInfo); + + return $propInfo; +} + +1; \ No newline at end of file
--- a/Lib/IMPL/Code/BasePropertyImplementor.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Code/BasePropertyImplementor.pm Mon Feb 04 02:10:37 2013 +0400 @@ -45,7 +45,8 @@ get => $spec & PROP_GET, set => $spec & PROP_SET, isList => $spec & PROP_LIST, - ownerSet => $spec & PROP_OWNERSET + ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET), + direct => $spec & PROP_DIRECT }; } @@ -54,14 +55,14 @@ join( '', map( - $_ - ? ref $_ eq 'CODE' + ($_ + ? (ref $_ eq 'CODE' ? 'x' - : 's' - : '_', + : 's') + : '_'), @$spec{qw(get set)} ), - $spec->{access}, + $spec->{access} || ACCESS_PUBLIC, $spec->{validator} ? 'v' : '_', $spec->{isList} ? 'l' : '_', $spec->{ownerSet} ? 'o' : '_' @@ -72,20 +73,26 @@ my ($self,$spec) = @_; return $self->CreateFactoryImpl( - $spec->{get} - ? ref $spec->{get} eq 'CODE' + ($spec->{get} + ? (ref $spec->{get} eq 'CODE' ? $self->CodeCustomGetAccessor - : $spec->{isList} - ? $spec->CodeGetListAccessor - : $spec->CodeGetAccessor - : $spec->CodeNoGetAccessor, - $spec->{set} - ? ref $spec->{set} eq 'CODE' + : ($spec->{isList} + ? $self->CodeGetListAccessor + : $self->CodeGetAccessor + ) + ) + : $self->CodeNoGetAccessor + ), + ($spec->{set} + ? (ref $spec->{set} eq 'CODE' ? $self->CodeCustomSetAccessor - : $spec->{isList} - ? $spec->CodeSetListAccessor - : $spec->CodeSetAccessor - : $spec->CodeNoSetAccessor, + : ($spec->{isList} + ? $self->CodeSetListAccessor + : $self->CodeSetAccessor + ) + ) + : $self->CodeNoSetAccessor + ), $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '', $spec->{validator} ? $self->CodeValidator : '', $spec->{ownerSet} ? $self->CodeOwnerCheck : ''
--- a/Lib/IMPL/Code/DirectPropertyImplementor.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Code/DirectPropertyImplementor.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,9 +1,13 @@ package IMPL::Code::DirectPropertyImplementor; use strict; +require IMPL::Object::List; + +use IMPL::lang qw(:hash); use IMPL::require { Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' + ArgException => '-IMPL::InvalidArgumentException', + DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo' }; use parent qw(IMPL::Code::BasePropertyImplementor); @@ -33,20 +37,22 @@ );' }; -sub factoryParams { qw($class $name $set $get $validator $field) }; +sub factoryParams { qw($class $name $get $set $validator $field) }; my %cache; sub Implement { - my ($self, $spec) = @_; + my $self = shift; + + my $spec = {}; + + map hashApply($spec,$self->NormalizeSpecification($_)), @_; my $name = $spec->{name} or ArgException->new(name => "The name of the property is required"); my $class = $spec->{class} or ArgException->new(name => "The onwer class must be specified"); - $spec = $self->NormalizeSpecification($spec); - my $id = $self->CreateFactoryId($spec); my $factory = $cache{$id}; unless($factory) { @@ -54,9 +60,37 @@ $cache{$id} = $factory; } + my $field = join( '_', split(/::/, $class), $name); + my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field); + my $args = { + getter => $spec->{get} ? $accessor : undef, + setter => $spec->{set} ? $accessor : undef, + ownetSet => $spec->{ownerSet} ? 1 : 0, + isList => $spec->{isList} ? 1 : 0, + name => $spec->{name}, + class => $spec->{class}, + type => $spec->{type}, + access => $spec->{access}, + fieldName => $field, + directAccess => $spec->{direct} + }; + delete @$spec{qw(get set ownerSet isList name class type access field direct)}; + + $args->{attributes} = $spec; + + my $propInfo = DirectPropertyInfo->new($args); + + { + no strict 'refs'; + *{"${class}::$name"} = $accessor; + *{"${class}::$name"} = \$field if $args->{directAccess}; + } + $class->SetMeta($propInfo); + + return $propInfo; } 1; \ No newline at end of file
--- a/Lib/IMPL/Code/Loader.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Code/Loader.pm Mon Feb 04 02:10:37 2013 +0400 @@ -42,6 +42,7 @@ if ($this->verifyNames) { $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/ or die ArgumentException->new(package => 'Invalid package name') ; + $package = $1; } $package = $this->prefix . '::' . $package if $this->prefix;
--- a/Lib/IMPL/Config.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Config.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,6 +2,7 @@ use strict; use warnings; +use IMPL::Const qw(:access); use IMPL::declare { base => [ 'IMPL::Object::Accessor' => undef, @@ -28,7 +29,7 @@ my $class = ref $self || $self; my $serializer = new IMPL::Serializer( - Formatter => new IMPL::Serialization::XmlFormatter( + formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1 ) @@ -52,7 +53,7 @@ my ($this,$file) = @_; my $serializer = new IMPL::Serializer( - Formatter => new IMPL::Serialization::XmlFormatter( + formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1 ) @@ -66,7 +67,7 @@ sub xml { my $this = shift; my $serializer = new IMPL::Serializer( - Formatter => new IMPL::Serialization::XmlFormatter( + formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1 ) @@ -89,8 +90,8 @@ $val = $this->rawGet($_) and $ctx->AddVar($_ => $val) foreach map $_->Name, $this->get_meta( 'IMPL::Class::PropertyInfo', sub { - $_->Access == IMPL::Class::Member::MOD_PUBLIC and - $_->canGet; + $_->access == ACCESS_PUBLIC and + $_->setter; }, 1); }
--- a/Lib/IMPL/Const.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Const.pm Mon Feb 04 02:10:37 2013 +0400 @@ -14,6 +14,7 @@ &PROP_OWNERSET &PROP_LIST &PROP_ALL + &PROP_DIRECT ) ], prop => [ @@ -25,6 +26,7 @@ &PROP_ALL &PROP_RO &PROP_RW + &PROP_DIRECT ) ], access => [ @@ -49,7 +51,8 @@ PROP_LIST => 4, PROP_ALL => 3, PROP_RW => 3, - PROP_RO => 11 + PROP_RO => 11, + PROP_DIRECT => 16 }; 1; \ No newline at end of file
--- a/Lib/IMPL/DOM/Navigator.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Navigator.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; BEGIN { private _direct property _path => prop_all; private _direct property _state => prop_all;
--- a/Lib/IMPL/DOM/Navigator/Builder.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Navigator/Builder.pm Mon Feb 04 02:10:37 2013 +0400 @@ -6,7 +6,6 @@ use parent qw(IMPL::DOM::Navigator); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; require IMPL::DOM::Navigator::SchemaNavigator; require IMPL::DOM::Schema::ValidationError; use IMPL::DOM::Document;
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Mon Feb 04 02:10:37 2013 +0400 @@ -3,7 +3,6 @@ use warnings; use IMPL::Class::Property; -use IMPL::Class::Property::Direct; require IMPL::DOM::Schema::ComplexType; require IMPL::DOM::Schema::NodeSet;
--- a/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Mon Feb 04 02:10:37 2013 +0400 @@ -5,7 +5,6 @@ use parent qw(IMPL::DOM::Navigator); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; require IMPL::DOM::Navigator::SchemaNavigator; use IMPL::DOM::Document;
--- a/Lib/IMPL/DOM/Node.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Node.pm Mon Feb 04 02:10:37 2013 +0400 @@ -6,7 +6,6 @@ use IMPL::Object::List; use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use Scalar::Util qw(weaken); use IMPL::Exception;
--- a/Lib/IMPL/DOM/Property.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Property.pm Mon Feb 04 02:10:37 2013 +0400 @@ -9,7 +9,7 @@ sub _dom($) { my ($prop_info) = @_; - $prop_info->attributes->{domProperty} = 1; + $prop_info->{domProperty} = 1; return $prop_info; }
--- a/Lib/IMPL/DOM/Schema.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Schema.pm Mon Feb 04 02:10:37 2013 +0400 @@ -22,7 +22,6 @@ use parent qw(IMPL::DOM::Document); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use File::Spec; our %CTOR = (
--- a/Lib/IMPL/DOM/Schema/ComplexType.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Schema/ComplexType.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::DOM::Schema::ComplexNode); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use IMPL::DOM::Property qw(_dom); BEGIN {
--- a/Lib/IMPL/DOM/Schema/Node.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Schema/Node.pm Mon Feb 04 02:10:37 2013 +0400 @@ -5,7 +5,6 @@ use parent qw(IMPL::DOM::Node); use IMPL::Class::Property; use IMPL::DOM::Property qw(_dom); -use IMPL::Class::Property::Direct; BEGIN { public _dom _direct property minOccur => prop_all;
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::DOM::Schema::Node); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use IMPL::DOM::Property qw(_dom); BEGIN {
--- a/Lib/IMPL/DOM/Schema/SimpleType.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleType.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::DOM::Schema::SimpleNode); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use IMPL::DOM::Property qw(_dom); BEGIN {
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Mon Feb 04 02:10:37 2013 +0400 @@ -8,7 +8,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use IMPL::Resources::Format qw(FormatMessage); BEGIN {
--- a/Lib/IMPL/DOM/XMLReader.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/DOM/XMLReader.pm Mon Feb 04 02:10:37 2013 +0400 @@ -5,7 +5,6 @@ use parent qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use XML::Parser; use IMPL::require {
--- a/Lib/IMPL/Exception.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Exception.pm Mon Feb 04 02:10:37 2013 +0400 @@ -11,7 +11,6 @@ } use parent qw(IMPL::Object::Abstract Error Class::Accessor); -require IMPL::Class::Property::Accessor; BEGIN { __PACKAGE__->mk_accessors( qw(Message Args CallStack Source) ); @@ -85,10 +84,6 @@ ($this->Message || ref $this) . join("\n",'',map { my $s = $_; local $_; indent("$s",1) } @{$this->Args} ) . ( $notrace ? '' : "\n" . $this->CallStack); } -sub _PropertyImplementor { - 'IMPL::Class::Property::Accessor' -} - package IMPL::InvalidOperationException; our @ISA = qw(IMPL::Exception); __PACKAGE__->PassThroughArgs;
--- a/Lib/IMPL/ORM/Entity.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/ORM/Entity.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; BEGIN { public _direct property Name => prop_get;
--- a/Lib/IMPL/ORM/Object.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/ORM/Object.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; require IMPL::ORM::Entity; require IMPL::ORM::Schema::Entity;
--- a/Lib/IMPL/ORM/PropertyImplementor.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/ORM/PropertyImplementor.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,7 +2,6 @@ use strict; use warnings; -use parent qw(IMPL::Class::Property::Direct); 1;
--- a/Lib/IMPL/Object.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,8 +2,9 @@ use strict; use parent qw(IMPL::Object::Abstract); -require IMPL::Class::Property::Direct; -use IMPL::Const qw(:prop); +use IMPL::require { + ClassPropertyImplementor => 'IMPL::Code::DirectPropertyImplementor' +}; sub surrogate { bless {}, ref $_[0] || $_[0]; @@ -17,22 +18,6 @@ $self; } -sub _PropertyImplementor { - 'IMPL::Class::Property::Direct' -} - -sub ImplementProperty { - my ($self,$name,$attributes) = @_; - - $attributes = { - get => $attributes & PROP_GET, - set => $attributes & PROP_SET, - isList => $attributes & PROP_LIST - } unless ref $attributes; - - $self->_ProppertyImplementor->Implement($name,$attributes); -} - 1; __END__
--- a/Lib/IMPL/Object/Accessor.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/Accessor.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,8 +1,16 @@ package IMPL::Object::Accessor; use strict; -use parent qw(IMPL::Object::Abstract Class::Accessor IMPL::Class::Meta); + +use parent qw( + IMPL::Object::Abstract + Class::Accessor +); -require IMPL::Class::Property::Accessor; +use IMPL::require { + ClassPropertyImplementor => '-IMPL::Code::AccessorPropertyImplementor' +}; + +require IMPL::Code::AccessorPropertyImplementor; sub new { my $class = shift; @@ -15,10 +23,4 @@ $_[0]->Class::Accessor::new; } -__PACKAGE__->static_accessor( propertyInfoClass => 'IMPL::Class::AccessorPropertyInfo' ); - -sub _PropertyImplementor { - 'IMPL::Class::Property::Accessor' -} - 1;
--- a/Lib/IMPL/Object/Autofill.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/Autofill.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,6 +1,7 @@ package IMPL::Object::Autofill; use strict; -use IMPL::Class::Property; + +use IMPL::Const qw(:access); sub CTOR { my $this = shift; @@ -51,18 +52,17 @@ HEADER - if ($class->can('get_meta')) { + if ($class->can('GetMeta')) { # meta supported foreach my $prop_info (grep { - my $mutators = $_->mutators; - ref $mutators ? (exists $mutators->{set}) : ($mutators & prop_set || $_->implementor->isa('IMPL::Class::Property::Direct')); - } $class->get_meta('IMPL::Class::PropertyInfo')) { + $_->setter && ($_->access & ACCESS_PUBLIC); + } $class->GetMeta('IMPL::Class::PropertyInfo')) { my $name = $prop_info->name; - if (ref $prop_info->mutators || !$prop_info->implementor->isa('IMPL::Class::Property::Direct')) { + if ($prop_info->isa('IMPL::Class::DirectPropertyInfo')) { $text .= " \$this->$name(\$fields->{$name}) if exists \$fields->{$name};\n"; } else { - my $fld = $prop_info->implementor->FieldName($prop_info); - if ($prop_info->mutators & prop_list) { + my $fld = $prop_info->fieldName; + if ($prop_info->isList) { $text .= " \$this->{$fld} = IMPL::Object::List->new ( ref \$fields->{$name} ? \$fields->{$name} : [\$fields->{$name}] ) if exists \$fields->{$name};\n"; } else { $text .= " \$this->{$fld} = \$fields->{$name} if exists \$fields->{$name};\n";
--- a/Lib/IMPL/Object/EventSource.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/EventSource.pm Mon Feb 04 02:10:37 2013 +0400 @@ -67,7 +67,6 @@ package IMPL::Object::EventSource::EventTable; use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use Scalar::Util qw(weaken); use overload
--- a/Lib/IMPL/Object/List.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/List.pm Mon Feb 04 02:10:37 2013 +0400 @@ -3,7 +3,7 @@ use warnings; use parent qw(IMPL::Object::ArrayObject); -use IMPL::Exception; +require IMPL::Exception; sub as_list { return $_[0];
--- a/Lib/IMPL/Object/Meta.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/Meta.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,21 +2,23 @@ use strict; use warnings; -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property Container => prop_get | owner_set; -} +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Object' => undef + ], + props => [ + owner => PROP_RO + ] +}; sub meta { my $class = shift; my $caller = caller; my $meta = $class->surrogate(); - $meta->IMPL::Object::Meta::Container(scalar caller); + $meta->owner(scalar caller); $meta->callCTOR(@_); - $caller->set_meta($meta); + $caller->SetMeta($meta); } 1;
--- a/Lib/IMPL/Object/PublicSerializable.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/PublicSerializable.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,7 +1,7 @@ package IMPL::Object::PublicSerializable; use strict; -use IMPL::Class::Member; +use IMPL::Const qw(:access); sub restore { my ($class,$data,$refSurrogate) = @_; @@ -22,13 +22,13 @@ my $val; defined($val = $this->$_()) and $ctx->AddVar($_,$val) foreach - map $_->Name,$this->get_meta( + map $_->name,$this->GetMeta( 'IMPL::Class::PropertyInfo', sub { - $_->Access == IMPL::Class::Member::MOD_PUBLIC and - $_->canGet and + $_->access == ACCESS_PUBLIC and + $_->getter and not $_->ownerSet and - not $seen{$_->Name} ++ + not $seen{$_->name} ++ }, 1 );
--- a/Lib/IMPL/Object/Serializable.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Object/Serializable.pm Mon Feb 04 02:10:37 2013 +0400 @@ -38,9 +38,9 @@ SAVE_METHOD $code .= - join "\n", map " ".'$ctx->AddVar('.$_->Name.' => ' . - ((not ref $_->Mutators and $_->Mutators & prop_list) ? ('[$this->'.$_->Class.'::'.$_->Name.'()]') : ('$this->'.$_->Class.'::'.$_->Name.'()')) . - ') if defined ' . '$this->'.$_->Class.'::'.$_->Name.'()' . ';', grep $_->canGet, $class->get_meta('IMPL::Class::PropertyInfo',undef,1); + join "\n", map " ".'$ctx->AddVar('.$_->name.' => ' . + ($_->isList ? ('[$this->'.$_->class.'::'.$_->name.'()]') : ('$this->'.$_->class.'::'.$_->name.'()')) . + ') if defined ' . '$this->'.$_->class.'::'.$_->name.'()' . ';', grep $_->setter, $class->get_meta('IMPL::Class::PropertyInfo',undef,1); $code .= <<SAVE_METHOD; }
--- a/Lib/IMPL/SQL/Schema.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,54 +1,54 @@ use strict; package IMPL::SQL::Schema; - -use IMPL::lang qw(is :declare); - -use parent qw( - IMPL::Object - IMPL::Object::Disposable - IMPL::Object::Autofill - IMPL::Object::Clonable -); +use mro; -use IMPL::Class::Property::Direct; - -require IMPL::SQL::Schema::Table; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public _direct property version => PROP_GET; - public _direct property name => PROP_GET; - private _direct property tables => PROP_GET; -} +use IMPL::lang qw(is); +use IMPL::Const qw(:prop); +use Scalar::Util qw(reftype); +use IMPL::declare { + require => { + Table => 'IMPL::SQL::Schema::Table' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Disposable' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Clonable' => undef, + ], + props => [ + version => PROP_RO | PROP_DIRECT, + name => PROP_RO | PROP_DIRECT, + _tables => PROP_RO | PROP_DIRECT + ] +}; sub AddTable { my ($this,$table) = @_; - if (UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table')) { + if (is($table,Table)) { - $table->Schema == $this or die new IMPL::InvalidOperationException('The specified table must belong to the database'); - not exists $this->{$tables}->{$table->name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + $table->schema == $this or die new IMPL::InvalidOperationException('The specified table must belong to the database'); + not exists $this->{$_tables}->{$table->name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); - } elsif (UNIVERSAL::isa($table,'HASH')) { + } elsif (reftype($table) eq 'HASH') { - not exists $this->{$tables}->{$table->{'name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + not exists $this->{$_tables}->{$table->{'name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); $table = { %$table }; $table->{'schema'} = $this; - $table = new IMPL::SQL::Schema::Table(%{$table}); + $table = Table->new(%{$table}); } else { die new IMPL::InvalidArgumentException('Either a table object or a hash with table parameters is required'); } - $this->{$tables}{$table->name} = $table; + $this->{$_tables}{$table->name} = $table; } sub RemoveTable { my ($this,$table) = @_; - my $tn = UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table->name : $table; + my $tn = is($table,Table) ? $table->name : $table; - $table = delete $this->{$tables}{$tn} or die new IMPL::InvalidArgumentException('The table doesn\'t exists',$tn); + $table = delete $this->{$_tables}{$tn} or die new IMPL::InvalidArgumentException('The table doesn\'t exists',$tn); # drop foreign keys map { $_->table->RemoveConstraint($_) } values %{$table->primaryKey->connectedFK} if $table->primaryKey; @@ -62,39 +62,39 @@ sub ResolveTable { my ($this,$table) = @_; - UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table : $this->{$tables}{$table}; + is($table,Table) ? $table : $this->{$_tables}{$table}; } sub GetTable { my ($this,$tableName) = @_; - return $this->{$tables}{$tableName}; + return $this->{$_tables}{$tableName}; } sub GetTables { my ($this) = @_; - return wantarray ? values %{$this->{$tables}} : [values %{$this->{$tables}}]; + return wantarray ? values %{$this->{$_tables}} : [values %{$this->{$_tables}}]; } sub RenameTable { my ($this,$oldName,$newName) = @_; - die new IMPL::InvalidOperationException("A source table doesn't exists", $oldName) unless exists $this->{$tables}{$oldName}; - die new IMPL::InvalidOperationException("A target table already exists", $newName) if exists $this->{$tables}{$newName}; + die new IMPL::InvalidOperationException("A source table doesn't exists", $oldName) unless exists $this->{$_tables}{$oldName}; + die new IMPL::InvalidOperationException("A target table already exists", $newName) if exists $this->{$_tables}{$newName}; - my $table = delete $this->{$tables}{$oldName}; + my $table = delete $this->{$_tables}{$oldName}; $table->_setName($newName); - $this->{$tables}{$newName} = $table; + $this->{$_tables}{$newName} = $table; } sub Dispose { my ($this) = @_; - $_->Dispose foreach values %{$this->{$tables}}; + $_->Dispose foreach values %{$this->{$_tables}}; - delete $this->{$tables}; + delete $this->{$_tables}; - $this->SUPER::Dispose; + $this->next::method(); } 1;
--- a/Lib/IMPL/SQL/Schema/Column.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Column.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,20 +1,22 @@ use strict; package IMPL::SQL::Schema::Column; -use parent qw(IMPL::Object IMPL::Object::Autofill); -use IMPL::lang qw( :DEFAULT :compare :declare :hash ); -use IMPL::Class::Property::Direct; +use IMPL::lang qw( :DEFAULT :compare :hash ); use IMPL::Exception(); - -BEGIN { - public _direct property name => PROP_GET; - public _direct property type => PROP_GET; - public _direct property isNullable => PROP_GET; - public _direct property defaultValue => PROP_GET; - public _direct property tag => PROP_GET; -} - -__PACKAGE__->PassThroughArgs; +use IMPL::Const qw(:prop); +use IMPL::declare { + 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 + ] +}; sub CTOR { my $this = shift;
--- a/Lib/IMPL/SQL/Schema/Constraint.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,18 +2,19 @@ use strict; use warnings; -use IMPL::lang qw(:declare is isclass); - -use parent qw(IMPL::Object IMPL::Object::Disposable); - -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property name => PROP_GET; - public _direct property table => PROP_GET; -} - -public property columns => PROP_GET | PROP_LIST | PROP_OWNERSET; +use IMPL::lang qw(is isclass); +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Disposable' => undef + ], + props => [ + name => PROP_RO | PROP_DIRECT, + table => PROP_RO | PROP_DIRECT, + columns => PROP_RO | PROP_LIST + ] +}; my %aliases;
--- a/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Mon Feb 04 02:10:37 2013 +0400 @@ -6,7 +6,6 @@ use parent qw(IMPL::SQL::Schema::Constraint); -use IMPL::Class::Property::Direct; BEGIN { public _direct property referencedPrimaryKey => PROP_GET;
--- a/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,7 +2,6 @@ use strict; use parent qw(IMPL::SQL::Schema::Constraint::Index); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; __PACKAGE__->PassThroughArgs; __PACKAGE__->RegisterAlias('pk');
--- a/Lib/IMPL/SQL/Schema/Table.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Table.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,30 +1,29 @@ +package IMPL::SQL::Schema::Table; use strict; -package IMPL::SQL::Schema::Table; - -use IMPL::lang qw(:declare is); -use parent qw( - IMPL::Object - IMPL::Object::Disposable -); +use IMPL::lang qw(is); +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Disposable' => undef + ], + props => [ + name => PROP_RO | PROP_DIRECT, + schema => PROP_RO | PROP_DIRECT, + columns => PROP_RO | PROP_DIRECT, + constraints => PROP_RO | PROP_DIRECT, + columnsByName => PROP_RO | PROP_DIRECT, + primaryKey => PROP_RO | PROP_DIRECT, + tag => PROP_RW | PROP_DIRECT, + ] +}; require IMPL::SQL::Schema::Column; require IMPL::SQL::Schema::Constraint; require IMPL::SQL::Schema::Constraint::PrimaryKey; require IMPL::SQL::Schema::Constraint::ForeignKey; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property name => PROP_GET; - public _direct property schema => PROP_GET; - public _direct property columns => PROP_GET; - public _direct property constraints => PROP_GET; - public _direct property columnsByName => 0; - public _direct property primaryKey => PROP_GET; - public _direct property tag => PROP_ALL; -} - sub CTOR { my ($this,%args) = @_;
--- a/Lib/IMPL/SQL/Schema/Traits/Formatter.pm Fri Feb 01 16:37:59 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -package IMPL::SQL::Traits::Formatter; -use parent qw(IMPL::Object); - -sub ToSQL { - my ($this,$sequence) = @_; -} - - -1;
--- a/Lib/IMPL/SQL/Schema/Traits/mysql.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits/mysql.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,7 +2,6 @@ use strict; use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; BEGIN { public _direct property SqlBatch => prop_all; @@ -468,10 +467,8 @@ } package IMPL::SQL::Schema::Traits::mysql; -use Common; use parent qw(IMPL::SQL::Schema::Traits); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; BEGIN { public _direct property PendingConstraints => prop_none; @@ -512,10 +509,8 @@ } package IMPL::SQL::Schema::Traits::mysql::MetaTable; -use Common; use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; BEGIN { public _direct property DBHandle => prop_none;
--- a/Lib/IMPL/SQL/Schema/TraitsOld.pm Fri Feb 01 16:37:59 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,275 +0,0 @@ -package IMPL::SQL::Schema::Traits; -use strict; -use parent qw(IMPL::Object IMPL::Object::Autofill); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -use constant { - STATE_NORMAL => 0, - STATE_UPDATED => 1, - STATE_CREATED => 2, - STATE_REMOVED => 3, - STATE_PENDING => 4 -} ; - -BEGIN { - public _direct property SrcSchema => prop_all; - public _direct property DstSchema => prop_all; - public _direct property PendingActions => prop_get; - public _direct property TableInfo => prop_get; - public _direct property Handler => prop_get; - public _direct property TableMap => prop_none; - public _direct property KeepTables => prop_all; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - $this->{$SrcSchema} or die new IMPL::InvalidArgumentException('A source schema is required'); - $this->{$DstSchema} or die new IMPL::InvalidArgumentException('A destination schema is required'); - $this->{$Handler} or die new IMPL::InvalidArgumentException('A handler is required to produce the update batch'); - - $this->{$TableInfo} = {}; - $this->{$PendingActions} = []; - -} - -sub UpdateTable { - my ($this,$srcTable) = @_; - - return 1 if $this->{$TableInfo}->{$srcTable->Name}->{'processed'}; - - my $dstTableName = $this->{$TableMap}->{$srcTable->Name} ? $this->{$TableMap}->{$srcTable->Name} : $srcTable->Name; - my $dstTable = $this->{$DstSchema}->Tables->{$dstTableName}; - - $this->{$TableInfo}->{$srcTable->Name}->{'processed'} = 1; - - if (not $dstTable) { - $this->DropTable($srcTable) if not $this->{$KeepTables}; - return 1; - } - - if ( not grep {$srcTable->Column($_->Name)} @{$dstTable->Columns} ) { - - $this->{$TableInfo}->{$srcTable->Name}->{'NewName'} = $dstTable->Name if $srcTable->Name ne $dstTable->Name; - - $this->DropTable($srcTable); - $this->CreateTable($dstTable); - - return 1; - } - - if ($srcTable->Name ne $dstTableName) { - $this->RenameTable($srcTable,$dstTableName); - } - - my %dstConstraints = %{$dstTable->Constraints}; - - foreach my $srcConstraint (values %{$srcTable->Constraints}) { - if (my $dstConstraint = delete $dstConstraints{$srcConstraint->Name}) { - $this->UpdateConstraint($srcConstraint,$dstConstraint); - } else { - $this->DropConstraint($srcConstraint); - } - } - - my $i = 0; - my %dstColumns = map { $_->Name, $i++} @{$dstTable->Columns} ; - - # сначала удаляем столбцы - # потом добавляем недостающие и изменяем столбцы в нужном порядке - - my @columnsToUpdate; - - foreach my $srcColumn (@{$srcTable->Columns}) { - if (defined (my $dstColumnIndex = delete $dstColumns{$srcColumn->Name})) { - push @columnsToUpdate, { Action => 'update', ColumnSrc => $srcColumn, ColumnDst => $dstTable->ColumnAt($dstColumnIndex), NewPosition => $dstColumnIndex}; - } else { - $this->DropColumn($srcTable,$srcColumn); - } - } - push @columnsToUpdate, map { {Action => 'add', ColumnDst => $dstTable->ColumnAt($_), NewPosition => $_} } values %dstColumns; - - foreach my $action (sort {$a->{'NewPosition'} <=> $b->{'NewPosition'}} @columnsToUpdate ) { - if ($action->{'Action'} eq 'update') { - $this->UpdateColumn($srcTable,@$action{'ColumnSrc','ColumnDst'},$dstTable,$action->{'NewPosition'}); # change type and position - }elsif ($action->{'Action'} eq 'add') { - $this->AddColumn($srcTable,$action->{'ColumnDst'},$dstTable,$action->{'NewPosition'}); # add at specified position - } - } - - foreach my $dstConstraint (values %dstConstraints) { - $this->AddConstraint($dstConstraint); - } - - $this->{$TableInfo}{$srcTable->Name}{'State'} = STATE_UPDATED; -} - -sub UpdateConstraint { - my ($this,$src,$dst) = @_; - - if (not ConstraintEquals($src,$dst)) { - if (UNIVERSAL::isa($src,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - $this->UpdateTable($_->Table) foreach values %{$src->ConnectedFK}; - } - $this->DropConstraint($src); - $this->AddConstraint($dst); - } else { - $this->{$TableInfo}->{$this->MapTableName($src->Table->Name)}->{'Constraints'}->{$src->Name} = STATE_UPDATED; - } -} - -sub ConstraintEquals { - my ($src,$dst) = @_; - - ref $src eq ref $dst or return 0; - - my @dstColumns = @{$dst->Columns}; - scalar(@{$src->Columns}) == scalar(@{$dst->Columns}) and not grep { my $column = shift @dstColumns; not $column->isSame($_) } @{$src->Columns} or return 0; - - not UNIVERSAL::isa($src,'IMPL::SQL::Schema::Constraint::ForeignKey') or ConstraintEquals($src->ReferencedPrimaryKey,$dst->ReferencedPrimaryKey) or return 0; - - 1; -} - -sub UpdateSchema { - my ($this) = @_; - - my %Updated = map { $this->UpdateTable($_); $this->MapTableName($_->Name) , 1; } values %{$this->{$SrcSchema}->Tables ? $this->{$SrcSchema}->Tables : {} }; - - $this->CreateTable($_) foreach grep {not $Updated{$_->Name}} values %{$this->{$DstSchema}->Tables}; - - $this->ProcessPendingActions(); -} - -sub RenameTable { - my ($this,$tblSrc,$tblDstName) = @_; - - $this->{$Handler}->AlterTableRename($tblSrc->Name,$tblDstName); - $this->{$TableInfo}->{$tblSrc->Name}->{'NewName'} = $tblDstName; -} - -sub MapTableName { - my ($this,$srcName) = @_; - - $this->{$TableInfo}->{$srcName}->{'NewName'} ? $this->{$TableInfo}->{$srcName}->{'NewName'} : $srcName; -} - -sub DropTable { - my ($this,$tbl) = @_; - - if ($tbl->PrimaryKey) { - $this->UpdateTable($_->Table) foreach values %{$tbl->PrimaryKey->ConnectedFK}; - } - - $this->{$Handler}->DropTable($this->MapTableName($tbl->Name)); - $this->{$TableInfo}{$this->MapTableName($tbl->Name)}{'State'} = STATE_REMOVED; - $this->{$TableInfo}{$this->MapTableName($tbl->Name)}{'Constraints'} = {map {$_,STATE_REMOVED} keys %{$tbl->Constraints}}; - $this->{$TableInfo}{$this->MapTableName($tbl->Name)}{'Columns'} = {map { $_->Name, STATE_REMOVED} @{$tbl->Columns}}; - - return 1; -} - -sub CreateTable { - my ($this,$tbl) = @_; - - # создаем таблицу, кроме внешних ключей - $this->{$Handler}->CreateTable($tbl,skip_foreign_keys => 1); - - $this->{$TableInfo}->{$tbl->Name}->{'State'} = STATE_CREATED; - - $this->{$TableInfo}->{$tbl->Name}->{'Columns'} = {map { $_->Name, STATE_CREATED } @{$tbl->Columns}}; - $this->{$TableInfo}->{$tbl->Name}->{'Constraints'} = {map {$_->Name, STATE_CREATED} grep { not UNIVERSAL::isa($_,'IMPL::SQL::Schema::Constraint::ForeignKey') } values %{$tbl->Constraints}}; - - $this->AddConstraint($_) foreach grep { UNIVERSAL::isa($_,'IMPL::SQL::Schema::Constraint::ForeignKey') } values %{$tbl->Constraints}; - - return 1; -} - -sub AddColumn { - my ($this,$tblSrc,$column,$tblDst,$pos) = @_; - - $this->{$Handler}->AlterTableAddColumn($this->MapTableName($tblSrc->Name),$column,$tblDst,$pos); - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$column->Name} = STATE_CREATED; - - return 1; -} - -sub DropColumn { - my ($this,$tblSrc,$column) = @_; - $this->{$Handler}->AlterTableDropColumn($this->MapTableName($tblSrc->Name),$column->Name); - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$column->Name} = STATE_REMOVED; - - return 1; -} - -sub UpdateColumn { - my ($this,$tblSrc,$srcColumn,$dstColumn,$tblDst,$pos) = @_; - - if ($srcColumn->isSame($dstColumn) and $pos < @{$tblSrc->Columns} and $tblSrc->ColumnAt($pos) == $srcColumn) { - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$dstColumn->Name} = STATE_UPDATED; - return 1; - } - - $this->{$Handler}->AlterTableChangeColumn($this->MapTableName($tblSrc->Name),$dstColumn,$tblDst,$pos); - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$dstColumn->Name} = STATE_UPDATED; - - return 1; -} - -sub DropConstraint { - my ($this,$constraint) = @_; - - $this->{$Handler}->AlterTableDropConstraint($this->MapTableName($constraint->Table->Name),$constraint); - $this->{$TableInfo}->{$constraint->Table->Name}->{'Constraints'}->{$constraint->Name} = STATE_REMOVED; - - return 1; -} - -sub IfUndef { - my ($value,$default) = @_; - - return defined $value ? $value : $default; -} - -sub AddConstraint { - my ($this,$constraint) = @_; - - # перед добавлением ограничения нужно убедиться в том, что созданы все необходимые столбцы и сопутствующие - # ограничения (например первичные ключи) - - my $pending; - - $pending = grep { - my $column = $_; - not grep { - IfUndef($this->{$TableInfo}{$constraint->Table->Name}{'Columns'}{$column->Name}, STATE_NORMAL) == $_ - } (STATE_UPDATED, STATE_CREATED) - } @{$constraint->Columns}; - - if ($pending) { - push @{$this->{$PendingActions}},{Action => \&AddConstraint, Args => [$constraint]}; - return 2; - } else { - if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::ForeignKey')) { - if (not grep { IfUndef($this->{$TableInfo}{$constraint->ReferencedPrimaryKey->Table->Name}{'Constraints'}{$constraint->ReferencedPrimaryKey->Name},STATE_NORMAL) == $_} (STATE_UPDATED, STATE_CREATED)) { - push @{$this->{$PendingActions}},{Action => \&AddConstraint, Args => [$constraint]}; - return 2; - } - } - $this->{$Handler}->AlterTableAddConstraint($constraint->Table->Name,$constraint); - $this->{$TableInfo}->{$constraint->Table->Name}->{'Constraints'}->{$constraint->Name} = STATE_CREATED; - } -} - -sub ProcessPendingActions { - my ($this) = @_; - - while (my $action = shift @{$this->{$PendingActions}}) { - $action->{'Action'}->($this,@{$action->{'Args'}}); - } -} - -1;
--- a/Lib/IMPL/SQL/Schema/Type.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Type.pm Mon Feb 04 02:10:37 2013 +0400 @@ -1,23 +1,23 @@ +package IMPL::SQL::Schema::Type; use strict; use warnings; -package IMPL::SQL::Schema::Type; -use parent qw(IMPL::Object IMPL::Object::Autofill); - -use IMPL::lang qw( :declare :compare ); - -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property name => PROP_GET; - public _direct property maxLength => PROP_GET; - public _direct property scale => PROP_GET; - public _direct property unsigned => PROP_GET; - public _direct property zerofill => PROP_GET; - public _direct property tag => PROP_GET; -} - -__PACKAGE__->PassThroughArgs; +use IMPL::lang qw( :compare ); +use IMPL::Const qw(:prop); +use IMPL::declare{ + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + name => PROP_RO | PROP_DIRECT, + maxLength => PROP_RO | PROP_DIRECT, + scale => PROP_RO | PROP_DIRECT, + unsigned => PROP_RO | PROP_DIRECT, + zerofill => PROP_RO | PROP_DIRECT, + tag => PROP_RO | PROP_DIRECT + ] +}; sub CTOR { my $this = shift;
--- a/Lib/IMPL/Serialization.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Serialization.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,313 +2,334 @@ use strict; package IMPL::Serialization::Context; -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use IMPL::Exception; +use IMPL::Exception(); use Scalar::Util qw(refaddr); -BEGIN { - private _direct property ObjectWriter => prop_all; - private _direct property Context => prop_all; - private _direct property NextID => prop_all; +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ 'IMPL::Object' => undef ], + props => [ + _objectWriter => PROP_RW | PROP_DIRECT, + _context => PROP_RW | PROP_DIRECT, + _nextId => PROP_RW | PROP_DIRECT, + serializer => PROP_RW | PROP_DIRECT, + _state => PROP_RW | PROP_DIRECT + ] +}; - public _direct property Serializer => prop_all; - - private _direct property State => prop_all; -} - -sub STATE_CLOSED () { 0 } -sub STATE_OPENED () { 1 } +sub STATE_CLOSED () { 0 } +sub STATE_OPENED () { 1 } sub STATE_COMPLEX () { 2 } -sub STATE_DATA () { 3 } +sub STATE_DATA () { 3 } sub CTOR { - my ($this,%args) = @_; - - $this->{$ObjectWriter} = $args{'ObjectWriter'}; - $this->{$NextID} = 1; - $this->{$Serializer} = ($args{'Serializer'} ? $args{'Serializer'} : \&DefaultSerializer ); - $this->{$State} = STATE_CLOSED; - - return 1; + my ( $this, %args ) = @_; + + $this->{$_objectWriter} = $args{'ObjectWriter'}; + $this->{$_nextId} = 1; + $this->{$serializer} = + ( $args{'Serializer'} ? $args{'Serializer'} : \&DefaultSerializer ); + $this->{$_state} = STATE_CLOSED; + + return 1; } sub AddVar { - my ($this,$sName,$Var) = @_; - - die new Exception ('Invalid operation') if $this->{$State} == STATE_DATA; - - if (not ref $Var) { - my $prevState = $this->{$State}; - - $this->{$ObjectWriter}->BeginObject(name => $sName); - $this->{$State} = STATE_OPENED; - - $this->{$Serializer}->($this,\$Var); - - $this->{$ObjectWriter}->EndObject(); - - if ($prevState == STATE_OPENED) { - $this->{$State} = STATE_COMPLEX; - } else { - $this->{$State} = $prevState; + my ( $this, $sName, $Var ) = @_; + + die new Exception('Invalid operation') if $this->{$_state} == STATE_DATA; + + if ( not ref $Var ) { + my $prevState = $this->{$_state}; + + $this->{$_objectWriter}->BeginObject( name => $sName ); + $this->{$_state} = STATE_OPENED; + + $this->{$serializer}->( $this, \$Var ); + + $this->{$_objectWriter}->EndObject(); + + if ( $prevState == STATE_OPENED ) { + $this->{$_state} = STATE_COMPLEX; + } + else { + $this->{$_state} = $prevState; + } + return 0; } - return 0; - } - - my $PrevState = $this->{$State}; - - my $ObjID = $this->{$Context}->{refaddr $Var}; - if ($ObjID) { - $this->{$ObjectWriter}->BeginObject(name => $sName, refid => $ObjID); - $this->{$ObjectWriter}->EndObject(); + + my $PrevState = $this->{$_state}; + + my $ObjID = $this->{$_context}->{ refaddr $Var}; + if ($ObjID) { + $this->{$_objectWriter}->BeginObject( name => $sName, refid => $ObjID ); + $this->{$_objectWriter}->EndObject(); + return $ObjID; + } + + $ObjID = $this->{$_nextId}; + $this->{$_nextId} = $ObjID + 1; + + $this->{$_context}->{ refaddr $Var} = $ObjID; + + $this->{$_objectWriter} + ->BeginObject( name => $sName, type => ref($Var), id => $ObjID ); + + $this->{$_state} = STATE_OPENED; + $this->{$serializer}->( $this, $Var ); + + $this->{$_objectWriter}->EndObject(); + + if ( $PrevState == STATE_OPENED ) { + $this->{$_state} = STATE_COMPLEX; + } + else { + $this->{$_state} = $PrevState; + } + return $ObjID; - } - - $ObjID = $this->{$NextID}; - $this->{$NextID} = $ObjID + 1; - - $this->{$Context}->{refaddr $Var} = $ObjID; - - $this->{$ObjectWriter}->BeginObject(name => $sName, type => ref($Var), id => $ObjID); - - $this->{$State} = STATE_OPENED; - $this->{$Serializer}->($this,$Var); - - $this->{$ObjectWriter}->EndObject(); - - if ($PrevState == STATE_OPENED) { - $this->{$State} = STATE_COMPLEX; - } else { - $this->{$State} = $PrevState; - } - - return $ObjID; } sub SetData { - my ($this,$Data,$Type) = @_; - - die new Exception ('The object should be a scalar value') if ref $Data; - die new Exception ('Invalid operation') if $this->{$State} != STATE_OPENED; - - $this->{$ObjectWriter}->SetData($Data,$Type); - - $this->{$State} = STATE_DATA; - - return 1; + my ( $this, $data, $type ) = @_; + + die new Exception('The object should be a scalar value') if ref $data; + die new Exception('Invalid operation') if $this->{$_state} != STATE_OPENED; + + $this->{$_objectWriter}->SetData( $data, $type ); + + $this->{$_state} = STATE_DATA; + + return 1; } sub DefaultSerializer { - my ($Context, $refObj) = @_; - - if (ref($refObj) eq 'SCALAR') { - $Context->SetData($$refObj, 'SCALAR'); - } elsif (ref($refObj) eq 'ARRAY') { - $Context->AddVar('item',$_) foreach @$refObj; - } elsif (ref($refObj) eq 'HASH') { - while (my ($key,$value) = each %$refObj) { - $Context->AddVar($key,$value); + my ( $_context, $refObj ) = @_; + + if ( ref($refObj) eq 'SCALAR' ) { + $_context->SetData( $$refObj, 'SCALAR' ); + } + elsif ( ref($refObj) eq 'ARRAY' ) { + $_context->AddVar( 'item', $_ ) foreach @$refObj; + } + elsif ( ref($refObj) eq 'HASH' ) { + while ( my ( $key, $value ) = each %$refObj ) { + $_context->AddVar( $key, $value ); + } } - } elsif (ref($refObj) eq 'REF') { - $Context->AddVar('ref',$$refObj); - } else { - if (ref $refObj and $refObj->UNIVARSAL::can('save')) { - $refObj->save($Context); - } else { - die new Exception('Cant serialize the object of the type: '.ref($refObj)); + elsif ( ref($refObj) eq 'REF' ) { + $_context->AddVar( 'ref', $$refObj ); } - } - - return 1; + else { + if ( ref $refObj and $refObj->UNIVARSAL::can('save') ) { + $refObj->save($_context); + } + else { + die new Exception( + 'Cant serialize the object of the type: ' . ref($refObj) ); + } + } + + return 1; } package IMPL::Deserialization::Context; -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use IMPL::Exception; - -BEGIN { - private _direct property Context => prop_all; - - # структура информации об объекте - # { - # Type => 'typename', - # Name => 'object_name', - # Data => $Data, - # Id => 'object_id' - # } - private _direct property CurrentObject => prop_all; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + Loader => 'IMPL::Code::Loader' + }, + base => [ 'IMPL::Object' => undef ], + props => [ - private _direct property ObjectsPath => prop_all; - - public _direct property Root => prop_get; - - # пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ - # ObjectFactory($Type,$DeserializationData,$refSurogate) - # $Type - пїЅпїЅпїЅ пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ - # $DeserializationData - пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, - # пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ. - # $refSurogate - пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ. - # пїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ undef - private _direct property ObjectFactory => prop_all; - - # пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ. - # SurogateHelper($Type) - # $Type пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ. - private _direct property SurrogateHelper => prop_all; -} + # структура информации об объекте + # { + # Type => 'typename', + # Name => 'object_name', + # Data => $data, + # Id => 'object_id' + # } + _context => PROP_RW | PROP_DIRECT, + _currentObject => PROP_RW | PROP_DIRECT, + _objectsPath => PROP_RW | PROP_DIRECT, + root => PROP_RW | PROP_DIRECT + ] +}; sub CTOR { - my ($this,%args) = @_; - $this->{$CurrentObject} = undef; - $this->{$Root} = undef; - $this->{$ObjectFactory} = $args{ObjectFactory} if $args{ObjectFactory}; - $this->{$SurrogateHelper} = $args{SurrogateHelper} if $args{SurrogateHelper}; + my ( $this, %args ) = @_; + $this->{$_currentObject} = undef; + $this->{$root} = undef; } sub OnObjectBegin { - my ($this,$name,$rhProps) = @_; - - die new Exception("Invalid data from an ObjectReader","An object reader should pass a referense to a hash which contains attributes of an object") if (ref $rhProps ne 'HASH'); - die new Exception("Trying to create second root object") if not $this->{$CurrentObject} and $this->{$Root}; - - if ($rhProps->{'refid'}) { - my $refObj = $this->{$Context}->{$rhProps->{'refid'}}; - die new Exception("A reference to a not existing object found") if not $refObj; - my $rhCurrentObj = $this->{$CurrentObject}; + my ( $this, $name, $rhProps ) = @_; + + die Exception->new( + "Invalid data from an ObjectReader", +"An object reader should pass a referense to a hash which contains attributes of an object" + ) if ( ref $rhProps ne 'HASH' ); + + die Exception->new("Trying to create second root object") + if not $this->{$_currentObject} and $this->{$root}; + + if ( $rhProps->{'refid'} ) { + + my $refObj = $this->{$_context}->{ $rhProps->{'refid'} }; + + die Exception->new("A reference to a not existing object found") + if not $refObj; + + my $rhCurrentObj = $this->{$_currentObject}; + + die Exception->new("The root object can't be a reference") + if not $rhCurrentObj; + + if ( $rhCurrentObj->{'Data'} ) { + + die Exception->new( "Invalid serializaed data", + "Plain deserialization data for an object already exist" ) + if not ref $rhCurrentObj->{'Data'}; - die new Exception("The root object can't be a reference") if not $rhCurrentObj; - - if ($rhCurrentObj->{'Data'}) { - die new Exception("Invalid serializaed data","Plain deserialization data for an object already exist") if not ref $rhCurrentObj->{'Data'}; - push @{$rhCurrentObj->{'Data'}}, $name,$refObj; + push @{ $rhCurrentObj->{'Data'} }, $name, $refObj; + } else { + $rhCurrentObj->{'Data'} = [ $name, $refObj ]; + } + + push @{ $this->{$_objectsPath} }, $rhCurrentObj; + $this->{$_currentObject} = undef; + } else { - $rhCurrentObj->{'Data'} = [$name,$refObj]; + push @{ $this->{$_objectsPath} }, $this->{$_currentObject} + if $this->{$_currentObject}; + + $this->{$_currentObject} = { + Name => $name, + Type => $rhProps->{'type'} || 'SCALAR', + Id => $rhProps->{'id'}, + refId => $rhProps->{'refid'} + }; + + if ( defined $rhProps->{'id'} ) { + die new IMPL::Exception( +"Trying to create a simple object instead of a reference, type is missing.", + $name, $rhProps->{id} + ) unless $rhProps->{'type'}; + + $this->{$_context}->{ $rhProps->{'id'} } = $this->CreateSurrogate( $rhProps->{'type'} ); + } } - # пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ OnObjectEnd пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ. пїЅ.пїЅ. пїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅ - push @{$this->{$ObjectsPath}},$rhCurrentObj; - $this->{$CurrentObject} = undef; - - } else { - push @{$this->{$ObjectsPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; - - $this->{$CurrentObject} = { - Name => $name, - Type => $rhProps->{'type'} || 'SCALAR', - Id => $rhProps->{'id'}, - refId => $rhProps->{'refid'} - }; - - if (defined $rhProps->{'id'}) { - die new IMPL::Exception("Trying to create a simple object instead of a reference, type is missing.",$name,$rhProps->{id}) unless $rhProps->{'type'} ; - $this->{$Context}->{$rhProps->{'id'}} = $this->{$SurrogateHelper} ? $this->{$SurrogateHelper}->($rhProps->{'type'}) : DefaultSurrogateHelper($rhProps->{'type'}); - } - } - - return 1; + return 1; } sub OnObjectData { - my ($this,$data) = @_; - - my $rhObject = $this->{$CurrentObject}; - - die new Exception("Trying to set data for an object which not exists") if not $rhObject; - - die new Exception("Deserialization data already exists for a current object", "ObjectName= $rhObject->{'Name'}") if $rhObject->{'Data'}; - - $rhObject->{'Data'} = $data; - - return 1; + my ( $this, $data ) = @_; + + my $rhObject = $this->{$_currentObject}; + + die Exception->new("Trying to set data for an object which not exists") + if not $rhObject; + + die Exception->new( + "Deserialization data already exists for a current object", + "ObjectName= $rhObject->{'Name'}" ) + if $rhObject->{'Data'}; + + $rhObject->{'Data'} = $data; + + return 1; } { - my $AutoId = 0; - sub OnObjectEnd { - my ($this,$name) = @_; - - my $rhObject = $this->{$CurrentObject}; - my $rhPrevObject = pop @{$this->{$ObjectsPath}}; - - # пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ - пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ - пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ - # пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ - if ((not defined($rhObject)) && $rhPrevObject) { - $this->{$CurrentObject} = $rhPrevObject; - return 1; + my $autoId = 0; + + sub OnObjectEnd { + my ( $this, $name ) = @_; + + my $rhObject = $this->{$_currentObject}; + my $rhPrevObject = pop @{ $this->{$_objectsPath} }; + + if ( ( not defined($rhObject) ) && $rhPrevObject ) { + $this->{$_currentObject} = $rhPrevObject; + return 1; + } + + my $refObj = $this->CreateObject( + $rhObject->{'Type'}, + $rhObject->{'Data'}, + $rhObject->{'Id'} + ? $this->{$_context}->{ $rhObject->{'Id'} } + : undef + ); + + die Exception->new("Trying to close a non existing oject") + if not $rhObject; + + my $data; + + if ( $rhObject->{'Id'} ) { + $this->{$_context}->{ $rhObject->{'Id'} } = $refObj; + $data = $refObj; + } + else { + if ( ref $refObj ne 'SCALAR' ) { + $rhObject->{Id} = "auto$autoId"; + $autoId++; + $this->{$_context}->{ $rhObject->{'Id'} } = $refObj; + $data = $refObj; + } + else { + $data = ${$refObj}; + } + } + + if ( not $rhPrevObject ) { + $this->{$root} = $data; + } + else { + if ( $rhPrevObject->{'Data'} ) { + die Exception->new( + "Trying append a reference to an object to the plain data") + if not ref $rhPrevObject->{'Data'}; + + push @{ $rhPrevObject->{'Data'} }, $rhObject->{'Name'}, $data; + } + else { + $rhPrevObject->{'Data'} = [ $rhObject->{'Name'}, $data ]; + } + } + + $this->{$_currentObject} = $rhPrevObject; + + return 1; } - - my $refObj = $this->{$ObjectFactory} ?$this->{$ObjectFactory}->($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef) : DefaultFactory($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef); - - die new Exception("Trying to close a non existing oject") if not $rhObject; - - my $Data; - - if ($rhObject->{'Id'}) { - $this->{$Context}->{$rhObject->{'Id'}} = $refObj; - $Data = $refObj; - } else { - if (ref $refObj ne 'SCALAR') { - $rhObject->{Id} = "auto$AutoId"; - $AutoId ++; - $this->{$Context}->{$rhObject->{'Id'}} = $refObj; - $Data = $refObj; - } else { - $Data = ${$refObj}; - } - } - - if (not $rhPrevObject) { - $this->{$Root} = $Data; - } else { - if ($rhPrevObject->{'Data'}) { - die new Exception("Trying append a reference to an object to the plain data") if not ref $rhPrevObject->{'Data'}; - push @{$rhPrevObject->{'Data'}},$rhObject->{'Name'},$Data; - } else { - $rhPrevObject->{'Data'} = [$rhObject->{'Name'},$Data]; - } - } - - $this->{$CurrentObject} = $rhPrevObject; - - return 1; - } } -{ - my %classes; - sub _load_class { - return if $classes{$_[0]}; - - die new IMPL::Exception("Invalid class name",$_[0]) unless $_[0] =~ m/^(\w+(?:\:\:\w+)*)$/; - - eval "require $1"; - $classes{$_[0]} = 1; - } -} +sub CreateSurrogate { + my ($this,$type) = @_; -sub DefaultSurrogateHelper { - my ($Type) = @_; - - if ($Type eq 'SCALAR' or $Type eq 'REF') { - my $var; - return \$var; - } elsif ($Type eq 'ARRAY') { - return []; - } elsif ($Type eq 'HASH') { - return {}; - } elsif ($Type) { - _load_class($Type); - if (UNIVERSAL::can($Type,'surrogate')) { - return $Type->surrogate(); - } else { - return bless {}, $Type; + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + my $var; + return \$var; + } + elsif ( $type eq 'ARRAY' ) { + return []; + } + elsif ( $type eq 'HASH' ) { + return {}; } - } + elsif ($type) { + Loader->safe->Require($type); + if ( eval { $type->can('surrogate') } ) { + return $type->surrogate(); + } + else { + return bless {}, $type; + } + } } # deserialization context: @@ -317,90 +338,112 @@ # .... # ] -sub DefaultFactory { - my ($Type,$Data,$refSurogate) = @_; - - if ($Type eq 'SCALAR') { - die new Exception("SCALAR needs a plain data for a deserialization") if ref $Data; - if ($refSurogate) { - $$refSurogate = $Data; - return $refSurogate; - } else { - return \$Data; +sub CreateObject { + my ($this, $type, $data, $refSurogate ) = @_; + + if ( $type eq 'SCALAR' ) { + die Exception->new("SCALAR needs a plain data for a deserialization") + if ref $data; + if ($refSurogate) { + $$refSurogate = $data; + return $refSurogate; + } + else { + return \$data; + } } - } elsif ($Type eq 'ARRAY') { - $Data ||= []; - die new Exception("Invalid a deserialization context when deserializing ARRAY") if not ref $Data and defined $Data; - if (not ref $refSurogate) { - my @Array; - $refSurogate = \@Array; - } - for (my $i = 0; $i < scalar(@{$Data})/2; $i++) { - push @$refSurogate,$Data->[$i*2+1]; + elsif ( $type eq 'ARRAY' ) { + $data ||= []; + die Exception->new( + "Invalid a deserialization context when deserializing ARRAY") + if not ref $data and defined $data; + if ( not ref $refSurogate ) { + my @Array; + $refSurogate = \@Array; + } + for ( my $i = 0 ; $i < scalar( @{$data} ) / 2 ; $i++ ) { + push @$refSurogate, $data->[ $i * 2 + 1 ]; + } + return $refSurogate; } - return $refSurogate; - } elsif ($Type eq 'HASH') { - $Data ||= []; - die new Exception("Invalid a deserialization context when deserializing HASH") if not ref $Data and defined $Data; - if (not ref $refSurogate) { - $refSurogate = {}; - } - for (my $i = 0; $i< @$Data; $i+= 2) { - $refSurogate->{$Data->[$i]} = $Data->[$i+1]; + elsif ( $type eq 'HASH' ) { + $data ||= []; + die Exception->new( + "Invalid a deserialization context when deserializing HASH") + if not ref $data and defined $data; + if ( not ref $refSurogate ) { + $refSurogate = {}; + } + for ( my $i = 0 ; $i < @$data ; $i += 2 ) { + $refSurogate->{ $data->[$i] } = $data->[ $i + 1 ]; + } + return $refSurogate; } - return $refSurogate; - } elsif ($Type eq 'REF') { - $Data ||= []; - die new Exception("Invalid a deserialization context when deserializing REF") if not ref $Data and defined $Data; - if (not ref $refSurogate) { - my $ref = $Data->[1]; - return \$ref; - } else { - $$refSurogate = $Data->[1]; - return $refSurogate; + elsif ( $type eq 'REF' ) { + $data ||= []; + die Exception->new( + "Invalid a deserialization context when deserializing REF") + if not ref $data and defined $data; + if ( not ref $refSurogate ) { + my $ref = $data->[1]; + return \$ref; + } + else { + $$refSurogate = $data->[1]; + return $refSurogate; + } } - } else { - _load_class($Type); - if ( $Type->UNIVERSAL::can('restore') ) { - return $Type->restore($Data,$refSurogate); - } else { - die new Exception("Don't know how to deserialize $Type"); + else { + Loader->safe->Require($type); + if ( eval { $type->can('restore') } ) { + return $type->restore( $data, $refSurogate ); + } + else { + die Exception->new("Don't know how to deserialize $type"); + } } - } } package IMPL::Serializer; -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use IMPL::Exception; - -BEGIN { - private _direct property Formatter => prop_all; -} +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + SerializationContext => '-IMPL::Serialization::Context', + DeserializationContext => '-IMPL::Deserialization::Context' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + _formatter => PROP_RW + ] +}; sub CTOR { - my ($this,%args) = @_; - $this->Formatter($args{'Formatter'}) or die new Exception("Omitted mandatory parameter 'Formatter'"); + my ( $this, %args ) = @_; + $this->_formatter( $args{formatter} ) + or die Exception->new("Omitted mandatory parameter 'formatter'"); } sub Serialize { - my $this = shift; - my ($hStream,$Object) = @_; - my $ObjWriter = $this->Formatter()->CreateWriter($hStream); - my $Context = new IMPL::Serialization::Context(ObjectWriter => $ObjWriter); - $Context->AddVar('root',$Object); - return 1; + my $this = shift; + my ( $hStream, $Object ) = @_; + my $ObjWriter = $this->_formatter->CreateWriter($hStream); + my $context = + SerializationContext->new( objectWriter => $ObjWriter ); + $context->AddVar( 'root', $Object ); + return 1; } sub Deserialize { - my $this = shift; - my ($hStream) = @_; - my $Context = new IMPL::Deserialization::Context(); - my $ObjReader = $this->Formatter()->CreateReader($hStream,$Context); - $ObjReader->Parse(); - return $Context->Root(); + my $this = shift; + my ($hStream) = @_; + my $context = DeserializationContext->new(); + my $ObjReader = $this->_formatter->CreateReader( $hStream, $context ); + $ObjReader->Parse(); + return $context->root; } 1;
--- a/Lib/IMPL/Serialization/XmlFormatter.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Serialization/XmlFormatter.pm Mon Feb 04 02:10:37 2013 +0400 @@ -3,7 +3,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use IMPL::Serialization; use XML::Writer; @@ -171,7 +170,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; BEGIN { public _direct property Encoding => prop_all;
--- a/Lib/IMPL/Test.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Test.pm Mon Feb 04 02:10:37 2013 +0400 @@ -2,6 +2,7 @@ use strict; use warnings; +use IMPL::Const qw(:access); require IMPL::Test::SkipException; require Exporter; @@ -11,7 +12,6 @@ require IMPL::Test::Unit; require IMPL::Test::Plan; require IMPL::Test::TAPListener; -use IMPL::Class::Member; sub test($$) { my ($name,$code) = @_; @@ -28,8 +28,8 @@ my $class = caller; die new IMPL::Exception("Only properties could be declared as shared",$propInfo->name) unless eval {$propInfo->isa('IMPL::Class::PropertyInfo')}; - die new IMPL::Exception("You can't mark the readonly property as shared",$propInfo->name) unless $propInfo->canSet; - die new IMPL::Exception("Only public properties could be declared as shared",$propInfo->name) unless $propInfo->access == IMPL::Class::Member::MOD_PUBLIC; + die new IMPL::Exception("You can't mark the readonly property as shared",$propInfo->name) unless $propInfo->setter; + die new IMPL::Exception("Only public properties could be declared as shared",$propInfo->name) unless $propInfo->access == ACCESS_PUBLIC; $class->set_meta(new IMPL::Test::Unit::SharedData($propInfo->name)); }
--- a/Lib/IMPL/Text/Parser/Chunk.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Text/Parser/Chunk.pm Mon Feb 04 02:10:37 2013 +0400 @@ -5,7 +5,6 @@ use parent qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use constant { OP_REGEXP => 1,
--- a/Lib/IMPL/Text/Parser/Player.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Text/Parser/Player.pm Mon Feb 04 02:10:37 2013 +0400 @@ -4,7 +4,6 @@ use parent qw(IMPL::Object); use IMPL::Class::Property; -use IMPL::Class::Property::Direct; use IMPL::Text::Parser::Chunk;
--- a/Lib/IMPL/Transform.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Transform.pm Mon Feb 04 02:10:37 2013 +0400 @@ -5,7 +5,6 @@ use IMPL::lang qw(:declare); -use IMPL::Class::Property::Direct; BEGIN { public _direct property templates => PROP_ALL;
--- a/Lib/IMPL/Web/Exception.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/Web/Exception.pm Mon Feb 04 02:10:37 2013 +0400 @@ -5,7 +5,7 @@ use IMPL::Const qw(:prop); use IMPL::declare { base => [ - 'IMPL::Exception' => '@_' + 'IMPL::AppException' => '@_' ], props => [ headers => PROP_ALL
--- a/Lib/IMPL/_core.pm Fri Feb 01 16:37:59 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -package IMPL::_core; -use strict; -use IMPL::_core::version; - -use parent qw(Exporter); -our @EXPORT_OK = qw( &isDebug &setDebug); - -our $Debug = 0; - -sub isDebug { $Debug }; -sub setDebug { $Debug = shift }; - -1;
--- a/Lib/IMPL/declare.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/declare.pm Mon Feb 04 02:10:37 2013 +0400 @@ -105,18 +105,17 @@ for ( my $i = 0 ; $i < @$props - 1 ; $i = $i + 2 ) { my ( $prop, $spec ) = @{$props}[ $i, $i + 1 ]; - - my $propInfo = IMPL::Class::PropertyInfo->new( + + $caller->ClassPropertyImplementor->Implement( + $spec, { name => $prop, - mutators => $spec, class => $caller, access => $prop =~ /^_/ ? ACCESS_PRIVATE : ACCESS_PUBLIC } ); - $propInfo->Implement(); } }
--- a/Lib/IMPL/lang.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/Lib/IMPL/lang.pm Mon Feb 04 02:10:37 2013 +0400 @@ -7,8 +7,6 @@ use IMPL::clone qw(clone); use Scalar::Util qw(blessed); -require IMPL::Class::PropertyInfo; - our @EXPORT = qw(&is &isclass &typeof); our %EXPORT_TAGS = ( base => [ @@ -25,10 +23,10 @@ &public &protected &private - &virtual &property &static &property + &_direct &ACCESS_PUBLIC &ACCESS_PROTECTED &ACCESS_PRIVATE @@ -39,6 +37,7 @@ &PROP_ALL &PROP_RO &PROP_RW + &PROP_DIRECT ) ], compare => [ @@ -76,40 +75,52 @@ eval { $_[0]->typeof } || blessed($_[0]); } -sub virtual($) { - $_[0]->Virtual(1); - $_[0]; -} - sub public($) { - $_[0]->access(ACCESS_PUBLIC); - $_[0]->Implement; - $_[0]; + my $info = shift; + $info->{access} = ACCESS_PUBLIC; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); } sub private($) { - $_[0]->access(ACCESS_PRIVATE); - $_[0]->Implement; - $_[0]; + my $info = shift; + $info->{access} = ACCESS_PRIVATE; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); } sub protected($) { - $_[0]->access(ACCESS_PROTECTED); - $_[0]->Implement; - $_[0]; + 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, $mutators, $attributes ) = @_; - my $Info = new IMPL::Class::PropertyInfo( +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, { - name => $propName, - mutators => $mutators, - class => scalar(caller), - attributes => $attributes + implementor => $class->ClassPropertyImplementor, + name => $propName, + class => scalar(caller), } ); - return $Info; } sub static($$) {
--- a/_test/Test/Class/Template.pm Fri Feb 01 16:37:59 2013 +0400 +++ b/_test/Test/Class/Template.pm Mon Feb 04 02:10:37 2013 +0400 @@ -19,7 +19,7 @@ declare => sub { my ($class) = @_; - public $class->CreateProperty( items => prop_get | owner_set | prop_list, { type => $class->TValue } ); + $class->CreateProperty( items => prop_get | owner_set | prop_list, { type => $class->TValue } ); } );