Mercurial > pub > Impl
changeset 407:c6e90e02dd17 ref20150831
renamed Lib->lib
author | cin |
---|---|
date | Fri, 04 Sep 2015 19:40:23 +0300 |
parents | f23fcb19d3c1 |
children | 5c80e33f1218 |
files | .includepath Lib/IMPL.pm Lib/IMPL/AppException.pm Lib/IMPL/Class/AccessorPropertyInfo.pm Lib/IMPL/Class/DirectPropertyInfo.pm Lib/IMPL/Class/Member.pm Lib/IMPL/Class/MemberInfo.pm Lib/IMPL/Class/Meta.pm Lib/IMPL/Class/MethodInfo.pm Lib/IMPL/Class/Property.pm Lib/IMPL/Class/PropertyInfo.pm Lib/IMPL/Class/Template.pm Lib/IMPL/Code/AccessorPropertyImplementor.pm Lib/IMPL/Code/BasePropertyImplementor.pm Lib/IMPL/Code/DirectPropertyImplementor.pm Lib/IMPL/Code/Loader.pm Lib/IMPL/Config.pm Lib/IMPL/Config/ActivationContext.pm Lib/IMPL/Config/Activator.pm Lib/IMPL/Config/Container.pm Lib/IMPL/Config/Descriptor.pm Lib/IMPL/Config/Include.pm Lib/IMPL/Config/Path.pm Lib/IMPL/Config/Reference.pm Lib/IMPL/Config/ReferenceDescriptor.pm Lib/IMPL/Config/Resolve.pm Lib/IMPL/Config/ServiceDescriptor.pm Lib/IMPL/Config/ServicesBag.pm Lib/IMPL/Config/ValueDescriptor.pm Lib/IMPL/Const.pm Lib/IMPL/DOM/Document.pm Lib/IMPL/DOM/Navigator.pm Lib/IMPL/DOM/Navigator/Builder.pm Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Lib/IMPL/DOM/Node.pm Lib/IMPL/DOM/Property.pm Lib/IMPL/DOM/Schema.pm Lib/IMPL/DOM/Schema/AnyNode.pm Lib/IMPL/DOM/Schema/ComplexNode.pm Lib/IMPL/DOM/Schema/ComplexType.pm Lib/IMPL/DOM/Schema/Label.pm Lib/IMPL/DOM/Schema/Node.pm Lib/IMPL/DOM/Schema/NodeList.pm Lib/IMPL/DOM/Schema/NodeSet.pm Lib/IMPL/DOM/Schema/Property.pm Lib/IMPL/DOM/Schema/SimpleNode.pm Lib/IMPL/DOM/Schema/SimpleType.pm Lib/IMPL/DOM/Schema/SwitchNode.pm Lib/IMPL/DOM/Schema/ValidationError.pm Lib/IMPL/DOM/Schema/Validator.pm Lib/IMPL/DOM/Schema/Validator/Compare.pm Lib/IMPL/DOM/Schema/Validator/RegExp.pm Lib/IMPL/DOM/Transform.pm Lib/IMPL/DOM/Transform/ObjectToDOM.pm Lib/IMPL/DOM/Transform/PostToDOM.pm Lib/IMPL/DOM/Transform/QueryToDOM.pm Lib/IMPL/DOM/XMLReader.pm Lib/IMPL/Exception.pm Lib/IMPL/Mailer.pm Lib/IMPL/ORM.pm Lib/IMPL/ORM/Adapter/Generic.pm Lib/IMPL/ORM/Entity.pm Lib/IMPL/ORM/Helpers.pm Lib/IMPL/ORM/Object.pm Lib/IMPL/ORM/PropertyImplementor.pm Lib/IMPL/ORM/Schema.pm Lib/IMPL/ORM/Schema/Entity.pm Lib/IMPL/ORM/Schema/Field.pm Lib/IMPL/ORM/Schema/GenericClass.pm Lib/IMPL/ORM/Schema/Relation.pm Lib/IMPL/ORM/Schema/Relation/HasMany.pm Lib/IMPL/ORM/Schema/Relation/HasOne.pm Lib/IMPL/ORM/Schema/Relation/Subclass.pm Lib/IMPL/ORM/Schema/TransformToSQL.pm Lib/IMPL/ORM/Schema/ValueType.pm Lib/IMPL/ORM/Store/DBIC.pm Lib/IMPL/ORM/Store/SQL.pm Lib/IMPL/ORM/Unit.pm Lib/IMPL/Object.pm Lib/IMPL/Object/Abstract.pm Lib/IMPL/Object/Accessor.pm Lib/IMPL/Object/ArrayObject.pm Lib/IMPL/Object/AutoDispose.pm Lib/IMPL/Object/Autofill.pm Lib/IMPL/Object/Clonable.pm Lib/IMPL/Object/Disposable.pm Lib/IMPL/Object/EventSource.pm Lib/IMPL/Object/Factory.pm Lib/IMPL/Object/Fields.pm Lib/IMPL/Object/InlineFactory.pm Lib/IMPL/Object/List.pm Lib/IMPL/Object/Meta.pm Lib/IMPL/Object/PublicSerializable.pm Lib/IMPL/Object/Serializable.pm Lib/IMPL/Object/Singleton.pm Lib/IMPL/Profiler.pm Lib/IMPL/Profiler/Memory.pm Lib/IMPL/Resources.pm Lib/IMPL/Resources/Format.pm Lib/IMPL/Resources/StringLocaleMap.pm Lib/IMPL/Resources/StringMap.pm Lib/IMPL/Resources/Strings.pm Lib/IMPL/SQL/Schema.pm Lib/IMPL/SQL/Schema/Column.pm Lib/IMPL/SQL/Schema/Constraint.pm Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Lib/IMPL/SQL/Schema/Constraint/Index.pm Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Lib/IMPL/SQL/Schema/Constraint/Unique.pm Lib/IMPL/SQL/Schema/Diff.pm Lib/IMPL/SQL/Schema/MySQL/CharType.pm Lib/IMPL/SQL/Schema/MySQL/EnumType.pm Lib/IMPL/SQL/Schema/MySQL/Formatter.pm Lib/IMPL/SQL/Schema/MySQL/Processor.pm Lib/IMPL/SQL/Schema/Processor.pm Lib/IMPL/SQL/Schema/Table.pm Lib/IMPL/SQL/Schema/Traits.pm Lib/IMPL/SQL/Schema/Traits/Diff.pm Lib/IMPL/SQL/Schema/Traits/mysql.pm Lib/IMPL/SQL/Schema/Type.pm Lib/IMPL/SQL/Types.pm Lib/IMPL/Security.pm Lib/IMPL/Security/AbstractContext.pm Lib/IMPL/Security/AbstractPrincipal.pm Lib/IMPL/Security/AbstractRole.pm Lib/IMPL/Security/Auth.pm Lib/IMPL/Security/Auth/Simple.pm Lib/IMPL/Security/Context.pm Lib/IMPL/Security/Principal.pm Lib/IMPL/Security/Role.pm Lib/IMPL/Security/Rule/RoleCheck.pm Lib/IMPL/Serialization.pm Lib/IMPL/Serialization/XmlFormatter.pm Lib/IMPL/TargetException.pm Lib/IMPL/Test.pm Lib/IMPL/Test/BadUnit.pm Lib/IMPL/Test/FailException.pm Lib/IMPL/Test/HarnessRunner.pm Lib/IMPL/Test/Plan.pm Lib/IMPL/Test/Result.pm Lib/IMPL/Test/SkipException.pm Lib/IMPL/Test/Straps/ShellExecutor.pm Lib/IMPL/Test/TAPListener.pm Lib/IMPL/Test/Unit.pm Lib/IMPL/Transform.pm Lib/IMPL/TypeKeyedCollection.pm Lib/IMPL/Web/Application.pm Lib/IMPL/Web/Application/Action.pm Lib/IMPL/Web/Application/HttpResponseResource.pm Lib/IMPL/Web/Application/Resource.pm Lib/IMPL/Web/Application/ResourceBase.pm Lib/IMPL/Web/Application/ResourceInterface.pm Lib/IMPL/Web/AutoLocator.pm Lib/IMPL/Web/BadRequestException.pm Lib/IMPL/Web/CGIApplication.pm Lib/IMPL/Web/CGIWrapper.pm Lib/IMPL/Web/DOM/FileNode.pm Lib/IMPL/Web/Exception.pm Lib/IMPL/Web/ForbiddenException.pm Lib/IMPL/Web/Handler/ErrorHandler.pm Lib/IMPL/Web/Handler/JSONView.pm Lib/IMPL/Web/Handler/LocaleHandler.pm Lib/IMPL/Web/Handler/RestController.pm Lib/IMPL/Web/Handler/SecureCookie.pm Lib/IMPL/Web/Handler/View.pm Lib/IMPL/Web/Handler/ViewSelector.pm Lib/IMPL/Web/HttpResponse.pm Lib/IMPL/Web/NotAcceptableException.pm Lib/IMPL/Web/NotAllowedException.pm Lib/IMPL/Web/NotFoundException.pm Lib/IMPL/Web/OutOfRangeException.pm Lib/IMPL/Web/PreconditionException.pm Lib/IMPL/Web/Security.pm Lib/IMPL/Web/Security/Session.pm Lib/IMPL/Web/UnauthorizedException.pm Lib/IMPL/Web/UnsupportedMediaException.pm Lib/IMPL/Web/View/Metadata/BaseMeta.pm Lib/IMPL/Web/View/Metadata/FormMeta.pm Lib/IMPL/Web/View/Metadata/ObjectMeta.pm Lib/IMPL/Web/View/ObjectFactory.pm Lib/IMPL/Web/View/TTContext.pm Lib/IMPL/Web/View/TTControl.pm Lib/IMPL/Web/View/TTView.pm Lib/IMPL/Web/View/TemplateView.pm Lib/IMPL/Web/ViewResult.pm Lib/IMPL/XML/SaxParser.pm Lib/IMPL/_core/version.pm Lib/IMPL/clone.pm Lib/IMPL/declare.pm Lib/IMPL/lang.pm Lib/IMPL/require.pm Lib/IMPL/template.pm _test/temp.pl lib/IMPL.pm lib/IMPL/AppException.pm lib/IMPL/Class/AccessorPropertyInfo.pm lib/IMPL/Class/DirectPropertyInfo.pm lib/IMPL/Class/Member.pm lib/IMPL/Class/MemberInfo.pm lib/IMPL/Class/Meta.pm lib/IMPL/Class/MethodInfo.pm lib/IMPL/Class/Property.pm lib/IMPL/Class/PropertyInfo.pm lib/IMPL/Class/Template.pm lib/IMPL/Code/AccessorPropertyImplementor.pm lib/IMPL/Code/BasePropertyImplementor.pm lib/IMPL/Code/DirectPropertyImplementor.pm lib/IMPL/Code/Loader.pm lib/IMPL/Config.pm lib/IMPL/Config/ActivationContext.pm lib/IMPL/Config/Activator.pm lib/IMPL/Config/Container.pm lib/IMPL/Config/Descriptor.pm lib/IMPL/Config/Include.pm lib/IMPL/Config/Path.pm lib/IMPL/Config/Reference.pm lib/IMPL/Config/ReferenceDescriptor.pm lib/IMPL/Config/Resolve.pm lib/IMPL/Config/ServiceDescriptor.pm lib/IMPL/Config/ServicesBag.pm lib/IMPL/Config/ValueDescriptor.pm lib/IMPL/Const.pm lib/IMPL/DOM/Document.pm lib/IMPL/DOM/Navigator.pm lib/IMPL/DOM/Navigator/Builder.pm lib/IMPL/DOM/Navigator/SchemaNavigator.pm lib/IMPL/DOM/Navigator/SimpleBuilder.pm lib/IMPL/DOM/Node.pm lib/IMPL/DOM/Property.pm lib/IMPL/DOM/Schema.pm lib/IMPL/DOM/Schema/AnyNode.pm lib/IMPL/DOM/Schema/ComplexNode.pm lib/IMPL/DOM/Schema/ComplexType.pm lib/IMPL/DOM/Schema/Label.pm lib/IMPL/DOM/Schema/Node.pm lib/IMPL/DOM/Schema/NodeList.pm lib/IMPL/DOM/Schema/NodeSet.pm lib/IMPL/DOM/Schema/Property.pm lib/IMPL/DOM/Schema/SimpleNode.pm lib/IMPL/DOM/Schema/SimpleType.pm lib/IMPL/DOM/Schema/SwitchNode.pm lib/IMPL/DOM/Schema/ValidationError.pm lib/IMPL/DOM/Schema/Validator.pm lib/IMPL/DOM/Schema/Validator/Compare.pm lib/IMPL/DOM/Schema/Validator/RegExp.pm lib/IMPL/DOM/Transform.pm lib/IMPL/DOM/Transform/ObjectToDOM.pm lib/IMPL/DOM/Transform/PostToDOM.pm lib/IMPL/DOM/Transform/QueryToDOM.pm lib/IMPL/DOM/XMLReader.pm lib/IMPL/Exception.pm lib/IMPL/Mailer.pm lib/IMPL/ORM.pm lib/IMPL/ORM/Adapter/Generic.pm lib/IMPL/ORM/Entity.pm lib/IMPL/ORM/Helpers.pm lib/IMPL/ORM/Object.pm lib/IMPL/ORM/PropertyImplementor.pm lib/IMPL/ORM/Schema.pm lib/IMPL/ORM/Schema/Entity.pm lib/IMPL/ORM/Schema/Field.pm lib/IMPL/ORM/Schema/GenericClass.pm lib/IMPL/ORM/Schema/Relation.pm lib/IMPL/ORM/Schema/Relation/HasMany.pm lib/IMPL/ORM/Schema/Relation/HasOne.pm lib/IMPL/ORM/Schema/Relation/Subclass.pm lib/IMPL/ORM/Schema/TransformToSQL.pm lib/IMPL/ORM/Schema/ValueType.pm lib/IMPL/ORM/Store/DBIC.pm lib/IMPL/ORM/Store/SQL.pm lib/IMPL/ORM/Unit.pm lib/IMPL/Object.pm lib/IMPL/Object/Abstract.pm lib/IMPL/Object/Accessor.pm lib/IMPL/Object/ArrayObject.pm lib/IMPL/Object/AutoDispose.pm lib/IMPL/Object/Autofill.pm lib/IMPL/Object/Clonable.pm lib/IMPL/Object/Disposable.pm lib/IMPL/Object/EventSource.pm lib/IMPL/Object/Factory.pm lib/IMPL/Object/Fields.pm lib/IMPL/Object/InlineFactory.pm lib/IMPL/Object/List.pm lib/IMPL/Object/Meta.pm lib/IMPL/Object/PublicSerializable.pm lib/IMPL/Object/Serializable.pm lib/IMPL/Object/Singleton.pm lib/IMPL/Profiler.pm lib/IMPL/Profiler/Memory.pm lib/IMPL/Resources.pm lib/IMPL/Resources/Format.pm lib/IMPL/Resources/StringLocaleMap.pm lib/IMPL/Resources/StringMap.pm lib/IMPL/Resources/Strings.pm lib/IMPL/SQL/Schema.pm lib/IMPL/SQL/Schema/Column.pm lib/IMPL/SQL/Schema/Constraint.pm lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm lib/IMPL/SQL/Schema/Constraint/Index.pm lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm lib/IMPL/SQL/Schema/Constraint/Unique.pm lib/IMPL/SQL/Schema/Diff.pm lib/IMPL/SQL/Schema/MySQL/CharType.pm lib/IMPL/SQL/Schema/MySQL/EnumType.pm lib/IMPL/SQL/Schema/MySQL/Formatter.pm lib/IMPL/SQL/Schema/MySQL/Processor.pm lib/IMPL/SQL/Schema/Processor.pm lib/IMPL/SQL/Schema/Table.pm lib/IMPL/SQL/Schema/Traits.pm lib/IMPL/SQL/Schema/Traits/Diff.pm lib/IMPL/SQL/Schema/Traits/mysql.pm lib/IMPL/SQL/Schema/Type.pm lib/IMPL/SQL/Types.pm lib/IMPL/Security.pm lib/IMPL/Security/AbstractContext.pm lib/IMPL/Security/AbstractPrincipal.pm lib/IMPL/Security/AbstractRole.pm lib/IMPL/Security/Auth.pm lib/IMPL/Security/Auth/Simple.pm lib/IMPL/Security/Context.pm lib/IMPL/Security/Principal.pm lib/IMPL/Security/Role.pm lib/IMPL/Security/Rule/RoleCheck.pm lib/IMPL/Serialization.pm lib/IMPL/Serialization/XmlFormatter.pm lib/IMPL/TargetException.pm lib/IMPL/Test.pm lib/IMPL/Test/BadUnit.pm lib/IMPL/Test/FailException.pm lib/IMPL/Test/HarnessRunner.pm lib/IMPL/Test/Plan.pm lib/IMPL/Test/Result.pm lib/IMPL/Test/SkipException.pm lib/IMPL/Test/Straps/ShellExecutor.pm lib/IMPL/Test/TAPListener.pm lib/IMPL/Test/Unit.pm lib/IMPL/Transform.pm lib/IMPL/TypeKeyedCollection.pm lib/IMPL/Web/Application.pm lib/IMPL/Web/Application/Action.pm lib/IMPL/Web/Application/HttpResponseResource.pm lib/IMPL/Web/Application/Resource.pm lib/IMPL/Web/Application/ResourceBase.pm lib/IMPL/Web/Application/ResourceInterface.pm lib/IMPL/Web/AutoLocator.pm lib/IMPL/Web/BadRequestException.pm lib/IMPL/Web/CGIApplication.pm lib/IMPL/Web/CGIWrapper.pm lib/IMPL/Web/DOM/FileNode.pm lib/IMPL/Web/Exception.pm lib/IMPL/Web/ForbiddenException.pm lib/IMPL/Web/Handler/ErrorHandler.pm lib/IMPL/Web/Handler/JSONView.pm lib/IMPL/Web/Handler/LocaleHandler.pm lib/IMPL/Web/Handler/RestController.pm lib/IMPL/Web/Handler/SecureCookie.pm lib/IMPL/Web/Handler/View.pm lib/IMPL/Web/Handler/ViewSelector.pm lib/IMPL/Web/HttpResponse.pm lib/IMPL/Web/NotAcceptableException.pm lib/IMPL/Web/NotAllowedException.pm lib/IMPL/Web/NotFoundException.pm lib/IMPL/Web/OutOfRangeException.pm lib/IMPL/Web/PreconditionException.pm lib/IMPL/Web/Security.pm lib/IMPL/Web/Security/Session.pm lib/IMPL/Web/UnauthorizedException.pm lib/IMPL/Web/UnsupportedMediaException.pm lib/IMPL/Web/View/Metadata/BaseMeta.pm lib/IMPL/Web/View/Metadata/FormMeta.pm lib/IMPL/Web/View/Metadata/ObjectMeta.pm lib/IMPL/Web/View/ObjectFactory.pm lib/IMPL/Web/View/TTContext.pm lib/IMPL/Web/View/TTControl.pm lib/IMPL/Web/View/TTView.pm lib/IMPL/Web/View/TemplateView.pm lib/IMPL/Web/ViewResult.pm lib/IMPL/XML/SaxParser.pm lib/IMPL/_core/version.pm lib/IMPL/clone.pm lib/IMPL/declare.pm lib/IMPL/lang.pm lib/IMPL/require.pm lib/IMPL/template.pm |
diffstat | 380 files changed, 21264 insertions(+), 21264 deletions(-) [+] |
line wrap: on
line diff
--- a/.includepath Mon Aug 31 20:22:16 2015 +0300 +++ b/.includepath Fri Sep 04 19:40:23 2015 +0300 @@ -1,5 +1,5 @@ <?xml version="1.0" encoding="UTF-8"?> <includepath> - <includepathentry path="${resource_loc:/Impl/Lib}" /> + <includepathentry path="${resource_loc:/Impl/lib}" /> </includepath>
--- a/Lib/IMPL.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -package IMPL; -use strict; - -use IMPL::_core qw(setDebug); -use IMPL::_core::version; - -sub import { - my ($opts) = @_; - - if (ref $opts eq 'HASH') { - setDebug($$opts{Debug}) if exists $$opts{Debug}; - } -} - -1;
--- a/Lib/IMPL/AppException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,144 +0,0 @@ -package IMPL::AppException; -use strict; -use mro 'c3'; -use overload - '""' => 'ToString', - 'bool' => sub { return 1; }, - 'fallback' => 1; - -use Carp qw(longmess shortmess); -use Scalar::Util qw(refaddr); - -use IMPL::Const qw(:prop); -use IMPL::Resources::Strings { - message => "Application exception" -}; - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef - ], - props => [ - source => PROP_RO, - callStack => PROP_RO, - ] -}; - -sub new { - my $self = shift; - - my $instance = $self->next::method(@_); - - $instance->source(shortmess); - $instance->callStack(longmess); - - return $instance; -} - -sub ToString { - my ($this) = @_; - - return join("\n", $this->message, $this->callStack); -} - -sub throw { - my $self = shift; - - die $self->new(@_); -} - -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
--- a/Lib/IMPL/Class/AccessorPropertyInfo.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -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 Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -package IMPL::Class::DirectPropertyInfo; -use strict; - -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 Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -package IMPL::Class::Member; -use strict; -use parent qw(Exporter); -our @EXPORT = qw(&public &private &protected &_direct); - - -use IMPL::Const qw(:access); - -require IMPL::Class::MemberInfo; - -sub public($) { - my $info = shift; - $info->{access} = ACCESS_PUBLIC; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub private($) { - my $info = shift; - $info->{access} = ACCESS_PRIVATE; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub protected($) { - my $info = shift; - $info->{access} = ACCESS_PROTECTED; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub _direct($) { - my $info = shift; - $info->{direct} = 1; - return $info; -} - -1;
--- a/Lib/IMPL/Class/MemberInfo.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -package IMPL::Class::MemberInfo; -use strict; - -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 - attributes - ) -); - -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; - - $this->attributes({}) unless defined $this->attributes; - $this->access(3) unless $this->access; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Class::MemberInfo> - информация о члене класса. - -=head1 DESCRIPTION - -Данный класс является базовым для таких классов как C<IMPL::Class::PropertyInfo>, C<IMPL::Class::MethodInfo> и -предназначен для хренения метаданных. - -Данный класс наследуется от C<IMPL::Object::Accessor> и не содержит в себе метаданных о своих членах. - -=head1 MEMBERS - -=over - -=item C<[get,set] name> - -Имя члена. - -=item C<[get,set] access> - -Default public. - -Атрибут доступа ( public | private | protected ) - -=item C<[get,set] class> - -Класс владелец - -=item C<[get,set] attributes> - -Дополнительные атрибуты - -=item C<Implement()> - -При реализации собственного субкласса, данный метод может быть переопределен для -реализации дополнительной обработки (например, создание методов доступа для свойств). - -=back - -=cut
--- a/Lib/IMPL/Class/Meta.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,344 +0,0 @@ -package IMPL::Class::Meta; -use strict; - -use Carp qw(carp confess); -use IMPL::clone qw(clone); - -my %class_meta; -my %class_data; - -sub SetMeta { - my ($class,$meta_data) = @_; - $class = ref $class || $class; - - # тут нельзя использовать стандартное исключение, поскольку для него используется - # класс IMPL::Object::Accessor, который наследуется от текущего класса - confess "The meta_data parameter should be an object" if not ref $meta_data; - - push @{$class_meta{$class}{ref $meta_data}},$meta_data; -} - -sub set_meta { - goto &SetMeta; -} - -sub GetMeta { - my ($class,$meta_class,$predicate,$deep) = @_; - $class = ref $class if ref $class; - no strict 'refs'; - my @result; - - if ($predicate) { - push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) ); - } else { - push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ); - } - - if ($deep) { - push @result, map { $_->can('GetMeta') ? $_->GetMeta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'}; - } - - wantarray ? @result : \@result; -} - -sub get_meta { - goto &GetMeta; -} - -sub class_data { - my $class = shift; - $class = ref $class || $class; - - carp 'The method is obsolete, use static_accessor($name,$value,\'clone\') instead'; - - if (@_ > 1) { - my ($name,$value) = @_; - return $class_data{$class}{$name} = $value; - } else { - my ($name) = @_; - - if( exists $class_data{$class}{$name} ) { - $class_data{$class}{$name}; - } else { - if ( my $value = $class->_find_class_data($name) ) { - $class_data{$class}{$name} = clone($value); - } else { - undef; - } - } - } -} - -sub static_accessor { - my ($class,$name,$value,$inherit) = @_; - - $inherit ||= 'inherit'; - - my $method = "static_accessor_$inherit"; - - return $class->$method($name,$value); -} - -sub static_accessor_clone { - my ($class,$name,$value) = @_; - $class = ref $class || $class; - - no strict 'refs'; - - *{"${class}::${name}"} = sub { - my $self = shift; - - $self = ref $self || $self; - - if (@_ > 0) { - if ($class ne $self) { - $self->static_accessor_clone( $name => $_[0] ); # define own class data - } else { - $value = $_[0]; - } - } else { - return $self ne $class - ? $self->static_accessor_clone($name => clone($value)) - : $value; - } - }; - return $value; -}; - -sub static_accessor_inherit { - my ($class,$name,$value) = @_; - - no strict 'refs'; - - *{"${class}::$name"} = sub { - my $self = shift; - - if (@_ > 0) { - $self = ref $self || $self; - - if ($class ne $self) { - $self->static_accessor_inherit( $name => $_[0] ); # define own class data - } else { - $value = $_[0]; - } - } else { - $value ; - } - }; - return $value; -} - -sub static_accessor_own { - my ($class,$name,$value) = @_; - - no strict 'refs'; - - *{"${class}::$name"} = sub { - my $self = shift; - $self = ref $self || $self; - - if ($class ne $self) { - if (@_ > 0) { - $self->static_accessor_own( $name => $_[0] ); # define own class data - } else { - return; - } - } else { - if ( @_ > 0 ) { - $value = $_[0]; - } else { - return $value; - } - } - }; - - return $value; -} - -sub _find_class_data { - my ($class,$name) = @_; - - no strict 'refs'; - - exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"}; - - my $val; - $val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"}; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Class::Meta> - информация хранимая на уровне класса. - -=head1 SYNOPSIS - -=begin code - -package InfoMeta; - -use parent qw(IMPL::Object IMPL::Object::Autofill); -use IMPL::Class::Property; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public property name => prop_get | owner_set; -} - -package InfoExMeta; -use parent qw(InfoMeta); - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public property description => prop_all; -} - -package Foo; - -__PACKAGE__->set_meta(new InfoMeta(name => 'info')); -__PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' )); - -package main; - -# get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta -my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx'; - -# get all InfoExMeta meta -@info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx' - -# get filtered meta -@info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info' - -=end code - -=head1 DESCRIPTION - -Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты, -притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные. - -Существует возможность выборки метаданных с учетом унаследованных от базовых классов - -=head1 MEMBERS - -=head2 C<set_meta($meta_data)> - -Добавляет метаданные C<$meta_data> к классу. - -=head2 C<get_meta($meta_class,$predicate,$deep)> - -Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения -метаданных базовых классов. - -=over - -=item C<$meta_class> - -Тип метаданных - -=item C<$predicate> - -Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата -ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра -объект с метаданными, возвращает C<true> - включить метаданные в результа, C<false> - пропустить -метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными. - -=begin code - -my @info = Foo->get_meta( - 'InfoMeta', - sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta') - 1 # deep search -); - -my @info = Foo->get_meta( - 'InfoMeta', - sub { - my $item = shift; - ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta') - }, - 1 # deep search -); - -=end code - -=item C<$deep> - -Осуществлять поиск по базовым классам. - -=back - -=head2 C<static_accessor($name[,$value[,$inherit]])> - -Создает статическое свойство с именем C<$name> и начальным значением C<$value>. - -Параметр C<$inherit> контролирует то, как наследуются значения. - -=over - -=item * C<inherit> - -По умолчанию. Означает, что если для класса не определено значение, оно будет -получено от родителя. - -=item * C<clone> - -Если для класса не определено значение, то оно будет клонировано из -родительского значения при первом обращении. Полезно, когда родитель задает -значение по-умолчанию, которое разделяется между несколькими потомками, -которые модифицирю само значение (например значением является ссылка на хеш, -а потомки добавляют или меняют значения в этом хеше). - -=item * C<own> - -Каждый класс имеет свое собственное значение не зависящее от того, что было -у предка. Начальное значение для этого статического свойства C<undef>. - -=back - -Данный метод является заглушкой, он передает управление -C<static_accessor_inherit>, C<static_accessor_clone>, C<static_accessor_own> -соответственно. Эти методы можно вызывать явно -C<static_accessor_*($name[,$value])>. - - -=begin code - -package Foo; -use parent qw(IMPL::Class::Meta); - -__PACKAGE__->static_accessor( info => { version => 1 } ); -__PACKAGE__->static_accessor( mappings => { toString => \&ToString }, 'clone' ); -__PACKAGE__->static_accessor( _instance => undef, 'own' ); - -sub ToString { - "[object Foo]"; -} - -sub default { - my ($self) = @_; - - $self = ref $self || $self; - return $self->_instance ? $self->_instance : $self->_instance($self->new()); -} - -package Bar; -use parent qw(Foo); - -__PACKAGE__->info({language => 'English', version => 2}); # will define own 'info' but will loose original data. -__PACKAGE__->mappings->{sayHello} = \&SayHello; # will not affect Foo->mappings; - -package main; - -my $foo = Foo->default; # will be a Foo object -my $bar = Bar->default; # will be a Bar object - -=end code - -=cut
--- a/Lib/IMPL/Class/MethodInfo.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -use strict; -package IMPL::Class::MethodInfo; - -use parent qw(IMPL::Class::MemberInfo); - -__PACKAGE__->PassThroughArgs; - -__PACKAGE__->mk_accessors(qw( - returnType - parameters -)); - -1;
--- a/Lib/IMPL/Class/Property.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -package IMPL::Class::Property; -use strict; -use parent qw(Exporter); - -BEGIN { - our @EXPORT = qw(property prop_get prop_set owner_set prop_none prop_all prop_list CreateProperty); -} - -use IMPL::lang qw(:hash); -use IMPL::Const qw(:prop); -use Carp qw(carp); -require IMPL::Class::Member; - -sub import { - __PACKAGE__->export_to_level(1,@_); - IMPL::Class::Member->export_to_level(1,@_); -} - -sub prop_get { 1 }; -sub prop_set { 2 }; -sub owner_set { 10 }; -sub prop_none { 0 }; -sub prop_all { 3 }; -sub prop_list { 4 }; - -sub property($$) { - my ($propName,$attributes) = @_; - - my $class = caller; - - return hashMerge ( - $class->ClassPropertyImplementor->NormalizeSpecification($attributes), - { - implementor => $class->ClassPropertyImplementor, - name => $propName, - class => scalar(caller), - } - ); -} - -sub CreateProperty { - my ($class,$propName,@attributes) = @_; - - $class - ->ClassPropertyImplementor - ->Implement( - @attributes, - { - name => $propName, - class => $class, - } - ); -}; - -1;
--- a/Lib/IMPL/Class/PropertyInfo.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -package IMPL::Class::PropertyInfo; -use strict; - -BEGIN { - our @ISA = qw(IMPL::Class::MemberInfo); -} - -require IMPL::Class::MemberInfo; - -our %CTOR = ( 'IMPL::Class::MemberInfo' => '@_' ); - -__PACKAGE__->mk_accessors( - qw( - type - getter - setter - ownerSet - isList - ) -); -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Class::PropertyInfo> - метаданные о свойствах объектов. Используются для отражения и -проверки данных объектов. - -=head1 DESCRIPTION - -В зависимости от типа каждый объект предоставляет способ хранения данных, например хеши позволяют -хранить состояние в виде ассоциативного массива и т.д. Информация о свойстве предоставляет определенный -уровень абстракции. - -=cut
--- a/Lib/IMPL/Class/Template.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -package IMPL::Class::Template; -use strict; -use IMPL::lang; -use IMPL::_core::version; - -sub makeName { - my ($class,@params) = @_; - - $_ =~ s/^.*::(\w+)$/$1/ foreach @params; - return join('',$class,@params); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Class::Template> базовый класс для шаблонов. - -=head1 SYNPOSIS - -=begin code - -package KeyValuePair; - -use IMPL::Class::Property; - -use IMPL::template ( - parameters => [qw(TKey TValue))], - base => [qw(IMPL::Object IMPL::Object::Autofill)], - declare => sub { - my ($class) = @_; - public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } ); - public $class->CreateProperty(value => prop_all, { type => $class->TValue} ); - - $class->PassThroughArgs; - } -); - -BEGIN { - public property id => prop_get | owner_set, { type => 'integer'}; -} - -__PACKAGE__->PassThroughArgs; - -package MyCollection; - -use IMPL::Class::Property; - -use IMPL::lang; -use IMPL::template( - parameters => [qw(TKey TValue)], - base => [qw(IMPL::Object)], - declare => sub { - my ($class) = @_; - my $item_t = spec KeyValuePair($class->TKey,$class->TValue); - - public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } ) - - $class->static_accessor( ItemType => $item_t ); - } -) - -sub Add { - my ($this,$key,$value) = @_; - - die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey; - die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue; - - $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) ); -} - -=end code - -=head1 DESCRIPTION - -Шаблоны используются для динамической генерации классов. Процесс создания класса -по шаблону называется специализацией, при этом создается новый класс: - -=over - -=item 1 - -Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона - -=item 2 - -Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона - -=item 3 - -Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров - -=item 4 - -Вызывается метод для конструирования специализиции - -=back - -=head1 MEMBERS - -=over - -=item C<spec(@params)> - -Метод, создающий специализацию шаблона. Может быть вызван как оператор. - -=back - -=cut
--- a/Lib/IMPL/Code/AccessorPropertyImplementor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -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 Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -package IMPL::Code::BasePropertyImplementor; -use strict; - -use IMPL::Const qw(:prop :access); -use Scalar::Util qw(looks_like_number); - -use constant { - CodeNoGetAccessor => 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;', - CodeNoSetAccessor => 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;', - CodeCustomGetAccessor => '$this->$get(@_);', - CodeCustomSetAccessor => '$this->$set(@_);', - CodeValidator => '$this->$validator(@_);', - CodeOwnerCheck => "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;" -}; - -sub CodeSetAccessor { - die new IMPL::Exception("Standard accessors not supported",'Set'); -} - -sub CodeGetAccessor { - die new IMPL::Exception("Standard accessors not supported",'Get'); -} - -sub CodeGetListAccessor { - die new IMPL::Exception("Standard accessors not supported",'GetList'); -} - -sub CodeSetListAccessor { - die new IMPL::Exception("Standard accessors not supported",'SetList'); -} - -sub factoryParams { qw($class $name $set $get $validator) }; - -our %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;" -); - -sub NormalizeSpecification { - my ($this,$spec) = @_; - - return $spec if ref($spec); - - if (looks_like_number($spec)) { - return { - get => $spec & PROP_GET, - set => $spec & PROP_SET, - isList => $spec & PROP_LIST, - ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET), - direct => $spec & PROP_DIRECT - }; - } else { - return {}; - } -} - -sub CreateFactoryId { - my ($self, $spec) = @_; - - join( '', - map( - ($_ - ? ( _isCustom($_) - ? 'x' - : 's') - : '_'), - @$spec{qw(get set)} - ), - $spec->{access} || ACCESS_PUBLIC, - $spec->{validator} ? 'v' : '_', - $spec->{isList} ? 'l' : '_', - $spec->{ownerSet} ? 'o' : '_' - ); -} - -sub _isCustom { - ref($_[0]) eq 'CODE' || not(ref($_[0]) || looks_like_number($_[0])); -} - -sub CreateFactory { - my ($self,$spec) = @_; - - return $self->CreateFactoryImpl( - ($spec->{get} - ? ( _isCustom($spec->{get}) - ? $self->CodeCustomGetAccessor - : ($spec->{isList} - ? $self->CodeGetListAccessor - : $self->CodeGetAccessor - ) - ) - : $self->CodeNoGetAccessor - ), - ($spec->{set} - ? ( _isCustom($spec->{set}) - ? $self->CodeCustomSetAccessor - : ($spec->{isList} - ? $self->CodeSetListAccessor - : $self->CodeSetAccessor - ) - ) - : $self->CodeNoSetAccessor - ), - $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '', - $spec->{validator} ? $self->CodeValidator : '', - $spec->{ownerSet} ? $self->CodeOwnerCheck : '' - ); -} - -sub CreateFactoryImpl { - my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_; - - my $strParams = join(',',$self->factoryParams); - - my $factory = <<FACTORY; - -sub { - my ($strParams) = \@_; - return 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 NAME - -C<IMPL::Code::BasePropertyImplementor> набор впомогательныйх статических методов -для генерации свойств. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Code/DirectPropertyImplementor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -package IMPL::Code::DirectPropertyImplementor; -use strict; - -require IMPL::Object::List; - -use IMPL::lang qw(:hash); -use IMPL::require { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo' -}; - -use parent qw(IMPL::Code::BasePropertyImplementor); - -use constant { - CodeGetAccessor => 'return ($this->{$field});', - CodeSetAccessor => 'return ($this->{$field} = $_[0])', - CodeGetListAccessor => 'return( - wantarray ? - @{ $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - } : - ( $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - ) - );', - CodeSetListAccessor => '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 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 = 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 Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,79 +0,0 @@ -package IMPL::Code::Loader; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use File::Spec; -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - }, - props => [ - verifyNames => PROP_RO, - prefix => PROP_RO, - _pending => PROP_RW - ] -}; - -my $default; -sub default { - $default ||= new IMPL::Code::Loader; -} - -my $safe; -sub safe { - $safe ||= new IMPL::Code::Loader(verifyNames => 1); -} - -sub CTOR { - my ($this) = @_; - - $this->_pending({}); -} - -sub Require { - my ($this,$package) = @_; - - 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; - - my $file = join('/', split(/::/,$package)) . ".pm"; - - require $file; - - return $package; -} - -sub ModuleExists { - my ($this,$package) = @_; - - my $file = join('/', split(/::/,$this->GetFullName($package))) . ".pm"; - - -f File::Spec->catfile($_,$file) and return 1 foreach @INC; - - return 0; -} - -sub GetFullName { - my ($this,$package) = @_; - - if ($this->verifyNames) { - $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/ - or die ArgumentException->new(package => 'Invalid package name') ; - } - - return $this->prefix . '::' . $package if $this->prefix; -} - -1; -
--- a/Lib/IMPL/Config.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,291 +0,0 @@ -package IMPL::Config; -use strict; -use warnings; -use mro; - -use Carp qw(carp); - -use IMPL::lang qw(is); -use IMPL::Exception; -use IMPL::Const qw(:access); -use IMPL::declare { - require => { - PropertyInfo => 'IMPL::Class::PropertyInfo', - XmlFormatter => 'IMPL::Serialization::XmlFormatter', - Serializer => '-IMPL::Serializer', - Activator => '-IMPL::Config::Activator', - - Exception => 'IMPL::Exception', - IOException => '-IMPL::IOException' - }, - base => [ - 'IMPL::Object::Accessor' => undef, - 'IMPL::Object::Serializable' => undef, - 'IMPL::Object::Autofill' => '@_' - ] -}; - -use File::Spec(); - - -our $ConfigBase ||= ''; -our $AppBase; - -sub LoadXMLFile { - my ($self,$file) = @_; - - my $class = ref $self || $self; - - my $serializer = Serializer->new( - formatter => XmlFormatter->new( - IdentOutput => 1, - SkipWhitespace => 1 - ) - ); - - open my $hFile,'<',$file or die IOException->new("Failed to open file",$file,$!); - - my $obj; - eval { - $obj = $serializer->Deserialize($hFile); - }; - - if ($@) { - my $e=$@; - die Exception->new("Can't load the configuration file",$file,$e); - } - return $obj; -} - -sub SaveXMLFile { - my ($this,$file) = @_; - - my $serializer = Serializer->new( - formatter => XmlFormatter->new( - IdentOutput => 1, - SkipWhitespace => 1 - ) - ); - - open my $hFile,'>',$file or die IOException->new("Failed to open file",$file,$!); - - $serializer->Serialize($hFile, $this); -} - -sub xml { - my $this = shift; - my $serializer = Serializer->new( - formatter => XmlFormatter->new( - IdentOutput => 1, - SkipWhitespace => 1 - ) - ); - my $str = ''; - open my $hFile,'>',\$str or die IOException->new("Failed to open stream",$!); - - $serializer->Serialize($hFile, $this); - - undef $hFile; - - return $str; -} - -sub save { - my ($this,$ctx) = @_; - - my $val; - - $val = $this->rawGet($_) and $ctx->AddVar($_ => $val) foreach map $_->Name, $this->get_meta( - PropertyInfo, - sub { - $_->access == ACCESS_PUBLIC and - $_->setter; - }, - 1); -} - -sub spawn { - my ($this,$file) = @_; - unless ($file) { - ($file = ref $this || $this) =~ s/:+/./g; - $file .= ".xml"; - } - return $this->LoadXMLFile( File::Spec->catfile($ConfigBase,$file) ); -} - -sub get { - my $this = shift; - - if (@_ == 1) { - my $obj = $this->SUPER::get(@_); - return is($obj,Activator) ? $obj->activate : $obj; - } else { - my @objs = $this->SUPER::get(@_); - return map is($_,Activator) ? $_->activate : $_, @objs ; - } -} - -sub rawGet { - my $this = shift; - return $this->SUPER::get(@_); -} - -sub Exists { - $_[0]->SUPER::get($_[1]) ? 1 : 0; -} - -sub AppBase { - carp "obsolete"; - shift; - File::Spec->catdir($AppBase,@_); -} - -sub AppDir { - shift; - File::Spec->catdir($AppBase,@_); -} - -sub AppFile { - shift; - File::Spec->catfile($AppBase,@_); -} - -sub ConfigBase { - carp "obsolete"; - shift; - File::Spec->catdir($ConfigBase,@_); -} - -sub ConfigDir { - shift; - File::Spec->catdir($ConfigBase,@_); -} - -sub ConfigFile { - shift; - File::Spec->catfile($ConfigBase,@_); -} - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config> - базовый класс для настраиваемого приложения. - -=head1 SYNOPSIS - -=begin code - -# define application - -package MyApp; -use parent qw(IMPL::Config); - -use IMPL::Class::Property; -use IMPL::Config::Class; - -BEGIN { - public property SimpleString => prop_all; - public property DataSource => prop_all; -} - -sub CTOR { - my $this = shift; - - $this->DataSource( - new IMPL::Config::Activator( - factory => 'MyDataSource', - parameters=>{ - host => 'localhost', - user => 'dbuser' - } - ) - ) unless $this->Exists('DataSource'); -} - -# using application object - -my $app = spawn MyApp('default.xml'); - -$app->Run(); - -=end code - -Ниже приведен пример файла C<default.xml> содержащего настройки приложения - -=begin code xml - -<app type='MyApp'> - <SimpleString>The application</SimpleString> - <DataSource type='IMPL::Config::Activator'> - <factory>MyDataSourceClass</factory> - <parameters type='HASH'> - <host>localhost</host> - <user>dbuser</user> - </parameters> - </DataSource> -</app> - -=end code xml - -=head1 DESCRIPTION - -C<[Serializable]> - -C<[Autofill]> - -C<use parent IMPL::Object::Accessor> - -Базовый класс для приложений. Использует подход, что приложение -является объектом, состояние которого предтавляет собой конфигурацию, -а методы - логику. - -Данный класс реализует функционал десериализации (и сериализации) экземпляра -приложения из XML документа. Для этого используется механизм C<IMPL::Serialization>. -При этом используются опции C<IMPL::Serialization::XmlFormatter> C<IdentOutput> и -C<SkipWhitespace> для записи документа в легко читаемом виде. - -Поскольку в результате восстановления приложения восстанавливаются все элементы -из файла конфигурации, то это может потребовать значительных ресурсов для -создания частей, которые могут никогда не понадобиться. Например, не требуется инициализация -источника данных для передачи пользователю статических данных, сохраненных на диске. - -Для решения этой проблемы используются специальные объекты C<IMPL::Config::Activator>. - -Если у приложения описано свойство, в котором хранится C<IMPL::Config::Activator>, то -при первом обращении к такому свойству, будет создан объект вызовом метода -C<< IMPL::Config::Activator->activate() >> и возвращен как значение этого свойства. -Таким образом реализуется прозрачная отложенная активация объектов, что позволяет -экономить ресурсы. - -=head1 MEMBERS - -=over - -=item C<[static] LoadXMLFile($fileName) > - -Создает из XML файла C<$fileName> экземпляр приложения - -=item C<SaveXMLFile($fileName)> - -Сохраняет приложение в файл C<$fileName> - -=item C<[get] xml > - -Сохраняет конфигурацию приложения в XML строку. - -=item C<[static,operator] spawn($file)> - -Синоним для C<LoadXMLFile>, предполагается использование как оператора. - -=item C<rawGet($propname,...)> - -Метод для получения значений свойств приложения. Данный метод позволяет избежать -использование активации объектов через C<IMPL::Config::Activator>. - -=back - -=cut
--- a/Lib/IMPL/Config/ActivationContext.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,68 +0,0 @@ -package IMPL::Config::ActivationContext; - -use IMPL::Const qw(:prop); -use IMPL::Exception(); -use IMPL::declare { - require => { - PropertyBag => 'IMPL::Config::ServicesBag' - }, - base => { - 'IMPL::Object' => '@_' - }, - props => { - _services => PROP_RW, - _cache => PROP_RW, - _stack => PROP_RW - } -}; - -sub GetService { - my ($this,$serviceId) = @_; - - $this->_services-> -} - -sub EnterScope { - my ($this, $name, $localize) = @_; - - my $info = { name => $name }; - - if ($localize) { - $info->{services} = $this->_services; - - $this->_services(PropertyBag->new($this->_services)); - } - - $this->_stack->Push($info); -} - -sub LeaveScope { - my ($this) = @_; - - my $info = $this->_stack->Pop() - or die IMPL::InvalidOperationException(); - - if ($info->{services}) - $this->_services($info->{services}); -} - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::ActivationContext> - an activation context for the service - -=head1 SYNOPSIS - -For the internal use only - -=head1 MEMBERS - -=head2 METHODS - -=head3 GetService($serviceId) - -=cut \ No newline at end of file
--- a/Lib/IMPL/Config/Activator.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,91 +0,0 @@ -package IMPL::Config::Activator; -use strict; - -use Scalar::Util qw(reftype); -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Loader => 'IMPL::Code::Loader', - Exception => 'IMPL::Exception' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::PublicSerializable' => undef - ], - props => [ - factory => PROP_RW, - parameters => PROP_RW, - singleCall => PROP_RW, - _object => PROP_RW - ] -}; - -use constant { - SELF_CLASS => __PACKAGE__, -}; - -sub CTOR { - my $this = shift; - - die Exception->new("A factory parameter is required") unless $this->factory; - -} - - -sub activate { - my $this = shift; - - unless ($this->_object) { - my @args; - - my $params = $this->parameters; - if (ref $params eq 'HASH') { - while ( my ($key,$value) = each %$params ) { - push @args,$key, is($value,SELF_CLASS) ? $value->activate : $value; - } - } elsif (ref $params eq 'ARRAY') { - push @args, map is($_,SELF_CLASS) ? $_->activate : $_, @$params; - } else { - push @args, is($params,SELF_CLASS) ? $params->activate : $params; - } - - push @args, map is($_,SELF_CLASS) ? $_->activate : $_, @_ if @_; - - my $factory = $this->factory; - Loader->default->Require($factory) - unless ref($factory); - - my $instance = $factory->new(@args); - - $this->_object($instance) - unless $this->singleCall; - - return $instance; - } else { - return $this->_object; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::Activator> - объект, используемый для получения других объектов. - -=head1 DESCRIPTION - -Служит дополнительным уровнем абстракции в тех случаях, когда нужный объект -заранее не известен или его создание должно происходить по требованию. -От обычной фабрики отличается также тем, что рассматривает формальные параметры -на наличие активаторов и выполняет их при активации. - -Кроме того можно указать, что процесс активации должен происходить при каждом -обращении. - -=cut
--- a/Lib/IMPL/Config/Container.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ -package IMPL::Config::Container; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::Container> - dependency injection container - -=head1 SYNOPSIS - -=head2 METHODS - -=head3 GetService($serviceId) - -=over - -=item * $serviceId - -A string indetifier of the service, it can be in two forms: class name or service name, -for the class name it should be prefixed with C<@>, for example: C<@Foo::Bar>. - -=back - -The activation container maintains two maps, one for classes and the other for names. -The first one is useful when we searching for an implementation the second one when -we need a particular service. - -=head3 RegisterService($descriptor) - -=cut \ No newline at end of file
--- a/Lib/IMPL/Config/Descriptor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -package IMPL::Config::Descriptor; - - - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::Descriptor> - the abstract base types for the service descriptors - -=head1 SYNOPSIS - -=begin code - -package MyDescriptor; - -use IMPL::declare { - base => { - 'IMPL::Config::Descriptor' => '@_' - } -}; - -sub Activate { - my ($this,$context) = @_; - - my $service = $context->GetService('service'); - my - -} - -=end code - -=head1 MEMBERS - -=head1 SEE ALSO - -=over - -=item * L<ReferenceDescriptor> - describes a reference to the service - -=item * L<ServiceDescriptor> - descibes a service factory - -=item * L<ValueDescriptor> - describes a value - -=back - -=cut \ No newline at end of file
--- a/Lib/IMPL/Config/Include.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -package IMPL::Config::Include; -use strict; -use warnings; -use IMPL::require { - Conf => 'IMPL::Config', - Exception => 'IMPL::Exception' -}; - - -sub restore { - my ($self,$data) = @_; - - die Exception->new("A file name is required") if ref $data || not $data; - - return Conf->spawn($data); -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Config/Path.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package IMPL::Config::Path; -use strict; -use IMPL::Config(); - -use IMPL::require { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException' -}; - -sub restore { - my ($self,$data,$surrogate) = @_; - - die OpException->new("Invalid content") unless ref $data eq 'ARRAY' && @$data == 2; - - my ($base,$path) = @$data; - - my %types = ( - appBase => 'AppDir', - configBase => 'ConfigDir' - ); - - my $method = $types{$base}; - - die OpException->new("Unsupported path type",$base) unless $method; - - return IMPL::Config->$method($path); -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Config/Reference.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -package IMPL::Config::Reference; -use strict; - -use IMPL::Exception; - -sub restore { - my ($self,$data,$surrogate) = @_; - - my @path; - - my ($tagTarget,$target) = splice @$data, 0, 2; - - die new IMPL::Exception('A traget tag must be the first tag in the reference specification') unless $tagTarget eq 'target'; - while(my ($method,$args) = splice @$data, 0, 2 ) { - $target = $self->_InvokeMember($target,{ method => $method, args => $args}); - } - return $target; -} - -sub _InvokeMember { - my ($self,$object,$member) = @_; - - my $method = $member->{method}; - return - ref $object eq 'HASH' ? - $object->{$method} - : - $object->$method( - exists $member->{args} ? - _as_list($member->{args}) - : - () - ) - ; -} - -sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Config::Reference> - ссылка на внешний объект, вычисляемый на этапе десериализации данных. - -=head1 SYNOPSIS - -=begin code xml - -<Application> - <processingStack type="IMPL::Config::Reference"> - <target>IMPL::Config</target> - <LoadXMLFile>stdprocessing.xml</LoadXMLFile> - </processingStack> -</Application> - -=end code xml - -=head1 DESCRIPTION - -Позволяет на указвать ссылки на вычисляемые объекты, например, загружаемые из файлов. Ссылки такого рода -будут вычислены на этапе десериализации еще до того, как будет создан объект верхнего уровня, поэтому -следует избегать таких ссылок на сам (его свойства и методы) десериализуемый объект. - -=head1 MEMBERS - -=head2 C<restore($class,$data,$surrogate)> - -Использует данные переданные в параметре дата C<$data> для вычисления свойства. Данный метод - стандартный -метод для десериализации объекта, а параметр C<$data> содержит пары значений C<(имя_узла,значение_узла)>, -первая пара обязательно является узлом C<target>, а его значение - целевой объект, который будет -использован для вычисления конечного значения. - -=back - -=cut \ No newline at end of file
--- a/Lib/IMPL/Config/Resolve.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,77 +0,0 @@ -package IMPL::Config::Resolve; -use strict; -use parent qw(IMPL::Object IMPL::Object::Serializable); - -use IMPL::Class::Property; -use IMPL::Exception; -use Carp qw(carp); - -BEGIN { - public property path => prop_all|prop_list; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - my $list = $this->path; - - while(my $name = shift ) { - my $args = shift; - $list->Append({ method => $name, (defined $args ? (args => $args) : ()) }); - } - - #die new IMPL::InvalidArgumentException("The argument is mandatory","path") unless $this->path->Count; -} - -sub Invoke { - my ($this,$target,$default) = @_; - - my $result = $target; - $result = $this->_InvokeMember($result,$_) || return $default foreach $this->path; - - return $result; -} - -sub _InvokeMember { - my ($self,$object,$member) = @_; - - my $method = $member->{method}; - - local $@; - return eval { - ref $object eq 'HASH' ? - $object->{$method} - : - $object->$method( - exists $member->{args} ? - _as_list($member->{args}) - : - () - ) - }; -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar($_->{method},$_->{args}) foreach $this->path; -} - -sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); -} - -1;
--- a/Lib/IMPL/Config/ServicesBag.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -package IMPL::Config::ServicesBag; - -require v5.9.5; - -use mro; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef - ], - props => [ - _prototype => PROP_RW, - _nameMap => PROP_RW, - _typeMap => PROP_RW, - _props => PROP_RW, - ] -}; - -sub CTOR { - my ( $this, $prototype ) = @_; - - $this->_prototype($prototype) if $prototype; - $this->_nameMap( {} ); - $this->_typeMap( {} ); -} - -sub GetDescriptorByName { - my ( $this, $name ) = @_; - - my $d = $this->_nameMap->{$name}; - return $d if $d and $d->{valid}; - - my $parent = $this->_prototype; - - if ( $parent and $d = $parent->GetDescriptorByName($name) ) { - return $this->_nameMap->{$name} = $d; - } - - return undef; -} - -sub GetDescriptorByType { - my ( $this, $type ) = @_; - - my $d = $this->_typeMap->{$type}; - return $d if $d and $d->{valid}; - - my $parent = $this->_prototype; - if ( $parent and $d = $parent->GetDescriptorByType($type) ) { - return $this->_typeMap->{$type} = $d; - } - - return undef; -} - -sub RegisterValue { - my ( $this, $value, $name, $type ) = @_; - - my $d = { owner => $this, value => $value, valid => 1 }; - - if ($type) { - my $map = $this->_typeMap; - my $isa = mro::get_linear_isa($type); - $d->{isa} = $isa; - - # the service record which is superseded by the current one - my $replaces = $this->GetDescriptorByType($type); - - foreach my $t (@$isa) { - if ( my $prev = $this->GetDescriptorByType($t) ) { - - # keep previous registrations if they are valid - next if not $replaces or $prev != $replaces; - } - - $map->{$t} = $d; - } - - if ($replaces) { - - # invalidate cache - $replaces->{owner}->UpdateDescriptor($replaces); - } - } - - if ($name) { - my $prev = $this->_nameMap->{$name}; - $d->{name} = $name; - $this->_nameMap->{$name} = $d; - $prev->{owner}->UpdateDescriptor($prev) if $prev; - } - - return $d; -} - -sub UpdateDescriptor { - my ( $this, $d ) = @_; - - my $d2 = {}; - - # copy descriptor - while ( my ( $k, $v ) = each %$d ) { - $d2->{$k} = $v; - } - - # update named entries - my $name = $d->{name}; - if ( $name and $this->_nameMap->{$name} == $d ) { - $this->_nameMap->{$name} = $d2; - } - - # update type entries - if ( my $isa = $d->{isa} ) { - my $map = $this->_typeMap; - foreach my $t (@$isa) { - next unless $map->{$t} == $d; - $map->{$t} = $d2; - } - } - - $d->{valid} = 0; -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Коллекция сервисов построена на прототиптровании экземпляров, т.е. при создании -новой коллекции может указваться базовая коллекция в которой будет происходить -поиск сервисов в случае их отсутсвия в основной. Для оптимизации данного процесса -сервисы кешируются, чтобы избежать можестрвенных операций поиска по иерархии -коллекций, для этого каждый сервис описывается дескриптором: - -=over - -=item * isa массив типов сервиса, если он регистрировался как сервис - -=item * value значение - -=item * valid признак того, что дескриптор действителен - -=item * owner коллекция, которая создала данный дескриптор - -=back - -Если запрашиваемый десриптор не найден это является ошибкой, поэтому негативные -ответы не кешируются - -=cut
--- a/Lib/IMPL/Const.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -package IMPL::Const; -use strict; - -use parent qw(Exporter); - -our %EXPORT_TAGS = ( - all => [ - qw( - &ACCESS_PUBLIC - &ACCESS_PROTECTED - &ACCESS_PRIVATE - &PROP_GET - &PROP_SET - &PROP_OWNERSET - &PROP_LIST - &PROP_ALL - &PROP_DIRECT - ) - ], - prop => [ - qw( - &PROP_GET - &PROP_SET - &PROP_OWNERSET - &PROP_LIST - &PROP_ALL - &PROP_RO - &PROP_RW - &PROP_DIRECT - ) - ], - access => [ - qw( - &ACCESS_PUBLIC - &ACCESS_PROTECTED - &ACCESS_PRIVATE - ) - ] - -); - -our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; - -use constant { - ACCESS_PUBLIC => 1, - ACCESS_PROTECTED => 2, - ACCESS_PRIVATE => 3, - PROP_GET => 1, - PROP_SET => 2, - PROP_OWNERSET => 10, - PROP_LIST => 4, - PROP_ALL => 3, - PROP_RW => 3, - PROP_RO => 11, - PROP_DIRECT => 16 -}; - -1; \ No newline at end of file
--- a/Lib/IMPL/DOM/Document.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -package IMPL::DOM::Document; -use strict; -use warnings; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - DOMNode => 'IMPL::DOM::Node' - }, - base => [ - DOMNode => '@_' - ], - props => [ - schemaDocument => PROP_RW - ] -}; - -sub document { - return $_[0]; -} - -sub Create { - my ($this,$nodeName,$class,$refProps) = @_; - - if ( ref $class eq 'HASH' ) { - $refProps = $class; - $class = undef; - } - - $class ||= DOMNode; - $refProps ||= {}; - - delete $refProps->{nodeName}; - - die new IMPL::Exception("class is not specified") unless $class; - return $class->new( - nodeName => $nodeName, - document => $this, - %$refProps - ); -} - -sub save { - my ($this,$writer) = @_; - - $writer->xmlDecl(undef,'yes'); - $this->SUPER::save($writer); - $writer->end(); -} - -{ - my $empty; - sub Empty() { - return $empty ? $empty : ($empty = __PACKAGE__->new(nodeName => 'Empty')); - } -} - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Document> DOM документ. - -=head1 DESCRIPTION - -Документ, позволяет создавать узлы определенных типов, что позволяет абстрагироваться -от механизмов реального создания объектов. Т.о. например C<IMPL::DOM::Navigator::Builder> -может формировать произвольные документы. - -=head1 SYNOPSIS - -=begin code - -package MyDocument; -use parent qw(IMPL::DOM::Document); - -sub Create { - my $this = shift; - my ($name,$class,$hashProps) = @_; - - if ($class eq 'Info') { - return MyInfo->new($name,$hashProps->{date},$hashProps->{description}); - } else { - # leave as it is - return $this->SUPER::Create(@_); - } -} - -=end code - -=head1 METHODS - -=over - -=item C< Create($nodeName,$class,$hashProps) > - -Реализация по умолчанию. Создает узел определеннго типа с определенным именем и свойствами. - -=begin code - -sub Create { - my ($this,$nodeName,$class,$hashProps) = @_; - - return $class->new ( - nodeName => $nodeName, - document => $this, - %$hashProps - ); -} - -=end code - -=item C< save($writer) > - -Сохраняет документ в виде XML узла и вызывает C<< $writer->end() >>. - -=over - -=item C<$writer> - -Объект с интерфейсом C<XML::Writer> который будет использован для записи -содержимого документа - -=back - -=back - -=cut
--- a/Lib/IMPL/DOM/Navigator.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,276 +0,0 @@ -package IMPL::DOM::Navigator; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; -BEGIN { - private _direct property _path => prop_all; - private _direct property _state => prop_all; - private _direct property _savedstates => prop_all; - public property Current => {get => \&_getCurrent}; -} - -sub CTOR { - my ($this,$CurrentNode) = @_; - - die IMPL::InvalidArgumentException->new("A starting node is a required paramater") unless $CurrentNode; - - $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; -} - -sub _initNavigator { - my ($this,$CurrentNode) = @_; - - die IMPL::InvalidArgumentException->new("A starting node is a required paramater") unless $CurrentNode; - - $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; - delete $this->{$_path}; - delete $this->{$_savedstates}; -} - -sub _getCurrent { - $_[0]->{$_state}{alternatives}[$_[0]->{$_state}{current}] -} - -sub Navigate { - my ($this,@path) = @_; - - return unless @path; - - my $node; - - foreach my $query (@path) { - if (my $current = $this->Current) { - - my @alternatives = $current->selectNodes($query); - - unless (@alternatives) { - $current = $this->advanceNavigator or return; - @alternatives = $current->selectNodes($query); - } - - push @{$this->{$_path}},$this->{$_state}; - $this->{$_state} = { - alternatives => \@alternatives, - current => 0, - query => $query - }; - - $node = $alternatives[0]; - } else { - return; - } - } - - $node; -} - -sub selectNodes { - my ($this,@path) = @_; - - return $this->Current->selectNodes(@path); -} - -sub internalNavigateNodeSet { - my ($this,@nodeSet) = @_; - - push @{$this->{$_path}}, $this->{$_state}; - - $this->{$_state} = { - alternatives => \@nodeSet, - current => 0 - }; - - $nodeSet[0]; -} - -sub fetch { - my ($this) = @_; - - my $result = $this->Current; - $this->advanceNavigator; - return $result; -} - -sub advanceNavigator { - my ($this) = @_; - - $this->{$_state}{current}++; - - if (@{$this->{$_state}{alternatives}} <= $this->{$_state}{current}) { - if ( exists $this->{$_state}{query} ) { - my $query = $this->{$_state}{query}; - - $this->Back or return; # that meams the end of the history - - undef while ( $this->advanceNavigator and not $this->Navigate($query)); - - return $this->Current; - } - return; - } - - return $this->Current; -} - -sub doeach { - my ($this,$code) = @_; - local $_; - - do { - for (my $i = $this->{$_state}{current}; $i < @{$this->{$_state}{alternatives}}; $i++) { - $_ = $this->{$_state}{alternatives}[$i]; - $code->(); - } - $this->{$_state}{current} = @{$this->{$_state}{alternatives}}; - } while ($this->advanceNavigator); -} - -sub Back { - my ($this,$steps) = @_; - - if ($this->{$_path} and @{$this->{$_path}}) { - if ( (not defined $steps) || $steps == 1) { - $this->{$_state} = pop @{$this->{$_path}}; - } elsif ($steps > 0) { - $steps = @{$this->{$_path}} - 1 if $steps >= @{$this->{$_path}}; - - $this->{$_state} = (splice @{$this->{$_path}},-$steps)[0]; - } - $this->Current if defined wantarray; - } else { - return; - } -} - -sub PathToString { - my ($this,$delim) = @_; - - $delim ||= '/'; - - join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); -} - -sub pathLength { - my ($this) = @_; - $this->{$_path} ? scalar @{$this->{$_path}} : 0; -} - -sub GetNodeFromHistory { - my ($this,$index) = @_; - - if (my $state = $this->{$_path} ? $this->{$_path}->[$index] : undef ) { - return $state->{alternatives}[$state->{current}] - } else { - return; - } -} - -sub clone { - my ($this) = @_; - - my $newNavi = __PACKAGE__->surrogate; - - $newNavi->{$_path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; - $newNavi->{$_state} = { %{$this->{$_state}} }; - - return $newNavi; - -} - -sub saveState { - my ($this) = @_; - - my %state; - - $state{path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; - $state{state} = { %{$this->{$_state}} }; - - push @{$this->{$_savedstates}}, \%state; -} - -sub restoreState { - my ($this) = @_; - - if ( my $state = pop @{$this->{$_savedstates}||[]} ) { - $this->{$_path} = $state->{path}; - $this->{$_state} = $state->{state}; - } -} - -sub applyState { - my ($this) = @_; - - pop @{$this->{$_savedstates}||[]}; -} - -sub dosafe { - my ($this,$transaction) = @_; - - $this->saveState(); - - my $result; - - eval { - $result = $transaction->(); - }; - - if ($@) { - $this->restoreState(); - return; - } else { - $this->applyState(); - return $result; - } -} - -1; - -__END__ -=pod - -=head1 DESCRIPTION - -Объект для хождения по дереву DOM объектов. - -Результатом навигации является множество узлов (альтернатив). - -Состоянием навигатора является текущий набор узлов, позиция в данном наборе, -а также запрос по которому были получены данные результаты. - -Если при навигации указан путь сосящий из нескольких фильтров, то он разбивается -этапы простой навигации по кадой из частей пути. На каждом элементарном этапе -навигации образуется ряд альтернатив, и при каждом следующем этапе навигации -альтернативы предыдущих этапов могут перебираться, до получения положительного -результата навигации, в противном случае навигация считается невозможной. - -=head1 METHODS - -=over - -=item C<<$obj->new($nodeStart)>> - -Создает объект навигатора с указанной начальной позицией. - -=item C<<$obj->Navigate([$query,...])>> - -Перейти в новый узел используя запрос C<$query>. На данный момент запросом может -быть только имя узла и будет взят только первый узел. Если по запросу ничего не -найдено, переход не будет осуществлен. - -Возвращает либо новый узел в который перешли, либо C<undef>. - -=item C<<$obj->Back()>> - -Возвращается в предыдущий узел, если таковой есть. - -Возвращает либо узел в который перешли, либо C<undef>. - -=item C<<$obj->advanceNavigator()>> - -Переходит в следующую альтернативу, соответствующую текущему запросу. - -=back - -=cut
--- a/Lib/IMPL/DOM/Navigator/Builder.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -package IMPL::DOM::Navigator::Builder; -use strict; -use warnings; - -use IMPL::Const qw(:prop); - -use parent qw(IMPL::DOM::Navigator); -use IMPL::Class::Property; -require IMPL::DOM::Navigator::SchemaNavigator; -require IMPL::DOM::Schema::ValidationError; -use IMPL::DOM::Document; - -BEGIN { - private _direct property _schemaNavi => PROP_RW; - private _direct property _docClass => PROP_RW; - public _direct property Document => PROP_RO; - public _direct property ignoreUndefined => PROP_RO; -} - -our %CTOR = ( - 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document->Empty; } -); - -sub CTOR { - my ($this,$docClass,$schema,%opts) = @_; - - $this->{$_docClass} = $docClass; - $this->{$_schemaNavi} = $schema ? IMPL::DOM::Navigator::SchemaNavigator->new($schema) : undef; - - $this->{$ignoreUndefined} = $opts{ignoreUndefined} if $opts{ignoreUndefined}; -} - -sub NavigateCreate { - my ($this,$nodeName,%props) = @_; - - if (my $schemaType = $this->{$_schemaNavi}->NavigateName($nodeName)) { - my $class = $schemaType->can('nativeType') ? $schemaType->nativeType || 'IMPL::DOM::Node' : 'IMPL::DOM::Node'; - - my $schemaNode = $this->{$_schemaNavi}->SourceSchemaNode; - - $props{schemaType} = $schemaType; - $props{schemaNode} = $schemaNode; - - my $node; - if (! $this->{$Document}) { - # keep reference to the schema document - $props{schemaDocument} = $this->{$_schemaNavi}->schema; - $node = $this->{$Document} = $this->{$_docClass}->new(nodeName => $nodeName,%props); - $this->_initNavigator($node); - } else { - die new IMPL::InvalidOperationException('Can\'t create a second top level element') unless $this->Current; - $node = $this->{$Document}->Create($nodeName,$class,\%props); - $this->Current->appendChild($node); - $this->internalNavigateNodeSet($node); - } - - return $node; - } else { - die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName) - if !$this->ignoreUndefined; - return; - } -} - -sub Back { - my ($this) = @_; - - $this->{$_schemaNavi}->SchemaBack(); - $this->SUPER::Back(); -} - -sub saveState { - my ($this) = @_; - - $this->{$_schemaNavi}->saveState; - $this->SUPER::saveState; -} - -sub restoreState { - my ($this) = @_; - - $this->{$_schemaNavi}->restoreState; - $this->SUPER::restoreState; -} - -sub document { - goto &Document; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C< IMPL::DOM::Navigator::Builder > - Навигатор, строящий документ по указанной схеме. - -=head1 SYNOPSIS - -=begin code - -my $builder = new IMPL::DOM::Navigator::Builder(new MyApp::Document,$schema); -my $reader = new IMPL::DOM::XMLReader(Navigator => $builder); - -$reader->ParseFile("document.xml"); - -my @errors = $schema->Validate($builder->Document); - -=end code - -=head1 DESCRIPTION - -Построитель DOM документов по указанной схеме. Обычно используется в связке -с объектами для чтения такими как C<IMPL::DOM::XMLReader>. - -=head1 MEMBERS - -=head2 C< CTOR($classDocument,$schema, %opts) > - -Создает новый объект, принимает на вход класс документа (или фабрику, например -L<IMPL::Object::Factory>) и схему. В процессе процедуры построения документа -будет создан объект документа. - -Необязательные именованные параметры - -=over - -=item C<ignoreUndefined> - -C<NavigateCreate> не будет вызывать исключение, если запрашиваемый узел не -найден в схеме, но будет возвращать C<undef>. - -=back - -=head2 C< NavigateCreate($nodeName,%props) > - -Создает новый узел с указанным именем и переходит в него. В случае если в схеме -подходящий узел не найден, то вызывается исключение или будет возвращено -C<undef> см. C<ignoreUndefined>. - -При этом по имени узла ищется его схема, после чего определяется класс для -создания экземпляра узла и созданный узел доавляется в документ. При создании -нового узла используется метод документа C<< IMPL::DOM::Document->Create >> - -Свойства узла передаются при создании через параметр C<%props>, но имя -создаваемого узла НЕ может быть переопределено свойством C<nodeName>, оно будет -проигнорировано. - -Свойства узла будут преобразованы при помощи заданных в схеме заполнителей -C<inflator>. - -=head2 C<[get]document > - -Свойство, которое содержит документ по окончании процедуры построения. - -=head2 C<[get]buildErrors> - -Ошибки, возникшие в процессе построения документа. - -=head2 C<[get]ignoreUndefined> - -Опция, заданная при создании построителя, отвечающая за обработку узлов -не найденных в схеме. - -=cut
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -package IMPL::DOM::Navigator::SchemaNavigator; -use strict; -use warnings; - -use IMPL::Class::Property; - -require IMPL::DOM::Schema::ComplexType; -require IMPL::DOM::Schema::NodeSet; -require IMPL::DOM::Schema::AnyNode; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Navigator' => '@_' - ] -}; - -BEGIN { - public _direct property Schema => prop_get; - private _direct property _historySteps => prop_all; -} - -sub CTOR { - my ($this,$schema) = @_; - - $this->{$Schema} = $schema->isa('IMPL::DOM::Schema::ComplexNode') ? $schema->document : $schema; - - die new IMPL::InvalidArgumentException("A schema object is required") unless ref $this->{$Schema} && eval { $this->{$Schema}->isa('IMPL::DOM::Schema') }; -} - -my $schemaAnyNode = IMPL::DOM::Schema::ComplexType->new(type => '::AnyNodeType', nativeType => 'IMPL::DOM::ComplexNode')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new() - ) -); - -sub NavigateName { - my ($this,$name) = @_; - - die new IMPL::InvalidArgumentException('name is required') unless defined $name; - - # perform a safe navigation - #return dosafe $this sub { - my $steps = 0; - # if we are currently in a ComplexNode, first go to it's content - if ($this->Current->isa('IMPL::DOM::Schema::ComplexNode')) { - # navigate to it's content - # ComplexNode - $this->internalNavigateNodeSet($this->Current->content); - $steps ++; - } - - # navigate to node - if ( - my $node = $this->Navigate( sub { - $_->isa('IMPL::DOM::Schema::Node') and ( - $_->name eq $name - or - $_->nodeName eq 'AnyNode' - or - ( $_->nodeName eq 'SwitchNode' and $_->selectNodes( sub { $_->name eq $name } ) ) - ) - }) - ) { - $steps ++; - if ($node->nodeName eq 'AnyNode') { - # if we navigate to the anynode - # assume it to be ComplexType by default - $node = $node->type ? $this->{$Schema}->resolveType($node->type) : $schemaAnyNode; - $this->internalNavigateNodeSet($node); - $steps ++; - } elsif ($node->nodeName eq 'SwitchNode') { - # if we are in the switchnode - # navigate to the target node - $node = $this->Navigate(sub { $_->name eq $name }); - $steps ++; - } - - die IMPL::Exception->new("A node is expected") - unless $node; - if ($node->nodeName eq 'Node') { - # if we navigate to a reference - # resolve it - $node = $this->{$Schema}->resolveType($node->type); - $this->internalNavigateNodeSet($node); - $steps++; - } - - push @{$this->{$_historySteps}},$steps; - - # return found node schema - return $node; - } else { - return; # abort navigation - } - #} -} - -sub SchemaBack { - my ($this) = @_; - - $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; -} - -sub SourceSchemaNode { - my ($this) = @_; - - if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or - $this->Current->isa('IMPL::DOM::Schema::ComplexType') - ) { - # we are redirected - return $this->GetNodeFromHistory(-1); - } else { - return $this->Current; - } -} - -sub schema { - goto &Schema; -} - -1; -__END__ - -=pod - -=head1 DESCRIPTION - -Помимо стандартных методов навигации позволяет переходить по элементам документа, -который данной схемой описывается. - -=head1 METHODS - -=over - -=item C<NavigateName($name)> - -Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>. - -=item C<SchemaBack> - -Возвращается на позицию до последней операции C<NavigateName>. Данный метод нужен -посокольку операция навигации по элементам описываемым схемой может приводить к -нескольким операциям навигации по самой схеме. - -=item C<SourceSchemaNode> - -Получает схему узла из которого было выполнено перенаправление, например, C<IMPL::DOM::Schema::Node>. -В остальных случаях совпадает со свойством C<Current>. - -=back - -=cut
--- a/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -package IMPL::DOM::Navigator::SimpleBuilder; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Navigator); - -use IMPL::Class::Property; - -require IMPL::DOM::Navigator::SchemaNavigator; -use IMPL::DOM::Document; - -BEGIN { - public _direct property Document => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document::Empty; } -); - -sub NavigateCreate { - my ($this,$nodeName,%props) = @_; - - my $node; - if (! $this->{$Document}) { - $node = $this->{$Document} = IMPL::DOM::Document->new(nodeName => $nodeName,%props); - $this->_initNavigator($node); - } else { - die new IMPL::InvalidOperationException('Can create a second top level element') unless $this->Current; - $node = $this->{$Document}->Create($nodeName,'IMPL::DOM::Node',\%props); - $this->Current->appendChild($node); - $this->internalNavigateNodeSet($node); - } - return $node; -} - -sub inflateValue { - $_[1]; -} - -1;
--- a/Lib/IMPL/DOM/Node.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,505 +0,0 @@ -package IMPL::DOM::Node; -use strict; -use warnings; - -use Scalar::Util qw(weaken); - -use IMPL::lang; -use IMPL::Object::List; - -use IMPL::Exception(); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - PropertyInfo => '-IMPL::Class::PropertyInfo' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - nodeName => PROP_RO | PROP_DIRECT, - document => PROP_RO | PROP_DIRECT, - isComplex => { get => \&_getIsComplex }, - nodeValue => PROP_RW | PROP_DIRECT, - childNodes => { get => \&_getChildNodes, isList => 1, direct => 1 }, - parentNode => PROP_RO | PROP_DIRECT, - schemaNode => PROP_RO | PROP_DIRECT, - schemaType => PROP_RO | PROP_DIRECT, - _propertyMap => PROP_RW | PROP_DIRECT - ] -}; - -our %Axes = ( - parent => \&selectParent, - siblings => \&selectSiblings, - child => \&childNodes, - document => \&selectDocument, - ancestor => \&selectAncestors, - descendant => \&selectDescendant -); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); - $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; - if ( exists $args{document} ) { - $this->{$document} = delete $args{document}; - weaken($this->{$document}); - } - - while ( my ($key,$value) = each %args ) { - $this->nodeProperty($key,$value); - } -} - -sub insertNode { - my ($this,$node,$pos) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - $this->childNodes->InsertAt($pos,$node); - - $node->_setParent( $this ); - - return $node; -} - -sub appendChild { - my ($this,$node) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - my $children = $this->childNodes; - $children->Push($node); - - $node->_setParent( $this ); - - return $node; -} - -sub appendNode { - goto &appendChild; -} - -sub appendRange { - my ($this,@range) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; - - foreach my $node (@range) { - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - $node->_setParent( $this ); - } - - $this->childNodes->Push(@range); - - return $this; -} - -sub _getChildNodes { - my ($this) = @_; - - $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; - return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes}; -} - -sub childNodesRef { - my ($this) = @_; - return scalar $this->_getChildNodes; -} - -sub removeNode { - my ($this,$node) = @_; - - if ($this == $node->{$parentNode}) { - $this->childNodes->RemoveItem($node); - $node->_setParent(undef); - return $node; - } else { - die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); - } -} - -sub replaceNodeAt { - my ($this,$index,$node) = @_; - - my $nodeOld = $this->childNodes->[$index]; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - # unlink node from previous parent - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - # replace (or set) old node - $this->childNodes->[$index] = $node; - - # set new parent - $node->_setParent( $this ); - - # unlink old node if we have one - $nodeOld->_setParent(undef) if $nodeOld; - - # return old node - return $nodeOld; -} - -sub removeAt { - my ($this,$pos) = @_; - - if ( my $node = $this->childNodes->RemoveAt($pos) ) { - $node->_setParent(undef); - return $node; - } else { - return undef; - } -} - -sub removeLast { - my ($this) = @_; - - if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { - $node->_setParent(undef); - return $node; - } else { - return undef; - } -} - -sub removeSelected { - my ($this,$query) = @_; - - my @newSet; - my @result; - - if (ref $query eq 'CODE') { - &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; - } elsif (defined $query) { - $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; - } else { - my $children = $this->childNodes; - $_->_setParent(undef) foreach @$children; - delete $this->{$childNodes}; - return wantarray ? @$children : $children; - } - - $_->_setParent(undef) foreach @result; - - $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; - - return wantarray ? @result : \@result; -} - -sub resolveAxis { - my ($this,$axis) = @_; - return $Axes{$axis}->($this) -} - -sub selectNodes { - my $this = shift; - my $path; - - if (@_ == 1) { - $path = $this->translatePath($_[0]); - } else { - $path = [@_]; - } - - my @set = ($this); - - while (@$path) { - my $query = shift @$path; - @set = map $_->selectNodesAxis($query), @set; - } - - return wantarray ? @set : \@set; -} - -sub selectSingleNode { - my $this = shift; - my @result = $this->selectNodes(@_); - return $result[0]; -} - -sub selectNodesRef { - my $this = shift; - - my @result = $this->selectNodes(@_); - return \@result; -} - -sub translatePath { - my ($this,$path) = @_; - - # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare - return [$path]; -} - -sub selectNodesAxis { - my ($this,$query,$axis) = @_; - - $axis ||= 'child'; - - die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis}; - - my $nodes = $this->resolveAxis($axis); - - my @result; - - if (ref $query eq 'CODE') { - @result = grep &$query($_), @{$nodes}; - } elsif (ref $query eq 'ARRAY' ) { - my %keys = map (($_,1),@$query); - @result = grep $keys{$_->nodeName}, @{$nodes}; - } elsif (ref $query eq 'HASH') { - while( my ($axis,$filter) = each %$query ) { - push @result, $this->selectNodesAxis($filter,$axis); - } - } elsif (defined $query) { - @result = grep $_->nodeName eq $query, @{$nodes}; - } else { - return wantarray ? @{$nodes} : $nodes; - } - - return wantarray ? @result : \@result; -} - -sub selectParent { - my ($this) = @_; - - if ($this->parentNode) { - return wantarray ? $this->parentNode : [$this->parentNode]; - } else { - return wantarray ? () : []; - } -} - -sub selectSiblings { - my ($this) = @_; - - if ($this->parentNode) { - return $this->parentNode->selectNodes( sub { $_ != $this } ); - } else { - return wantarray ? () : []; - } -} - -sub selectDocument { - my ($this) = @_; - - if ($this->document) { - return wantarray ? $this->document : [$this->document]; - } else { - return wantarray ? () : []; - } -} - -sub selectDescendant { - wantarray ? - map $_->selectAll(), $_[0]->childNodes : - [map $_->selectAll(), $_[0]->childNodes] -} - -sub selectAll { - map(selectAll($_),@{$_[0]->childNodes}) , $_[0] -} - -sub selectAncestors { - my $parent = $_[0]->parentNode; - - wantarray ? - ($parent ? ($parent->selectAncestors,$parent) : ()) : - [$parent ? ($parent->selectAncestors,$parent) : ()] -} - -sub firstChild { - @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; -} - -sub _getIsComplex { - ($_[0]->{$childNodes} and $_[0]->{$childNodes}->Count) ? 1 : 0; -} - -sub _updateDocRefs { - my ($this) = @_; - - # this method is called by the parent node on his children, so we need no to check parent - $this->{$document} = $this->{$parentNode}->document; - - # prevent cyclic - weaken($this->{$document}) if $this->{$document}; - - map $_->_updateDocRefs, @{$this->{$childNodes}} if $this->{$childNodes}; -} - -sub _setParent { - my ($this,$node) = @_; - - - if (($node || 0) != ($this->{$parentNode} || 0)) { - my $newOwner; - if ($node) { - $this->{$parentNode} = $node; - $newOwner = $node->document || 0; - - # prevent from creating cyclicreferences - weaken($this->{$parentNode}); - - } else { - delete $this->{$parentNode}; - - #keep document - $newOwner = $this->{$document}; - } - - if (($this->{$document}||0) != $newOwner) { - $this->{$document} = $newOwner; - weaken($this->{$document}) if $newOwner; - $_->_updateDocRefs foreach @{$this->childNodes}; - } - } -} - -sub text { - my ($this) = @_; - - join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes})); -} - -sub nodeProperty { - my $this = shift; - my $name = shift; - - return unless defined $name; - - if (my $method = $this->can($name)) { - unshift @_,$this; - # use goto to preserve calling context - goto &$method; - } - # dynamic property - if (@_) { - # set - return $this->{$_propertyMap}{$name} = shift; - } else { - return $this->{$_propertyMap}{$name}; - } -} - -sub listProperties { - my ($this) = @_; - - my %props = map {$_->name, 1} $this->GetMeta(PropertyInfo, sub { $_->attributes->{dom} },1); - - return (keys %props,keys %{$this->{$_propertyMap}}); -} - -sub save { - my ($this,$writer) = @_; - - if ( not ( $this->isComplex or defined $this->{$nodeValue} ) ) { - $writer->emptyTag( - $this->{$nodeName}, - map { - $_, - $this->nodeProperty($_) - } grep defined $this->nodeProperty($_), $this->listProperties - ); - } else { - $writer->startTag( - $this->{$nodeName}, - map { - $_, - $this->nodeProperty($_) - } grep defined $this->nodeProperty($_), $this->listProperties - ); - $writer->characters($this->{$nodeValue}) if $this->{$nodeValue}; - - $_->save($writer) foreach $this->childNodes; - - $writer->endTag($this->{$nodeName}); - } -} - -sub qname { - $_[0]->{$nodeName}; -} - -sub path { - my ($this) = @_; - - if ($this->parentNode) { - return $this->parentNode->path.'.'.$this->qname; - } else { - return $this->qname; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Node> Элемент DOM модели - -=head1 DESCRIPTION - -Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get] nodeName> - -Имя узла. Задается при создании. - -=item C<[get] document> - -Документ к которому принадлежит узел. Задается при поздании узла. - -=item C<[get] isComplex> - -Определяет является ли узел сложным (тоесть есть ли дети). - -C<true> - есть, C<false> - нет. - -=item C<[get,set] nodeValue> - -Значение узла, обычно простой скаляр, но ничто не мешает туда -устанавливать любое значение. - -=item C<[get,list] childNodes> - -Список детей, является списокм C<IMPL::Object::List>. - -=item C<[get] parentNode> - -Ссылка на родительский элемент, если таковой имеется. - -=item C<[get] schemaType> - -Ссылка на узел из C<IMPL::DOM::Schema>, представляющий схему данных текущего узла. Может быть C<undef>. - -=item C<[get] schemaNode> - -Ссылка на узел из C<IMPL::DOM::Schema>, представляющий элемент схемы, объявляющий данный узел. Может быть C<undef>. - -Отличается от свойства C<schemaType> тем, что узел в случае ссылки на тип узла, данной свойство будет содержать -описание ссылки C<IMPL::DOM::Schema::Node>, а свойство C<schema> например будет ссылаться на -C<IMPL::DOM::Schema::ComplexType>. - -=back - -=head2 METHODS - -=cut
--- a/Lib/IMPL/DOM/Property.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -package IMPL::DOM::Property; -use strict; -use warnings; - -require IMPL::Exception; - -use parent qw(Exporter); -our @EXPORT_OK = qw(_dom); - -sub _dom($) { - my ($prop_info) = @_; - $prop_info->{dom} = 1; - return $prop_info; -} - -1; -__END__ -=pod - -=head1 SYNOPSIS - -package TypedNode; - -use parent qw(IMPL::DOM::Node); -use IMPL::DOM::Property qw(_dom); - -BEGIN { - public _dom property Age => prop_all; - public _dom property Address => prop_all; - public property ServiceData => prop_all; -} - -=head1 DESCRIPTION - -Позволяет объявлять свойства, которые будут видны в списке свойств. - -=cut
--- a/Lib/IMPL/DOM/Schema.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,371 +0,0 @@ -package IMPL::DOM::Schema; -use strict; -use warnings; - -use File::Spec; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ComplexNode => 'IMPL::DOM::Schema::ComplexNode', - ComplexType => 'IMPL::DOM::Schema::ComplexType', - SimpleNode => 'IMPL::DOM::Schema::SimpleNode', - SimpleType => 'IMPL::DOM::Schema::SimpleType', - Node => 'IMPL::DOM::Schema::Node', - AnyNode => 'IMPL::DOM::Schema::AnyNode', - NodeList => 'IMPL::DOM::Schema::NodeList', - NodeSet => 'IMPL::DOM::Schema::NodeSet', - Property => 'IMPL::DOM::Schema::Property', - SwitchNode => 'IMPL::DOM::Schema::SwitchNode', - Validator => 'IMPL::DOM::Schema::Validator', - Builder => 'IMPL::DOM::Navigator::Builder', - XMLReader => 'IMPL::DOM::XMLReader', # XMLReader references Schema - Loader => 'IMPL::Code::Loader', - StringMap => 'IMPL::Resources::StringLocaleMap' - }, - base => [ - 'IMPL::DOM::Document' => sub { - nodeName => 'schema' - } - ], - props => [ - _typesMap => PROP_RW | PROP_DIRECT, - baseDir => PROP_RW | PROP_DIRECT, - schemaName => PROP_RW | PROP_DIRECT, - baseSchemas => PROP_RO | PROP_LIST | PROP_DIRECT, - stringMap => { - get => '_getStringMap', - direct => 1 - } - ] -}; - -my $validatorLoader = Loader->new(prefix => Validator, verifyNames => 1); - -#TODO rename and remove -sub resolveType { - goto &ResolveType; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$baseDir} = ($args{baseDir} || '.'); -} - -# compat -sub ResolveType { - my ($this,$typeName) = @_; - - my $type = $this->{$_typesMap}{$typeName}; - return $type if $type; - - foreach my $base ($this->baseSchemas) { - last if $type = $base->ResolveType($typeName); - } - - die IMPL::KeyNotFoundException->new($typeName) - unless $type; - return $this->{$_typesMap}{$typeName} = $type; -} - -sub Create { - my ($this,$nodeName,$class,$refArgs) = @_; - - die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Node'); - - if ($class->isa('IMPL::DOM::Schema::Validator')) { - $class = $validatorLoader->GetFullName($nodeName); - unless (eval {$class->can('new')}) { - eval { - $validatorLoader->Require($nodeName); - }; - my $e = $@; - die new IMPL::Exception("Invalid validator",$class,$e) if $e; - } - } - - return $this->SUPER::Create($nodeName,$class,$refArgs); -} - -sub _getStringMap { - my ($this) = @_; - - return $this->{$stringMap} - if $this->{$stringMap}; - - my $map = StringMap->new(); - if ($this->baseDir and $this->schemaName) { - - $map->paths( File::Spec->catdir($this->baseDir,'locale') ); - $map->name( $this->schemaName ); - } - - return $this->{$stringMap} = $map; -} - -sub Process { - my ($this) = @_; - - # process instructions - $this->Include($_) foreach map $_->nodeProperty('source'), $this->selectNodes('Include'); - - # build types map - $this->{$_typesMap} = { map { $_->type, $_ } $this->selectNodes(sub { $_[0]->nodeName eq 'ComplexType' || $_[0]->nodeName eq 'SimpleType' } ) }; -} - -sub Include { - my ($this,$file) = @_; - - my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file)); - - $this->baseSchemas->Push( $schema ); -} - -sub LoadSchema { - my ($this,$file) = @_; - - $file = File::Spec->rel2abs($file); - - my $class = ref $this || $this; - - my $reader = XMLReader->new( - Navigator => Builder->new( - $class, - $class->MetaSchema - ), - SkipWhitespace => 1 - ); - - $reader->ParseFile($file); - - my $schema = $reader->Navigator->Document; - - my ($vol,$dir,$name) = File::Spec->splitpath($file); - - $name =~ s/\.xml$//; - - $schema->baseDir($dir); - $schema->schemaName($name); - - my @errors = $class->MetaSchema->Validate($schema); - - die new IMPL::Exception("Schema is invalid",$file,map( $_->message, @errors ) ) if @errors; - - $schema->Process; - - return $schema; -} - -sub Validate { - my ($this,$node) = @_; - - if ( my ($schemaNode) = $this->selectNodes(sub { $_->isa(Node) and $_[0]->name eq $node->nodeName })) { - $schemaNode->Validate($node); - } else { - return new IMPL::DOM::Schema::ValidationError(node => $node, message=> "A specified document (%Node.nodeName%) doesn't match the schema"); - } -} - -my $schema; - -sub MetaSchema { - - return $schema if $schema; - - $schema = __PACKAGE__->new(); - - $schema->appendRange( - ComplexNode->new(name => 'schema')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), - SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( - Property->new(name => 'source') - ) - ), - ), - ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), - SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange( - Node->new(name => 'AnyNode', type => 'AnyNode'), - Node->new(name => 'SwitchNode',type => 'SwitchNode') - ) - ) - ), - ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), - ) - ), - ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( - NodeSet->new()->appendRange( - Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), - Node->new(name => 'AnyNode', type => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), - ) - ), - ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( - NodeList->new()->appendRange( - SwitchNode->new()->appendRange( - Node->new(name => 'NodeSet', type => 'NodeSet'), - Node->new(name => 'NodeList',type => 'NodeList'), - ), - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'type') - ), - ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange( - NodeList->new()->appendRange( - SwitchNode->new()->appendRange( - Node->new(name => 'NodeSet', type => 'NodeSet'), - Node->new(name => 'NodeList',type => 'NodeList'), - ), - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'name') - ), - ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange( - NodeList->new()->appendRange( - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'type') - ), - ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( - NodeList->new()->appendRange( - Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), - AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - Property->new(name => 'name') - ), - ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange( - NodeList->new()->appendRange( - AnyNode->new(maxOccur => 'unbounded', minOccur => 0) - ) - ), - ComplexType->new(type => 'Property', nativeType => 'IMPL::DOM::Schema::Property' )->appendRange( - NodeList->new()->appendRange( - AnyNode->new(maxOccur => 'unbounded', minOccur => 0) - ), - Property->new(name => 'name') - ), - SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange( - Property->new(name => 'name'), - Property->new(name => 'type') - ), - SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode') - ); - - $schema->Process; - - return $schema; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema> - Схема документа. - -=head1 DESCRIPTION - -C<use parent qw(IMPL::DOM::Document)> - -DOM схема - это документ, состоящий из определенных узлов, описывающая структуру -других документов. - -=head1 METHODS - -=over - -=item C<< $obj->Process() >> - -Обновляет таблицу типов из содержимого. - -=item C<< $obj->ResolveType($typeName) >> - -Возвращает схему типа c именем C<$typeName>. - -=back - -=head1 META SCHEMA - -Схема для описания схемы, эта схема используется для постороения других схем, выглядит приблизительно так - -=begin code xml - -<schema> - <ComplexNode name="schema"> - <NodeSet> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexType" type="ComplexType"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleType" type="SimpleType"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Include"/> - </NodeSet> - </ComplexNode> - - <ComplexType type="NodeContainer"> - <NodeSet> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> - </NodeSet> - </ComplexType> - - <ComplexType type="ComplexType"> - <NodeList> - <Node name="NodeSet" type="NodeContainer" minOcuur=0/> - <Node name="NodeList" type="NodeContainer" minOccur=0/> - <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> - </NodeList> - </ComplexType> - - <ComplexType type="ComplexNode"> - <NodeList> - <Node name="NodeSet" type="NodeContainer" minOcuur=0/> - <Node name="NodeList" type="NodeContainer" minOccur=0/> - <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> - </NodeList> - </ComplexType> - - <ComplexType type="SimpleNode"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> - </NodeSet> - </ComplexType> - - <ComplexType type="SimpleType"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> - </NodeSet> - </ComplexType> - - <ComplexType type="Validator"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded"/> - </NodeSet> - </ComplexType> - -</schema> - -=end code xml - -=cut
--- a/Lib/IMPL/DOM/Schema/AnyNode.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package IMPL::DOM::Schema::AnyNode; -use strict; -use warnings; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Schema::Node' => sub { - my %args = @_; - $args{nodeName} ||= 'AnyNode'; - $args{name} = '::any'; - - %args; - } - ] -}; - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Узел с произвольным именем, для этого узла предусмотрена специальная проверка -в контейнерах. - -В контейнерах типа C<IMPL::DOM::Schema::NodeSet> этот узел можно использовать только один раз -причем его использование исключает использование узла C<IMPL::DOM::Schema::SwitchNode>. - -В контейнерах типа С<IMPL::DOM::Schema::NodeList> данный узел может применяться несколько раз -для решения таких задач как последовательности разноименных узлов с одним типом. - -<NodeList> - <SimpleNode name="firstName"/> - <SimpleNode name="age"/> - <AnyNode type="Notes" minOccur="0" maxOccur="unbounded"/> - <Node name="primaryAddress" type="Address"/> - <AnyNode/> -</NodeList> - -=cut
--- a/Lib/IMPL/DOM/Schema/ComplexNode.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -package IMPL::DOM::Schema::ComplexNode; -use strict; -use warnings; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'ComplexNode'; %args } - ], - props => [ - content => { - get => \&_getContent, - set => \&_setContent - } - ] -}; - - -sub _getContent { - $_[0]->firstChild; -} - -sub _setContent { - $_[0]->firstChild($_[1]); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - # для случаев анонимных типов, указанных прямо в узле - $ctx->{schemaNode} ||= $this; - $ctx->{schemaType} = $this; - - map $_->Validate($node,$ctx), @{$this->childNodes}; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Описывает сложный узел. Требует либо соответствие структуры, либо соответствия -типу. - -Дочерними элементами могут быть правила контроля свойств и т.п. -Первым дочерним элементом может быть только содержимое узла, см. C<content> - -=head2 PROPERTIES - -=over - -=item C<content> - -Содержимое узла, может быть либо C<IMPL::DOM::Schema::NodeSet> либо -C<IMPL::DOM::Schema::NodeList>, в зависимости от того важен порядок или нет. -Это свойство ссылается на первый дочерний элемент узла. - -=back - -=cut
--- a/Lib/IMPL/DOM/Schema/ComplexType.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ -package IMPL::DOM::Schema::ComplexType; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::ComplexNode' => sub { - my %args = @_; - $args{nodeName} ||= 'ComplexType'; - $args{minOccur} = 0; - $args{maxOccur} = 'unbounded'; - $args{name} ||= 'ComplexType'; - delete @args{qw(nativeType messageWrongType)}; - %args - } - ], - props => [ - nativeType => { get => 1, set => 1, direct => 1, dom => 1 }, - messageWrongType => { get => 1, set => 1, direct => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nativeType} = $args{nativeType}; - $this->{$messageWrongType} = $args{messageWrongType} || "A complex node '%node.path%' is expected to be %schemaType.nativeType%"; -} - -sub Validate { - my ($this, $node,$ctx) = @_; - - if ($this->{$nativeType}) { - return ValidationError->new ( - node => $node, - schemaNode => $ctx->{schemaNode} || $this, - schemaType => $this, - message => $this->_MakeLabel($this->messageWrongType) - ) unless $node->isa($this->{$nativeType}); - } - - return $this->SUPER::Validate($node,$ctx); -} - -sub qname { - $_[0]->nodeName.'[type='.$_[0]->type.']'; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - - -1;
--- a/Lib/IMPL/DOM/Schema/Label.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,59 +0,0 @@ -package IMPL::DOM::Schema::Label; -use strict; -use overload - '""' => 'ToString', - 'bool' => sub { return 1; }, - 'fallback' => 1; - -use IMPL::Const qw(:prop); -use IMPL::Exception(); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - _map => PROP_RW, - _id => PROP_RW - ] -}; - -sub CTOR { - my ($this,$map,$id) = @_; - - die ArgException->new('map' => 'A strings map is required') - unless $map; - die ArgException->new('id' => 'A lable identifier is required') - unless $id; - - $this->_map($map); - $this->_id($id); -} - -our $AUTOLOAD; -sub AUTOLOAD { - my ($this) = @_; - - my ($method) = ($AUTOLOAD =~ /(\w+)$/); - return - if $method eq 'DESTROY'; - - warn $this->_id . ".$method"; - - return $this->new($this->_map,$this->_id . ".$method"); -} - -sub ToString { - my ($this) = @_; - return $this->_map->GetString($this->_id); -} - -sub Format { - my ($this,$args) = @_; - - return $this->_map->GetString($this->_id,$args); -} - -1; \ No newline at end of file
--- a/Lib/IMPL/DOM/Schema/Node.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -package IMPL::DOM::Schema::Node; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label' - }, - base => [ - 'IMPL::DOM::Node' => sub { - my %args = @_; - delete @args{qw( - minOccur - maxOccur - type - name - )} ; - $args{nodeName} ||= 'Node'; - %args - } - ], - props => [ - minOccur => { get => 1, set => 1, direct => 1, dom => 1}, - maxOccur => { get => 1, set => 1, direct => 1, dom => 1}, - type => { get => 1, set => 1, direct => 1, dom => 1}, - name => { get => 1, set => 1, direct => 1, dom => 1}, - label => { get => '_getLabel', direct => 1 } - ] -}; - -sub _getLabel { - my ($this) = @_; - - $this->{$label} ||= Label->new($this->document->stringMap, $this->name ); -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$minOccur} = defined $args{minOccur} ? $args{minOccur} : 1; - $this->{$maxOccur} = defined $args{maxOccur} ? $args{maxOccur} : 1; - $this->{$type} = $args{type}; - $this->{$name} = $args{name} or die new IMPL::InvalidArgumentException('Argument is required','name'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - $ctx->{schemaNode} = $this; # запоминаем источник ссылки - - if (my $schemaType = $this->{$type} ? $this->document->ResolveType($this->{$type}) : undef ) { - my @errors = $schemaType->Validate($node,$ctx); - return @errors; - } else { - return (); - } -} - -sub isOptional { - my ($this) = @_; - - return $this->{$minOccur} ? 0 : 1; -} - -sub isMultiple { - my ($this) = @_; - - return ($this->{$maxOccur} eq 'unbounded' || $this->{$maxOccur} > 1 ) ? 1 : 0; -} - -sub qname { - $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -package SchemaEntity; -use parent qw(IMPL::DOM::Schema::Node); - -sub Validate { - my ($this,$node) = @_; -} - -=head1 DESCRIPTION - -Базовый класс для элементов схемы. Также позволяет объявлять узлы определенного типа. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get,set] minOccur> - -C<default: 1>. - -Минимальное количество повторений узла. - -=item C<[get,set] maxOccur> - -C<default: 1>. - -Максимальное количество повторений узла - -=item C<[get,set] type> - -C<default: undef> - -Имя типа из схемы. - -=item C<[get,set] name> - -Имя узла. - -=back - -=cut
--- a/Lib/IMPL/DOM/Schema/NodeList.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -package IMPL::DOM::Schema::NodeList; -use strict; -use warnings; - - -use IMPL::declare { - require => { - ValidationError => 'IMPL::DOM::Schema::ValidationError', - AnyNode => '-IMPL::DOM::Schema::AnyNode', - Label => 'IMPL::DOM::Schema::Label' - }, - base => [ - 'IMPL::DOM::Node' => sub { nodeName => 'NodeList' } - ], - props => [ - messageUnexpected => { get => 1, set => 1, dom => 1 }, - messageNodesRequired => { get => 1, set => 1, dom => 1} - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageUnexpected($args{messageUnexpected} || 'A %node.nodeName% isn\'t allowed in %node.parentNode.path%'); - $this->messageNodesRequired($args{messageNodesRequired} || 'A %schemaNode.name% is required in the node %parent.path%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my @nodes = map { - {nodeName => $_->name, anyNode => $_->isa(AnyNode) , schemaNode => $_, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur, min => $_->minOccur, seen => 0 } - } @{$this->childNodes}; - - my $info = shift @nodes; - - foreach my $child ( @{$node->childNodes} ) { - #skip schema elements - while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) { - # if possible of course :) - return ValidationError->new ( - message => $this->_MakeLabel( $this->messageUnexpected ), - node => $child, - parent => $node, - schemaNode => $info->{schemaNode} - ) if $info->{min} > $info->{seen}; # we trying to skip a schema node which has a quantifier - - $info = shift @nodes; - } - - # return error if no more children allowed - return ValidationError->new ( - message => $this->_MakeLabel( $this->messageUnexpected ), - node => $child, - parent => $node - ) unless $info; - - # it's ok, we found schema element for child - - # validate - while (my @errors = $info->{schemaNode}->Validate( $child ) ) { - if( $info->{anyNode} and $info->{seen} >= $info->{min} ) { - # in case of any or switch node, skip it if possible - next if $info = shift @nodes; - } - return @errors; - } - - $info->{seen}++; - - # check count limits - return ValidationError->new( - message => $this->_MakeLabel( $this->messageUnexpected ), - node => $child, - parent => $node, - schemaNode => $info->{schemaNode}, - ) if $info->{max} and $info->{seen} > $info->{max}; - } - - # no more children left (but may be should :) - while ($info) { - return ValidationError->new( - message => $this->_MakeLabel( $this->messageNodesRequired ), - parent => $node, - schemaNode => $info->{schemaNode} - ) if $info->{seen} < $info->{min}; - - $info = shift @nodes; - } - return; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Содержимое для сложного узла. Порядок важен. Дочерними элементами могут быть -только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. - -=cut
--- a/Lib/IMPL/DOM/Schema/NodeSet.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -package IMPL::DOM::Schema::NodeSet; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError', - AnyNode => '-IMPL::DOM::Schema::AnyNode' - }, - base => [ - 'IMPL::DOM::Node' => sub { nodeName => 'NodeSet' } - ], - props => [ - messageUnexpected => { get => 1, set => 1, dom => 1}, - messageMax => { get => 1, set => 1, dom => 1}, - messageMin => { get => 1, set => 1, dom => 1} - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageMax( $args{messageMax} || 'Too many %node.nodeName% nodes'); - $this->messageMin( $args{messageMin} || '%schemaNode.name% nodes expected'); - $this->messageUnexpected( $args{messageUnexpected} || 'A %node.nodeName% isn\'t allowed in %node.parentNode.path%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my @errors; - - my %nodes; - my $anyNode; - - foreach (@{$this->childNodes}) { - if ($_->isa(AnyNode)) { - $anyNode = {schemaNode => $_, min => $_->minOccur, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , seen => 0 }; - } else { - $nodes{$_->name} = {schemaNode => $_, min => $_->minOccur, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , seen => 0 }; - } - } - - foreach my $child ( @{$node->childNodes} ) { - if (my $info = $nodes{$child->nodeName} || $anyNode) { - $info->{seen}++; - push @errors,ValidationError->new( - schemaNode => $info->{schemaNode}, - node => $child, - parent => $node, - message => $this->_MakeLabel($this->messageMax) - ) if ($info->{max} and $info->{seen} > $info->{max}); - - if (my @localErrors = $info->{schemaNode}->Validate($child)) { - push @errors,@localErrors; - } - } else { - push @errors, ValidationError->new( - node => $child, - parent => $node, - message => $this->_MakeLabel($this->messageUnexpected) - ) - } - } - - foreach my $info (values %nodes) { - push @errors, ValidationError->new( - schemaNode => $info->{schemaNode}, - parent => $node, - message => $this->_MakeLabel($this->messageMin) - ) if $info->{min} > $info->{seen}; - } - - return @errors; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Содержимое для сложного узла. Порядок не важен. Дочерними элементами могут быть -только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. - -При проверке данного правила, проверяются имеющиеся элементы на соответсие схемы -и количества встречаемости, после чего проверяются количественные ограничения -для несуществующих элементов. - -=cut
--- a/Lib/IMPL/DOM/Schema/Property.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -package IMPL::DOM::Schema::Property; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - DOMNode => 'IMPL::DOM::Node', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::SimpleNode' => sub { - my %args = @_; - - $args{maxOccur} = 1; - $args{minOccur} = delete $args{optional} ? 0 : 1; - $args{nodeName} ||= 'Property'; - - return %args; - } - ], - props => [ - messageRequired => { get => 1, set => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageRequired($args{messageRequired} || 'A property %schemaNode.name% is required in the %node.qname%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my $nodeValue = $node->nodeProperty($this->name); - - if (length $nodeValue) { - # we have a value so validate it - - # buld a pseudo node for the property value - my $nodeProp = DOMNode->new(nodeName => '::property', nodeValue => $nodeValue); - - return $this->SUPER::Validate($nodeProp); - - } elsif($this->minOccur) { - # we don't have a value but it's a mandatory property - return ValidationError->new( - message => $this->_MakeLabel($this->messageRequired), - node => $node, - schemaNode => $this - ); - } - return (); -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1;
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,49 +0,0 @@ -package IMPL::DOM::Schema::SimpleNode; -use strict; -use warnings; - -use IMPL::declare { - base => [ - 'IMPL::DOM::Schema::Node' => sub { - my %args = @_; - $args{nodeName} ||= 'SimpleNode'; - %args - } - ] -}; - -sub Validate { - my ($this,$node,$ctx) = @_; - - $ctx->{schemaNode} ||= $this; # для безымянных типов - - $ctx->{schemaType} = $this; - - my @result; - - push @result, $_->Validate($node,$ctx) foreach $this->childNodes; - - return @result; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::SimpleNode> - узел с текстом. - -=head1 DESCRIPTION - -Узел имеющий простое значение. Данный узел может содержать ограничения -на простое значение. - -Производит валидацию содержимого, при постоении DOM модели не имеет специального -типа и будет создан в виде C<IMPL::DOM::Node>. - -Также определяет как будет воссоздано значение узла в DOM модели. - -=cut
--- a/Lib/IMPL/DOM/Schema/SimpleType.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -package IMPL::DOM::Schema::SimpleType; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::SimpleNode' => sub { - my %args = @_; - $args{nodeName} = 'SimpleType'; - $args{minOccur} = 0; - $args{maxOccur} = 'unbounded'; - $args{name} ||= 'SimpleType'; - delete @args{qw(nativeType messageWrongType)}; - %args - } - ], - props => [ - nativeType => { get => 1, set => 1, direct => 1, dom => 1}, - messageWrongType => { get => 1, set => 1, direct => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nativeType} = $args{nativeType} if $args{nativeType}; - $this->{$messageWrongType} = $args{messageWrongType} || "A simple node '%node.path%' is expected to be %schemaType.nativeType%"; -} - -sub Validate { - my ($this, $node, $ctx) = @_; - - if ($this->{$nativeType}) { - return ValidationError->new( - node => $node, - schemaNode => $ctx->{schemaNode} || $this, - schemaType => $this, - message => $this->_MakeLabel($this->messageWrongType) - ) unless $node->isa($this->{$nativeType}); - } - return $this->SUPER::Validate($node,$ctx); -} - -sub qname { - $_[0]->nodeName.'[type='.$_[0]->type.']'; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::SimpleType> - тип для простых узлов. - -=head1 DESCRIPTION - -Используется для описания простых узлов, которые можно отобразить в узлы -определенного типа при построении DOM документа. - -=head1 MEMBERS - -=over - -=item C<nativeType> - -Имя класса который будет представлять узел в DOM модели. - -=item C<messageWrongType> - -Формат сообщения которое будет выдано, если узел в дом модели не будет -соответствовать свойству C<nativeType>. - -=back - -=cut
--- a/Lib/IMPL/DOM/Schema/SwitchNode.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,64 +0,0 @@ -package IMPL::DOM::Schema::SwitchNode; -use strict; -use warnings; - -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::AnyNode' => sub { - my %args = @_; - - $args{nodeName} ||= 'SwitchNode'; - - %args; - } - ], - props => [ - messageNoMatch => { get => 1, set => 1, dom => 1 } - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->messageNoMatch($args{messageNoMatch} || 'A node %node.nodeName% isn\'t expected in the %parent.path%'); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - if ( my ($schema) = $this->selectNodes(sub {$_[0]->name eq $node->nodeName} ) ) { - return $schema->Validate($node,$ctx); - } else { - return ValidationError->new( - node => $node, - message => $this->_MakeLabel($this->messageNoMatch) - ); - } -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Представляет узел, который может быть одним из узлов, которые лежат внутри него. -Это более строгий вариант C<IMPL::DOM::Schema::AnyNode>. - -=cut
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -package IMPL::DOM::Schema::ValidationError; -use strict; -use warnings; - -use overload - '""' => \&toString, - 'fallback' => 1; - -use IMPL::lang qw(is); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => '-IMPL::DOM::Schema::Label' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - node => PROP_RO | PROP_DIRECT, - schemaNode => PROP_RO | PROP_DIRECT, - schemaType => PROP_RO | PROP_DIRECT, - parent => PROP_RO | PROP_DIRECT, - message => PROP_RO | PROP_DIRECT - ] -}; -use IMPL::Resources::Format qw(FormatMessage); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$node} = $args{node}; - $this->{$schemaNode} = $args{schemaNode} if $args{schemaNode}; - $this->{$schemaType} = $args{schemaType} if $args{schemaType}; - - if ($args{parent}) { - $this->{$parent} = $args{parent}; - } elsif ($args{node}) { - $this->{$parent} = $args{node}->parentNode; - } else { - die new IMPL::InvalidArgumentException("A 'parent' or a 'node' parameter is required"); - } - - if ($args{message}) { - $this->{$message} = is($args{message},Label) ? $args{message}->Format(\%args) : FormatMessage($args{message}, \%args) ; - } - -} - -sub toString { - (my $this) = @_; - return $this->message; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::ValidationError> - Описывает ошибку в документе. - -=head1 DESCRIPTION - -При проверке документа на ошибки формирования возвращается массив с объектами -C<IMPL::DOM::Schema::ValidationError>, каждая из которых описывает одну ошибку -в документе. - -С помощью данного объекта осущетсвляется привязка элемента схемы, элемента документа -и сообщения о причине возникновения ошибки. - -Часть ошибок, таких как проверка содержимого на регулярные выражения, привязаны -непосредственно к элементу. Но есть ошибки которые привязываются к родительскому -контейнеру, например отсутсвие обязательного элемента. В таком случае ошибка -содержит свойство C<parent> и по свойству C<source> можно определить элемент -(например его имя), к которому относится ошибка. - -=head1 MEMBERS - -=over - -=item C<[get] node> - -Узел в документе который привел к ошибке. Как правило это либо простые узлы, либо -узлы, которые не могут присутствоать в данном месте по схеме. - -Данное свойство может быть C<undef>. - -=item C<[get] parent> - -Родительский узел в котором произошла ошибка. Используется в случаях, когда C<node> -не указан, например, если по схеме должен существовать дочерний узел с определенным -именем, а в реальном документе его нет. - -Также это свойство может использоваться при формировании сообщения. - -=item C<[get] schema> - -Схема для C<Node> или узла который должен присутсвовать если C<Node> не задан. - -=item C<[get] source> - -Схема, проверка которой привела к возникновению ошибки. Поскольку схемы могут -использовать ссылки, то данное свойство нужно для получения схемы узла, а не -схемы его типа. - -Тоесть проверка схемы узла C<IMPL::DOM::Schema::Node> приводит к проверке схемы -типа, например, C<IMPL::DOM::Schema::ComplexType>, а свойство C<Source> будет -указывать именно на C<IMPL::DOM::Schema::Node>. - -=item C<[get] message> - -Возвращает форматированное сообщение об ошибке. - -=item C<toString()> - -Преобразует ошибку к строке, возвращает значение свойства C<Message> - -=back - -=head1 REMARKS - -=begin code - -my $doc = IMPL::DOM::XMLReader->LoadDocument('data.xml'); -my $schema = IMPL::DOM::Schema->LoadSchema('schema.xml'); - -my @errors = $schema->Validate($doc); - -my $node = $doc->selectSingleNode('user','name'); - -# Получаем все ошибки относящиеся к данному узлу -my @nodeErrors = grep { ($_->node || $_->parent) == $node } @errors; - -=end code - -=cut
--- a/Lib/IMPL/DOM/Schema/Validator.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::DOM::Schema::Validator; -use strict; - -require IMPL::Exception; -use IMPL::declare { - base => [ - 'IMPL::DOM::Node' => '@_' - ] -}; - -sub Validate { - my ($this,$node) = @_; - - die new IMPL::NotImplementedException(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::Validator> - Базовый класс для ограничений на простые значения. - -=head1 DESCRIPTION - -От основных элементов схемы его отличает то, что в конечном документе он не соответсвует -никаким узлам и поэтому у него отсутствуют свойства C<minOcuur,maxOccur,name>. - -=cut
--- a/Lib/IMPL/DOM/Schema/Validator/Compare.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,264 +0,0 @@ -package IMPL::DOM::Schema::Validator::Compare; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::Validator' => sub { - my %args = @_; - $args{nodeName} ||= 'Compare'; - delete @args{qw(targetProperty op nodePath optional message)}; - %args; - } - ], - props => [ - targetProperty => PROP_RW, - op => PROP_RW, - nodePath => PROP_RW, - optional => PROP_RW, - _pathTranslated => PROP_RW, - _targetNode => PROP_RW, - _schemaNode => PROP_RW, - message => PROP_RW - ] -}; -use IMPL::Resources::Format qw(FormatMessage); - -our %Ops = ( - '=' => \&_equals, - 'eq' => \&_equalsString, - '!=' => \&_notEquals, - 'ne' => \&_notEqualsString, - '=~' => \&_matchRx, - '!~' => \&_notMatchRx, - '<' => \&_less, - '>' => \&_greater, - 'lt' => \&_lessString, - 'gt' => \&_greaterString -); - -my $rxOps = map qr/$_/, join( '|', keys %Ops ); - -sub CTOR { - my ($this,%args) = @_; - - $this->targetProperty($args{targetProperty} || 'nodeValue'); - $this->op( $Ops{ $args{op} || '=' } ) or die new IMPL::InvalidArgumentException("Invalid parameter value",'op',$args{op},$this->path); - $this->nodePath($args{nodePath}) or die new IMPL::InvalidArgumentException("The argument is required", 'nodePath', $this->path); - $this->message($args{message} || 'The value of %node.path% %schemaNode.op% %value% (%schemaNode.nodePath%)' ); - $this->optional($args{optional}) if $args{optional}; -} - -sub TranslatePath { - my ($this,$path) = @_; - - $path ||= ''; - - my @selectQuery; - - my $i = 0; - - foreach my $chunk (split /\//,$path) { - $chunk = 'document:*' if $i == 0 and not length $chunk; - next if not length $chunk; - - my $query; - my ($axis,$filter) = ( $chunk =~ /^(?:(\w+):)?(.*)$/); - - if ($filter =~ /^\w+|\*$/ ) { - $query = $filter eq '*' ? undef : $filter; - } elsif ( $filter =~ /^(\w+|\*)\s*((?:\[\s*\w+\s*(?:=|!=|=~|!~|eq|ne|lt|gt)\s*["'](?:[^\\'"]|\\[\\"'])*["']\])+)$/) { - my ($nodeName,$filterArgs) = ($1,$2); - - - my @parsedFilters = map { - my ($prop,$op,$value) = ($_ =~ /\s*(\w+)\s*(=|!=|=~|!~|eq|ne|lt|gt)\s*(?:["']((?:[^\\'"]|\\[\\"'])*)["'])/); - - $value =~ s/\\[\\'"]/$1/g; - { - prop => $prop, - op => $Ops{$op}, - value => $value - } - } grep ( $_, split ( /[\]\[]+/,$filterArgs ) ); - - $query = sub { - my ($node) = shift; - - $node->nodeName eq $nodeName or return 0 if $nodeName ne '*'; - $_->{op}->( - _resovleProperty($node,$_->{prop}), - FormatMessage($_->{value},{ - Schema => $this->parentNode, - Node => $this->_targetNode, - schema => $this->parentNode, - schemaType => $this->parentNode, - node => $this->_targetNode, - source => $this->_schemaNode, - schemaNode => $this->_schemaNode - },\&_resovleProperty) - ) or return 0 foreach @parsedFilters; - return 1; - }; - } else { - die new IMPL::Exception("Invalid query syntax",$path,$chunk); - } - - push @selectQuery, $axis ? { $axis => $query } : $query; - - $i++; - } - - return \@selectQuery; -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my @result; - - my $schemaNode = $ctx->{schemaNode}; - my $schemaType = $ctx->{schemaType}; - - $this->_schemaNode($schemaNode); - - $this->_targetNode($node); - - my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath)); - - my ($foreignNode) = $node->selectNodes(@$query); - - - - if ($foreignNode) { - my $value = $this->nodeValue; - - if ($value) { - $value = FormatMessage($value, { Schema => $this->parentNode, Node => $this->_targetNode, ForeignNode => $foreignNode },\&_resovleProperty); - } else { - $value = $foreignNode->nodeValue; - } - - push @result, ValidationError->new( - node => $node, - foreignNode => $foreignNode, - value => $value, - schemaNode => $schemaNode, - schemaType => $schemaType, - message => $this->_MakeLabel($this->message) - ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value); - } elsif (not $this->optional) { - push @result, ValidationError->new( - node => $node, - value => '', - schemaNode => $schemaNode, - schemaType => $schemaType, - message => $this->_MakeLabel( $this->message ) - ); - } - - $this->_targetNode(undef); - $this->_schemaNode(undef); - - return @result; -} - -sub _resovleProperty { - my ($node,$prop) = @_; - - return $node->can($prop) ? $node->$prop() : $node->nodeProperty($prop); -} - -sub _matchRx { - $_[0] =~ $_[1]; -} - -sub _notMatchRx { - $_[0] !~ $_[1]; -} - -sub _equals { - $_[0] == $_[1]; -} - -sub _notEquals { - $_[0] != $_[0]; -} - -sub _equalsString { - $_[0] eq $_[1]; -} - -sub _notEqualsString { - $_[0] ne $_[1]; -} - -sub _less { - $_[0] < $_[1]; -} - -sub _greater { - $_[0] > $_[1]; -} - -sub _lessString { - $_[0] lt $_[1]; -} - -sub _greaterString { - $_[0] gt $_[1]; -} - -sub _lessEq { - $_[0] <= $_[1]; -} - -sub _greaterEq { - $_[0] >= $_[1]; -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Schema::Validator::Compare> - ограничение на содержимое текущего узла, -сравнивая его со значением другого узла. - -=head1 SYNOPSIS - -Пример типа описания поля с проверочным полем - -=begin code xml - -<schema> - <SimpleType type="retype_field"> - <Property name="linkedNode" message="Для узла %node.nodeName% необходимо задать свойство %schemaNode.name%"/> - <Compare op="eq" nodePath="sibling:*[nodeName eq '%node.linkedNode%']"/> - </SimpleType> -</schema> - -=begin code xml - -=head1 DESCRIPTION - -Позволяет сравнивать значение текущего узла со значением другого узла. - -=cut
--- a/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -package IMPL::DOM::Schema::Validator::RegExp; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Label => 'IMPL::DOM::Schema::Label', - ValidationError => 'IMPL::DOM::Schema::ValidationError' - }, - base => [ - 'IMPL::DOM::Schema::Validator' => sub { - my %args = @_; - $args{nodeName} ||= 'RegExp'; - %args; - } - ], - props => [ - message => { get => 1, set =>1, dom =>1 }, - launder => { get => 1, set =>1, dom =>1 }, - _rx => { get=> 1, set=> 1} - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->message($args{message} || "A %node.nodeName% doesn't match to the format %schemaNode.label%"); -} - -sub Validate { - my ($this,$node,$ctx) = @_; - - my $rx = $this->_rx() || $this->_rx( map qr{$_}, $this->nodeValue ); - - return ValidationError->new ( - node => $node, - schemaNode => $ctx->{schemaNode}, - schemaType => $ctx->{schemaType}, - message => $this->_MakeLabel($this->message) - ) unless (not $node->isComplex) and $node->nodeValue =~ /($rx)/; - - $node->nodeValue($1) if $this->launder; - - return (); -} - -sub _MakeLabel { - my ($this,$label) = @_; - - if ($label =~ /^ID:(\w+)$/) { - return Label->new($this->document->stringMap, $1); - } else { - return $label; - } -} - -1;
--- a/Lib/IMPL/DOM/Transform.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package IMPL::DOM::Transform; -use strict; -use warnings; - -use parent qw(IMPL::Transform); - -__PACKAGE__->PassThroughArgs; - -sub GetClassForObject { - my ($this,$object) = @_; - - if (my $class = ref $object) { - if (UNIVERSAL::isa($object,'IMPL::DOM::Node')) { - return $object->nodeName; - } else { - return $class; - } - } else { - return undef; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Преобразование для DOM документа, использует имя узла для применения подходящего преобразования. - -=cut
--- a/Lib/IMPL/DOM/Transform/ObjectToDOM.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,255 +0,0 @@ -package IMPL::DOM::Transform::ObjectToDOM; -use strict; - -use IMPL::Const qw(:prop :access); -use IMPL::declare { - require => { - PropertyInfo => 'IMPL::Class::PropertyInfo', - Builder => 'IMPL::DOM::Navigator::Builder', - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - OperationException => '-IMPL::InvalidOperationException' - }, - base => [ - 'IMPL::Transform' => sub { - -plain => 'TransformPlain', - HASH => 'TransformHash', - -default => 'TransformDefault' - } - ], - props => [ - documentSchema => PROP_RO, - _schema => PROP_RW, - _navi => PROP_RW - ] -}; - -use constant { - SchemaNode => 'IMPL::DOM::Schema::Node', - ComplexNode => 'IMPL::DOM::Schema::ComplexNode' -}; - -sub CTOR { - my ($this,$docName,$docSchema,$transforms) = @_; - - my $docNodeSchema = $docSchema->selectSingleNode(sub { $_->isa(SchemaNode) and $_->name eq $docName } ) - or die OperationException->new("Can't find a node schema for the document '$docName'"); - - my $docClass = ($docNodeSchema->can('nativeType') ? $docNodeSchema->nativeType : undef) || 'IMPL::DOM::Document'; - - $this->documentSchema($docNodeSchema); - - $this->_navi( - Builder->new( - $docClass, - $docSchema, - ignoreUndefined => 1 - ) - ); - $this->_schema($docSchema); - - $this->_navi->NavigateCreate($docName); - $this->currentNode->nodeProperty(schemaDocument => $docSchema); -} - -sub TransformPlain { - my ($this,$data) = @_; - - $this->_navi->Current->nodeValue( $data ); - return $this->_navi->Current; -} - -sub currentNode { - shift->_navi->Current; -} - -sub TransformHash { - my ($this,$data) = @_; - - die ArgumentException->new(data => 'A HASH reference is required') - unless ref $data eq 'HASH'; - - return $this->StoreObject($this->currentNode,$data) - if !$this->currentNode->schemaType->isa(ComplexNode); - - KEYLOOP: foreach my $key (keys %$data) { - my $value = $data->{$key}; - - if (ref $value eq 'ARRAY') { - foreach my $subval (grep $_, @$value) { - - $this->_navi->saveState(); - - my $node = $this->_navi->NavigateCreate($key); - - unless(defined $node) { - #$this->_navi->Back(); - $this->_navi->restoreState(); - next KEYLOOP; - } - - $this->_navi->applyState(); - - $this->Transform($subval); - - $this->_navi->Back(); - } - } else { - $this->_navi->saveState(); - my $node = $this->_navi->NavigateCreate($key); - - unless(defined $node) { - #$this->_navi->Back(); - $this->_navi->restoreState(); - next KEYLOOP; - } - - $this->_navi->applyState(); - - $this->Transform($value); - - $this->_navi->Back(); - } - } - return $this->_navi->Current; -} - -# this method handles situatuions when a complex object must be stored in a -# simple node. -sub StoreObject { - my ($this,$node,$data) = @_; - - $node->nodeValue($data); - - return $node; -} - -sub TransformDefault { - my ($this,$data) = @_; - - return $this->StoreObject($this->currentNode,$data) - if !$this->currentNode->schemaType->isa(ComplexNode); - - if ( ref $data and eval { $data->can('GetMeta') } ) { - my %props = map { - $_->name, 1 - } $data->GetMeta(PropertyInfo, sub { $_->access == ACCESS_PUBLIC }, 1 ); - - - my %values = map { - $_, - scalar($data->$_()) - } keys %props; - - return $this->Transform(\%values); - } else { - die OperationException->new("Don't know how to transform $data"); - } - - return $this->_navi->Current; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Transform::ObjectToDOM> -преобразование объекта в DOM документ. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Schema => 'IMPL::DOM::Schema', - Config => 'IMPL::Config' -} - -my $data = { - id => '12313-232', - name => 'Peter', - age => 20 -}; - -my $schema = Schema->LoadSchema(Config->AppBase('schemas','person.xml')); -my $transorm = IMPL::DOM::Transform::ObjectToDOM->new('edit', $schema); - -my $form = $transform->Transform($data); - -my @errors; - -push @errors, $schema->Validate($doc); - -=end code - -=head1 DESCRIPTION - -Наследует C<IMPL::Transform>. Определяет базовые преобразования для хешей и -объектов, поддерживающих метаданные. - -Результатом выполнения преобразования является DOM документ. При построении -документа используется навигатор C<IMPL::DOM::Navigator::Builder> для -сопоставления схемы и свойств преобразуемого объекта. Элементы полученного -документа имеют ссылки на соответствующие им элементы схемы. - -После того, как документ построен и преобразование будет очищено, не останется -объектов, которые бы ссылались на документ со схемой, поскольку элементы схемы -имеют слабые ссылки на саму схему и не могут предотвратить ее удаление. -Для предотвращения очитски документа схемы, ссылка на него сохраняется в -атрибуте документа C<schemaDocument>, что обеспечит жизнь схемы на протяжении -жизни документа. - -Преобразование происходит рекурсивно, сначала используется метод -C<NavigateCreate> для создания элемента соответсвующего свойству объекта, -затем вызывается метод C<Transform> для преобразования значения свойства, при -этом C<currentNode> указывает на только что созданный элемент документа. - -Для изменения поведения преобразования можно добавлять новые обработчики, как -в случае со стандартным преобразованием, а также можно унаследовать текущий -класс для переопределения его некоторых методов. - -=head1 MEMBERS - -=head2 C<CTOR($docName,$schema)> - -Создает преобразование, при этом будет создан документ состоящий только из -корневого элемента с именем C<$docName> и будет найдена подходящий для него -элемент схемы C<$schema>. - -=over - -=item * C<$docName> - -Имя корневого узла документа, которое будет использовано для поиска -соответствующего элемента схемы C<$schema> - -=item * C<$schema> - -Схема, содержащая описание документа. Если в данной схеме нет описания корневого -элемента с именем C<$docName>, будет вызвано исключение. - -=back - -=head2 C<[get]documentSchema> - -Элемент схемы C<ComplexNode> соответствующий документу. Определяется в -конструкторе исходя из имени документа. - -=head2 C<[get]currentNode> - -Текущий элемент документа. После создания преобразования - это сам документ. -Данное свойство использется внутри преобразования для работы с текущим -элементом. - -=head2 C<[virtual]StoreObject($node,$data)> - -Метод, который вызывается преобразованием в случае если текущий узел документа -является простым, а значени которое ему соответсвует является объектом (ссылкой). - -По-умолчанию будет выполнено присваивание C<< $node->nodeValue($data) >>, однако -это можно заменить, например, на преобразование в строку. - -=cut \ No newline at end of file
--- a/Lib/IMPL/DOM/Transform/PostToDOM.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,161 +0,0 @@ -package IMPL::DOM::Transform::PostToDOM; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Builder => 'IMPL::DOM::Navigator::Builder' - }, - base => [ - 'IMPL::Transform' => sub { - -plain => \&TransformPlain, - HASH => \&TransformContainer, - CGI => \&TransformCGI, - CGIWrapper => \&TransformCGI - } - ], - props => [ - documentClass => PROP_RO, - documentSchema => PROP_RO, - prefix => PROP_RO, - _navi => PROP_RW, - errors => PROP_RW | PROP_LIST, - _schema => PROP_RW - ] -}; - -sub CTOR { - my ($this,$docClass,$docSchema,$prefix) = @_; - $docClass ||= 'IMPL::DOM::Document'; - - $this->_navi( - IMPL::DOM::Navigator::Builder->new( - $docClass, - $docSchema - ) - ); - $this->_schema($docSchema); - $this->prefix($prefix) if $prefix; -} - -sub TransformContainer { - my ($this,$data) = @_; - - my $navi = $this->_navi; - - foreach my $key ( - sort { $a->[1] cmp $b->[1] || $a->[2] <=> $b->[2]} - map [$_,/(\w+)(?:\[(\d+)\])?/], keys %$data - ){ - my $value = $data->{$key->[0]}; - my $node = $navi->NavigateCreate($key->[1]); - - $node->nodeProperty(instanceId => $key->[2]) if defined $key->[2]; - - $this->Transform($value); - - $navi->Back(); - } - - return $navi->Current; -} - -sub TransformPlain { - my ($this,$data) = @_; - - $this->_navi->Current->nodeValue( $this->_navi->inflateValue($data) ); -} - -sub TransformCGI { - my ($this,$query) = @_; - - my $data={}; - - my $prefix = $this->prefix; - my $delim = $this->delimiter; - - foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { - length (my $value = $query->param($param)) or next; - - my @parts = split /\//,$param; - - my $node = $data; - while ( my $part = shift @parts ) { - if (@parts) { - $node = ($node->{$part} ||= {}); - } else { - $node->{$part} = $value; - } - } - } - - if (keys %$data > 1) { - $data = { document => $data }; - } - - my $doc = $this->Transform($data); - $doc->nodeProperty( query => $query ); - $this->errors->Append( $this->_navi->BuildErrors); - $this->errors->Append( $this->_schema->Validate($doc)); - return $doc; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Transform::PostToDOM> - Преобразование объекта C<CGI> в DOM документ. - -=head1 SINOPSYS - -=begin code - - my $schema = IMPL::DOM::Schema->LoadSchema('Data/user.add.schema.xml'); - - my $transform = IMPL::DOM::Transform::PostToDOM->new( - undef, # default class - $schema, - $schema->selectSingleNode('ComplexNode')->name - ); - - my $doc = $transform->Transform( - CGI->new({ - 'user/login' => 'bob', - 'user/fullName' => 'Bob Marley', - 'user/password' => 'secret', - 'user/password_retype' => 'secret', - 'user/birthday' => '1978-12-17', - 'user/email[1]' => 'bob@marley.com', - 'user/email[2]' => 'bob.marley@google.com', - process => 1 - }) - ); - -=end code - -=head1 DESCRIPTION - -Используется для преобразования CGI запроса в DOM документ. Для этого используются параметры запроса, имена которых -начинаются со значение из свойства C<prefix>. - -Имена параметров интерпретируются следующим образом - -=over - -=item 1 Имя параметра составляется из имени узла, имен всех его родителей и указанием номера экземпляра. - -=item 2 Имена узлов могут содержать только буквы, цифры и символ _ - -=item 3 В случае когда узел может повторяться несколько раз, в квадратных скобках указывается -послеовательный номер экземпляра. - -=item 4 Имена параметров объединяются через символ '/' - -=back - -=cut
--- a/Lib/IMPL/DOM/Transform/QueryToDOM.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -package IMPL::DOM::Transform::QueryToDOM; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - OutOfRangeException => '-IMPL::OutOfRangeException' - }, - base => [ - 'IMPL::DOM::Transform::ObjectToDOM' => '@_' - ], - props => [ - prefix => PROP_RO, - delimiter => PROP_RO - ] -}; - -our $MAX_INDEX = 1024; - -sub CTOR { - my ($this) = @_; - - $this->templates->{'CGI'} = 'TransformCGI'; - $this->templates->{'IMPL::Web::Application::Action'} = 'TransformAction'; - - $this->delimiter('[.]'); - $this->prefix(''); -} - -# inflate simple properties -sub TransformPlain { - my ($this,$data) = @_; - - $this->currentNode->nodeProperty( rawValue => $data ); - $this->currentNode->nodeValue( $data ); - return $this->currentNode; -} - -# do not store complex data as node values -sub StoreObject { - my ($this,$node,$data) = @_; - - return $node; -} - -#TODO: support a.b[0][1].c[1] - -sub TransformCGI { - my ($this,$query) = @_; - - my $data={}; - - my $prefix = $this->prefix; - my $delim = $this->delimiter; - - foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { - - my @value = grep length($_), $query->param($param) or next; - - my @parts = split /$delim/,$param; - - my $node = $data; - while ( my $part = shift @parts ) { - if (my ($name,$index) = ($part =~ m/^(\w+)(?:\[(\d+)\])?$/) ) { - if (@parts) { - if(defined $index) { - $this->ValidateIndex($index); - $node = ($node->{$name}[$index] ||= {}); - } else { - $node = ($node->{$name} ||= {}); - } - } else { - if(defined $index) { - $this->ValidateIndex($index); - $node->{$name}[$index] = (@value == 1 ? $value[0] : \@value); - } else { - $node->{$name} = (@value == 1 ? $value[0] : \@value); - } - } - } - } - } - - return $this->Transform($data); -} - -sub ValidateIndex { - my ($this,$index) = @_; - - die OutOfRangeException->new() - unless $index >= 0 and $index <= $MAX_INDEX; -} - -sub TransformAction { - my ($this,$action) = @_; - - return $this->Transform($action->isJson ? $action->jsonData : $action->query); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::DOM::Transform::QueryToDOM> - преобразование CGI запроса в DOM документ. - -=head1 SYNOPSIS - -=begin code - -use CGI(); -use IMPL::require { - Schema => 'IMPL::DOM::Schema', - Config => 'IMPL::Config', - QueryToDOM => 'IMPL::DOM::Transform::QueryToDOM' -} - -my $q = CGI->new(); - -my $schema = Schema->LoadSchema(Config->AppBase('schemas','person.xml')); -my $transorm = QueryToDOM->new('edit', $schema); - -my $form = $transform->Transform($q); - -my @errors; - -push @errors, $transform->buildErrors; -push @errors, $schema->Validate($doc); - - -=end code - -=head1 DESCRIPTION - -Наследует C<IMPL::DOM::Transform::ObjectToDOM>. Добавляет метод -C<TransformCGI> который применятеся к объектам типа C<CGI> (и производных). - -Запрос C<CGI> сначала приводится к хешу, затем полученный хеш преобразуется -в DOM документ при помощи вызова метода C<Transform>. - -Для этого выбираются параметры запроса, затем, имя каждого параметра -рассматривается в виде пути к свойству, создается структура из хешей и массивов -в которую по указанному пути кладется значение. - -Если параметр имеет несколько значений, значит свойство является массивом. - -Также изменено поведение некоторых методов преобразования. - -=over - -=item * C<TransformPlain($value)> - -Преобразование для простого значения свойства. Посокльку в запросе передаются -строковые значения, а схема документа может предполпгать другие типы, при -преобразовании значения параметра из запроса к значению узла используется -метод C<< $this->inflateNodeValue($value) >>, также помимо значения -C<< $this->currentNode->nodeValue >> задается атрибут -C<< $this->currentNode->nodeProperty( rawValue => $value) >>, для того, чтобы -была возможность получить оригинальное значение параметра запроса (например, -в случае когда его формат был не верным и C<nodeValue> будет C<undef>). - -=item * C<StoreObject($node,$object)> - -Данный метод вызывается если текущий узел (переданный в параметре C<$node>) -предполагает простое значение, однако в запросе для него было передано сложное -содержимое. Данная реализация просто игнорирует переданный объект C<$object> -и возвращает C<$node> без изменений. - -=back - -=head1 MEMBERS - -=head2 C<[get]delimiter> - -REGEX. Разделитель свойств в имени параметра, по-умолчанию C<'[.]'> - -=head2 C<[get]prefix> - -Строка, префикс имен параметров, которые участвуют в формировании документа. -По-умолчанию пусто. - -=cut \ No newline at end of file
--- a/Lib/IMPL/DOM/XMLReader.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,143 +0,0 @@ -package IMPL::DOM::XMLReader; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Autofill); - -use IMPL::Class::Property; -use XML::Parser; - -use IMPL::require { - Schema => 'IMPL::DOM::Schema', # IMPL::DOM::Schema references IMPL::DOM::XML::Reader - Builder => 'IMPL::DOM::Navigator::Builder', - SimpleBuilder => 'IMPL::DOM::Navigator::SimpleBuilder' -}; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public _direct property Navigator => prop_get | owner_set; - public _direct property SkipWhitespace => prop_get | owner_set; - private _direct property _current => prop_all; - private _direct property _text => prop_all; - private _direct property _textHistory => prop_all; -} - -sub Parse { - my ($this,$in) = @_; - - my $parser = new XML::Parser( - Handlers => { - Start => sub {shift; goto &OnStart($this,@_)}, - End => sub {shift; goto &OnEnd($this,@_)}, - Char => sub {shift; goto &OnChar($this,@_)} - } - ); - - $parser->parse($in); -} - -sub ParseFile { - my ($this,$in) = @_; - - my $parser = new XML::Parser( - Handlers => { - Start => sub {shift; unshift @_, $this; goto &_OnBegin;}, - End => sub {shift; unshift @_, $this; goto &_OnEnd;}, - Char => sub {shift; unshift @_, $this; goto &_OnChar;} - } - ); - - $parser->parsefile($in); -} - -sub _OnBegin { - my ($this,$element,%attrs) = @_; - - push @{$this->{$_textHistory}},$this->{$_text}; - $this->{$_text} = ""; - $this->{$_current} = $this->Navigator->NavigateCreate($element,%attrs); -} - -sub _OnEnd { - my ($this,$element) = @_; - $this->{$_current}->nodeValue($this->{$_text}) if length $this->{$_text} and (not $this->{$SkipWhitespace} or $this->{$_text} =~ /\S/); - $this->{$_text} = pop @{$this->{$_textHistory}}; - $this->{$_current} = $this->Navigator->Back; -} - -sub _OnChar { - my ($this,$val) = @_; - $this->{$_text} .= $val; -} - -sub LoadDocument { - my ($self,$file,$schema) = @_; - - my $parser; - if ($schema) { - $schema = IMPL::DOM::Schema->LoadSchema($schema) if not ref $schema; - $parser = $self->new( - Navigator => IMPL::DOM::Navigator::Builder->new( - 'IMPL::DOM::Document', - $schema - ) - ); - } else { - $parser = $self->new( - Navigator => IMPL::DOM::Navigator::SimpleBuilder->new() - ); - } - - $parser->ParseFile($file); - my $doc = $parser->Navigator->Document; - my @errors; - if ($schema) { - push @errors, $schema->Validate($doc); - } - - if (wantarray) { - return $doc,\@errors; - } else { - die new IMPL::Exception("Loaded document doesn't match the schema", @errors) if @errors; - return $doc; - } -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -my $reader = new IMPL::DOM::XMLReader(Navigator => $DomBuilder); -my $obj = $reader->parsefile("data.xml"); - -=head1 DESCRIPTION - -Простой класс, использующий навигатор для постороения документа. В зависимости от -используемого навигатора может быть получен различный результат. - -Навигатор должен поодерживать методы C<NavigateCreate> и C<Back> - -=head1 METHODS - -=over - -=item C<CTOR(Naviagtor => $builder)> - -Создает новый экземпляр парсера, с указанным навигатором для построения документа - -=item C<$obj->Parse($in)> - -Строит документ. На вход получает либо xml строку, либо HANDLE. - -=item C<$obj->ParseFile($fileName)> - -Строит документ из файла с именем C<$fileName>. - -=back - -=cut
--- a/Lib/IMPL/Exception.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,141 +0,0 @@ -package IMPL::Exception; -use strict; -use overload - '""' => \&ToString, - 'fallback' => 1; -use Carp qw(longmess shortmess); -use Scalar::Util qw(refaddr); - -BEGIN { - require Error; -} - -use parent qw(IMPL::Object::Abstract Error Class::Accessor); - -BEGIN { - __PACKAGE__->mk_accessors( qw(Message Args CallStack Source) ); -} - -sub indent { - my ($str,$level) = @_; - $level ||= 0; - $str = '' unless defined $str; - join ("\n", map( " "x$level.$_ , split(/\n/,$str) ) ); -} - -sub new { - my $class = shift; - $class = ref $class || $class; - - my $this = $class->Error::new() or die "Failed to create an exception"; - - $this->callCTOR(@_); - $this->{-text} = $this->Message; - - local $Carp::CarpLevel = 0; - - $this->CallStack(longmess); - $this->Source(shortmess); - - return $this; -} - -sub CTOR { - my ($this,$message,@args) = @_; - $this->Message($message || ''); - die new IMPL::Exception("Fatal erorr: cyclic structure in the exceptions were detected, do not use \$\@ while throwing the exception!") if grep ref $_ ? refaddr($this) == refaddr($_) : 0 , @args; - $this->Args([map defined $_ ? $_ : 'undef', @args]); -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar(Message => $this->Message) if $this->Message; - $ctx->AddVar(Args => $this->Args) if @{$this->Args}; - $ctx->AddVar(Source => $this->Source); - $ctx->AddVar(CallStack => $this->CallStack); -} - -sub restore { - my ($class,$data,$instance) = @_; - - my %args = @$data; - - if ($instance) { - $instance->callCTOR($args{Message},@{$args{Args}}); - } else { - $instance = $class->new($args{Message},@{$args{Args}}); - } - - $instance->Source($args{Source}); - $instance->CallStack($args{CallStack}); - - return $instance; -} - -sub ToString { - my $this = shift; - - $this->toString(); -} - -sub toString { - my ($this,$notrace) = @_; - ($this->Message || ref $this) . join("\n",'',map { my $s = $_; local $_; indent("$s",1) } @{$this->Args} ) . ( $notrace ? '' : "\n" . $this->CallStack); -} - -package IMPL::InvalidOperationException; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -package IMPL::InvalidArgumentException; -our @ISA = qw(IMPL::Exception); -our %CTOR = ( - 'IMPL::Exception' => sub { "An invalid argument", @_ } -); - -package IMPL::DuplicateException; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -package IMPL::KeyNotFoundException; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -our %CTOR = ( - 'IMPL::Exception' => sub { "A specified element isn't found", $_[0] } -); - -package IMPL::NotImplementedException; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -package IMPL::SecurityException; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -package IMPL::AccessDeniedException; -our @ISA = qw(IMPL::SecurityException); -our %CTOR = ( 'IMPL::SecurityException' => sub { 'Access denied' ,@_ } ); - -package Exception; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -package IMPL::DeprecatedException; -our @ISA = qw(IMPL::Exception); -our %CTOR = ( - 'IMPL::Exception' => sub { @_ ? @_ : "The method is deprecated" } -); - -package IMPL::WrongDataException; -our @ISA = qw(IMPL::Exception); -our %CTOR = ( - 'IMPL::Exception' => sub { "The input data is wrong", @_ } -); - -package IMPL::IOException; -our @ISA = qw(IMPL::Exception); -__PACKAGE__->PassThroughArgs; - -1;
--- a/Lib/IMPL/Mailer.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,69 +0,0 @@ -package IMPL::Mailer; -use strict; - -use Encode qw (encode); -use Encode::MIME::Header; -use MIME::Base64 qw(encode_base64); -use Email::Simple; - -our $SENDMAIL; - -sub DeliverMessage { - my $message = shift; - - $message = shift if $message eq __PACKAGE__ or ref $message eq __PACKAGE__; - - my $email = new Email::Simple($message); - - $email->header_set('Content-Transfer-Encoding' => 'base64'); - $email->header_set('MIME-Version' => '1.0') if !$email->header('MIME-Version'); - $email->header_set('Content-Type' => 'text/plain; charset="utf-8"'); - my $raw = $email->body(); - utf8::encode($raw) if utf8::is_utf8($raw); - $email->body_set(encode_base64($raw)); - - foreach my $field ($email->header_names()) { - $email->header_set($field, map { encode('MIME-Header', utf8::is_utf8($_) ? $_ : Encode::decode('utf-8',$_) ) } $email->header($field) ); - } - - return SendMail($email,@_); -} - -sub _find_sendmail { - return $SENDMAIL if defined $SENDMAIL; - - my @path = split (/:/, $ENV{PATH}); - my $sendmail; - for (@path) { - if ( -x "$_/sendmail" ) { - $sendmail = "$_/sendmail"; - last; - } - } - return $sendmail; -} - -sub SendMail { - my ($message, %args) = @_; - my $mailer = _find_sendmail; - - local *SENDMAIL; - if( $args{'TestFile'} ) { - open SENDMAIL, '>', $args{TestFile} or die "Failed to open $args{TestFile}: $!"; - binmode(SENDMAIL); - print SENDMAIL "X-SendMail-Cmd: sendmail ",join(' ',%args),"\n"; - } else { - my @args = %args; - die "sendmail not found" unless $mailer; - die "Found $mailer but cannot execute it" - unless -x $mailer; - open SENDMAIL, "| $mailer -t -oi @args" - or die "Error executing $mailer: $!"; - } - print SENDMAIL $message->as_string - or die "Error printing via pipe to $mailer: $!"; - close SENDMAIL; - return 1; -} - -1;
--- a/Lib/IMPL/ORM.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -package IMPL::ORM; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use Scalar::Util qw(weaken refaddr); - -use IMPL::Exception; - -our $Depth = 1; # загружать объект + 1 уровень детей -our $UseProxy = 1; - -BEGIN { - private property _ObjectCache => prop_all; - private property _MapInstances => prop_all; - private property _WorkUnit => prop_all; - public property Schema => prop_all; -} - -sub ObjectInfoById { - my ($this,$oid) = @_; - - return $this->_ObjectCache->{$oid}; -} - -sub ObjectInfo { - my ($this,$inst) = @_; - - die new IMPL::InvalidOperationException("This method can be used only for a reference") unless ref $inst; - - return $this->_MapInstances->{refaddr $inst}; -} - - -1; -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM> - Object Relational Mapping - -=head1 SYNOPSIS - -=begin code - -my $ds = IMPL::ORM::Storage::DBIC->new('My::Data',$dsn,$user,$pass,{Autocommit => 1}); - - -my $foo = $ds->Insert( - My::Data::Foo->new( - 'foo class' - ) -); - -my $bar = $ds->Insert( - My::Data::Bar->new( - 'bar class' - ) -) - -$bar->fooObject($foo); - -$ds->Save($bar); - -my $fooOther = $ds->Retrieve( - 'My::Data::Bar', - { - name => 'bar class', - fooObject => { - name => 'some foo' - } - } -) - -=end code - -=head1 DESCRIPTION - -=cut
--- a/Lib/IMPL/ORM/Adapter/Generic.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -package IMPL::ORM::Adapter::Generic; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Adapter::Generic> Адаптер для работы с данными объекта произвольного класса. - -=head1 DESCRIPTION - -Позволяет получать данные, изменения данных из объекта, а также записать данные в -объект и создать новый объект. - -=head1 MEMBERS - -=over - -=item C<CTOR($object,$hashOptions)> - -Создает новый адаптер к объекту C<$object> - -=item C<[get]object> - -Объект для которого создан данный адаптер, C<undef> если объект удален. - -=item C<[get]isChanged> - -Были ли обновления в объекте. - -=item C<[get]isDeleted> - -Является ли объект удаленным. - -=item C<[get]isNew> - -Является ли объект новым для БД. - -=item C<[get]initialState> - -Начальное состояние объекта, C<undef> если объект был создан. - -=item C<[get]currentState> - -Текущие состояние. C<undef> если объект удален. - -=item C<[get,list]history> - -История изменений. C<IMPL::Object::List> - -=item C<SaveChanges> - -Сохраняет изменения из объекта в текущее состояние, при этом изменения записываются в историю. - -B<returns> информацию об изменениях в объекте. - -=item C<Revert($version)> - -Возвращает объект в определенную версию. - -=item C<Delete> - -Удаляет объект, точнее помечает его для удаления до вызова C<Commit>. - -=item C<Commit> - -Сбрасывает историю изменений, и устанавливает соответсвующие свойства. - -=back - -=head1 Информация об изменениях объекта - -=begin code - -{ - version => 1, # object version - op => STORAGE_UPDATE, - data => { - entity1 => { - field1 => 'value 1' - }, - entity2 => { - field2 => 'value 2' - } - } -} - -=end code - -=head1 Информация об отображении объекта - -=begin code - -{ - prop_name => [ entity => 'field' ] -} - -=end code - -=cut
--- a/Lib/IMPL/ORM/Entity.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -package IMPL::ORM::Entity; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Class => prop_get; - public _direct property Values => prop_get; - public _direct property Schema => prop_get; -} - -sub CTOR { - my ($this,$class,$schema) = @_; - - $this->{$Class} = $class; - (my $name = $class) =~ s/::/_/g; - $this->{$Name} = $name; - $this->Schema = $schema; - $this->{$Values} = { - map {$_->{name},{type => $_->{type}, virtual => $_->{virtual}}} @$schema - }; -} - -sub Store; -*Store = \&dbgStore; - -sub dbgStore { - my ($this,$prop,$value) = @_; - - if ( my $container = $this->{$Values}{$prop} ) { - $container->{oldValue} = $container->{value}; - $container->{value} = $value; - } else { - die new IMPL::InvalidOperationException("Property not found",$this->Name,$prop); - } -} - -sub Get { - my ($this,$prop) = @_; - - return $this->{$Values}{$prop}{value}; -} - -1;
--- a/Lib/IMPL/ORM/Helpers.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::ORM::Helpers; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Map &Box); - -sub Map($$) { - my ($TKey,$TValue) = @_; - - $TKey =~ s/:://g; - $TValue =~ s/:://g; - - return "IMPL::ORM::Map::${TKey}${TValue}"; -} - -sub Box($) { - my ($TValue) = @_; - $TValue =~ s/:://g; - return "IMPL::ORM::Box::$TValue"; -} - -1;
--- a/Lib/IMPL/ORM/Object.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,115 +0,0 @@ -package IMPL::ORM::Object; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -require IMPL::ORM::Entity; -require IMPL::ORM::Schema::Entity; -require IMPL::ORM::Schema::Field; -require IMPL::ORM::Schema::Relation::HasMany; -require IMPL::ORM::Schema::Relation::HasOne; -require IMPL::ORM::Schema::Relation::Subclass; - -BEGIN { - private _direct property _entities => prop_all; - public property objectType => prop_all, {type => 'String'}; - - sub _PropertyImplementor { - 'IMPL::ORM::PropertyImplementor' - } -} - -my %schemaCache; - -sub CTOR { - my ($this) = @_; - - while ( my ($class,$schema) = $this->ormGetSchema ) { - $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema); - } -} - -sub ormStore { - my ($this,$class,$prop,$value) = @_; - - die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class}; - - $this->{$_entities}{$class}->Store($prop,$value); -} - -sub ormGet { - my ($this,$class,$prop,$value) = @_; - - return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef; -} - -sub entityName { - (my $self = ref $_[0] || $_[0]) =~ s/^.*?(\w+)$/$1/; - return $self; -} - -sub ormGetSchema { - my ($self,$dataSchema,$surrogate) = @_; - - my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName); - - # для текущего класса, проходим по всем свойствам - foreach my $ormProp ( - $self->get_meta( - 'IMPL::Class::PropertyInfo', - sub { - UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' ) - }, - 0 - ) - ){ - if ($ormProp->Mutators & prop_list) { - # отношение 1 ко многим - my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name); - $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); - } elsif (my $type = $dataSchema->isValueType($ormProp->Type)) { - # поле - $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$ormProp->Type) ); - } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { - # отношение ссылка - $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); - } else { - # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле. - die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type); - } - } - - # Формируем отношения наследования - { - # локализуем прагму - no strict 'refs'; - - my $class = ref $self || $self; - - # по всем классам - foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) { - my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super); - $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type)); - } - } - - return $schema; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Базовый объект для реляционного отображения, -содержит в себе реляционные записи представляющие данный объект. - -Каждый класс отображается в определенную сущность. Сущности хранят -состояние объектов в том виде в котором удобно записывать в реляционную базу. - -=cut
--- a/Lib/IMPL/ORM/PropertyImplementor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -package IMPL::ORM::PropertyImplementor; -use strict; -use warnings; - - - -1;
--- a/Lib/IMPL/ORM/Schema.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -package IMPL::ORM::Schema; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Document); -use IMPL::Class::Property; -require IMPL::ORM::Schema::Entity; -require IMPL::ORM::Schema::ValueType; - -our %CTOR = ( - 'IMPL::DOM::Document' => sub { nodeName => 'ORMSchema' } -); - -BEGIN { - public property mapValueTypes => prop_get | owner_set; - public property mapReferenceTypes => prop_get | owner_set; - public property mapPending => prop_get | owner_set; - public property prefix => prop_get | owner_set; -} - -sub CTOR { - my ($this ) = @_; - $this->mapValueTypes({}); - $this->mapReferenceTypes({}); - $this->mapPending({}); -} - -# return an entity for the specified typename -# makes forward declaration if nesessary -sub resolveType { - my ($this,$typeName) = @_; - - $this = ref $this ? $this : $this->instance; - - if (my $entity = $this->mapReferenceTypes->{$typeName}) { - return $entity; - } elsif (UNIVERSAL::isa($typeName,'IMPL::ORM::Object')) { - return $this->declareReferenceType($typeName); - } else { - return undef; - } -} - -sub declareReferenceType { - my ($this,$typeName) = @_; - - my $entity = new IMPL::ORM::Schema::Entity($typeName->entityName); - - $this->mapPending->{$typeName} = $entity; - - $this->appendChild($entity); - - return $this->mapReferenceTypes->{$typeName} = $entity; -} - -sub _addReferenceType { - my ($this,$className) = @_; - - if ( my $entity = delete $this->mapPending->{$className} ) { - $className->ormGetSchema($this,$entity); - } else { - return $this->appendChild( $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this) ); - } - -} - -# returns valuetype name -sub isValueType { - my ($this,$typeName) = @_; - - $this = ref $this ? $this : $this->instance; - - return $this->mapValueTypes->{$typeName}; -} - -my %instances; -sub instance { - my ($class) = @_; - - return ($instances{$class} || ($instances{$class} = $class->new)); -} - -sub ValueTypes { - my ($this,%classes) = @_; - - $this = ref $this ? $this : $this->instance; - - while ( my ($typeName,$typeReflected) = each %classes ) { - $this->mapValueTypes->{$typeName} = $typeReflected; - $this->appendChild(IMPL::ORM::Schema::ValueType->new($typeName,$typeReflected)); - } -} - -sub Classes { - my ($this,@classNames) = @_; - - $this = ref $this ? $this : $this->instance; - - $this->_addReferenceType($this->prefix . $_) foreach @classNames; -} - -sub usePrefix { - my ($this,$prefix) = @_; - - $prefix .= '::' if $prefix and $prefix !~ /::$/; - - (ref $this ? $this : $this->instance)->prefix($prefix); -} - -sub CompleteSchema { - my ($this) = @_; - - $this = ref $this ? $this : $this->instance; - - $_->ormGetSchema($this,delete $this->mapPending->{$_}) foreach (keys %{$this->mapPending}); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Schema> Схема отображения классов в реляционную структуру. - -=head1 DESCRIPTION - -Схема данных, представляет собой DOM документ, элементами которой -являются сущности. - -Каждый узел - это описание сущности. - -=begin code xml - -<Schema> - <Entity entityName="My_Data_Foo"> - <Field fieldName="Doo" fieldType="String"/> - <HasMany name="Boxes" target="My_Data_Box"/> - </Entity> - <Entity entityName="My_Data_Bar"> - <Subclass base="My_Data_Foo"/> - <Field fieldName="Timestamp" fieldType="Integer"/> - </Entity> - <Entity entityName="My_Data_Box"> - <Field fieldName="Capacity" fieldType="Integer"/> - </Entity> -</Schema> - -=end code xml - -=cut
--- a/Lib/IMPL/ORM/Schema/Entity.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::ORM::Schema::Entity; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -BEGIN { - public property entityName => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { - nodeName => 'Entity' - } -); - -sub CTOR { - my ($this,$name) = @_; - - $this->entityName($name); -} - -1;
--- a/Lib/IMPL/ORM/Schema/Field.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::ORM::Schema::Field; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -BEGIN { - public property fieldName => prop_get | owner_set; - public property fieldType => prop_get | owner_set; - public property fieldNullbale => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'Field' } -); - -sub CTOR { - my ($this,$name,$type,$nullable) = @_; - - $this->fieldName($name) or die new IMPL::InvalidArgumentException('A name is required for the field'); - $this->fieldType($type) or die new IMPL::InvalidArgumentException('A type is required for the field'); - $this->fieldNullbale(1) if $nullable; -} - -sub canHaveChildren { - 0; -} - -1;
--- a/Lib/IMPL/ORM/Schema/GenericClass.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -package IMPL::ORM::Schema::GenericClass; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Schema::GenericClass> Построение схемы из произвольного класса. - -=head1 DESCRIPTION - -Читает метаданные класса и строит на их основании элементы схемы данных. - -=cut
--- a/Lib/IMPL/ORM/Schema/Relation.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -package IMPL::ORM::Schema::Relation; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Node); - -our %CTOR =( - 'IMPL::DOM::Node' => sub { nodeName => $_[0] } -); - - -1;
--- a/Lib/IMPL/ORM/Schema/Relation/HasMany.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -package IMPL::ORM::Schema::Relation::HasMany; -use strict; -use warnings; - -use parent qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property target => prop_get | owner_set; - public property name => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'HasMany' } -); - -sub CTOR { - my ($this,$name,$target) = @_; - $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); - $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); -} - -sub canHaveChildren { - 0; -} - -1;
--- a/Lib/IMPL/ORM/Schema/Relation/HasOne.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::ORM::Schema::Relation::HasOne; -use strict; -use warnings; - -use parent qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property target => prop_get | owner_set; - public property name => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'HasOne' } -); - -sub CTOR { - my ($this,$name,$target) = @_; - $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); - $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); -} - -sub canHaveChildren { - 0; -} - - -1;
--- a/Lib/IMPL/ORM/Schema/Relation/Subclass.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -package IMPL::ORM::Schema::Relation::Subclass; -use strict; -use warnings; - -use parent qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property base => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'Subclass' } -); - -sub CTOR { - my ($this,$base) = @_; - - $this->base($base) or die new IMPL::InvalidArgumentException('A base is required for this relation'); -} - -sub canHaveChildren { - 0; -} - -1;
--- a/Lib/IMPL/ORM/Schema/TransformToSQL.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -package IMPL::ORM::Schema::TransformToSQL; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Transform); -use IMPL::Class::Property; -use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary); - -require IMPL::SQL::Schema; - -BEGIN { - public property Types => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Transform' => sub { - ORMSchema => \&ORMSchemaTransform, - Entity => \&EntityTransform, - Field => \&FieldTransform, - HasOne => \&HasOneTransform, - HasMany => \&HasManyTransform, - Subclass => \&SubclassTransform, - ValueType => sub {} - } -); - -sub CTOR { - my ($this,$refTypeMap) = @_; - - $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required"); -} - -sub ORMSchemaTransform { - my ($this,$node) = @_; - - my $schema = IMPL::SQL::Schema->new(Name => ref $node); - - my @constraints; - - my %ctx = (Schema => $schema); - - # all tables - foreach my $entity ($node->selectNodes('Entity')) { - $schema->AddTable($this->Transform($entity,\%ctx)); - push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')}); - } - - # establish relations - $this->Transform($_,\%ctx) foreach @constraints; - - return $schema; -} - -sub EntityTransform { - my ($this,$node,$ctx) = @_; - - my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema}); - - $this->MakePrimaryKey($table); - - $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field'); - - return $table; -} - -sub FieldTransform { - my ($this,$field,$ctx) = @_; - - return { - Name => $field->fieldName, - Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType), - CanBeNull => $field->fieldNullable - }; -} - -sub HasOneTransform { - my ($this,$relation,$ctx) = @_; - - my $sqlSchema = $ctx->{Schema}; - my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; - my $tableForeign = $sqlSchema->Tables->{$relation->target}; - my $prefix = $relation->name; - - my @fkColumns = $tableForeign->PrimaryKey->columns; - - if (@fkColumns > 1) { - @fkColumns = map - $table->InsertColumn({ - Name => $prefix . $_->Name, - Type => $_->Type, - CanBeNull => 1 - }), @fkColumns; - } else { - @fkColumns = $table->InsertColumn({ - Name => $prefix, - Type => $fkColumns[0]->Type, - CanBeNull => 1 - }); - } - - $table->LinkTo($tableForeign,@fkColumns); -} - -sub HasManyTransform { - my ($this,$relation,$ctx) = @_; - - #similar to HasOne - - my $sqlSchema = $ctx->{Schema}; - my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; - my $tableForeign = $sqlSchema->Tables->{$relation->target}; - my $prefix = $relation->name; - - my @fkColumns = $table->PrimaryKey->columns; - - if (@fkColumns > 1 ) { - @fkColumns = map $tableForeign->InsertColumn({ - Name => $prefix . $_->Name, - Type => $_->Type, - CanBeNull => 1 - }), @fkColumns; - } else { - @fkColumns = $tableForeign->InsertColumn({ - Name => $prefix, - Type => $fkColumns[0]->Type, - CanBeNull => 1 - }); - } - - $tableForeign->LinkTo($table,@fkColumns); -} - -sub SubclassTransform { - # actually this rlations has only logical implementation -} - -sub MapType { - my ($this,$typeName) = @_; - - $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName); -} - -sub MakePrimaryKey { - my ($this,$table) = @_; - - $table->InsertColumn( {Name => '_Id', Type => Integer } ); - $table->SetPrimaryKey('_Id'); -} - -{ - my $std; - sub Std { - $std ||= __PACKAGE__->new({ - String => Varchar(255), - DateTime => DateTime, - Integer => Integer, - Float => Float(24), - Decimal => Float(53), - Real => Float(24), - Binary => Binary, - Text => Text - }); - } -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -=begin code - -my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance); - -=end code - -=cut -
--- a/Lib/IMPL/ORM/Schema/ValueType.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -package IMPL::ORM::Schema::ValueType; - -use strict; - -use parent qw(IMPL::DOM::Node); - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'ValueType' } -); - -use IMPL::Class::Property; - -BEGIN { - public property typeName => prop_all; - public property typeReflected => prop_all; -} - -sub CTOR { - my ($this,$typeName,$typeReflected) = @_; - - $this->typeName($typeName); - $this->typeReflected($typeReflected); -} - -1; - -__END__ - -=pod - -=cut
--- a/Lib/IMPL/ORM/Store/DBIC.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -package IMPL::ORM::DBIC; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::DBIC> - Хранилище данных на основе C<DBIx::Class>. - -=cut
--- a/Lib/IMPL/ORM/Store/SQL.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::ORM::Store::SQL; -use strict; -use warnings; - -use parent qw(IMPL::Object); - -use IMPL::Class::Property; - -BEGIN { - public property Connection => prop_all; -} - -sub loadObjects { - my ($this,$rObjects) = @_; -} - -sub search { - my ($this,$query) = @_; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION -Драйвер для SQL баз данных. - -=cut
--- a/Lib/IMPL/ORM/Unit.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -package IMPL::ORM::Unit; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::ORM::Unit> Единица действий. - -=head1 DESCRIPTION - -C<[Infrastructure]> - -Позволяет записывать последовательность изменений. Используется C<IMPL::ORM> для реализации логических -транзакций. - -=cut
--- a/Lib/IMPL/Object.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -package IMPL::Object; -use strict; - -use parent qw(IMPL::Object::Abstract); -use IMPL::require { - ClassPropertyImplementor => 'IMPL::Code::DirectPropertyImplementor' -}; - -sub surrogate { - bless {}, ref $_[0] || $_[0]; -} - -sub new { - my $class = shift; - my $self = bless {}, ref($class) || $class; - $self->callCTOR(@_); - - $self; -} - -1; - -__END__ - -=pod - -=head1 SINOPSYS - -=begin code - -package Foo; -use parent qw(IMPL::Object); - -sub CTOR { - my ($this,$arg) = @_; - print "Foo: $arg\n"; -} - -package Bar; -use parent qw(IMPL::Object); - -sub CTOR { - my ($this,$arg) = @_; - print "Bar: $arg\n"; -} - -package Baz; -use parent qw(Foo Bar); - -our %CTOR = ( - Foo => sub { my %args = @_; $args{Mazzi}; }, - Bar => sub { my %args = @_; $args{Fugi}; } -); - -package Composite; -use parent qw(Baz Foo Bar); - -our %CTOR = ( - Foo => undef, - Bar => undef -); - -sub CTOR { - my ($this,%args) = @_; - - print "Composite: $args{Text}\n"; -} - -package main; - -my $obj = new Composite( - Text => 'Hello World!', - Mazzi => 'Mazzi', - Fugi => 'Fugi' -); - -# will print -# -# Foo: Mazzi -# Bar: Fugi -# Bar: -# Composite: Hello World! - -=end code - -=head1 Description - -Базовый класс для объектов, основанных на хеше. - -=head1 Members - -=over - -=item operator C<new>(@args) - -Создает экземпляр объекта и вызывает конструктор с параметрами @args. - -=item operator C<surrogate>() - -Создает неинициализированный экземпляр объекта. - -=back - -=head1 Cavearts - -Нужно заметить, что директива C<use parent> работает не совсем прозрачно, если в нашем примере -класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от -C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:) - -=cut
--- a/Lib/IMPL/Object/Abstract.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,189 +0,0 @@ -package IMPL::Object::Abstract; -use strict; -use warnings; - -use parent qw(IMPL::Class::Meta); -use Carp qw(croak); - -our $MemoryLeakProtection; -my $Cleanup = 0; - -my %cacheCTOR; - -my $t = 0; -sub cache_ctor { - my $class = shift; - - no strict 'refs'; - my @sequence; - - my $refCTORS = *{"${class}::CTOR"}{HASH}; - - foreach my $super ( @{"${class}::ISA"} ) { - my $superSequence = $cacheCTOR{$super} || cache_ctor($super); - - my $mapper = $refCTORS ? $refCTORS->{$super} : undef; - if (ref $mapper eq 'CODE') { - if ($mapper == *_pass_through_mapper{CODE}) { - push @sequence,@$superSequence; - } else { - push @sequence, sub { - my $this = shift; - $this->$_($mapper->(@_)) foreach @$superSequence; - } if @$superSequence; - } - } elsif ($mapper and not ref $mapper and $mapper eq '@_') { - push @sequence,@$superSequence; - } else { - warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; - push @sequence, sub { - my $this = shift; - $this->$_() foreach @$superSequence; - } if @$superSequence; - } - } - - push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; - - $cacheCTOR{$class} = \@sequence; - return \@sequence; -} - -sub dump_ctor { - my ($self) = @_; - $self = ref $self || $self; - - warn "dumping $self .ctor"; - warn "$_" foreach @{$cacheCTOR{$self}||[]}; -} - -sub callCTOR { - my $self = shift; - my $class = ref $self; - - $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)}; -} - -sub _init_dtor { - my ($class) = @_; - - no strict 'refs'; - - # avoid warnings for classes without destructors - no warnings 'once'; - - my @dtors; - - my @hierarchy = ($class); - my %visited; - - while(my $subclass = shift @hierarchy) { - if(*{"${subclass}::DTOR"}{CODE}) { - push @dtors, *{"${subclass}::DTOR"}{CODE}; - } - - push @hierarchy, @{"${subclass}::ISA"}; - } - - if (@dtors) { - - return *{"${class}::callDTOR"} = sub { - my ($self) = @_; - my $selfClass = ref $self; - if ($selfClass ne $class) { - goto &{$selfClass->_init_dtor()}; - } else { - map $_->($self), @dtors; - } - } - - } else { - return *{"${class}::callDTOR"} = sub { - my $self = ref $_[0]; - - goto &{$self->_init_dtor()} unless $self eq $class; - } - } -} - -__PACKAGE__->_init_dtor(); - -sub toString { - my $self = shift; - - return (ref $self || $self); -} - -sub _typeof { - ref $_[0] || $_[0]; -} - -sub isDisposed { - 0; -} - -sub DESTROY { - shift->callDTOR(); -} - -sub END { - $Cleanup = 1; -} - -sub _pass_through_mapper { - @_; -} - -sub PassArgs { - \&_pass_through_mapper; -} - -sub PassThroughArgs { - my $class = shift; - $class = ref $class || $class; - no strict 'refs'; - no warnings 'once'; - ${"${class}::CTOR"}{$_} = \&_pass_through_mapper foreach @{"${class}::ISA"}; -} - -package self; - -our $AUTOLOAD; -sub AUTOLOAD { - goto &{caller(). substr $AUTOLOAD,4}; -} - -package supercall; - -our $AUTOLOAD; -sub AUTOLOAD { - my $sub; - my $methodName = substr $AUTOLOAD,9; - no strict 'refs'; - $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'}; -} - -1; - -__END__ - -=pod -=head1 SYNOPSIS - -package MyBaseObject; -use parent qw(IMPL::Object::Abstract); - -sub new { - # own implementation of the new opeator -} - -sub surrogate { - # own implementation of the surrogate operator -} - -=head1 DESCRIPTION - -Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов -создания экземпляров. - -=cut
--- a/Lib/IMPL/Object/Accessor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -package IMPL::Object::Accessor; -use strict; - -use parent qw( - IMPL::Object::Abstract - Class::Accessor -); - -use IMPL::require { - ClassPropertyImplementor => '-IMPL::Code::AccessorPropertyImplementor' -}; - -require IMPL::Code::AccessorPropertyImplementor; - -sub new { - my $class = shift; - my $self = $class->Class::Accessor::new( @_ == 1 && ref $_[0] && UNIVERSAL::isa($_[0],'HASH') ? $_[0] : ()); - $self->callCTOR(@_); - return $self; -} - -sub surrogate { - $_[0]->Class::Accessor::new; -} - -1;
--- a/Lib/IMPL/Object/ArrayObject.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,19 +0,0 @@ -package IMPL::Object::ArrayObject; -use strict; -use warnings; - -use parent qw(IMPL::Object::Abstract); - -sub new { - my $class = shift; - my $self = bless [], ref $class || $class; - $self->callCTOR(@_); - return $self; -} - -sub surrogate { - return bless [], ref $_[0] || $_; -} - -1; -
--- a/Lib/IMPL/Object/AutoDispose.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -package IMPL::Object::AutoDispose; -use strict; - -sub new { - my $self = shift; - - if (ref $self) { - return ${$self}->new(@_); - } else { - my $obj = shift; - return bless \$obj, $self; - } -} - -sub isa { - ${shift(@_)}->isa(@_); -} - -sub can { - ${shift(@_)}->can(@_); -} - -sub DESTROY { - ${shift(@_)}->Dispose(); -} - -sub AUTOLOAD { - our $AUTOLOAD; - my ($method) = ($AUTOLOAD =~ m/(\w+)$/); - - no strict 'refs'; - - goto &{*{$AUTOLOAD} = sub { - ${shift(@_)}->$method(@_); - }}; -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Object/Autofill.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -package IMPL::Object::Autofill; -use strict; - -use IMPL::Const qw(:access); - -sub CTOR { - my $this = shift; - no strict 'refs'; - - my $fields = @_ == 1 ? $_[0] : {@_}; - - $this->_fill(ref $this,$fields); -} - -sub _fill { - my ($this,$class,$fields) = @_; - - $class->_autofill_method->($this,$fields); - - no strict 'refs'; - $this->_fill($_,$fields) foreach grep $_->isa('IMPL::Object::Autofill'), @{"${class}::ISA"}; -} - -sub DisableAutofill { - my $self = shift; - - no strict 'refs'; - my $class = ref $self || $self; - - *{"${class}::_impl_object_autofill"} = sub {}; -} - -sub _autofill_method { - my ($class) = @_; - - $class = ref $class if ref $class; - - # для автозаполнения нужен свой метод верхнего уровня - my $method; - { - no strict 'refs'; - $method = ${$class.'::'}{_impl_object_autofill}; - } - - if ($method) { - return $method; - } else { - my $text = <<HEADER; -package $class; -sub _impl_object_autofill { - my (\$this,\$fields) = \@_; -HEADER - - - if ($class->can('GetMeta')) { - # meta supported - foreach my $prop_info (grep { - $_->setter && ($_->access & ACCESS_PUBLIC); - } $class->GetMeta('IMPL::Class::PropertyInfo')) { - my $name = $prop_info->name; - if ($prop_info->isa('IMPL::Class::DirectPropertyInfo')) { - $text .= " \$this->$name(\$fields->{$name}) if exists \$fields->{$name};\n"; - } else { - 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"; - } - } - } - } else { - # meta not supported - #$text .= " ".'$this->$_($fields->{$_}) foreach keys %$fields;'."\n"; - } - $text .= "}\n\\&_impl_object_autofill;"; - return eval $text; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Object::Autofill> - автозаполнение объектов - -=head1 SYNOPSIS - -=begin code - -package MyClass; -use IMPL::declare { - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - } -}; - -BEGIN { - private property PrivateData => prop_all; - public property PublicData => prop_get; -} - -sub CTOR { - my $this = shift; - - print $this->PrivateData,"\n"; - print $this->PublicData,"\n"; -} - -my $obj = new MyClass(PrivateData => 'private', PublicData => 'public', Other => 'some data'); - -#will print -#private -#public - -=end code - -=cut
--- a/Lib/IMPL/Object/Clonable.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,10 +0,0 @@ -package IMPL::Object::Clonable; -use strict; - -use IMPL::lang qw(clone); - -sub Clone { - clone($_[0]); -} - -1;
--- a/Lib/IMPL/Object/Disposable.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ -package IMPL::Object::Disposable; -use strict; -require IMPL::Object::AutoDispose; - -our $Strict = 1; - -sub Dispose { - my ($this) = @_; - - bless $this, 'IMPL::Object::Disposed'; -} - -sub DTOR { - my ($this) = @_; - - warn sprintf('The object %s were marked as disposable but isn\'t disposed properly', $this->can('ToString') ? $this->ToString() : (ref $this || $this) ); -} - -sub AutoPtr { - IMPL::Object::AutoDispose->new(shift); -} - -package IMPL::Object::Disposed; -our $AUTOLOAD; -sub AUTOLOAD { - return if $AUTOLOAD eq __PACKAGE__.'::DESTROY'; - die new IMPL::Exception('Object have been disposed',$AUTOLOAD); -} - -sub isDisposed { - 1; -} - -1;
--- a/Lib/IMPL/Object/EventSource.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,191 +0,0 @@ -package IMPL::Object::EventSource; -use strict; -require IMPL::Exception; -use IMPL::Class::Property; - -sub CreateEvent { - my ($class,$event) = @_; - - die new IMPL::Exception('A name is required for the event') unless $event; - - (my $fullEventName = "$class$event") =~ s/:://g; - - my $globalEventTable = new IMPL::Object::EventSource::EventTable($fullEventName); - my $propEventTable = $event.'Table'; - public CreateProperty($class,$propEventTable,prop_all); - public CreateProperty($class,$event, - { - get => sub { - my $this = shift; - if (not defined wantarray and caller(1) eq $class) { - (ref $this ? $this->$propEventTable() || $globalEventTable : $globalEventTable)->Invoke($this); - } else { - if (ref $this) { - if (my $table = $this->$propEventTable()) { - return $table; - } else { - $table = new IMPL::Object::EventSource::EventTable($fullEventName,$globalEventTable); - $this->$propEventTable($table); - return $table; - } - } else { - return $globalEventTable; - } - } - }, - set => sub { - (ref $_[0] ? $_[0]->$propEventTable() || $globalEventTable : $globalEventTable)->Invoke(@_); - } - } - ); -} - -sub CreateStaticEvent { - my ($class,$event) = @_; - - die new IMPL::Exception('A name is required for the event') unless $event; - - (my $fullEventName = "$class$event") =~ s/:://g; - - my $globalEventTable = new IMPL::Object::EventSource::EventTable($fullEventName); - - no strict 'refs'; - *{"${class}::$event"} = sub { - shift; - if (not @_) { - if (not defined wantarray and caller(1) eq $class) { - $globalEventTable->Invoke($class); - } else { - return $globalEventTable; - } - } else { - $globalEventTable->Invoke($class,@_); - } - }; -} - -package IMPL::Object::EventSource::EventTable; -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use Scalar::Util qw(weaken); - -use overload - '+=' => \&opSubscribe, - 'fallback' => 1; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Handlers => { get => \&get_handlers }; - private _direct property Next => prop_all; - private _direct property NextId => prop_all; -} - -sub CTOR { - my $this = shift; - - $this->{$Handlers} = {}; - $this->{$Name} = shift; - $this->{$Next} = shift; - $this->{$NextId} = 1; -} - -sub get_handlers { - my $this = shift; - return values %{$this->{$Handlers}}; -} - -sub Invoke { - my $this = shift; - - my $tmp; - $tmp = $_ and local($_) or &$tmp(@_) foreach values %{$this->{$Handlers}}; - - $this->{$Next}->Invoke(@_) if $this->{$Next}; -} - -sub Subscribe { - my ($this,$consumer,$nameHandler) = @_; - - my $id = $this->{$NextId} ++; - - if (ref $consumer eq 'CODE') { - $this->{$Handlers}{$id} = $consumer; - } else { - $nameHandler ||= $this->Name or die new IMPL::Exception('The name for the event handler method must be specified'); - my $method = $consumer->can($nameHandler) or die new IMPL::Exception('Can\'t find the event handler method',$nameHandler,$consumer); - - weaken($consumer) if ref $consumer; - $this->{$Handlers}{$id} = sub { - unshift @_, $consumer; - $consumer ? goto &$method : delete $this->{$Handlers}{$id}; - }; - } - - return $id; -} - -sub Remove { - my ($this,$id) = @_; - return delete $this->{$Handlers}{$id}; -} -1; - -__END__ -=pod -=head1 SYNOPSIS -package Foo; -use parent qw(IMPL::Object IMPL::Object::EventSource); - -# declare events -__PACKAGE__->CreateEvent('OnUpdate'); -__PACKAGE__->CreateStaticEvent('OnNewObject'); - -sub CTOR { - my $this = shift; - // rise static event - $this->OnNewObject(); -} - -sub Update { - my ($this,$val) = @_; - - // rise object event - $this->OnUpdate($val); -} - -package Bar; - -// subscribe static event -Foo->OnNewObject->Subscribe(sub { warn "New $_[0] created" } ); - -sub LookForFoo { - my ($this,$foo) = @_; - - // subscribe object event - $foo->OnUpdate->Subscribe($this,'OnFooUpdate'); -} - -// event handler -sub OnFooUpdate { - my ($this,$sender,$value) = @_; -} - -=head1 DESCRIPTION -Позволяет объявлять и инициировать события. События делятся на статические и -локальные. Статические события объявляются для класса и при возникновении -данного события вызываются всегда все подписчики. Статические события могут быть -вызваны как для класса, так и для объекта, что приведет к одинаковым результатам. - -Локальные события состоят из статической (как статические события) и локальной -части. Если подписываться на события класса, то обработчики будут вызываться при -любых вариантах инициации данного события (как у статических событий). При -подписке на события объекта, обработчик будет вызван только при возникновении -событий у данного объекта. - -=head1 METHODS -=level 4 -=back - -=head1 EventTable - -=cut
--- a/Lib/IMPL/Object/Factory.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,209 +0,0 @@ -package IMPL::Object::Factory; -use strict; - -use IMPL::Const qw(:prop); - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => undef - ], - props => [ - factory => PROP_RO, - parameters => PROP_RO, - method => PROP_RO - ] -}; - -# custom factory, overrides default -sub new { - my $self = shift; - - return ref $self ? $self->CreateObject(@_) : $self->IMPL::Object::new(@_); -} - -sub CTOR { - my ($this,$factory,$parameters,$method) = @_; - - $this->factory($factory) or die new IMPL::InvalidArgumentException("The argument 'factory' is mandatory"); - $this->parameters($parameters) if $parameters; - $this->method($method) if $method; -} - -# override default restore method -sub restore { - my ($class,$data,$surrogate) = @_; - - my %args = @$data; - - if ($surrogate) { - $surrogate->self::CTOR($args{factory},$args{parameters},$args{method}); - return $surrogate; - } else { - return $class->new($args{factory},$args{parameters},$args{method}); - } -} - -sub CreateObject { - my $this = shift; - - if (my $method = $this->method) { - $this->factory->$method($this->MergeParameters(@_)); - } else { - $this->factory->new($this->MergeParameters(@_)); - } -} - -sub MergeParameters { - my $this = shift; - - $this->parameters ? (_as_list($this->parameters),@_) : @_; -} - - -sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); -} - - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -=begin code - -my $factory = new IMPL::Object::Factory( - 'MyApp::User', - { - isAdmin => 1 - } -); - -my $class = 'MyApp::User'; - -my $user; - -$user = $class->new(name => 'nobody'); # will create object MyApp::User - # and pass parameters (name=>'nobody') - -$user = $factory->new(name => 'root'); # will create object MyApp::User - # and pass paremeters (isAdmin => 1, name => 'root') - -=end code - -Или сериализованная форма в XML. - -=begin code xml - -<factory type="IMPL::Object::Factory"> - <factory>MyApp::User</factory>, - <parameters type="HASH"> - <isAdmin>1</isAdmin> - </parameters> -</factory> - -=end code xml - -=head1 DESCRIPTION - -C<[Serializable]> - -Класс, реализующий фабрику классов. - -Фабрика классов это любой объект, который имеет метод C< new > вызов которого приводит к созданию нового -объекта. Например каждый класс сам явялется фабрикой, поскольку, если у него вызвать метод -C< new >, то будет создан объект. Полученные объекты, в силу механизмов языка Perl, также -являются фабриками, притом такимиже, что и класс. - -Данный класс меняет поведение метода C< new > в зависимости от контекста вызова: статического -метода или метода объекта. При вызове метода C< new > у класса происходит создание объекта -фабрики с определенными параметрами. Далее объект-фабрика может быть использована для создания -объектов уже на основе параметров фабрики. - -=head1 MEMBERS - -=over - -=item C< CTOR($factory,$parameters,$method) > - -Создает новый экземпляр фабрики. - -=over - -=item C<$factory> - -Либо имя класса, либо другая фабрика. - -=item C<$parameters> - -Ссылка на параметры для создания объектов, может быть ссылкой на хеш, массив и т.д. - -Если является ссылкой на хеш, то при создании объектов данной фабрикой этот хеш -будет развернут в список и передан параметрами методу C<new>. - -Если является ссылкой на массив, то при создании объектов данной фабрикой этот массив -будет передан в списк и передан параметрами методу C<new>. - -Если является любым другим объектом или скаляром, то будет передан параметром методу -C<new> как есть. - -=item C<$method> - -Имя метода (или ссылка на процедуру), который будет вызван у C<$factory> при создании -текущей фабрикой нового объекта. - -=back - -=item C< [get] factory > - -Свойство, содержащее фабрику для создание новых объектов текущей фабрикой. Чаще всего оно содержит -имя класса. - -=item C< [get] parameters > - -Свойство, содержит ссылку на параметры для создания объектов, при создании объекта эти параметры будут -развернуты в список и переданы оператору C< new > фабрике из свойства C< factory >, за ними будут -следовать параметры непосредственно текущей фабрики. - -=item C<MergeParameters(@params)> - -Метод смешивающий фиксированные параметры с параметрами переданными методу C<new(@params)>. По умолчанию -добавляет пареметры фабрики в конец к фиксированным параметрам. Для изменения этого поведения требуется -переопределить данный метод. Также этот метод можно переопределить для передачи параметров, значения -которых вычисляются. - -=item C<new(@params)> - -Создает новый объект, используя свйство C<factory> как фабрику и передавая туда параметры -из свойства C<parameters> и списка C<@params>. Ниже приведен упрощенный пример, как это происходит. - -=begin code - -sub new { - my ($this,@params) = @_; - - my $method = $this->method || 'new'; - - return $this->factory->$method(_as_list($this->parameters), @params); -} - -=end code - -=back - -=cut
--- a/Lib/IMPL/Object/Fields.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -package IMPL::Object::Fields; -use strict; -use warnings; - -use parent qw(IMPL::Object::Abstract); - -sub new { - my $class = shift; - - $class = ref $class || $class; - - my $this = fields::new($class); - $this->callCTOR(@_); - - return $this; -} - -sub surrogate { - my $class = shift; - - $class = ref $class || $class; - - return fields::new($class); -} - -1;
--- a/Lib/IMPL/Object/InlineFactory.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -package IMPL::Object::InlineFactory; -use strict; -use Carp qw(croak); - -sub new { - my $self = shift; - if(ref $self) { - return &$$self(@_); - } else { - my $factory = shift; - - croak "A code reference is required" - unless ref $factory eq 'CODE'; - - return bless \$factory, $self; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Object::InlineFactory> - реализация фабрики на основе процедуры. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - InlineFactory => 'IMPL::Object::InlineFactory', - Foo => 'My::App::Foo' -}; - -my $factory = InlineFactory->new(sub { Foo->new(mode => 'direct', @_) }); - -my $obj = $factory->new(timeout => 10); # Foo->new(mode => 'direct', timeout => 10); - -=end code - -=cut \ No newline at end of file
--- a/Lib/IMPL/Object/List.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,124 +0,0 @@ -package IMPL::Object::List; -use strict; -use warnings; - -use Carp qw(carp); -use parent qw(IMPL::Object::ArrayObject); -require IMPL::Exception; - -sub as_list { - return $_[0]; -} - -sub CTOR { - my ($this,$data) = @_; - - if ($data) { - die new IMPL::InvalidArgumentException("The parameter should be a reference to an array") unless UNIVERSAL::isa($data,"ARRAY"); - @$this = @$data; - } -} - -sub Append { - carp "Appen method is obsolete use Push instead"; - push @{$_[0]}, @_[1 .. $#_]; -} - -sub Push { - push @{$_[0]}, @_[1 .. $#_]; -} - -sub AddLast { - carp "Appen method is obsolete use Push instead"; - push @{$_[0]}, @_[1 .. $#_]; -} - -sub RemoveLast { - return pop @{$_[0]}; -} - -sub AddFirst { - return unshift @{$_[0]}, $_[1]; -} - -sub RemoveFirst { - return shift @{$_[0]}; -} - -sub Count { - return scalar @{$_[0]}; -} - -sub Item { - return $_[0]->[$_[1]]; -} - -sub InsertAt { - my ($this,$index,@val) = @_; - - splice @$this,($index||0),0,@val; -} - -sub RemoveAt { - my ($this,$index,$count) = @_; - - $count ||= 1; - - return splice @$this,$index,$count; -} - -sub RemoveItem { - my ($this,$item) = @_; - - @$this = grep $_ != $item, @$this; - - return $this; -} - -sub RemoveItemStr { - my ($this,$item) = @_; - - @$this = grep $_ ne $item, @$this; - - return $this; -} - -sub FindItem { - my ($this,$item) = @_; - - for (my $i = 0; $i < @$this; $i++ ) { - return $i if $this->[$i] == $item - } - return undef; -} - -sub FindItemStr { - my ($this,$item) = @_; - - for (my $i = 0; $i < @$this; $i++ ) { - return $i if $this->[$i] eq $item - } - return undef; -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar( item => $_ ) foreach @$this; -} - -sub restore { - my ($class,$data,$surrogate) = @_; - - my $i = 0; - - if ($surrogate) { - @$surrogate = grep { ($i++)%2 } @$data; - } else { - $surrogate = $class->new([grep { ($i++)%2 } @$data]); - } - - return $surrogate; -} - -1;
--- a/Lib/IMPL/Object/Meta.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,50 +0,0 @@ -package IMPL::Object::Meta; -use strict; -use warnings; - -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->owner(scalar caller); - $meta->callCTOR(@_); - $caller->SetMeta($meta); -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -package Foo; - -meta BarAttribute('Simple bar attribute'); #mark Foo with BarAttribute - -=head1 DESCRIPTION - -Базовый класс для мета-свойств класса. Определяет оператор C< meta > для создания метаданных в вызвавшем классе. - -=head1 MEMBERS - -=over - -=item C< Container > - -Свойство заполняется до вызова конструктора и содержит имя модуля к которому применяется атрибут. - -=back - -=cut
--- a/Lib/IMPL/Object/PublicSerializable.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -package IMPL::Object::PublicSerializable; -use strict; - -use IMPL::Const qw(:access); - -sub restore { - my ($class,$data,$refSurrogate) = @_; - - if ($refSurrogate) { - $refSurrogate->callCTOR(@$data); - return $refSurrogate; - } else { - return $class->new(@$data); - } -} - -sub save { - my ($this,$ctx) = @_; - - my %seen; - - my $val; - - defined($val = $this->$_()) and $ctx->AddVar($_,$val) foreach - map $_->name,$this->GetMeta( - 'IMPL::Class::PropertyInfo', - sub { - $_->access == ACCESS_PUBLIC and - $_->getter and - $_->setter and - not $_->ownerSet and - not $seen{$_->name} ++ - }, - 1 - ); -} - -1;
--- a/Lib/IMPL/Object/Serializable.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -package IMPL::Object::Serializable; -use strict; -use warnings; - -require IMPL::Exception; -use IMPL::Class::Property; - -sub restore { - my ($class,$data,$refSurrogate) = @_; - - if ($refSurrogate) { - $refSurrogate->callCTOR(@$data); - return $refSurrogate; - } else { - return $class->new(@$data); - } -} - -sub save { - my ($this,$ctx,$predicate) = @_; - - ($this->_get_save_method)->($this,$ctx); -} - -sub _get_save_method { - my ($class) = @_; - - $class = ref $class || $class; - - no strict 'refs'; - if (my $method = *{"${class}::_impl_auto_save"}{CODE}) { - return $method; - } else { - my $code = <<SAVE_METHOD; -package $class; -sub _impl_auto_save { - my (\$this,\$ctx) = \@_; -SAVE_METHOD - - $code .= - 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; - -} -\\\&_impl_auto_save; -SAVE_METHOD - - return (eval $code || die new IMPL::Exception("Failed to generate serialization method",$class,$@)); - } -} - -1;
--- a/Lib/IMPL/Object/Singleton.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,81 +0,0 @@ -package IMPL::Object::Singleton; -use strict; -use warnings; - -require IMPL::Exception; -use parent qw( - IMPL::Class::Meta -); - -__PACKAGE__->static_accessor_own(_instance => undef); - -sub InitInstance { - my $self = shift; - die IMPL::InvalidOperationException->new("Only one instance of the singleton can be created", $self) - if $self->_instance; - - $self->_instance($self->new(@_)); -} - -sub instance { - my $this = shift; - return $this->_instance || $this->_instance($this->Activate()); -} - -sub Activate { - die IMPL::NotImplementedException->new("Activation isn't implemented", shift); -} - -sub Release { - shift->_instance(undef); -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -=begin code - -package Foo; - -use parent qw(IMPL::Object IMPL::Object::Singleton); - -#.... - -Foo->isnatnce->some_work(); - -Foo->isnatnce->get_result(); - -=end code - -=head1 DESCRIPTION - -Реализует шаблон Singleton. Наследники данного класса могут иметь только один -экземпляр. Создать этот экземпляр можно явно, используюя конструктор, либо -автоматически при обращении к свойству C<instance>, для этого нужно -переопределить метод C<Activate()> - -=head1 MEMBERS - -=head2 C<CTOR()> - -Проверяет на единственность экземпляра класса, запоминает созданный экземпляр. - -=head2 C<[static,get]instance> - -Текущий экземпляр класса, если он еще не создан, то вызывает метод C<Activate>. - -=head2 C<[static,abstract]Activate()> - -Вызывается автоматически при обращении к свойству C<instance>, если экземпляр -объекта еще не был создан. - -=head2 C<[static]Release()> - -Освобождает текущий экземпляр. - -=cut
--- a/Lib/IMPL/Profiler.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -package IMPL::Profiler; - -use strict; -use warnings; -use Time::HiRes; -require Scalar::Util; - -our $Enabled; -our %TrappedModules; -our %InvokeInfo; -our $InvokeTime = 0; -our @TrapQueue; -our $Filter ||= qr//; -my $level; - -BEGIN { - $level = 0; - if ($Enabled) { - warn "profiler enabled"; - - unshift @INC, sub { - my ($self,$filename) = @_; - - (my $module = $filename) =~ s/\//::/g; - $module =~ s/\.\w+$//; - - return unless $module =~ $Filter; - - foreach my $dir (@INC) { - my $fullName = "$dir/$filename"; - if (-f $fullName) { - open my $hmod, $fullName or die "$fullName: $!" if $!; - - - - my @source; - local $/ = "\n"; - while (my $line = <$hmod>) { - last if $line =~ /^\s*__END__/; - push @source, $line; - } - - undef $hmod; - - push @source, - "IMPL::Profiler::trap_all(__PACKAGE__);\n", - "1;\n"; - - - return (sub { - if (@source) { - $_ = shift @source; - return 1; - } else { - return 0; - } - }, undef ); - } - } - }; - - no warnings 'once'; - *CORE::GLOBAL::caller = sub { - my $target = (shift || 0)+1; - my $realFrame = 1; - - for (my $i = 1; $i<$target; $i++) { - $realFrame ++; - my $caller = CORE::caller($realFrame-1) or return; - $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy - } - - my @frame = CORE::caller($realFrame) or return; - if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) { - my @next = CORE::caller($realFrame+1) or return; - @frame[0..2] = @next[0..2]; - } - - #warn " "x$level,"$frame[0] - $frame[3]"; - return wantarray ? @frame : $frame[0]; - }; - } -} - -sub trap_all { - return if not $Enabled; - no strict 'refs'; - foreach my $class (@_) { - next if $TrappedModules{$class}; - $TrappedModules{$class} = 1; - - eval "warn 'load $class'; require $class;" if not %{"${class}::"}; - die $@ if $@; - - no strict 'refs'; - my $table = \%{"${class}::"}; - trap($class,$_) foreach (grep eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference - } -} - -sub trap { - my ($class,$method) = @_; - - return if not $Enabled; - - return if $method eq 'import'; - - no strict 'refs'; - my $prevCode = \&{"${class}::${method}"}; - my $proto = prototype $prevCode; - - if (defined $proto and not $proto) { - return; - } - { - package IMPL::Profiler::Proxy; - no warnings 'redefine'; - my $sub = sub { - my $t0 = [Time::HiRes::gettimeofday]; - my @arr; - my $scalar; - my $entry = $prevCode; - my ($timeOwn,$timeTotal); - my $context = wantarray; - { - local $InvokeTime = 0; - #warn " "x$level,"enter ${class}::$method"; - $level ++; - if ($context) { - @arr = &$entry(@_); - } else { - if (defined $context) { - $scalar = &$entry(@_); - } else { - &$entry(@_); - } - } - $timeTotal = Time::HiRes::tv_interval($t0); - $timeOwn = $timeTotal - $InvokeTime; - } - $InvokeInfo{"${class}::${method}"}{Count} ++; - $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; - $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; - $InvokeTime += $timeTotal; - $level --; - #warn " "x$level,"leave ${class}::$method"; - return $context ? @arr : $scalar; - }; - if ($proto) { - Scalar::Util::set_prototype($sub => $proto); - } - *{"${class}::${method}"} = $sub; - } - -} - -sub PrintStatistics { - my $hout = shift || *STDERR; - print $hout "-- modules --\n"; - print $hout "$_\n" foreach sort keys %TrappedModules; - print $hout "\n-- stats --\n"; - print $hout - pad($_,50), - pad("$InvokeInfo{$_}{Count}",10), - pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10), - pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10), - "\n" - foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo; -} - -sub ResetStatistics { - $InvokeTime = 0; - %InvokeInfo = (); -} - -sub pad { - my ($str,$len) = @_; - if (length $str < $len) { - return $str.(' 'x ($len- length $str)); - } else { - return $str; - } -} -1;
--- a/Lib/IMPL/Profiler/Memory.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,111 +0,0 @@ -package IMPL::Profiler::Memory; - -use strict; -use Carp qw(longmess shortmess); -use Scalar::Util qw(refaddr weaken isweak); - -my %listeners; -my $trapped; - -BEGIN { - $trapped = 0; -} - -sub import { - if (not $trapped) { - *CORE::GLOBAL::bless = sub { - $_[1] |= caller unless $_[1]; - my $ref = CORE::bless $_[0],$_[1]; - - $_->track($ref) foreach values %listeners; - - return $ref; - }; - $trapped = 1; - } -} - -sub _ConnectListener { - my ($self,$listener) = @_; - - die "Invalid listener" unless ref $listener; - - $listeners{refaddr($listener)} = $listener; -} - -sub _RemoveListener { - my ($self,$listener) = @_; - - die "Invalid listener" unless ref $listener; - - delete $listeners{refaddr($listener)}; -} - -sub Monitor { - my ($self,$code) = @_; - - my $data = IMPL::Profiler::Memory::Data->new(); - - $data->Monitor($code); - - return $data; -} - -package IMPL::Profiler::Memory::Data; -use parent qw(IMPL::Object::Fields); - -use Data::Dumper(); -use Scalar::Util qw(refaddr weaken isweak); - -use fields qw( objects counter); - -sub CTOR { - my $this = shift; - $this->{objects} = []; - $this->{counter} = 0; -} - -sub track { - my $i = scalar @{$_[0]->{objects}}; - $_[0]->{objects}[$i] = $_[1]; - weaken($_[0]->{objects}[$i]); - $_[0]->{counter} ++; -} - -sub Purge { - my $this = shift; - - return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; -} - -sub Dump { - my $this = shift; - return Data::Dumper->Dump([$this->{objects}]); -} - -sub isLeak { - my ($this) = @_; - $this->Purge(); - return ( scalar(@{$this->{objects}}) > 0); -} - -sub Monitor { - my ($this,$code) = @_; - - die "A reference to a subroutine is required" unless ref $code; - - IMPL::Profiler::Memory->_ConnectListener($this); - eval { - $code->(); - }; - my $err = $@; - IMPL::Profiler::Memory->_RemoveListener($this); - - die $err if $err; - - return; -} - - - -1;
--- a/Lib/IMPL/Resources.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::Resources; -use strict; - -our $CurrentLocale ||= 'default'; - -sub currentLocale { - $CurrentLocale; -} - -sub SetLocale { - my ($self,$locale) = @_; - - $locale =~ tr/\-/_/; - - $CurrentLocale = $locale; -} - -sub InvokeInLocale { - my ($this,$locale,$code) = @_; - - local $CurrentLocale; - $this->SetLocale($locale); - - &$code() - if $code; -} - -1;
--- a/Lib/IMPL/Resources/Format.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -package IMPL::Resources::Format; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&FormatMessage); - -sub FormatMessage { - my ($string,$args,$resolver) = @_; - - $args ||= {}; - $resolver ||= \&_defaultResolver; - $string ||= ''; - - $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]",$resolver)/ge; - - return $string; -} - -sub _getvalue { - my ($obj,$path,$default,$resolver) = @_; - - foreach my $chunk (split /\./,$path) { - return $default unless $obj; - if (ref $obj eq 'HASH') { - $obj = $obj->{$chunk}; - } else { - $obj = $resolver->($obj,$chunk); - } - } - return $obj||'<undef>'; -} - -sub _defaultResolver { - my ($obj,$prop) = @_; - - return eval { $obj->$prop() }; -} - -1;
--- a/Lib/IMPL/Resources/StringLocaleMap.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,143 +0,0 @@ -package IMPL::Resources::StringLocaleMap; -use strict; - -use List::Util qw(first); -use IMPL::lang qw(:base); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Resources => 'IMPL::Resources', - StringMap => 'IMPL::Resources::StringMap', - Exception => 'IMPL::Exception', - FS => 'File::Spec' - }, - base => { - 'IMPL::Object' => '@_' - }, - props => [ - _maps => PROP_RW, - name => PROP_RW, - paths => PROP_RW | PROP_LIST - ] -}; - -sub CTOR { - my ($this,$data,$parent) = @_; - - if (is($data, StringMap)) { - $this->_maps({ default => $data }); - } elsif ( ref($data) eq 'HASH' ) { - $this->_maps({ default => StringMap->new($data,$parent)}); - } else { - # в данном случае таблица строк по-умолчанию будет загружена - # из файла при необходимости - $this->_maps({}); - } -} - -sub GetString { - my ($this,$id,$args) = @_; - - my $locale = Resources->currentLocale || 'default'; - my $map; - - #warn "id: $id,\t\tlocale: $locale"; - - if(not $map = $this->_maps->{$locale}) { - my $default = $this->GetDefaultMap(); - $map = $this->LoadMap($locale,$default); - if (is($map,StringMap)) { - #nop - } elsif (ref($map) eq 'HASH') { - $map = StringMap->new($map,$default); - } elsif( not $map ) { - $map = $default; - } else { - die Exception->new("ResolveLocale returned unexpected data", $map); - } - - $this->_maps->{$locale} = $map; - } - - return $map->GetString($id,$args); -} - -sub GetDefaultMap { - my ($this) = @_; - - my $map = $this->_maps->{default}; - return $map - if $map; - - $map = $this->LoadMap('default') || StringMap->new({}); - $this->_maps->{default} = $map; - - return $map; -} - -sub LoadMap { - my ($this,$locale,$default) = @_; - - my @spec = split /_/, $locale; - - my @locales; - - do { - push @locales, join('_', @spec); - } while(pop @spec); - - my $file = first { -f } map { - my $path = $_; - - map { - my $name = FS->catfile($path,$_,$this->name); - ("$name.s", "$name.p"); - } @locales; - } $this->paths; - - if($file) { - if ($file =~ /\.s$/) { - return $this->LoadStringMap($file); - } else { - return $this->LoadPerlMap($file,$default); - } - } - - return; -} - -sub LoadPerlMap { - my ($self,$file,$parent) = @_; - - my $data = do $file; - my $e = $@; - die Exception->new("Failed to load file '$file'", $e) if $e; - die IOException->new("Failed to load file '$file'", $!) if not defined $data and $!; - die Exception->new("Failed to load file '$file'", "A hash data is expected") unless ref($data) eq 'HASH'; - - return StringMap->new($data,$parent); -} - -sub LoadStringMap { - my ($this,$fname) = @_; - - open my $hRes, "<:encoding(utf-8)", $fname or die "Failed to open file $fname: $!"; - local $_; - my %map; - my $line = 1; - while (<$hRes>) { - chomp; - $line ++ and next if /^\s*$/; - - if (/^([\w\.]+)\s*=\s*(.*)$/) { - $map{$1} = $2; - } else { - die "Invalid resource format in $fname at $line"; - } - $line ++; - } - - return \%map; -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Resources/StringMap.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -package IMPL::Resources::StringMap; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - IOException => '-IMPL::IOException', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => '@_' - ], - props => [ - _data => PROP_RW, - _parent => PROP_RW - ] -}; - -sub CTOR { - my ($this,$data,$parent) = @_; - - die ArgException->new( data => 'A hash reference is required' ) - unless ref($data) eq 'HASH'; - - die ArgException->new( data => 'A hash must contain either scalars or subs') - if grep ref($_) && ref($_) ne 'CODE', values %$data; - - $this->_data($data); - $this->_parent($parent); -} - -sub GetString { - my ($this,$id,$args) = @_; - - if(my $format = $this->_data->{$id}) { - return ref($format) eq 'CODE' ? &$format($this,$args || {}) : $this->FormatString($format,$args); - } else { - return $this->_parent? $this->_parent->GetString($id,$args) : "[ $id ]"; - } - -} - -sub AddFormat { - my ($this,$id,$format) = @_; - - die ArgException->new( id => 'A format id is required' ) - unless $id; - - die ArgException->new( format => 'A format must be a scalar or a sub' ) - if ref($format) and ref($format) ne 'CODE'; - - $this->_data->{$id} = $format; -} - -sub FormatString { - my ($self,$text,$args) = @_; - - $args ||= {}; - $text ||= ''; - - $text =~ s/%(\w+(?:\.\w+)*)%/$self->GetValue($args,$1,"\[$1\]")/ge; - - return $text; - -} - -sub GetValue { - my ($self,$obj,$path,$default) = @_; - - foreach my $chunk (split /\./,$path) { - return $default unless $obj; - if (ref $obj eq 'HASH') { - $obj = $obj->{$chunk}; - } else { - $obj = $self->Resolve($obj,$chunk); - } - } - return $obj||'<undef>'; -} - -sub Resolve { - my ($self,$obj,$prop) = @_; - - return eval { $obj->$prop() }; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Resources::StringMap> - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - StringMap => 'IMPL::Resources::StringMap' -}; - -my $data = { - TitleLabel => 'Search results', - ViewLabel => 'View %name%', # same as sub { $_[0]->Format('View %name%',$_[1]) } - ResultsCountLabel => sub { - my ($self,$args) = @_; - - $args ||= {}; - - if (not $args->{count}) { - return "No items found"; - } elsif($args->{count} == 1) { - return "Found one item"; - } else { - return $self->Format('Found %count% items', $args); - } - } -} - -my $def = StringMap->new({ - ResultsCountLabel => 'Found %count% items' -}); - -my $map = StringMap->new($data, $def); - -print $map->GetString('TitleLabel'); -print $map->GetString(ResultsCountLabel => { count => 0 }); # will print "No items found" - - -=end code - -=head1 DESCRIPTION - -=head1 MEMBERS - -=cut \ No newline at end of file
--- a/Lib/IMPL/Resources/Strings.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,142 +0,0 @@ -package IMPL::Resources::Strings; -use strict; - -use File::Spec; -use List::Util qw(first); -use IMPL::require { - StringMap => 'IMPL::Resources::StringLocaleMap' -}; - -our @Locations; -my %maps; - -sub import { - my ($self,$refStrings,%options) = @_; - - no strict 'refs'; - - my $class = caller; - my $methods = $options{methods}; - - if (ref $refStrings eq 'HASH') { - my $map = $self->_GetMapForClass($class,$refStrings); - - while(my ($str,$format) = each %$refStrings) { - *{"${class}::$str"} = sub { - shift if $methods; - my $args = @_ == 1 ? shift : { @_ }; - - return $map->GetString($str,$args); - } - } - } -} - -sub _GetResourceLocations { - my ($self,$class) = @_; - - my @classNamespace = split /::/,$class; - - my $classShortName = pop @classNamespace; - - my @paths = map File::Spec->catdir($_,@classNamespace), @Locations; - - # Foo::Bar -> 'Foo/Bar.pm' - my $classModuleName = File::Spec->catfile(@classNamespace,"${classShortName}.pm"); - - # 'Foo/Bar.pm' -> '/full/path/to/Foo/Bar.pm' - my $fullModulePath = first { -f } map( File::Spec->catfile($_,$classModuleName), @INC ); - - if ($fullModulePath) { - - # '/full/path/to/Foo/Bar.pm' -> '/full/path/to/Foo/locale/' - my ($vol,$dir,$file) = File::Spec->splitpath($fullModulePath); - push @paths, File::Spec->catpath($vol,File::Spec->catdir($dir,'locale'),''); - } - - return \@paths, $classShortName; -} - -sub _GetMapForClass { - my ($self,$class,$data) = @_; - - my $map; - - unless ($map) { - - my ($paths,$name) = $self->_GetResourceLocations($class); - - $map = StringMap->new($data); - $map->name($name); - $map->paths($paths); - - $maps{$class} = $map; - - } - - return $map; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Resources::Strings> - Строковые ресурсы - -=head1 SYNOPSIS - -=begin code - -package Foo; - -use IMPL::Resources::Strings { - msg_say_hello => "Hello, %name%!", - msg_module_name => "Simple Foo class" -}; - -sub InviteUser { - my ($this,$uname) = @_; - - print msg_say_hello(name => $uname); - -} - -=end code - -=head1 DESCRIPTION - -Импортирует в целевой модуль функции, которые возвращают локализованные -параметризованные сообщения. - -При импорте ищутся модули по следующему алгоритму: - -В каталогах из массива C<@Locations> ищется файл с относительным путем -C<$Locale/$ModName>, где C<$Locale> - глобальная переменная -модуля C<IMPL::Resourses::Strings>, а переменная C<$ModName> получена -путем замены 'C<::>' в имени целевого модуля на 'C</>'. - -Если файл не был найден, то производится поиск в каталоге, где -расположен сам модуль, файла с относительным путем C<locale/$Locale/$ShortModName>, -где C<$ShortModeName> - последняя часть после 'C<::>' из имени целевого модуля. - -Если файл не найден, то используются строки, указанные при объявлении -сообщений в целевом модуле. - -=head1 FORMAT - -=begin code text - -msg_name = any text with named %params% -msg_hello = hello, %name%!!! -msg_resolve = this is a value of the property: %user.age% - -msg_short_err = %error.Message% -msg_full_err = %error% - -=end code text - -=cut
--- a/Lib/IMPL/SQL/Schema.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,185 +0,0 @@ -use strict; -package IMPL::SQL::Schema; -use mro; - -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 (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'); - - } 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'); - $table = { %$table }; - $table->{'schema'} = $this; - $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; -} - -sub RemoveTable { - my ($this,$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); - - # drop foreign keys - map { $_->table->RemoveConstraint($_) } values %{$table->primaryKey->connectedFK} if $table->primaryKey; - - # drop table contents - $table->Dispose(); - - return 1; -} - -sub ResolveTable { - my ($this,$table) = @_; - - is($table,Table) ? $table : $this->{$_tables}{$table}; -} - -sub GetTable { - my ($this,$tableName) = @_; - return $this->{$_tables}{$tableName}; -} - -sub GetTables { - my ($this) = @_; - - 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}; - - my $table = delete $this->{$_tables}{$oldName}; - $table->_setName($newName); - $this->{$_tables}{$newName} = $table; -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose foreach values %{$this->{$_tables}}; - - delete $this->{$_tables}; - - $this->next::method(); -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -=begin code - -require IMPL::SQL::Schema; -use IMPL::SQL::Types qw(Varchar Integer); - -my $dbSchema = new IMPL::SQL::Schema; - -my $tbl = $dbSchema->AddTable({name => 'Person' }); -$tbl->AddColumn({ - name => 'FirstName', - canBeNull => 1, - type => Varchar(255) -}); -$tbl->AddColumn({ - name => 'Age', - type => Integer -}); - -# so on - -# and finally don't forget to - -$dbSchema->Dispose(); - -=end code - -=head1 DESCRIPTION - -Схема реляциоонной базы данных, орентированная на язык SQL, содержит описания таблиц -которые являются частью базы. Позволяет создавать и удалать таблицы. - -=head1 MEMBERS - -=over - -=item C<CTOR(%props)> - -Конструктор заполняет объект свойствами из C<props>. - -=item C<[get]name> - -Имя схемы. - -=item C<[get]version> - -Версия схемы. - -=item C<AddTable($table)> - -Доавляет таблицу в схему. C<$table> может быть либо таблице, либо хешем с набором -свойств для создания новой таблицы. Если таблица с таким именем уже существует в сехеме, -то вызывается исключение. - -=item C<GetTable($name)> - -Возвращает таблицу с именем C<$name> или C<undef>. - -=item C<GetTables()> - -Возвращает список таблиц. В скалярном контексте - ссылку на массив с таблицами. - -=item C<ResolveTable($table)> - -Если параметр C<$table> - таблица, то возвращается C<$table>, если C<$table> строка, то -ищется таблица с таким именем, если таблица не найдена, возвращается C<undef>. - -=item C<RenameTable($oldName,$newName)> - -Происходит переименование таблицы. Если C<$oldName> не существует, либо если C<$newName> -существует, вызывается исключение. - -=item C<RemoveTable($table)> - -Удаляется таблица C<$table> с удалением всех связей и ограничений. Если такой таблицы нет, -то вызывается исключение. C<$table> может быть либо именем таблицы, либо объектом. - -=back - -=cut
--- a/Lib/IMPL/SQL/Schema/Column.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -use strict; -package IMPL::SQL::Schema::Column; - -use IMPL::lang qw( :DEFAULT :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 - ] -}; - -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}); -} - -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}) - ); -} - -sub SetType { - my ($this,$newType) = @_; - - $this->{$type} = $newType; -} - -sub SetDefaultValue { - my ($this,$value) = @_; - - $this->{$defaultValue} = $value; -} - -sub SetNullable { - 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); -} - -1;
--- a/Lib/IMPL/SQL/Schema/Constraint.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -package IMPL::SQL::Schema::Constraint; -use strict; -use warnings; - -use IMPL::lang; -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; - -sub CTOR { - my ($this,%args) = @_; - is( $args{table}, typeof IMPL::SQL::Schema::Table ) or - die new IMPL::InvalidArgumentException("table argument must be a table object"); - $this->{$name} = $args{'name'}; - $this->{$table} = $args{'table'}; - $this->columns( [map { ResolveColumn($this->table,$_) } @{$args{'columns'}}] ); -} - -sub ResolveColumn { - my ($Table,$Column) = @_; - - my $cn = is($Column,'IMPL::SQL::Schema::Column') ? $Column->name : $Column; - - my $resolved = $Table->GetColumn($cn); - die new IMPL::InvalidOperationException("The column is not found in the table", $cn, $Table->name) if not $resolved; - return $resolved; -} - -sub HasColumn { - my ($this,@Columns) = @_; - - my %Columns = map { $_, 1} @Columns; - - return scalar(grep { $Columns{$_->name} } $this->columns ) == scalar(@Columns); -} - -sub uniqName { - my ($this) = @_; - return $this->{$table}->name.'_'.$this->{$name}; -} - -sub Dispose { - my ($this) = @_; - - $this->columns([]); - - delete $$this{$table}; - - $this->SUPER::Dispose; -} - -sub SameValue { - my ($this,$other) = @_; - - return 0 unless $this->columns->Count == $other->columns->Count; - - for ( my $i=0; $i < $this->columns->Count; $i++ ) { - return 0 unless $this->columns->[$i]->name eq $other->columns->[$i]->name; - } - - return 1; -} - -sub ResolveAlias { - my ($self,$alias) = @_; - - return isclass($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; -} - -sub RegisterAlias { - my ($self,$alias) = @_; - - $aliases{$alias} = typeof($self); -} - -1;
--- a/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -package IMPL::SQL::Schema::Constraint::ForeignKey; -use strict; -use warnings; - -use IMPL::lang qw(:declare is); - -use parent qw(IMPL::SQL::Schema::Constraint); - - -BEGIN { - public _direct property referencedPrimaryKey => PROP_GET; - public _direct property onDelete => PROP_GET; - public _direct property onUpdate => PROP_GET; -} - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('fk'); - -sub CTOR { - my ($this,%args) = @_; - - die new Exception("Referenced table must be an instance of a table object") if not is($args{'referencedTable'},'IMPL::SQL::Schema::Table'); - - die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'referencedColumns'},'ARRAY') or not scalar(@{$args{'referencedColumns'}}); - - my @ReferencedColumns = map {IMPL::SQL::Schema::Constraint::ResolveColumn($args{'referencedTable'},$_)} @{$args{'referencedColumns'}}; - my $ForeingPK = $args{'referencedTable'}->primaryKey or die new Exception('The referenced table doesn\'t have a primary key'); - - scalar (@ReferencedColumns) == $this->columns->Count or die new Exception('A foreing key columns doesn\'t match refenced columns'); - my @ColumnsCopy = @ReferencedColumns; - - die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->type->SameValue((shift @ColumnsCopy)->type)} @{$this->columns}; - - @ColumnsCopy = @ReferencedColumns; - die new Exception('The foreign key must match to the primary key of the referenced table',$this->name) if grep { not $_->type->SameValue(shift(@ColumnsCopy)->type)} @{$ForeingPK->columns}; - - $this->{$referencedPrimaryKey} = $ForeingPK; - - $ForeingPK->ConnectFK($this); - - $this->onUpdate($args{onUpdate}) if $args{onUpdate}; - $this->onDelete($args{onDelete}) if $args{onDelete}; -} - -sub Dispose { - my ($this) = @_; - - $this->{$referencedPrimaryKey}->DisconnectFK($this) if not $this->{$referencedPrimaryKey}->isDisposed; - delete $this->{$referencedPrimaryKey}; - - $this->SUPER::Dispose; -} - -sub SameValue { - my ($this,$other) = @_; - - uc($this->onDelete || '') eq uc($other->onDelete || '')or return 0; - uc($this->onUpdate || '') eq uc($other->onUpdate || '') or return 0; - - return $this->SUPER::SameValue($other); -} - - - -1;
--- a/Lib/IMPL/SQL/Schema/Constraint/Index.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -package IMPL::SQL::Schema::Constraint::Index; -use strict; -use parent qw(IMPL::SQL::Schema::Constraint); - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('index'); - -sub CTOR { - my $this = shift; - - my %colnames; - not grep { $colnames{$_}++ } $this->columns or die new Exception('Each column in the index can occur only once'); -} - -1;
--- a/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package IMPL::SQL::Schema::Constraint::PrimaryKey; -use strict; -use parent qw(IMPL::SQL::Schema::Constraint::Index); -use IMPL::Class::Property; - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('pk'); - -BEGIN { - public _direct property connectedFK => prop_get; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$connectedFK} = {}; -} - -sub ConnectFK { - my ($this,$FK) = @_; - - UNIVERSAL::isa($FK,'IMPL::SQL::Schema::Constraint::ForeignKey') or die new Exception('Aprimary key could be connected only to a foreign key'); - not exists $this->{$connectedFK}->{$FK->uniqName} or die new Exception('This primary key already conneted with the specified foreing key',$FK->name,$FK->table->name); - - $this->{$connectedFK}->{$FK->uniqName} = $FK; -} - -sub DisconnectFK { - my ($this,$FK) = @_; - - delete $this->{$connectedFK}->{$FK->uniqName}; -} - -sub Dispose { - my ($this) = @_; - - delete $this->{$connectedFK}; - - $this->SUPER::Dispose; -} - -1;
--- a/Lib/IMPL/SQL/Schema/Constraint/Unique.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -package IMPL::SQL::Schema::Constraint::Unique; -use strict; -use parent qw(IMPL::SQL::Schema::Constraint::Index); - -__PACKAGE__->PassThroughArgs; -__PACKAGE__->RegisterAlias('unique'); - -1;
--- a/Lib/IMPL/SQL/Schema/Diff.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -package IMPL::SQL::Schema::Diff; -use strict; -use warnings; -use IMPL::lang qw(:compare :hash is typeof); - -use IMPL::SQL::Schema::Traits(); - -use IMPL::require { - Schema => 'IMPL::SQL::Schema', - ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', - PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', - UniqueConstraint =>'-IMPL::SQL::Schema::Constraint::Unique', - Index => '-IMPL::SQL::Schema::Constraint::Index', - TraitsForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', - TraitsPrimaryKey => '-IMPL::SQL::Schema::Traits::PrimaryKey', - TraitsUnique => '-IMPL::SQL::Schema::Traits::Unique', - TraitsIndex => '-IMPL::SQL::Schema::Traits::Index', - TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', - TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', - TraitsTable => '-IMPL::SQL::Schema::Traits::Table', - TraitsColumn => '-IMPL::SQL::Schema::Traits::Column', - TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', - TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', - TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', - TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', - TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn', - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' -}; - -sub Diff { - my ($self,$src,$dst) = @_; - - die ArgException->new( src => "A valid source schema is required") unless is($src,Schema); - die ArgException->new( dst => "A valid desctination schema is requried" ) unless is($src,Schema); - - my %dstTables = map { $_->name, $_ } $dst->GetTables; - - my @operations; - - foreach my $srcTable ( $src->GetTables) { - my $dstTable = delete $dstTables{$srcTable->name}; - - if (not $dstTable) { - # if a source table doesn't have a corresponding destination table, it should be deleted - push @operations, TraitsDropTable->new($srcTable->name); - } else { - # a source table needs to be updated - push @operations, $self->_DiffTables($srcTable,$dstTable); - } - - } - - foreach my $tbl ( values %dstTables ) { - push @operations, TraitsCreateTable->new( - TraitsTable->new( - $tbl->name, - [ map _Column2Traits($_), @{$tbl->columns} ], - [ map _Constraint2Traits($_), $tbl->GetConstraints()], - $tbl->{tag} - ) - ) - } - - return \@operations; -} - -sub _DiffTables { - my ($self,$src,$dst) = @_; - - my @dropConstraints; - my @createConstraints; - - my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); - my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); - - foreach my $cnSrcName (keys %srcConstraints) { - if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { - unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { - push @dropConstraints, - TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); - push @createConstraints, - TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); - } - } else { - push @dropConstraints,TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); - } - } - - foreach my $cnDst (values %dstConstraints) { - push @createConstraints, - TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); - } - - my @deleteColumns; - my @addColumns; - my @updateColumns; - - my %dstColumnIndexes = map { - my $col = $dst->GetColumnAt($_); - ($col->name, { column => $col, index => $_ }) - } 0 .. $dst->ColumnsCount-1; - - my @columns; - - # remove old columns, mark for update changed columns - for( my $i=0; $i < $src->ColumnsCount; $i++) { - my $colSrc = $src->GetColumnAt($i); - - if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { - $infoDst->{prevColumn} = $colSrc; - push @columns,$infoDst; - } else { - push @deleteColumns,TraitsAlterTableDropColumn->new($src->name,$colSrc->name); - } - } - - #insert new columns at specified positions - foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { - splice(@columns,$_->{index},0,$_); - push @addColumns, TraitsAlterTableAddColumn->new($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); - } - - # remember old indexes - for(my $i =0; $i< @columns; $i ++) { - $columns[$i]->{prevIndex} = $i; - } - - # reorder columns - @columns = sort { $a->{index} <=> $b->{index} } @columns; - - foreach my $info (@columns) { - if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { - my $op = TraitsAlterTableChangeColumn->new($src->name,$info->{column}->name); - - $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; - $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); - $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); - - my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); - $op->options($diff) if %$diff; - - push @updateColumns, $op; - } - } - - my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); - - return @result; -} - -sub _Column2Traits { - my ($column,%options) = @_; - - return TraitsColumn->new( - $column->name, - $column->type, - isNullable => $column->isNullable, - defaultValue => $column->defaultValue, - tag => $column->tag, - %options - ); -} - -sub _Constraint2Traits { - my ($constraint) = @_; - - my $map = { - ForeignKey , TraitsForeignKey, - PrimaryKey , TraitsPrimaryKey, - UniqueConstraint , TraitsUnique, - Index , TraitsIndex - }; - - my $class = $map->{typeof($constraint)} or die Exception->new("Can't map the constraint",typeof($constraint)); - - if ($class eq TraitsForeignKey) { - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ], - $constraint->referencedPrimaryKey->table->name, - [ map $_->name, $constraint->referencedPrimaryKey->columns ] - ); - } else { - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ] - ); - } -} - -1;
--- a/Lib/IMPL/SQL/Schema/MySQL/CharType.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -package IMPL::SQL::Schema::MySQL::CharType; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::SQL::Schema::Type' => '@_' - ], - props => [ - encoding => PROP_RO - ] -}; - -my @CHAR_TYPES = qw(VARCHAR CHAR); - -sub CTOR { - my ($this) = @_; - - die ArgException->new(name => "The specified name is invalid", $this->name) - unless grep uc($this->name) eq $_, @CHAR_TYPES; -} - -1; \ No newline at end of file
--- a/Lib/IMPL/SQL/Schema/MySQL/EnumType.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,23 +0,0 @@ -package IMPL::SQL::Schema::MySQL::EnumType; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::SQL::Schema::Type' => '@_' - ], - props => [ - enumValues => PROP_RO | PROP_LIST - ] -}; - -our @ENUM_TYPES = qw(ENUM SET); - -sub CTOR { - my $this = shift; - - die ArgException->new(name => "The specified name is invalid", $this->name) - unless grep uc($this->name) eq $_, @ENUM_TYPES; -} - -1; \ No newline at end of file
--- a/Lib/IMPL/SQL/Schema/MySQL/Formatter.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,561 +0,0 @@ -package IMPL::SQL::Schema::MySQL::Formatter; -use strict; - -use IMPL::lang qw(is); -use IMPL::require { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException', - ArgException => '-IMPL::InvalidArgumentException', - PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', - UniqueIndex => '-IMPL::SQL::Schema::Constraint::Unique', - Index => '-IMPL::SQL::Schema::Constraint::Index', - ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', - CharType => '-IMPL::SQL::Schema::MySQL::CharType', - EnumType => '-IMPL::SQL::Schema::MySQL::EnumType', - TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', - TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', - TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', - TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', - TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', - TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', - TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn' -}; - -our %TRAITS_FORMATS = ( - TraitsDropTable, 'FormatDropTable', - TraitsCreateTable, 'FormatCreateTable', - TraitsAlterTableDropConstraint, 'FormatAlterTableDropConstraint', - TraitsAlterTableAddConstraint, 'FormatAlterTableAddConstraint', - TraitsAlterTableDropColumn, 'FormatAlterTableDropColumn', - TraitsAlterTableAddColumn, 'FormatAlterTableAddColumn', - TraitsAlterTableChangeColumn, 'FormatAlterTableChangeColumn' -); - -sub quote { - my $self = shift; - - if (wantarray) { - return map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; - } - else { - return join '', map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; - } -} - -sub quote_names { - my $self = shift; - - if (wantarray) { - return map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; - } - else { - return join '', map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; - } -} - -sub formatTypeNameInteger { - my ( $self, $type ) = @_; - - return - $type->name - . ( $type->maxLength ? '(' . $type->maxLength . ')' : '' ) - . ( $type->unsigned ? ' UNSIGNED' : '' ) - . ( $type->zerofill ? ' ZEROFILL' : '' ); -} - -sub formatTypeNameReal { - my ( $self, $type ) = @_; - - return $type->name - . ( $type->maxLength - ? '(' . $type->maxLength . ', ' . $type->scale . ')' - : '' ) - . ( $type->unsigned ? ' UNSIGNED' : '' ) - . ( $type->zerofill ? ' ZEROFILL' : '' ); -} - -sub formatTypeNameNumeric { - my ( $self, $type ) = @_; - $type->maxLength - or die ArgException->new( - type => 'The length and precission must be specified', - $type->name - ); - return $type->name - . ( $type->maxLength - ? '(' . $type->maxLength . ', ' . $type->scale . ')' - : '' ) - . ( $type->unsigned ? ' UNSIGNED' : '' ) - . ( $type->zerofill ? ' ZEROFILL' : '' ); -} - -sub formatTypeName { - my ( $self, $type ) = @_; - return $type->name; -} - -sub formatTypeNameChar { - my ( $self, $type ) = @_; - - return ($type->name . '(' - . $type->MaxLength . ')' - . ( is( $type, CharType ) ? $type->encoding : '' ) ); -} - -sub formatTypeNameVarChar { - my ( $self, $type ) = @_; - - return ($type->name . '(' - . $type->maxLength . ')' - . ( is( $type, CharType ) ? $type->encoding : '' ) ); -} - -sub formatTypeNameEnum { - my ( $self, $type ) = @_; - - die ArgException->new( type => 'Invalid enum type' ) - unless is( $type, EnumType ); - return ($type->name . '(' - . join( ',', map { $self->quote($_) } $type->enumValues ) - . ')' ); -} - -sub formatStringValue { - my ( $self, $value ) = @_; - - if ( ref $value eq 'SCALAR' ) { - return $$value; - } - else { - return $self->quote($value); - } -} - -sub formatNumberValue { - my ( $self, $value ) = @_; - - if ( ref $value eq 'SCALAR' ) { - return $$value; - } - else { - $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ - or die ArgException->new( - value => 'The specified value isn\'t a valid number', - $value - ); - return $value; - } -} - -our %TYPES_FORMATS = ( - TINYINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - SMALLINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - MEDIUMINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INTEGER => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - BIGINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - REAL => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DOUBLE => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - FLOAT => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DECIMAL => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - NUMERIC => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - DATE => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIMESTAMP => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - DATETIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - CHAR => { - formatType => \&formatTypeNameChar, - formatValue => \&formatStringValue - }, - VARCHAR => { - formatType => \&formatTypeNameVarChar, - formatValue => \&formatStringValue - }, - TINYBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - BLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TINYTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - ENUM => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - }, - SET => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - } -); - -sub FormatTypeName { - my ( $self, $type ) = @_; - - my $fn = $TYPES_FORMATS{ $type->name }{formatType} - or die ArgException->new( type => "The specified type is unknown", - $type->name ); - - return $self->$fn($type); -} - -sub FormatValue { - my ( $self, $value, $type ) = @_; - - my $fn = $TYPES_FORMATS{ $type->name }{formatValue} - or die ArgException->new( type => "The specified type is unknown", - $type->name ); - - return $self->$fn( $value, $type ); -} - -sub FormatColumn { - my ( $self, $column ) = @_; - - my @parts = ( - $self->quote_names( $column->{name} ), - $self->FormatTypeName( $column->{type} ), - $column->{isNullable} ? 'NULL' : 'NOT NULL' - ); - - push @parts, $self->FormatValue( $column->{defaultValue}, $column->{type} ) - if $column->{defaultValue}; - - push @parts, 'AUTO_INCREMENT' - if $column->{tag} and $column->{tag}->{auto_increment}; - - return join ' ', @parts; -} - -sub FormatCreateTable { - my ( $self, $op ) = @_; - - my $table = $op->table; - - my @lines; - my @body; - - push @lines, "CREATE TABLE " . $self->quote_names($table->{name}) . "("; - - push @body, map { " " . $self->FormatColumn($_) } @{ $table->{columns} } - if $table->{columns}; - - push @body, map { " " . $self->FormatConstraint($_) } @{ $table->{constraints} } - if $table->{constraints}; - - push @lines, join(",\n", @body); - - push @lines, ");"; - - return join "\n", @lines; -} - -sub FormatDropTable { - my ( $self, $op ) = @_; - - return join ' ', 'DROP TABLE', $self->quote_names( $op->tableName ), ';'; -} - -sub FormatRenameTable { - my ( $self, $op ) = @_; - - return join ' ', - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'RENAME TO', - $self->quote_names( $op->tableNewName ), - ';'; -} - -sub FormatAlterTableAddColumn { - my ( $self, $op, $schema ) = @_; - - my @parts = ( - 'ALTER TABLE',$self->quote_names($op->tableName), 'ADD COLUMN', - $self->FormatColumn( $op->column ) - ); - - if ( defined $op->position ) { - - # mysql supports column reordering - # the new location is specified relative to the previous column - # to determine the name of the previous column we need to ask the schema - - my $table = $schema->GetTable( $op->tableName ); - - if ( $op->position == 0 ) { - push @parts, 'FIRST'; - } - else { - push @parts, 'AFTER'; - - my $prevColumn = $table->GetColumnAt( $op->position - 1 ); - push @parts, $self->quote_names( $prevColumn->{name} ); - } - } - - push @parts, ';'; - - return join ' ', @parts; -} - -sub FormatAlterTableDropColumn { - my ( $self, $op ) = @_; - - return join ' ', - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'DROP COLUMN', - $self->quote_names( $op->columnName ), - ';'; -} - -sub FormatAlterTableChangeColumn { - my ( $self, $op, $schema ) = @_; - - my $table = $schema->GetTable( $op->tableName ); - my $column = $table->GetColumn( $op->columnName ); - - my @parts = ( - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'MODIFY COLUMN', - $self->quote_names( $op->columnName ), - $self->FormatColumn( $self->_Column2Traits($column) ) - ); - - if ( defined $op->position ) { - - # mysql supports column reordering - # the new location is specified relative to the previous column - # to determine the name of the previous column we need to ask the schema - - if ( $op->position == 0 ) { - push @parts, 'FIRST'; - } - else { - push @parts, 'AFTER'; - - my $prevColumn = $table->GetColumnAt( $op->position - 1 ); - push @parts, $self->quote_names( $prevColumn->{name} ); - } - } - - push @parts, ';'; - return join ' ', @parts; -} - -sub FormatConstraint { - my ($self,$constraint) = @_; - - my @fkRules = - ( 'RESTRICT', 'CASCADE', 'SET NULL', 'SET DEFAULT', 'NO ACTION' ); - - my @parts; - - if ( $constraint->constraintClass eq ForeignKey ) { - push @parts, - 'CONSTRAINT', - $self->quote_names( $constraint->{name} ), - 'FOREIGN KEY', - $self->quote_names( $constraint->{name} ), - '(', - join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), - ')', - 'REFERENCES', $self->quote_names( $constraint->{foreignTable} ), '(', - join( ', ', - $self->quote_names( @{ $constraint->{foreignColumns} || [] } ) ), - ')'; - - if ( my $rule = $constraint->{onDelete} ) { - $rule = uc($rule); - grep $_ eq $rule, @fkRules - or die Exception->new( "Invalid onDelete rule specified", - $constraint->{name}, $rule ); - - push @parts, 'ON DELETE', $rule; - } - - if ( my $rule = $constraint->{onUpdate} ) { - $rule = uc($rule); - grep $_ eq $rule, @fkRules - or die Exception->new( "Invalid onUpdate rule specified", - $constraint->{name}, $rule ); - - push @parts, 'ON UPDATE', $rule; - } - - } - else { - if ( $constraint->constraintClass eq PrimaryKey ) { - push @parts, 'PRIMARY KEY'; - - } - elsif ( $constraint->constraintClass eq UniqueIndex ) { - push @parts, 'UNIQUE', $self->quote_names( $constraint->{name} ); - } - elsif ( $constraint->constraintClass eq Index ) { - push @parts, 'INDEX', $self->quote_names( $constraint->{name} ); - } - else { - die Exception->new( 'Invalid constraint type', - $constraint->constraintClass ); - } - - push @parts, - '(', - join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), - ')'; - } - - - return join ' ', @parts; -} - -sub FormatAlterTableAddConstraint { - my ( $self, $op ) = @_; - - return join(' ', - 'ALTER TABLE', - $self->quote_names( $op->tableName ), - 'ADD', - $self->FormatConstraint($op->constraint), - ';' - ); -} - -sub FormatAlterTableDropConstraint { - my ( $self, $op, $constraintType ) = @_; - - my @parts = ( 'ALTER TABLE', $self->quote_names( $op->tableName ), 'DROP' ); - - if ( $constraintType eq PrimaryKey ) { - push @parts, 'PRIMARY KEY'; - } - elsif ( $constraintType eq ForeignKey ) { - push @parts, 'FOREIGN KEY', $self->quote_names( $op->constraintName ); - } - elsif ( $constraintType eq UniqueIndex or $constraintType eq Index ) { - push @parts, 'INDEX', $self->quote_names( $op->constraintName ); - } - else { - die Exception->new( - 'Invalid constraint type', $op->tableName, - $op->constraintName, $constraintType - ); - } - - push @parts, ';'; - - return join ' ', @parts; -} - -sub Format { - my $self = shift; - my ($op) = @_; - - my $formatter = $TRAITS_FORMATS{ref $op} - or die OpException->new("Don't know how to format the specified operation", $op); - - $self->$formatter(@_); -} - -sub _Column2Traits { - my ( $self, $column, %options ) = @_; - - return new IMPL::SQL::Schema::Traits::Column( - $column->name, - $column->type, - isNullable => $column->isNullable, - defaultValue => $column->defaultValue, - tag => $column->tag, - %options - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::SQL::Traits::MysqlFormatter> - преобразует операции над схемой в C<SQL> -выражения. - -=head1 DESCRIPTION - -Используется для форматирования операций изменения схемы БД. Осуществляет -правильное экранирование имен, форматирование значений, имен типов данных. - -=cut
--- a/Lib/IMPL/SQL/Schema/MySQL/Processor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,150 +0,0 @@ -package IMPL::SQL::Schema::MySQL::Processor; -use strict; - -use mro; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - MySQLFormatter => 'IMPL::SQL::Schema::MySQL::Formatter', - AlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', - AlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', - DropTable => '-IMPL::SQL::Schema::Traits::DropTable', - PrimitiveDropTable => '-IMPL::SQL::Schema::MySQL::Processor::PrimitiveDropTable', - CreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', - Table => '-IMPL::SQL::Schema::Traits::Table', - ForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', - - }, - base => [ - 'IMPL::SQL::Schema::Processor' => sub { $_[0] } - ], - props => [ - formatter => PROP_RO, - sqlBatch => PROP_RO - ] -}; -use IMPL::lang qw(is); - -sub CTOR { - my ( $this, $schema, %opts ) = @_; - - $this->formatter( $opts{formatter} || MySQLFormatter ); - $this->sqlBatch([]); -} - -sub AddSqlBatch { - my $this = shift; - - push @{$this->sqlBatch}, @_; -} - -sub ApplyOperation { - my ($this, $op, $iteration ) = @_; - - my @formatterParams; - - if ( is( $op, AlterTableDropConstraint ) ) { - my $constraint = $this - ->dbSchema - ->GetTable($op->tableName) - ->GetConstraint($op->constraintName); - - push @formatterParams, ref $constraint; - } else { - push @formatterParams, $this->dbSchema; - } - - if ( is( $op, CreateTable ) ) { - my @constraints; - my @fk; - my $table = $op->table; - - # отделяем создание внешних ключей от таблиц - - foreach my $c (@{$table->{constraints} || []}) { - if ( is($c,ForeignKey)) { - push @fk,$c; - } else { - push @constraints, $c; - } - } - - if (@fk) { - $op = CreateTable->new( - Table->new( - $table->{name}, - $table->{columns}, - \@constraints, - $table->{options} - ) - ); - - $this->AddPendingOperations( - map AlterTableAddConstraint->new($table->{name},$_), @fk - ); - } - } - - if (is($op, DropTable)) { - my $table = $this->dbSchema->GetTable($op->tableName); - - if(my $pk = $table->primaryKey) { - $this->ApplyOperation($_,$iteration) - foreach - map - AlterTableDropConstraint->new($_->table->name,$_->name), - values %{$pk->connectedFK || {}}; - } - } - - $this->next::method($op,$iteration); - - $this->AddSqlBatch( - $this->formatter->Format($op,@formatterParams) - ); -} - -package IMPL::SQL::Schema::MySQL::Processor::PrimitiveDropTable; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - tableName => PROP_RO, - ] -}; - -sub CTOR { - my ($this,$tableName) = @_; - - $this->tableName($tableName) or die ArgException->new("tableName is required"); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable( $this->tableName ) - or return 0; - - my $pk = $table->primaryKey - or return 1; - - my $canDrop = keys(%{$pk->connectedFK || {}}) ? 0 : 1; - - warn "Can drop ", $this->tableName - if $canDrop; - - return $canDrop; -} - -sub Apply { - my ($this,$schema) = @_; - - $schema->RemoveTable($this->tableName); -} - -1;
--- a/Lib/IMPL/SQL/Schema/Processor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -package IMPL::SQL::Schema::Processor; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - dbSchema => PROP_RO, - updateBatch => PROP_RO, - pendingOperations => PROP_RO - ] -}; - -sub CTOR { - my ($this,$schema) = @_; - - $this->dbSchema($schema) - or die ArgException->new(schema => 'A DB schema is required'); - - $this->updateBatch([]); - $this->pendingOperations([]); -} - -sub AddUpdateBatch { - my $this = shift; - - push @{$this->updateBatch}, @_; -} - -sub AddPendingOperations { - my $this = shift; - - push @{$this->pendingOperations}, @_; -} - -sub ProcessBatch { - my ($this,$batch) = @_; - - $this->pendingOperations($batch); - my $i = 1; - while(@{$this->pendingOperations}) { - $batch = $this->pendingOperations; - $this->pendingOperations([]); - - my $noChanges = 1; - - foreach my $op (@$batch) { - if ($this->CanApplyOperation($op,$i)) { - $noChanges = 0; - - $this->ApplyOperation($op,$i); - } else { - $this->AddPendingOperations($op); - } - } - - if ($noChanges && @{$this->pendingOperations}) { - die Exception->new("No changes were made (iteration $i), but some operations are pending",@{$this->pendingOperations}); - } - - $i++; - } -} - -sub CanApplyOperation { - my ($this,$op) = @_; - - return $op->CanApply($this->dbSchema); -} - -sub ApplyOperation { - my ($this,$op) = @_; - - $op->Apply($this->dbSchema); - $this->AddUpdateBatch($op); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Позволяет применит набор примитивных операций C<IMPL::SQL::Schema::Traits> к -схеме. - -=cut \ No newline at end of file
--- a/Lib/IMPL/SQL/Schema/Table.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,273 +0,0 @@ -package IMPL::SQL::Schema::Table; -use strict; - -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; - -sub CTOR { - my ($this,%args) = @_; - - $this->{$name} = $args{'name'} or die new IMPL::InvalidArgumentException('a table name is required'); - $this->{$schema} = $args{'schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); - - if ($args{columns}) { - die new IMPL::InvalidOperationException('A columns property should be a reference to an array') unless ref $args{columns} eq 'ARRAY'; - - $this->InsertColumn($_) foreach @{$args{columns}}; - } -} - -sub InsertColumn { - my ($this,$column,$index) = @_; - - $index = ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0) if not defined $index; - - die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0)); - - if (UNIVERSAL::isa($column,'IMPL::SQL::Schema::Column')) { - - } elsif (UNIVERSAL::isa($column,'HASH')) { - $column = new IMPL::SQL::Schema::Column(%{$column}); - } else { - die new IMPL::InvalidArgumentException("The invalid column parameter"); - } - - if (exists $this->{$columnsByName}->{$column->name}) { - die new IMPL::InvalidOperationException("The column already exists",$column->name); - } else { - $this->{$columnsByName}->{$column->name} = $column; - splice @{$this->{$columns}},$index,0,$column; - } - - return $column; -} - -sub RemoveColumn { - my ($this,$NameOrColumn,$Force) = @_; - - my $ColName; - if (UNIVERSAL::isa($NameOrColumn,'IMPL::SQL::Schema::Column')) { - $ColName = $NameOrColumn->name; - } elsif (not ref $NameOrColumn) { - $ColName = $NameOrColumn; - } - - if (exists $this->{$columnsByName}->{$ColName}) { - my $index = 0; - foreach my $column(@{$this->{$columns}}) { - last if $column->name eq $ColName; - $index++; - } - - my $column = $this->{$columns}[$index]; - if (my @constraints = $this->GetColumnConstraints($column)){ - $Force or die new IMPL::InvalidOperationException('Can\'t remove column which is used in the constraints',@constraints); - $this->RemoveConstraint($_) foreach @constraints; - } - - my $removed = splice @{$this->{$columns}},$index,1; - delete $this->{$columnsByName}->{$ColName}; - return $removed; - } else { - die new IMPL::InvalidOperationException("The column not found",$NameOrColumn->name); - } -} - -sub GetColumn { - my ($this,$name) = @_; - - return $this->{$columnsByName}->{$name}; -} - -sub GetColumnAt { - my ($this,$index) = @_; - - die new IMPL::InvalidArgumentException("The index is out of range") - if $index < 0 || $index >= ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0); - - return $this->{$columns}[$index]; -} - -sub SetColumnPosition { - my ($this,$nameOrColumn,$pos) = @_; - - my $colName; - if (is($nameOrColumn,'IMPL::SQL::Schema::Column')) { - $colName = $nameOrColumn->name; - } elsif (not ref $nameOrColumn) { - $colName = $nameOrColumn; - } else { - die IMPL::InvalidArgumentException->new(column => 'The specified column isn\'t found in the table'); - } - - die IMPL::InvalidArgumentException->new( 'pos' => 'The specified position is invalid') - if not defined $pos || $pos < 0 || $pos >= $this->columnsCount; - - my $index = 0; - foreach my $column(@{$this->{$columns}}) { - last if $column->name eq $colName; - $index++; - } - - if ($pos != $index) { - #position needs to be changed; - - my ($column) = splice @{$this->{$columns}}, $index, 1; - splice @{$this->{$columns}}, $pos, 0, $column; - } - - return; -} - -sub columnsCount { - my ($this) = @_; - - return scalar(@{$this->{$columns}}); -} - -sub ColumnsCount { - goto &columnsCount; -} - -sub AddConstraint { - my $this = shift; - if (@_ == 1) { - my ($Constraint) = @_; - - die new IMPL::InvalidArgumentException('The invalid parameter') if not is($Constraint,'IMPL::SQL::Schema::Constraint'); - - $Constraint->table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); - - if (exists $this->{$constraints}->{$Constraint->name}) { - die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->name); - } else { - if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not $this->{$primaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); - $this->{$primaryKey} = $Constraint; - } - - $this->{$constraints}->{$Constraint->name} = $Constraint; - } - } elsif( @_ == 2) { - my ($type,$params) = @_; - - $type = IMPL::SQL::Schema::Constraint->ResolveAlias($type) or - die new IMPL::Exception("Can't resolve a constraint alias",$_[0]); - - $params = {%{$params}}; - - $params->{table} = $this; - - $this->AddConstraint($type->new(%$params)); - } else { - die new IMPL::Exception("Wrong arguments number",scalar(@_)); - } -} - -sub RemoveConstraint { - my ($this,$Constraint,$Force) = @_; - - my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->name : $Constraint; - $Constraint = $this->{$constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); - - if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not scalar keys %{$this->{$primaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('Can\'t remove Primary Key unless some foreign keys referenses it'); - - delete $this->{$primaryKey}; - } - $Constraint->Dispose; - delete $this->{$constraints}->{$cn}; - return $cn; -} - -sub GetConstraint { - my ($this,$name) = @_; - - return $this->{$constraints}{$name}; -} - -sub GetConstraints { - my ($this) = @_; - - return wantarray ? values %{$this->{$constraints}} : [values %{$this->{$constraints}}]; -} - -sub GetColumnConstraints { - my ($this,@Columns) = @_; - - my @cn = map { UNIVERSAL::isa($_ ,'IMPL::SQL::Schema::Column') ? $_ ->name : $_ } @Columns; - exists $this->{$columnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; - - return grep {$_->HasColumn(@cn)} values %{$this->{$constraints}}; -} - -sub SetPrimaryKey { - my ($this,@ColumnList) = @_; - - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(name => $this->{$name}.'_PK', table => $this, columns => \@ColumnList)); -} - -sub LinkTo { - my ($this,$table,@ColumnList) = @_; - $table->primaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); - my $constraintName = $this->{$name}.'_'.$table->name.'_FK_'.join('_',map {ref $_ ? $_->name : $_} @ColumnList); - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(name => $constraintName, table => $this, columns => \@ColumnList, referencedTable => $table, referencedColumns => $table->primaryKey->columns->as_list)); -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose() foreach values %{$this->{$constraints}}; - - undef %{$this}; - $this->SUPER::Dispose(); -} - -sub SameValue { - my ($this,$other) = @_; - - return 0 unless is($other, typeof($this)); - - return 0 unless $this->name eq $other->name; - return 0 unless $this->ColumnsCount eq $other->ColumnsCount; - - for (my $i = 0; $i < $this->ColumsCount; $i ++) { - return 0 unless $this->($i)->SameValue($other->GetColumnAt($i)); - } - - my %thisConstraints = map { $_->name, $_ } $this->GetConstraints(); - my %otherConstraints = map { $_->name, $_ } $other->GetConstraints(); - - foreach my $name ( keys %thisConstraints ) { - return 0 unless $otherConstraints{$name}; - return 0 unless $thisConstraints{$name}->SameValue(delete $otherConstraints{$name}); - } - - return 0 if %otherConstraints; - - return 1; -} - -1; - -
--- a/Lib/IMPL/SQL/Schema/Traits.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,742 +0,0 @@ -package IMPL::SQL::Schema::Traits; -use strict; -use IMPL::_core::version; -use IMPL::Exception(); - -use parent qw(IMPL::Object); - -# required for use with typeof operator -use IMPL::SQL::Schema::Constraint::PrimaryKey(); -use IMPL::SQL::Schema::Constraint::Index(); -use IMPL::SQL::Schema::Constraint::Unique(); -use IMPL::SQL::Schema::Constraint::ForeignKey(); - -################################################### - -package IMPL::SQL::Schema::Traits::Table; -use base qw(IMPL::Object::Fields); - -use fields qw( - name - columns - constraints - options -); - -sub CTOR { - my ($this,$table,$columns,$constraints,$options) = @_; - - $this->{name} = $table or die new IMPL::InvalidArgumentException(table => "A table name is required"); - $this->{columns} = $columns if defined $columns; - $this->{constraints} = $constraints if defined $constraints; - $this->{options} = $options if defined $options; -} - -################################################### - -package IMPL::SQL::Schema::Traits::Column; -use base qw(IMPL::Object::Fields); - -use fields qw( - name - type - isNullable - defaultValue - tag -); - -sub CTOR { - my ($this, $name, $type, %args) = @_; - - $this->{name} = $name or die new IMPL::InvalidArgumentException("name"); - $this->{type} = $type or die new IMPL::InvalidArgumentException("type"); - $this->{isNullable} = $args{isNullable} if exists $args{isNullable}; - $this->{defaultValue} = $args{defaultValue} if exists $args{defaultValue}; - $this->{tag} = $args{tag} if exists $args{tag}; -} - -################################################## - -package IMPL::SQL::Schema::Traits::Constraint; -use base qw(IMPL::Object::Fields); - -use fields qw( - name - columns -); - -sub CTOR { - my ($this, $name, $columns) = @_; - - $this->{name} = $name; - $this->{columns} = $columns; # list of columnNames -} - -sub constraintClass { - die new IMPL::NotImplementedException(); -} - -################################################## - -package IMPL::SQL::Schema::Traits::PrimaryKey; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); - -__PACKAGE__->PassThroughArgs; - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::PrimaryKey }; - -################################################## - -package IMPL::SQL::Schema::Traits::Index; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); - -__PACKAGE__->PassThroughArgs; - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::Index }; - -################################################## - -package IMPL::SQL::Schema::Traits::Unique; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); - -__PACKAGE__->PassThroughArgs; - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::Unique }; - -################################################## - -package IMPL::SQL::Schema::Traits::ForeignKey; - -use base qw(IMPL::SQL::Schema::Traits::Constraint); -use fields qw( - foreignTable - foreignColumns - onUpdate - onDelete -); - -use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::ForeignKey }; - -our %CTOR = ( - 'IMPL::SQL::Schema::Traits::Constraint' => sub { @_[0..1] } -); - -sub CTOR { - my ($this,$foreignTable,$foreignColumns,%args) = @_[0,3..$#_]; - - $this->{foreignTable} = $foreignTable; - $this->{foreignColumns} = $foreignColumns; - - $this->{onDelete} = $args{onDelete} if $args{onDelete}; - $this->{onUpdate} = $args{onUpdate} if $args{onUpdate}; -} - - -################################################## - -package IMPL::SQL::Schema::Traits::CreateTable; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Table => '-IMPL::SQL::Schema::Traits::Table', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - table => PROP_RO, - ] -}; -use IMPL::lang; - -sub CTOR { - my ($this,$table) = @_; - - die ArgException->new("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") - unless is($table, Table); - - $this->table($table); -} - -sub CanApply { - my ($this,$schema) = @_; - - return( $schema->GetTable( $this->table->{name} ) ? 0 : 1 ); -} - -sub Apply { - my ($this,$schema) = @_; - - my $args = {%{$this->table}}; - - my $constraints = delete $args->{constraints} || []; - - my $table = $schema->AddTable($args); - - $table->AddConstraint($_->constraintClass, $_) foreach @{$constraints}; -} - -################################################## - -package IMPL::SQL::Schema::Traits::DropTable; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - ] -}; - -sub CTOR { - my ($this,$tableName) = @_; - - $this->tableName($tableName) or die ArgException->new("tableName is required"); -} - -sub CanApply { - my ($this,$schema) = @_; - - return $schema->GetTable( $this->tableName ) ? 1 : 0; -} - -sub Apply { - my ($this,$schema) = @_; - - $schema->RemoveTable($this->tableName); -} - -################################################## - -package IMPL::SQL::Schema::Traits::RenameTable; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - tableNewName => PROP_RO, - ] -}; - -sub CTOR { - my ($this, $oldName, $newName) = @_; - - $this->tableName($oldName) or die ArgException->new("A table name is required"); - $this->tableNewName($newName) or die ArgException->new("A new table name is required"); -} - -sub CanApply { - my ($this, $schema) = @_; - - return ($schema->GetTable($this->tableName) and not $schema->GetTable($this->tableNewName) ? 1 : 0 ); -} - -sub Apply { - my ($this,$schema) = @_; - - $schema->RenameTable($this->tableName, $this->tableNewName); - -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableAddColumn; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Column => '-IMPL::SQL::Schema::Traits::Column', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - column => PROP_RO, - position => PROP_RO - ] -}; -use IMPL::lang; - - -sub CTOR { - my ($this,$tableName,$column) = @_; - - $this->tableName($tableName) or die ArgException->new("A table name is required"); - - die ArgException->new("A column should be a IMPL::SQL::Schema::Traits::Column object") - unless is($column, Column); - - $this->column($column); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - return $table->GetColumn( $this->column->{name} ) ? 0 : 1; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die OpException->new("The specified table doesn't exists", $this->tableName); - - if ($this->position) { - $table->AddColumn($this->column); - } else { - $table->InsertColumn($this->column,$this->position); - } -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableDropColumn; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - FK => '-IMPL::SQL::Schema::Constraint::ForeignKey', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - columnName => PROP_RO, - ] -}; -use IMPL::lang; - - -sub CTOR { - my ($this,$table,$column) = @_; - - $this->tableName($table) or die ArgException->new(tableName => "A table name should be specified"); - $this->columnName($column) or die ArgException->new(columnName => "A column name should be specified"); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - $table->GetColumn($this->columnName) or - return 0; - - # столбец - return $table->GetColumnConstraints($this->columnName) - ? 0 - : 1 - ; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die OpException->new("The specified table doesn't exists", $this->tableName); - - $table->RemoveColumn($this->columnName); -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableChangeColumn; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Constraint => '-IMPL::SQL::Schema::Traits::Constraint', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - columnName => PROP_RO, - columnType => PROP_RW, - defaultValue => PROP_RW, - isNullable => PROP_RW, - position => PROP_RW, - options => PROP_RW # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) - ] -}; -use IMPL::lang; - -sub CTOR { - my ($this, $table,$column,%args) = @_; - - $this->tableName($table) or die ArgException->new(tableName => "A table name is required"); - $this->columnName($column) or die ArgException->new(columnName => "A column name is required"); - - $this->$_($args{$_}) - for (grep exists $args{$_}, qw(columnType defaultValue isNullable options)); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - return $table->GetColumn($this->columnName) ? 1 : 0; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die OpException->new("The specified table doesn't exists", $this->tableName); - - my $column = $table->GetColumn($this->columnName) - or die OpException->new("The specified column doesn't exists", $this->tableName, $this->columnName); - - $column->SetType($this->columnType) if defined $this->columnType; - $column->SetNullable($this->isNullable) if defined $this->isNullable; - $column->SetDefaultValue($this->defaultValue) if defined $this->defaultValue; - $column->SetOptions($this->options) if defined $this->options; - - $table->SetColumnPosition($this->position) - if ($this->position); - -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableAddConstraint; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Constraint => '-IMPL::SQL::Schema::Traits::Constraint', - ArgException => '-IMPL::InvalidArgumentException', - FK => '-IMPL::SQL::Schema::Traits::ForeignKey' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - constraint => PROP_RO - ] -}; -use IMPL::lang; - -sub CTOR { - my ($this,$table,$constraint) = @_; - - $this->tableName($table) or die ArgException->new( tableName => "A table name is required"); - - die ArgException->new(constaraint => "A valid " . Constraint . " is required") - unless is($constraint, Constraint); - - $this->constraint($constraint); -} - -sub CanApply { - my ($this, $schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - my $constraint = $this->constraint; - - my @columns = map $table->GetColumn($_), @{$constraint->{columns} || []}; - - # проверяем, что в таблице есть все столбцы для создания ограничения - return 0 if grep not($_), @columns; - - if (is($constraint,FK)) { - my $foreignTable = $schema->GetTable($constraint->{foreignTable}) - or return 0; - - my @foreignColumns = map $foreignTable->GetColumn($_), @{$constraint->{foreignColumns}||[]}; - - # внешняя таблица имеет нужные столбцы - return 0 - if grep not($_), @foreignColumns; - - # типы столбцов во внешней таблице совпадают с типами столбцов ограничения - return 0 - if grep not($columns[$_]->type->SameValue($foreignColumns[$_]->type)), (0 .. $#columns); - } - - return 1; -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); - - my $constraint = $this->constraint; - - if (is($constraint,FK)) { - my $args = { %$constraint }; - $args->{referencedTable} = $schema->GetTable(delete $args->{foreignTable}); - $args->{referencedColumns} = delete $args->{foreignColumns}; - $table->AddConstraint($constraint->constraintClass, $args); - } else { - $table->AddConstraint($constraint->constraintClass, $constraint); - } - -} - -################################################# - -package IMPL::SQL::Schema::Traits::AlterTableDropConstraint; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - PK => '-IMPL::SQL::Schema::Constraint::PrimaryKey' - }, - base => [ - '-IMPL::SQL::Schema::Traits' => undef - ], - props => [ - tableName => PROP_RO, - constraintName => PROP_RO - ] -}; -use IMPL::lang qw(is); - -sub CTOR { - my ($this,$table,$constraint) = @_; - - die new IMPL::InvalidArgumentException( tableName => "A table name is required" ) unless $table; - die new IMPL::InvalidArgumentException( constraintName => "A constraint name is required" ) unless $constraint; - - $this->tableName($table); - $this->constraintName($constraint); -} - -sub CanApply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or return 0; - - my $constraint = $table->GetConstraint($this->constraintName) - or return 0; - - # есть ли внешние ключи на данную таблицу - return ( - is($constraint,PK) - && values( %{$constraint->connectedFK || {}} ) - ? 0 - : 1 - ); -} - -sub Apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) - or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); - - $table->RemoveConstraint($this->constraintName); -} - - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::SQL::Traits> - Операции над объектками SQL схемы. - -=head1 DESCRIPTION - -Изменения схемы могу быть представлены в виде последовательности примитивных операций. -Правила выполнения последовательности примитывных действий могут варьироваться -в зависимости от процессора, который их выполняет. Например C<IMPL::SQL::Schema::Traits::Processor>. - -Данные, которые содержаться в примитивных операциях не могут существовать независимо от схемы. - -=head1 OPERATIONS - -=head2 General - -Методы обще для всех примитивных операций. - -=head3 C<CanApply($schema)> - -Определяет возможность применения операции к указанной схеме. - -Возвращаемое значение: - -=over - -=item C<true> - -Операция приминима к схеме. - -=item C<false> - -Операция не может быть применена к схеме. - -=back - -=head3 C<Apply($schema)> - -Применяет операцию к указанной схеме. - -=head2 Primitive operations - -=head3 C<IMPL::SQL::Schema::Traits::CreateTable> - -Создает таблицу - -=head4 C<CTOR($table)> - -=head4 C<[get]table> - -C<IMPL::SQL::Schema::Traits::Table> - описание создаваемой таблицы - -=head3 C<IMPL::SQL::Schema::Traits::DropTable> - -Удалает таблицу по имени - -=head4 C<CTOR($tableName)> - -=head4 C<[get]tableName> - -Имя удаляемой таблицы - -=head3 C<IMPL::SQL::Schema::Traits::RenameTable> - -=head4 C<CTOR($tableName,$tableNewName)> - -=head4 C<[get]tableName> - -Имя таблицы, которую требуется переименовать - -=head4 C<[get]tableNewName> - -Новое имя таблицы - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableAddColumn> - -Добавляет столбец в таблицу - -=head4 C<CTOR($tableName,$column,$position)> - -=head4 C<[get]tableName> - -Имя таблицы в которую нужно добавить столбец - -=head4 C<[get]column> - -C<IMPL::SQL::Schema::Traits::Column> - описание столбца который нужно добавить - -=head4 C<[get]position> - -Позиция на которую нужно вставить столбец - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableDropColumn> - -Удаляет столбец из таблицы - -=head4 C<CTOR($tableName,$columnName)> - -=head4 C<[get]tableName> - -Имя таблицы в которой нужно удалить столбец - -=head4 C<[get]columnName> - -Имя столбца для удаления - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableChangeColumn> - -Меняет описание столбца - -=head4 C<CTOR($tableName,$columnName,%args)> - -C<%args> - хеш, ключами которого являются оставшиеся свойства создаваемого объекта. - -=head4 C<[get]tableName> - -Имя таблицы в которой находится столбец. - -=head4 C<[get]columnName> - -Имя столбца для изменения - -=head4 C<[get]columnType> - -Новый тип столбца. Не задан, если тип не меняется - -=head4 C<[get]defaultValue> - -Значение по умолчанию. Не задано, если не меняется - -=head4 C<[get]isNullable> - -Может ли столбец содержать C<NULL>. Не задано, если не меняется. - -=head4 C<[get]options> - -Хеш опций, не задан, если опции не меняются. Данный хеш содержит разничу между -старыми и новыми значениями свойства C<tag> столбца. - - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableAddConstraint> - -Базовый класс для операций по добавлению ограничений - -=head4 C<CTOR($tableName,$constraint)> - -=head4 C<[get]tableName> - -Имя таблицы в которую добавляется ограничение. - -=head4 C<[get]constraint> - -C<IMPL::SQL::Schema::Traits::Constraint> - описние ограничения, которое нужно добавить. - -=head3 C<IMPL::SQL::Schema::Traits::AlterTableDropConstraint> - -Удаляет ограничение на таблицу - -=head4 C<CTOR($tableName,$constraintName)> - -=head4 C<[get]tableName> - -Имя таблицы в которой требуется удалить ограничение. - -=head4 C<[get]constraintName> - -Имя ограничения для удаления. - -=cut
--- a/Lib/IMPL/SQL/Schema/Traits/Diff.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -package IMPL::SQL::Schema::Traits::Diff; -use strict; -use warnings; -use IMPL::lang qw(:compare :hash is typeof); - -use IMPL::SQL::Schema(); -use IMPL::SQL::Schema::Traits(); - -# defining a constant is a good style to enable compile checks -use constant { - schema_t => 'IMPL::SQL::Schema', - ConstraintForeignKey => 'IMPL::SQL::Schema::Constraint::ForeignKey', - TraitsForeignKey => 'IMPL::SQL::Schema::Traits::ForeignKey', - ConstraintPrimaryKey => 'IMPL::SQL::Schema::Constraint::PrimaryKey', - TraitsPrimaryKey => 'IMPL::SQL::Schema::Traits::PrimaryKey', - ConstraintUnique => 'IMPL::SQL::Schema::Constraint::Unique', - TraitsUnique => 'IMPL::SQL::Schema::Traits::Unique', - ConstraintIndex => 'IMPL::SQL::Schema::Constraint::Index', - TraitsIndex => 'IMPL::SQL::Schema::Traits::Index' -}; - -sub Diff { - my ($self,$src,$dst) = @_; - - die new IMPL::InvalidArgumentException( src => "A valid source schema is required") unless is($src,schema_t); - die new IMPL::InvalidArgumentException( dst => "A valid desctination schema is requried" ) unless is($src,schema_t); - - my %dstTables = map { $_->name, $_ } $dst->GetTables; - - my @operations; - - foreach my $srcTable ( $src->GetTables) { - my $dstTable = delete $dstTables{$srcTable->name}; - - if (not $dstTable) { - # if a source table doesn't have a corresponding destination table, it should be deleted - push @operations, new IMPL::SQL::Schema::Traits::DropTable($srcTable->name); - } else { - # a source table needs to be updated - push @operations, $self->_DiffTables($srcTable,$dstTable); - } - - } - - foreach my $tbl ( values %dstTables ) { - push @operations, new IMPL::SQL::Schema::Traits::CreateTable( - new IMPL::SQL::Schema::Traits::Table( - $tbl->name, - [ map _Column2Traits($_), @{$tbl->columns} ], - [ map _Constraint2Traits($_), $tbl->GetConstraints()], - $tbl->{tag} - ) - ) - } - - return \@operations; -} - -sub _DiffTables { - my ($self,$src,$dst) = @_; - - my @dropConstraints; - my @createConstraints; - - my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); - my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); - - foreach my $cnSrcName (keys %srcConstraints) { - if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { - unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { - push @dropConstraints, - new IMPL::SQL::Schema::Traits::AlterTableDropConstraint( $src->name, $cnSrcName ); - push @createConstraints, - new IMPL::SQL::Schema::Traits::AlterTableAddConstraint( $dst->name, _Constraint2Traits($cnDst) ); - } - } else { - push @dropConstraints,new IMPL::SQL::Schema::Traits::AlterTableDropConstraint( $src->name, $cnSrcName ); - } - } - - foreach my $cnDst (values %dstConstraints) { - push @createConstraints, - IMPL::SQL::Schema::Traits::AlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); - } - - my @deleteColumns; - my @addColumns; - my @updateColumns; - - my %dstColumnIndexes = map { - my $col = $dst->GetColumnAt($_); - ($col->name, { column => $col, index => $_ }) - } 0 .. $dst->ColumnsCount-1; - - my @columns; - - # remove old columns, mark for update changed columns - for( my $i=0; $i < $src->ColumnsCount; $i++) { - my $colSrc = $src->GetColumnAt($i); - - if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { - $infoDst->{prevColumn} = $colSrc; - push @columns,$infoDst; - } else { - push @deleteColumns,new IMPL::SQL::Schema::Traits::AlterTableDropColumn($src->name,$colSrc->name); - } - } - - #insert new columns at specified positions - foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { - splice(@columns,$_->{index},0,$_); - push @addColumns, new IMPL::SQL::Schema::Traits::AlterTableAddColumn($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); - } - - # remember old indexes - for(my $i =0; $i< @columns; $i ++) { - $columns[$i]->{prevIndex} = $i; - } - - # reorder columns - @columns = sort { $a->{index} <=> $b->{index} } @columns; - - foreach my $info (@columns) { - if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { - my $op = new IMPL::SQL::Schema::Traits::AlterTableChangeColumn($src->name,$info->{column}->name); - - $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; - $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); - $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); - - my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); - $op->options($diff) if %$diff; - - push @updateColumns, $op; - } - } - - my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); - - return @result; -} - -sub _Column2Traits { - my ($column,%options) = @_; - - return new IMPL::SQL::Schema::Traits::Column( - $column->name, - $column->type, - isNullable => $column->isNullable, - defaultValue => $column->defaultValue, - tag => $column->tag, - %options - ); -} - -sub _Constraint2Traits { - my ($constraint) = @_; - - my $map = { - ConstraintForeignKey , TraitsForeignKey, - ConstraintPrimaryKey , TraitsPrimaryKey, - ConstraintUnique , TraitsUnique, - ConstraintIndex , TraitsIndex - }; - - my $class = $map->{typeof($constraint)} or die new IMPL::Exception("Can't map the constraint",typeof($constraint)); - - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ] - ) -} - -1;
--- a/Lib/IMPL/SQL/Schema/Traits/mysql.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,550 +0,0 @@ -package IMPL::SQL::Schema::Traits::mysql::Handler; -use strict; -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public _direct property SqlBatch => prop_all; -} - -sub formatTypeNameInteger { - my ($type) = @_; - - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeNameReal { - my ($type) = @_; - - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeNameNumeric { - my ($type) = @_; - $type->MaxLength or die new IMPL::InvalidArgumentException('The length and precission must be specified',$type->Name); - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeName { - my ($type) = @_; - return $type->Name; -} - -sub formatTypeNameChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::CHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameVarChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::VARCHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameEnum { - my ($type) = @_; - die new Exception('Enum must be a type of either IMPL::SQL::Schema::Type::mysql::ENUM or IMPL::SQL::Schema::Type::mysql::SET') if not (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::ENUM') or UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::SET')); - return ( - $type->Name.'('.join(',',map {quote($_)} $type->Values).')' - ); -} - -sub quote{ - if (wantarray) { - return map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } -} - -sub quote_names { - if (wantarray) { - return map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } -} - -sub formatStringValue { - my ($value) = @_; - - if (ref $value) { - if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) { - return $value->as_string; - } else { - die new Exception('Can\'t format the object as a value',ref $value); - } - } else { - return quote($value); - } -} - - -sub formatNumberValue { - my ($value) = @_; - - if (ref $value) { - if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) { - return $value->as_string; - } else { - die new Exception('Can\'t format the object as a value',ref $value); - } - } else { - $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ or die new Exception('The specified value isn\'t a valid number',$value); - return $value; - } -} - - -my %TypesFormat = ( - TINYINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - SMALLINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - MEDIUMINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INTEGER => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - BIGINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - REAL => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DOUBLE => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - FLOAT => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DECIMAL => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - NUMERIC => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - DATE => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIMESTAMP => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - DATETIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - CHAR => { - formatType => \&formatTypeNameChar, - formatValue => \&formatStringValue - }, - VARCHAR => { - formatType => \&formatTypeNameVarChar, - formatValue => \&formatStringValue - }, - TINYBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - BLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TINYTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - ENUM => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - }, - SET => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - } -); - - -=pod -CREATE TABLE 'test'.'New Table' ( - 'dd' INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, - `ff` VARCHAR(45) NOT NULL, - `ffg` VARCHAR(45) NOT NULL DEFAULT 'aaa', - `ddf` INTEGER UNSIGNED NOT NULL, - PRIMARY KEY(`dd`), - UNIQUE `Index_2`(`ffg`), - CONSTRAINT `FK_New Table_1` FOREIGN KEY `FK_New Table_1` (`ddf`) - REFERENCES `user` (`id`) - ON DELETE RESTRICT - ON UPDATE RESTRICT -) -ENGINE = InnoDB; -=cut -sub formatCreateTable { - my ($table,$level,%options) = @_; - - my @sql; - - # table body - push @sql, map { formatColumn($_,$level+1) } @{$table->Columns} ; - if ($options{'skip_foreign_keys'}) { - push @sql, map { formatConstraint($_,$level+1) } grep {not UNIVERSAL::isa($_,'IMPL::SQL::Schema::Constraint::ForeignKey')} values %{$table->Constraints}; - } else { - push @sql, map { formatConstraint($_,$level+1) } values %{$table->Constraints}; - } - - for(my $i = 0 ; $i < @sql -1; $i++) { - $sql[$i] .= ','; - } - - unshift @sql, "CREATE TABLE ".quote_names($table->Name)."("; - - if ($table->Tag) { - push @sql, ")"; - push @sql, formatTableTag($table->Tag,$level); - $sql[$#sql].=';'; - } else { - push @sql, ');'; - } - - return map { (" " x $level) . $_ } @sql; -} - -sub formatDropTable { - my ($tableName,$level) = @_; - - return " "x$level."DROP TABLE ".quote_names($tableName).";"; -} - -sub formatTableTag { - my ($tag,$level) = @_; - return map { " "x$level . "$_ = ".$tag->{$_} } grep {/^(ENGINE)$/i} keys %{$tag}; -} - -sub formatColumn { - my ($column,$level) = @_; - $level ||= 0; - return " "x$level.quote_names($column->Name)." ".formatType($column->Type)." ".($column->CanBeNull ? 'NULL' : 'NOT NULL').($column->DefaultValue ? formatValueToType($column->DefaultValue,$column->Type) : '' ).($column->Tag ? ' '.join(' ',$column->Tag) : ''); -} - -sub formatType { - my ($type) = @_; - my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); - $format->{formatType}->($type); -} - -sub formatValueToType { - my ($value,$type) = @_; - - my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); - $format->{formatValue}->($value); -} - -sub formatConstraint { - my ($constraint,$level) = @_; - - if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::ForeignKey')) { - return formatForeignKey($constraint,$level); - } else { - return formatIndex($constraint, $level); - } -} - -sub formatIndex { - my ($constraint,$level) = @_; - - my $name = quote_names($constraint->Name); - my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns}); - - if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') { - return " "x$level."PRIMARY KEY ($columns)"; - } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Unique') { - return " "x$level."UNIQUE $name ($columns)"; - } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Index') { - return " "x$level."INDEX $name ($columns)"; - } else { - die new IMPL::InvalidArgumentException('The unknown constraint', ref $constraint); - } - -} - -sub formatForeignKey { - my ($constraint,$level) = @_; - - my $name = quote_names($constraint->Name); - my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns}); - - not $constraint->OnDelete or grep { uc $constraint->OnDelete eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new IMPL::Exception('Invalid ON DELETE reference',$constraint->OnDelete); - not $constraint->OnUpdate or grep { uc $constraint->OnUpdate eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new IMPL::Exception('Invalid ON UPDATE reference',$constraint->OnUpdate); - - my $refname = quote_names($constraint->ReferencedPrimaryKey->Table->Name); - my $refcolumns = join(',',map quote_names($_->Name),@{$constraint->ReferencedPrimaryKey->Columns}); - return ( - " "x$level. - "CONSTRAINT $name FOREIGN KEY $name ($columns) REFERENCES $refname ($refcolumns)". - ($constraint->OnUpdate ? 'ON UPDATE'.$constraint->OnUpdate : ''). - ($constraint->OnDelete ? 'ON DELETE'.$constraint->OnDelete : '') - ); -} - -sub formatAlterTableRename { - my ($oldName,$newName,$level) = @_; - - return " "x$level."ALTER TABLE ".quote_names($oldName)." RENAME TO ".quote_names($newName).";"; -} - -sub formatAlterTableDropColumn { - my ($tableName, $columnName,$level) = @_; - - return " "x$level."ALTER TABLE ".quote_names($tableName)." DROP COLUMN ".quote_names($columnName).";"; -} - -=pod -ALTER TABLE `test`.`user` ADD COLUMN `my_col` VARCHAR(45) NOT NULL AFTER `name2` -=cut -sub formatAlterTableAddColumn { - my ($tableName, $column, $table, $pos, $level) = @_; - - my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); - - return " "x$level."ALTER TABLE ".quote_names($tableName)." ADD COLUMN ".formatColumn($column) .' '. $posSpec.";"; -} - -=pod -ALTER TABLE `test`.`manager` MODIFY COLUMN `description` VARCHAR(256) NOT NULL DEFAULT NULL; -=cut -sub formatAlterTableChangeColumn { - my ($tableName,$column,$table,$pos,$level) = @_; - my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); - return " "x$level."ALTER TABLE ".quote_names($tableName)." MODIFY COLUMN ".formatColumn($column).' '. $posSpec.";"; -} - -=pod -ALTER TABLE `test`.`manager` DROP INDEX `Index_2`; -=cut -sub formatAlterTableDropConstraint { - my ($tableName,$constraint,$level) = @_; - my $constraintName; - if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') { - $constraintName = 'PRIMARY KEY'; - } elsif (ref $constraint eq 'IMPL::SQL::Schema::Constraint::ForeignKey') { - $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name); - } elsif (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { - $constraintName = 'INDEX '.quote_names($constraint->Name); - } else { - die new IMPL::Exception("The unknow type of the constraint",ref $constraint); - } - return " "x$level."ALTER TABLE ".quote_names($tableName)." DROP $constraintName;"; -} - -=pod -ALTER TABLE `test`.`session` ADD INDEX `Index_2`(`id`, `name`); -=cut -sub formatAlterTableAddConstraint { - my ($tableName,$constraint,$level) = @_; - - return " "x$level."ALTER TABLE ".quote_names($tableName)." ADD ".formatConstraint($constraint,0).';'; -} - -sub CreateTable { - my ($this,$tbl,%option) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatCreateTable($tbl,0,%option)); - - return 1; -} - -sub DropTable { - my ($this,$tbl) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatDropTable($tbl,0)); - - return 1; -} - -sub RenameTable { - my ($this,$oldName,$newName) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableRename($oldName,$newName,0)); - - return 1; -} - -sub AlterTableAddColumn { - my ($this,$tblName,$column,$table,$pos) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddColumn($tblName,$column,$table,$pos,0)); - - return 1; -} -sub AlterTableDropColumn { - my ($this,$tblName,$columnName) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropColumn($tblName,$columnName,0)); - - return 1; -} - -sub AlterTableChangeColumn { - my ($this,$tblName,$column,$table,$pos) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableChangeColumn($tblName,$column,$table,$pos,0)); - - return 1; -} - -sub AlterTableAddConstraint { - my ($this,$tblName,$constraint) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddConstraint($tblName,$constraint,0)); - - return 1; -} - -sub AlterTableDropConstraint { - my ($this,$tblName,$constraint) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropConstraint($tblName,$constraint,0)); - - return 1; -} - -sub Sql { - my ($this) = @_; - if (wantarray) { - @{$this->SqlBatch || []}; - } else { - return join("\n",$this->SqlBatch); - } -} - -package IMPL::SQL::Schema::Traits::mysql; -use parent qw(IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; - -BEGIN { - public _direct property PendingConstraints => prop_none; -} - -our %CTOR = ( - 'IMPL::SQL::Schema::Traits' => sub { - my %args = @_; - $args{'Handler'} = new IMPL::SQL::Schema::Traits::mysql::Handler; - %args; - } -); - -sub DropConstraint { - my ($this,$constraint) = @_; - - if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { - return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED} $constraint->Columns; - my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns); - if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'IMPL::SQL::Schema::Constraint::ForeignKey')) { - my $fk = shift @constraints; - if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED) { - push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]}; - $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++; - - die new IMPL::Exception('Can\'t drop the primary key becouse of the foreing key',$fk->UniqName) if $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} > 2; - return 2; - } - } - } - $this->SUPER::DropConstraint($constraint); -} - -sub GetMetaTable { - my ($class,$dbh) = @_; - - return IMPL::SQL::Schema::Traits::mysql::MetaTable->new( DBHandle => $dbh); -} - -package IMPL::SQL::Schema::Traits::mysql::MetaTable; -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public _direct property DBHandle => prop_none; -} - -sub ReadProperty { - my ($this,$name) = @_; - - local $this->{$DBHandle}->{PrintError}; - $this->{$DBHandle}->{PrintError} = 0; - my ($val) = $this->{$DBHandle}->selectrow_array("SELECT value FROM _Meta WHERE name like ?", undef, $name); - return $val; -} - -sub SetProperty { - my ($this,$name,$val) = @_; - - if ( $this->{$DBHandle}->selectrow_arrayref("SELECT TABLE_NAME FROM information_schema.`TABLES` T where TABLE_SCHEMA like DATABASE() and TABLE_NAME like '_Meta'")) { - if ($this->{$DBHandle}->selectrow_arrayref("SELECT name FROM _Meta WHERE name like ?", undef, $name)) { - $this->{$DBHandle}->do("UPDATE _Meta SET value = ? WHERE name like ?",undef,$val,$name); - } else { - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES ('$name',?)",undef,$val); - } - } else { - $this->{$DBHandle}->do(q{ - CREATE TABLE `_Meta` ( - `name` VARCHAR(255) NOT NULL, - `value` LONGTEXT NULL, - PRIMARY KEY(`name`) - ); - }) or die new IMPL::Exception("Failed to create table","_Meta"); - - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val); - } -} - -1;
--- a/Lib/IMPL/SQL/Schema/Type.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,98 +0,0 @@ -package IMPL::SQL::Schema::Type; -use strict; -use warnings; - -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; - - $this->{$scale} = 0 if not $this->{$scale}; -} - -sub SameValue { - my ($this,$other) = @_; - - return ( - $this->{$name} eq $other->name - and equals($this->{$maxLength},$other->{$maxLength}) - and equals($this->{$scale},$other->{$scale}) - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::SQL::Schema::Type> Описывает SQL типы данных - -=head1 SYNOPSIS - -=begin code - -use IMPL::SQL::Schema::Type; - -my $varchar_t = new IMPL::SQL::Schema::Type( name => 'varchar', maxLength => 255 ); - -my $real_t = new IMPL::SQL::Schema::Type( name => 'float', maxLength=> 10, scale => 4); # mysql: float(10,4) - -=end - -Данный класс используется для стандатрного описания SQL типов данных. В зависимости -от движка БД эти объекты могут быть представлены различными строковыми представлениями. - -=head1 MEMBERS - -=over - -=item C<CTOR(%props)> - -Конструктор, заполняет объект значениями которые были переданы в конструкторе. - -=item C<[get]name> - -Имя типа. Обязательно. - -=item C<[get]maxLength> - -Максимальная длина, используется только для типов, имеющих длину (либо переменную, -либо постоянную). - -=item C<[get]scale> - -Точность, количество знаков после запятой. Используется вместе с C<maxLength>. - -=item C<[get]unsigned> - -Используется с числовыми данными, обозначает беззнаковые типы. - -=item C<[get]zerofill> - -Нестандартный атрибут дополняющий числа лидирующими нулями до C<maxLength>. - -=item C<[get]tag> - -Хеш с дополнительными опциями. - -=back - -=cut
--- a/Lib/IMPL/SQL/Types.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -package IMPL::SQL::Types; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime); - -require IMPL::SQL::Schema::Type; - -sub Integer() { - return IMPL::SQL::Schema::Type->new(name => 'INTEGER'); -} - -sub Varchar($) { - return IMPL::SQL::Schema::Type->new(name => 'VARCHAR', maxLength => shift); -} - -sub Float($) { - return IMPL::SQL::Schema::Type->new(name => 'FLOAT', scale => shift); -} - -sub Real() { - return IMPL::SQL::Schema::Type->new(name => 'REAL'); -} - -sub Text() { - return IMPL::SQL::Schema::Type->new(name => 'TEXT'); -} - -sub Binary() { - return IMPL::SQL::Schema::Type->new(name => 'BINARY'); -} - -sub DateTime() { - return IMPL::SQL::Schema::Type->new(name => 'DATETIME'); -} - -1;
--- a/Lib/IMPL/Security.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package IMPL::Security; -use strict; -use Carp qw(carp); - -##VERSION## - -require IMPL::Exception; -require IMPL::Security::Rule::RoleCheck; - -use IMPL::require { - Principal => 'IMPL::Security::Principal', - AbstractContext => 'IMPL::Security::AbstractContext', - Context => 'IMPL::Security::Context' -}; - -sub principal { - return - AbstractContext->current - && AbstractContext->current->principal - || Principal->nobody; -} - -sub context { - AbstractContext->current || Context->nobody; -} - -1; - -__END__ \ No newline at end of file
--- a/Lib/IMPL/Security/AbstractContext.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,167 +0,0 @@ -package IMPL::Security::AbstractContext; -use strict; -use warnings; - -use IMPL::Const qw(:prop); - -use IMPL::require { - Role => 'IMPL::Security::Role', - Principal => 'IMPL::Security::Principal', - Exception => 'IMPL::Exception', - NotImplementedException => '-IMPL::NotImplementedException' -}; - -use parent qw(IMPL::Class::Meta); - -__PACKAGE__->static_accessor_clone(abstractProps => [ - principal => PROP_RW, - rolesAssigned => PROP_RW | PROP_LIST, - auth => PROP_RW, - authority => PROP_RW -]); - -my $current; # current session if any - -sub Impersonate { - my ($this,$code,@args) = @_; - - my $old = $current; - $current = $this; - my $result; - my $e; - - { - local $@; - eval { - $result = $code->(@args); - }; - $e = $@; - } - $current = $old; - if($e) { - die $e; - } else { - return $result; - } -} - -sub Apply { - my ($this) = @_; - - $current = $this; -} - -sub isTrusted { - my ($this) = @_; - - if (my $auth = $this->auth) { - return $auth->isTrusted; - } else { - return 0; - } -} - -sub isNobody { - return (shift->principal == Principal->nobody ? 1 : 0); -} - -sub Satisfy { - my ($this,@roles) = @_; - - my $roleEffective = Role->new ( _effective => scalar $this->rolesAssigned ); - - return $roleEffective->Satisfy(@roles); -} - -sub current { - $current; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<abstract IMPL::Security::Context> - контекст безопасности. - -=head1 SINOPSYS - -=begin code - -package MyApp::Model::Session; -use strict; - -use IMPL::delare { - base => [ - 'MyApp::Model::BaseDBO' => '@_', - 'IMPL::Security::AbstractContext' => undef - ], - props { - IMPL::Security::AbstractContext->abstractProps, - qouta => PROP_GET - } -} - -package main; - -$app->model->GetSession('546a54df4')->Impersonate(sub{ - # do something -}); - -=end code - -=head1 DESCRIPTION - -Код приложения, которое выполняется - -Являет собой контекст безопасности, описывает пользователя и привелегии, так же -у программы есть текущий контекст безопасности, по умолчанию он C<nobody>. - -=head1 MEMBERS - -=head2 C<[get] principal> - -Идентификатор пользователя, владельца контекста. - -=head2 C<[get,set] rolesAssigned> - -Явно назначенные роли. Если список пуст, то считается, что используются роли -пользователя по-умолчанию. - -=head2 C<[get] auth> - -Объект асторизации C<IMPL::Security::Auth>, использованный при создании текущего контекста. - -=head2 C<[get] authority> - -Модуль безопасности, породивший данный контекст. Модуль безопасности, отвечающий -за создание контекста безопасности должен реализовывать метод -C<CreateContext($user,$auth,$roles)> - -=head2 C<[get] isTrusted> - -Возвращает значение является ли контекст доверенным, тоесть клиент -аутентифицирован и сессия установлена. Если C<false> значит, что сессия была -начата, однако не установлена до конца. - -=head2 C<Impersonate($code)> - -Делает контекст текущим и выполняет в нем функцию по ссылке C<$code>. По окончании -выполнения, контекст восстанавливается в предыдущий (не зависимо от того, что -с ним происходило во время выполнения C<$code>). - -=head2 C<Apply()> - -Заменяет текущий контекст на себя, но до конца действия метода C<Impersonate>, если -таковой был вызван. - -=head2 C<Satisfy(@roles)> - -Проверяет наличие необходимых ролей у контекста. Данный метод позволяет -абстрагироваться от механизмов связи контекста и ролей. Возвращает истинное -значение если список необходимых ролей у пользователя имеется. - -=cut
--- a/Lib/IMPL/Security/AbstractPrincipal.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -package IMPL::Security::AbstractPrincipal; -use strict; - -use parent qw(IMPL::Class::Meta); - -use IMPL::Const qw(:prop); - -__PACKAGE__->static_accessor_clone(abstractProps => [ - name => PROP_RW, - description => PROP_RW -]); - -sub isNobody { - -} - -1; -
--- a/Lib/IMPL/Security/AbstractRole.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -package IMPL::Security::AbstractRole; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::lang qw(equals_s); -use parent qw(IMPL::Class::Meta); - -__PACKAGE__->static_accessor_clone( abstractProps => [ - roleName => PROP_RW, - parentRoles => PROP_RW | PROP_LIST -]); - -sub Satisfy { - my ($this,@roles) = @_; - - return 1 unless $this->_FilterRoles( @roles ); - return 0; -} - -sub _FilterRoles { - my ($this,@roles) = @_; - - @roles = grep not (ref $_ ? equals_s($this->roleName,$_->roleName) : equals_s($this->roleName, $_) ), @roles; - - @roles = $_->_FilterRoles(@roles) or return foreach $this->parentRoles ; - - return @roles; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Security::Role> Роль - -=head1 DESCRIPTION - -Может включать в себя базовые роли. -Имеется метод для проверки наличия необходимых ролей в текущей роли. - -=head1 MEMBERS - -=over - -=item C<[get] roleName> - -Имя роли, ее идентификатор - -=item C<[get,list] parentRoles> - -Список родительских ролей - -=item C<Satisfy(@roles_list)> - -Проверяет наличие ролей указанных ролей из списка @roles_list. -Допускается использование как самих объектов, так и имен ролей. -Возвращает 0 в случае неудачи (хотябы одна роль не была удовлетворена), 1 при наличии необходимых ролей. - -=back - -=cut
--- a/Lib/IMPL/Security/Auth.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,132 +0,0 @@ -package IMPL::Security::Auth; -use strict; - -use Digest::MD5 qw(md5_hex); - -use constant { - AUTH_SUCCESS => 1, - AUTH_INCOMPLETE => 2, - AUTH_FAIL => 3 -}; - -use parent qw(Exporter); - -our @EXPORT_OK = qw(&AUTH_SUCCESS &AUTH_INCOMPLETE &AUTH_FAIL &GenSSID); -our %EXPORT_TAGS = (Const => [qw(&AUTH_SUCCESS &AUTH_INCOMPLETE &AUTH_FAIL)]); - -{ - my $i = 0; - sub GenSSID { - return md5_hex(time,rand,$i++); - } -} - -sub DoAuth { - die new IMPL::NotImplementedException; -} - -sub isTrusted { - 0; -} - -sub Create { - my ($self,%args) = @_; - - return $self->new($self->CreateSecData(%args)); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Security::Auth> Базовыйы класс для объектов аутентификации. - -=head1 DESCRIPTION - -C<[Abstract]> - -Объект аутентификации служет для аутентификации клиента, в случае успеха -образуется сессия идентифицирующая клиента, которая представлена на стороне -сервера объектом аутентификации. - -Аутентификация носит итеративный характер, объект аутентификации сохраняет -состояние между итерациями. - -Результатом аутентификации является сессия, состояние этой сессии также хранит объект -аутентификации. - -В процессе авторизации клиент и сервер обмениеваются данными безопасности C<$challenge>. -И результатом каждой итерации является либо упех (C<AUTH_SUCCESS>), либо запрос на продолжение -(C<AUTH_INCOMPLETE>), либо неудача (C<AUTH_FAIL>). Количество итераций может быть разным, -зависит от пакета аутентификации. - -=head1 EXPORT - -=over - -=item C<:Const> - -Константы результата аутентификации - -=over - -=item C<AUTH_SUCCESS> - -Успешная аутентификация - -=item C<AUTH_INCOMPLETE> - -Требуются дополнительные шаги - -=item C<AUTH_FAIL> - -Аутентификация неуспешна. - -=back - -=back - -=head1 MEMBERS - -=over - -=item C<CTOR($SecData)> - -Создает пакет для авторизации на основе данных безопасности для пользователя. -C<$SecData> - Зависит от пакета аутентификации. - -=item C<[get] isTrusted> - -Флаг того, что аутентификация закончена успешно и сессия создана. Данный объект -может быть создан для аутентификации сессии. - -=item C<DoAuth($challenge)> - -Производит аутентификацию пользователя, возвращает результат -аутентификации, в виде массива ($status,$challenge). - -Даже после успешной аутентификации полученные данные C<$challenge> должны быть -отправлены клиенту для завершения аутентификации на стороне клиента. - -=item C<[static] CreateSecData(%args)> - -Создает данные безопасности, на основе параметров. Параметры зависят от пакета -аутентификации. Возвращает строку с данными безопасности. - -=item C<[static] Create(%args)> - -Создает объект аутентификации, на основе параметров. Параметры зависят от -пакета аутентификации. Внутри вызывает метод C<CreateSecData(%args)>. - -=item C<[static] SecDataArgs()> - -Возвращает хеш с описанием параметров для функции C<CreateSecData>. -Ключами являются имена параметров, значениями - типы. - -=back - -=cut
--- a/Lib/IMPL/Security/Auth/Simple.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,133 +0,0 @@ -package IMPL::Security::Auth::Simple; -use strict; - -use Digest::MD5 qw(md5_hex); -use Encode qw(encode); - -use IMPL::Security::Auth qw(:Const); - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - WrongDataException => '-IMPL::WrongDataException' - }, - base => [ - 'IMPL::Security::Auth' => undef, - 'IMPL::Object' => undef - ], - props => [ - _stage => PROP_ALL, - _salt => PROP_ALL, - _image => PROP_ALL - ] -}; - -use constant { - STAGE_INIT => 1, - STAGE_DONE => 2 -}; - -sub CTOR { - my ($this,$secData) = @_; - - my ($stage,$salt,$img) = split /\|/,$secData; - - die WrongDataException->new() unless grep $_ == $stage, (STAGE_INIT, STAGE_DONE); - - $this->_stage($stage); - $this->_salt($salt); - $this->_image($img); - -} - -sub secData { - my ($this) = @_; - - return join ('|',$this->_stage, $this->_salt , $this->_image ); -} - -sub isTrusted { - my ($this) = @_; - - $this->_stage == STAGE_DONE ? 1 : 0; -} - -sub DoAuth { - my ($this,$challenge) = @_; - - my $salt = $this->_salt; - - if (md5_hex($salt,encode('utf-8', $challenge), $salt) eq $this->_image) { - if ($this->_stage == STAGE_INIT) { - $this->_stage(STAGE_DONE); - } - return (AUTH_SUCCESS, undef); - } else { - return (AUTH_FAIL, undef); - } -} - -sub CreateSecData { - my ($self,%args) = @_; - - die new IMPL::InvalidArgumentException("The parameter is required",'password') unless $args{password}; - - my $salt = $self->GenSSID(); - return return join ('|',STAGE_INIT, $salt, md5_hex($salt,encode('utf-8', $args{password}),$salt)); -} - -sub SecDataArgs { - password => 'SCALAR' -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Security::Auth::Simple> Модуль простой авторизации. - -=head1 DESCRIPTION - -Использует алгоритм MD5 для хранения образа пароля. - -=head1 MEMBERS - -=head2 C<CTOR($secData)> - -Создает объект аутентификации, передавая ему данные для инициализации. - -=head2 C<[get]secData> - -Возвращает данные безопасности, которые можно использовать для восстановления -состояния объекта. - -=head2 C<[get]isTrusted> - -Является ли объект доверенным для аутентификации сессии (тоесть хранит данные -для аутентификации сессии). - -=head2 C<DoAuth($challenge)> - -Аутентифицирует пользователя. Используется один этап. C<$challenge> -открытый пароль пользователя или cookie сессии. - -Возвращает C<($status,$challenge)> - -=over - -=item C<$status> - -Результат либо C<AUTH_SUCCESS>, либо C<AUTH_FAIL> - -=item C<$challenge> - -В случае успеха возвращает cookie (уникальный номер) сессии, либо C<undef> - -=back - -=cut
--- a/Lib/IMPL/Security/Context.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -package IMPL::Security::Context; -use strict; -use warnings; - -use IMPL::require { - AbstractContext => 'IMPL::Security::AbstractContext', -}; - -use IMPL::declare { - require => { - Principal => 'IMPL::Security::Principal', - Role => 'IMPL::Security::Role', - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Security::AbstractContext' => undef, - ], - props => [ - @{AbstractContext->abstractProps()} - ] -}; - -__PACKAGE__->abstractProps([]); - - -my $nobody; - -sub CTOR { - my ($this) = @_; - - die ArgumentException->new("The parameter is required", 'principal') unless $this->principal; -} - -sub nobody { - my ($self) = @_; - $nobody = $self->new(principal => Principal->nobody) unless $nobody; - $nobody; -} - -sub isTrusted { - return 1; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Security::Context> - реализация контекста безопасности создаваемого в -приложении. - -=head1 SYNOPSIS - -=begin code - -my $context = IMPL::Security::Context->nobody; - -my $result = $context->Impersonate( - sub { - # do some untrusted code - } -); - -$context = IMPL::Security::Context->new( - principal => $user, - assignedRoles => [ - $backupRole, - $controlRole - ] -); - -$context->Impersonate( - sub { - - # do some authorized operations - - $service->backupData('current.bak'); - $service->stop(); - } -); - -=end code - -=head1 DESCRIPTION - -C<autofill> - -Данная реализация контекста безопасности не привязана ни к источнику данных -ни к пакету аутентификации и авторизации, ее приложение может создать в любой -момент, при этом система сама несет ответственность за последствия. - -Данный контекст нужен для выполнения системой служебных функций. - -=head1 MEMBERS - -см. также C<IMPL::Security::AbstractContext>. - -=head2 C<CTOR(%props)> - -Создает объект и заполняет его свойствами. C<principal> должен быть обязательно -указан. - -=head2 C<[static,get] nobody> - -Контекст для неаутентифицированных пользователей, минимум прав. - -=cut
--- a/Lib/IMPL/Security/Principal.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -package IMPL::Security::Principal; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::require { - AbstractPrincipal => 'IMPL::Security::AbstractPrincipal' -}; -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Security::AbstractPrincipal' => undef - ], - props => [ - @{AbstractPrincipal->abstractProps()}, - isNobody => PROP_RW - ] -}; - -__PACKAGE__->abstractProps([]); - -my $nobody; - -sub nobody { - $nobody = $_[0]->new(name => 'nobody', description => '', isNobody => 1) unless $nobody; - return $nobody; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Security::Principal> Идентификатор пользователя - -C<[Autofill]> - -=head1 MEMBERS - -=over - -=item C<CTOR(%props)> - -Создает новый объект. - -=item C<[get] name> - -Возвращает имя пользователя. - -=item C<[get,set] description> - -Возвращает описание пользователя. - -=back - -=cut
--- a/Lib/IMPL/Security/Role.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -package IMPL::Security::Role; -use strict; - -use IMPL::require { - AbstractRole => 'IMPL::Security::AbstractRole' -}; - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Security::AbstractRole' => undef - ], - _implement => 1 -}; - -sub CTOR { - my ($this,$name,$parentRoles) = @_; - - $this->roleName($name) if $name; - $this->parentRoles($parentRoles) if $parentRoles; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Security::Role> - стандартная реализация роли безопасности. - -=head1 SYNOPSIS - -=begin code - -# create the megarole -my $role = IMPL::Security::Role->new(megarole => [ $adminRole, $directorRole ] ); - -#use it in context -my $context = IMPL::Security::Context->new( - principal => $user, - assignedRoles => [$user->roles, $megarole] -); - -$context->Impersonate( sub { - # do something forbidden -}); - -=end code - -=head1 DESCRIPTION - -Позволяет создавать объекты ролей без привязки к источникам данных и модулям -авторизации. Чаще всего используется при реализации каких либо механизмов -безопасности, где требуется создать временную роль. - -C<IMPL::Security::AbstractRole> - -=cut \ No newline at end of file
--- a/Lib/IMPL/Security/Rule/RoleCheck.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -package IMPL::Security::Rule::RoleCheck; -use strict; - -require IMPL::Security::Role; - -sub SatisfyAll { - my ($secPackage,$object,$desiredAccess,$context) = @_; - - my $roleEffective = new IMPL::Security::Role ( _effective => $context->rolesAssigned ); - - return $roleEffective->Satisfy(ExtractRoles($object)); -} - -sub _ExtractRoles { - return (); -} - -1;
--- a/Lib/IMPL/Serialization.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,449 +0,0 @@ -package IMPL::Serialization; -use strict; - -package IMPL::Serialization::Context; - -use IMPL::Exception(); -use Scalar::Util qw(refaddr); - -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 - ] -}; - -sub STATE_CLOSED () { 0 } -sub STATE_OPENED () { 1 } -sub STATE_COMPLEX () { 2 } -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; -} - -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; - } - return 0; - } - - 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; -} - -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; -} - -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 ); - } - } - 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) ); - } - } - - return 1; -} - -package IMPL::Deserialization::Context; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - Loader => 'IMPL::Code::Loader' - }, - base => [ 'IMPL::Object' => undef ], - props => [ - - # структура информации об объекте - # { - # 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; -} - -sub OnObjectBegin { - 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'}; - - push @{ $rhCurrentObj->{'Data'} }, $name, $refObj; - } else { - $rhCurrentObj->{'Data'} = [ $name, $refObj ]; - } - - 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->CreateSurrogate( $rhProps->{'type'} ); - } - } - - return 1; -} - -sub OnObjectData { - 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 $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; - } -} - -sub CreateSurrogate { - my ($this,$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: -# [ -# 'var_name',value, -# .... -# ] - -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 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; - } - 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; - } - 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 { - 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 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 Exception->new("Omitted mandatory parameter 'formatter'"); -} - -sub Serialize { - 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 = DeserializationContext->new(); - my $ObjReader = $this->_formatter->CreateReader( $hStream, $context ); - $ObjReader->Parse(); - return $context->root; -} - -1;
--- a/Lib/IMPL/Serialization/XmlFormatter.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,200 +0,0 @@ -package IMPL::Serialization::XmlObjectWriter; -use strict; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use IMPL::Serialization; -use XML::Writer; -use IMPL::Exception; - -sub CONTAINER_EMPTY () { 1 } -sub CONTAINER_NORMAL () { 2 } - -BEGIN { - public _direct property Encoding => prop_all; - public _direct property hOutput => prop_all; - public _direct property IdentOutput => prop_all; - - private _direct property CurrentObject => prop_all; - private _direct property ObjectPath => prop_all; - private _direct property XmlWriter => prop_all; - private _direct property IdentLevel => prop_all; - private _direct property IdentNextTag => prop_all; -} - -sub new { - my $class = shift; - my $self = bless {}, ref($class) || $class; - $self->CTOR(@_); - return $self; -} - -sub CTOR { - my $this = shift; - my %args = @_; - $this->{$hOutput} = $args{'hOutput'}; - $this->{$Encoding} = $args{'Encoding'}; - $this->{$CurrentObject} = undef; - $this->{$IdentOutput} = $args{'IdentOutput'}; - $this->{$IdentLevel} = 0; - $this->{$IdentNextTag} = 0; - #$this->{$ObjectPath} = []; - return 1; -} - -sub BeginObject { - my $this = shift; - my %args = @_; - - if (not $this->{$CurrentObject}) { - my $xmlWriter = new XML::Writer(OUTPUT => $this->{$hOutput}, ENCODING => $this->{$Encoding}); - $this->{$XmlWriter} = $xmlWriter; - $xmlWriter->xmlDecl(); - } - - push @{$this->{$ObjectPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; - - my %ObjectProperties = %args; - delete $ObjectProperties{'name'}; - delete $args{'container_type'}; - - $this->{$CurrentObject} = \%ObjectProperties; - - my $tagname; - if (_CheckName($args{'name'})) { - $tagname = $args{'name'}; - } else { - $tagname = 'element'; - $ObjectProperties{'extname'} = $args{'name'}; - } - - if ($args{'refid'}) { - $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; - $this->{$XmlWriter}->emptyTag($tagname,%ObjectProperties); - $ObjectProperties{'container_type'} = CONTAINER_EMPTY; - } else { - $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; - $this->{$XmlWriter}->startTag($tagname,%ObjectProperties); - $ObjectProperties{'container_type'} = CONTAINER_NORMAL; - } - - $this->{$IdentLevel} ++; - $this->{$IdentNextTag} = $this->{$IdentOutput}; - - return 1; -} - -sub EndObject { - my $this = shift; - - my $hCurrentObject = $this->{$CurrentObject} or return 0; - - $this->{$IdentLevel} --; - - if ( $hCurrentObject->{'container_type'} != CONTAINER_EMPTY ) { - $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; - $this->{$XmlWriter}->endTag(); - } - - $this->{$IdentNextTag} = $this->{$IdentOutput}; - - $this->{$CurrentObject} = pop @{$this->{$ObjectPath}} if exists $this->{$ObjectPath}; - $this->{$XmlWriter} = undef if (not $this->{$CurrentObject}); - - return 1; -} - -sub SetData { - my $this = shift; - #my $hCurrentObject = $this->{$CurrentObject} or return 0; - - if ($this->{$CurrentObject}->{'container_type'} == CONTAINER_NORMAL) { - $this->{$XmlWriter}->characters($_[0]) if defined $_[0]; - $this->{$IdentNextTag} = 0; - return 1; - } else { - return 0; - } -} - -sub _CheckName { - return 0 if not $_[0]; - return $_[0] =~ /^(_|\w|\d)+$/; -} - -package IMPL::Serialization::XmlObjectReader; -use parent qw(XML::Parser); - -sub new { - my $class = shift; - my %args = @_; - die new Exception("Handler parameter is reqired") if not $args{'Handler'}; - die new Exception("Handler parameter must be a reference") if not ref $args{'Handler'}; - - #my $this = $class->SUPER::new(Style => 'Stream', Pkg => 'Serialization::XmlObjectReader', 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); - my $this = $class->SUPER::new(Handlers => { Start => \&StartTag, End => \&EndTag, Char => \&Text} , 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); - return $this; -} - -sub Parse { - my $this = shift; - $this->parse($this->{'Non-Expat-Options'}->{'hInput'}); - return 1; -} - -sub StartTag { - my $this = shift; - my $name = shift; - my %Attr = @_; - $name = $Attr{'extname'} if defined $Attr{'extname'}; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectBegin($name,\%Attr); - return 1; -} - -sub EndTag { - my ($this,$name) = @_; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectEnd($name); - return 1; -} - -sub Text { - my ($this) = shift; - my $text = shift; - return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and $text =~ /^\n*\s*\n*$/; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($text); - return 1; -} - -package IMPL::Serialization::XmlFormatter; -use parent qw(IMPL::Object); - -use IMPL::Class::Property; - -BEGIN { - public _direct property Encoding => prop_all; - public _direct property SkipWhitespace => prop_all; - public _direct property IdentOutput => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->Encoding($args{'Encoding'} || 'utf-8'); - $this->SkipWhitespace($args{'SkipWhitespace'}); - $this->IdentOutput($args{'IdentOutput'}); - - return 1; -} - -sub CreateWriter { - my ($this,$hStream) = @_; - return new IMPL::Serialization::XmlObjectWriter(Encoding =>$this->Encoding() , hOutput => $hStream, IdentOutput => $this->IdentOutput()); -} - -sub CreateReader { - my ($this,$hStream,$refHandler) = @_; - return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace()); -} - -1;
--- a/Lib/IMPL/TargetException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::TargetException; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::AppException' => undef, - ], - props => [ - innerException => PROP_RO - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->innerException($args{innerException}); -} - -use IMPL::Resources::Strings { - message => "An invocation target throws an exception '%innerException.message%' \n%innerException.callStack%\n__END_OF_INNER_EXCEPTION__\n" -}; - -1; \ No newline at end of file
--- a/Lib/IMPL/Test.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -package IMPL::Test; -use strict; -use warnings; - -use IMPL::lang qw(equals_s); -use IMPL::Const qw(:access); -require IMPL::Test::SkipException; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert &assertarray &GetCallerSourceLine); - -require IMPL::Test::Unit; -require IMPL::Test::Plan; -require IMPL::Test::TAPListener; - -sub test($$) { - my ($name,$code) = @_; - my $class = caller; - - $class->set_meta( - new IMPL::Test::Unit::TestInfo( $name, $code ) - ); -} - -sub shared($) { - my ($propInfo) = @_; - - 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->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)); -} - -sub failed($;@) { - die new IMPL::Test::FailException(@_); -} - -sub assert { - my ($condition,@params) = @_; - - die new IMPL::Test::FailException(@params ? @params : ("Assertion failed" , _GetSourceLine( (caller)[1,2] )) ) unless $condition; -} - -sub skip($;@) { - die new IMPL::Test::SkipException(@_); -} - -sub cmparray { - my ($a,$b) = @_; - - return 0 unless @$a == @$b; - - for (my $i=0; $i < @$a; $i++ ) { - return 0 unless - equals_s($a->[$i], $b->[$i]); - } - - return 1; -} - -sub assertarray { - my ($a,$b) = @_; - - - die IMPL::Test::FailException->new( - "Assert arrays failed", - _GetSourceLine( (caller)[1,2] ), - join(', ', map defined($_) ? $_ : '<undef>', @$a), - join(', ', map defined($_) ? $_ : '<undef>', @$b) - ) - unless cmparray($a,$b); -} - -sub _GetSourceLine { - my ($file,$line) = @_; - - open my $hFile, $file or return "failed to open file: $file: $!"; - - my $text; - $text = <$hFile> for ( 1 .. $line); - chomp $text; - $text =~ s/^\s+//; - return "line $line: $text"; -} - -sub GetCallerSourceLine { - my $line = shift || 0; - return _GetSourceLine( (caller($line + 1))[1,2] ) -} - -sub run_plan { - my (@units) = @_; - - my $plan = new IMPL::Test::Plan(@units); - - $plan->Prepare; - $plan->AddListener(new IMPL::Test::TAPListener); - $plan->Run; -} -1;
--- a/Lib/IMPL/Test/BadUnit.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -package IMPL::Test::BadUnit; -use strict; -use warnings; - -use parent qw(IMPL::Test::Unit); -use IMPL::Class::Property; - -BEGIN { - public property UnitName => prop_all; - public property Message => prop_all; - public property Error => prop_all; -} - -our %CTOR = ( - 'IMPL::Test::Unit' => sub { - if (@_>1) { - # Unit construction - my ($unit,$message,$error) = @_; - return new IMPL::Test::Unit::TestInfo( - BadUnitTest => sub { - die new IMPL::Test::FailException($message,$unit,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) - } - ); - } else { - # test construction - return @_; - } - } -); - -sub CTOR { - my ($this,$name,$message,$error) = @_; - - $this->UnitName($name); - $this->Message($message); - $this->Error($error); -} - -sub save { - my ($this,$ctx) = @_; - - defined ($this->$_()) and $ctx->AddVar($_ => $this->$_()) foreach qw(UnitName Message); -} - -sub restore { - my ($class,$data,$inst) = @_; - - my %args = @$data; - - $inst ||= $class->surrogate; - $inst->callCTOR(@args{qw(UnitName Message)}); -} - -sub List { - my ($this) = @_; - my $error = $this->Error; - return new IMPL::Test::Unit::TestInfo( - BadUnitTest => sub { - die new IMPL::Test::FailException($this->Message,$this->UnitName,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) - } - ); -} - - -1;
--- a/Lib/IMPL/Test/FailException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -package IMPL::Test::FailException; -use strict; -use warnings; - -use parent qw(IMPL::Exception); - -__PACKAGE__->PassThroughArgs; - -sub toString { - my $this = shift; - - $this->Message . join("\n",'',map IMPL::Exception::indent($_,1), @{$this->Args} ); -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar(Message => $this->Message); - $ctx->AddVar(Args => $this->Args) if @{$this->Args}; -} - -1;
--- a/Lib/IMPL/Test/HarnessRunner.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package IMPL::Test::HarnessRunner; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); - -use TAP::Parser; -use Test::Harness; - -__PACKAGE__->PassThroughArgs; - - -sub CTOR { - my $this = shift; -} - -sub RunTests { - my ($this,@files) = @_; - - return runtests(@files); -} - -sub ExecuteTests { - my ($this,%args) = @_; - - return Test::Harness::execute_tests(%args); -} - -1;
--- a/Lib/IMPL/Test/Plan.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,238 +0,0 @@ -package IMPL::Test::Plan; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use IMPL::Exception; -use IMPL::Test::Result; -use IMPL::Test::BadUnit; -use Error qw(:try); - -use IMPL::Serialization; -use IMPL::Serialization::XmlFormatter; - -BEGIN { - public property Units => prop_all | prop_list; - public property Results => prop_all | prop_list; - public property Listeners => prop_all | prop_list; - private property _Cache => prop_all | prop_list; - private property _Count => prop_all; -} - -sub CTOR { - my $this = shift; - $this->Units(\@_); -} - -sub restore { - my ($class,$data,$instance) = @_; - - $instance ||= $class->surrogate; - - $instance->callCTOR(); - - my %args = @$data; - - $instance->Units($args{Units}); - $instance->Results($args{Results}) if $args{Results}; - $instance->Listeners($args{Listeners}) if $args{Listeners}; -} - -sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar(Units => [$this->Units]); - $ctx->AddVar(Results => [$this->Results]) if $this->Results; - $ctx->AddVar(Listeners => [$this->Listeners]) if $this->Listeners; -} - -sub AddListener { - my ($this,$listener) = @_; - - $this->Listeners($this->Listeners,$listener); -} - -sub Prepare { - my ($this) = @_; - - my $count = 0; - my @cache; - - foreach my $Unit ($this->Units){ - my %info; - - # preload module - undef $@; - - eval "require $Unit" unless (ref $Unit); - - # handle loading errors - $Unit = new IMPL::Test::BadUnit($Unit,"Failed to load unit",$@) if $@; - - $info{Unit} = $Unit; - try { - $info{Tests} = [$Unit->List]; - } otherwise { - my $err = $@; - $Unit = $info{Unit} = new IMPL::Test::BadUnit( - $Unit->can('UnitName') ? - $Unit->UnitName : - $Unit, - "Failed to extract tests", - $err - ); - $info{Tests} = [$Unit->List]; - }; - $count += @{$info{Tests}}; - push @cache, \%info if @{$info{Tests}}; - } - - $this->_Count($count); - $this->_Cache(\@cache); -} - -sub Count { - my ($this) = @_; - return $this->_Count; -} - -sub Run { - my $this = shift; - - die new IMPL::InvalidOperationException("You must call the prepare method before running the plan") unless $this->_Cache; - - $this->_Tell(RunPlan => $this); - - my @resultsTotal; - - foreach my $info ($this->_Cache) { - $this->_Tell(RunUnit => $info->{Unit}); - - my $data; - undef $@; - eval { - $data = $info->{Unit}->StartUnit; - }; - - my @results; - - if (not $@) { - - foreach my $test (@{$info->{Tests}}) { - my $name = $test->Name; - - #protected creation of the test - $test = eval { $info->{Unit}->new($test); } || new IMPL::Test::BadUnit( - $info->{Unit}->can('UnitName') ? - $info->{Unit}->UnitName : - $info->{Unit}, - "Failed to construct the test $name", - $@ - ); - - # invoke the test - $this->_Tell(RunTest => $test); - my $result = $test->Run($data); - $this->_Tell(EndTest => $test,$result); - - push @results,$result; - } - } else { - my $e = $@; - my $badTest = new IMPL::Test::BadUnit( - $info->{Unit}->can('UnitName') ? - $info->{Unit}->UnitName : - $info->{Unit}, - "Failed to initialize the unit", - $@ - ); - foreach my $test (@{$info->{Tests}}) { - - $this->_Tell(RunTest => $badTest); - my $result = new IMPL::Test::Result( - Name => $test->Name, - State => IMPL::Test::Result::FAIL, - Exception => $e - ); - $this->_Tell(EndTest => $badTest,$result); - push @results,$result; - } - } - - eval { - $info->{Unit}->FinishUnit($data); - }; - - undef $@; - - push @resultsTotal, { Unit => $info->{Unit}, Results => \@results}; - - $this->_Tell(EndUnit => $info->{Unit},\@results); - } - - $this->Results(\@resultsTotal); - $this->_Tell(EndPlan => $this); -} - -sub _Tell { - my ($this,$what,@args) = @_; - - $_->$what(@args) foreach $this->Listeners; -} - -sub SaveXML { - my ($this,$out) = @_; - - my $h; - - if (ref $out eq 'GLOB') { - $h = $out; - } elsif ($out and not ref $out) { - open $h, ">", $out or die new IMPL::Exception("Failed to open file",$out); - } else { - die new IMPL::InvalidOperationException("Invalid output specified"); - } - - my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); - $s->Serialize($h,$this); -} - -sub LoadXML { - my ($self,$in) = @_; - - my $h; - - if (ref $in eq 'GLOB') { - $h = $in; - } elsif ($in and not ref $in) { - open $h, ">", $in or die new IMPL::Exception("Failed to open file",$in); - } else { - die new IMPL::InvalidOperationException("Invalid input specified"); - } - - my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); - return $s->Deserialize($h); -} - -sub xml { - my $this = shift; - my $str = ''; - - open my $h,'>',\$str or die new IMPL::Exception("Failed to create stream"); - $this->SaveXML($h); - undef $h; - return $str; -} - -sub LoadXMLString { - my $self = shift; - my $str = shift; - - open my $h,'<',\$str or die new IMPL::Exception("Failed to create stream"); - return $self->LoadXML($h); -} - - -1;
--- a/Lib/IMPL/Test/Result.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::Test::Result; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); -use IMPL::Class::Property; - -__PACKAGE__->PassThroughArgs; - -use constant { - SUCCESS => 0, - FAIL => 1, - ERROR => 2 -}; - -BEGIN { - public property Name => prop_all; - public property State => prop_all; - public property Exception => prop_all; - public property TimeExclusive => prop_all; - public property TimeInclusive => prop_all; -} - -sub CTOR { - my ($this) = @_; - - $this->TimeInclusive(0) unless defined $this->TimeInclusive; - $this->TimeExclusive(0) unless defined $this->TimeExclusive; -} - - -1;
--- a/Lib/IMPL/Test/SkipException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -package IMPL::Test::SkipException; - -use parent qw(IMPL::Test::FailException); - -__PACKAGE__->PassThroughArgs; - -1; -
--- a/Lib/IMPL/Test/Straps/ShellExecutor.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::Test::Straps::ShellExecutor; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Serializable); - -if ($^O =~ /win32/i) { - require Win32::Console; -} - -sub Execute { - my ($this,$file) = @_; - - my $h; - - if ($^O =~ /win32/i) { - Win32::Console::OutputCP(65001); - unless ( open $h,'-|',$file ) { - return undef; - } - binmode $h,':encoding(utf-8)'; - } else { - unless ( open $h,'-|',$file ) { - return undef; - } - } - - return $h; -} - - -1;
--- a/Lib/IMPL/Test/TAPListener.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -package IMPL::Test::TAPListener; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Serializable); -use IMPL::Class::Property; -use IMPL::Test::Result; - -BEGIN { - private property _Output => prop_all; - private property _testNo => prop_all; -} - -sub CTOR { - my ($this,$out) = @_; - - $this->_Output($out || *STDOUT); - $this->_testNo(1); -} - -sub RunPlan { - my ($this,$plan) = @_; - - my $out = $this->_Output; - - print $out "1..",$plan->Count,"\n"; -} - -sub EndPlan { - -} - -sub RunUnit { - my ($this,$unit) = @_; - - my $out = $this->_Output; - - print $out "#\n",join("\n",map "# $_", split /\n/, "Running unit: " . $unit->UnitName, ),"\n#\n"; -} - -sub EndUnit { - -} - -sub RunTest { - -} - -sub EndTest { - my ($this,$test,$result) = @_; - - my $out = $this->_Output; - my $n = $this->_testNo; - - $this->_testNo($n+1); - - print $out ( - $result->State == IMPL::Test::Result::SUCCESS ? - "ok $n " . join("\n# ", split(/\n/, $result->Name) ) - : - (eval { $result->Exception->isa('IMPL::Test::SkipException') } ? "ok $n #SKIP: " : "not ok $n ") . join("\n# ", split(/\n/, $result->Name.": ".$result->Exception || '') ) - ),"\n"; - -} - -sub save { - -} - -1;
--- a/Lib/IMPL/Test/Unit.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ -package IMPL::Test::Unit; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use Time::HiRes qw(gettimeofday tv_interval); - -use Error qw(:try); -use Carp qw(carp); -use File::Spec(); -use IMPL::Test::Result(); -use IMPL::Test::FailException(); -use IMPL::Exception(); - -BEGIN { - public property Name => prop_all; - public property Code => prop_all; -} - -sub CTOR { - my ($this,$info) = @_; - - die new IMPL::InvalidArgumentException("TestInfo should be supplied as an argument") unless $info; - - $this->Name($info->Name || 'Annon'); - $this->Code($info->Code)or die new IMPL::InvalidOperationException("Can't create test without entry point"); -} - -sub UnitName { - my ($self) = @_; - $self->toString; -} - -sub Cleanup { - my ($this,$session) = @_; - - $session->{$_} = $this->$_() foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1); - - 1; -} - -sub StartUnit { - my $class = shift; - - return {}; -} - -sub InitTest { - my ($this,$session) = @_; - - $this->$_($session->{$_}) foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1); -} - -sub FinishUnit { - my ($class,$session) = @_; - - 1; -} - -sub List { - my $self = shift; - - return $self->get_meta('IMPL::Test::Unit::TestInfo',undef,1); # deep search with no criteria -} - -sub Run { - my ($this,$session) = @_; - - my $t = [gettimeofday]; - return try { - $this->InitTest($session); - my $code = $this->Code; - - - my $t0 = [gettimeofday]; - my $elapsed; - - try { - $this->$code(); - $elapsed = tv_interval ( $t0 ); - } finally { - # we need to call Cleanup anyway - $this->Cleanup($session); - }; - - return new IMPL::Test::Result( - Name => $this->Name, - State => IMPL::Test::Result::SUCCESS, - TimeExclusive => $elapsed, - TimeInclusive => tv_interval ( $t ) - ); - } catch IMPL::Test::FailException with { - my $e = shift; - return new IMPL::Test::Result( - Name => $this->Name, - State => IMPL::Test::Result::FAIL, - Exception => $e, - TimeInclusive => tv_interval ( $t ) - ); - } otherwise { - my $e = shift; - return new IMPL::Test::Result( - Name => $this->Name, - State => IMPL::Test::Result::ERROR, - Exception => $e, - TimeInclusive => tv_interval ( $t ) - ); - } -} - -sub GetResourceFile { - my ($this,@path) = @_; - - my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); - return File::Spec->catfile($cwd,@path); -} - -sub GetResourceDir { - my ($this,@path) = @_; - - my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); - return File::Spec->catdir($cwd,@path); -} - -package IMPL::Test::Unit::TestInfo; -use parent qw(IMPL::Object::Meta); -use IMPL::Class::Property; - -require IMPL::Exception; - -BEGIN { - public property Name => prop_all; - public property Code => prop_all; -} - -sub CTOR { - my ($this,$name,$code) = @_; - - $this->Name($name); - $this->Code($code) or die new IMPL::InvalidArgumentException("The Code is a required parameter"); -} - -package IMPL::Test::Unit::SharedData; -use parent qw(IMPL::Object::Meta); -use IMPL::Class::Property; - -BEGIN { - public property DataList => prop_all | prop_list; -} - -sub CTOR { - my $this = shift; - - $this->DataList(\@_); -} -1;
--- a/Lib/IMPL/Transform.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -package IMPL::Transform; -use strict; - -use parent qw(IMPL::Object); - -use IMPL::lang qw(:declare); - - -BEGIN { - public _direct property templates => PROP_ALL; - public _direct property default => PROP_ALL; - public _direct property plain => PROP_ALL; - private _direct property _cache => PROP_ALL; -} - -sub CTOR { - my $this = shift; - my $args = @_ == 1 ? shift : { @_ }; - - $this->{$plain} = delete $args->{-plain}; - $this->{$default} = delete $args->{-default}; - - $this->{$templates} = $args; -} - -sub Transform { - my ($this,$object,@args) = @_; - - if (not ref $object) { - die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$plain}; - my $template = $this->{$plain}; - return $this->$template($object,@args); - } else { - - my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object); - - return $this->ProcessTemplate($template,$object,@args); - } -} - -sub MatchTemplate { - my ($this,$object) = @_; - my $class = $this->GetClassForObject( $object ); - - if (my $t = $this->{$_cache}->{$class} ) { - return $t; - } else { - $t = $this->{$templates}->{$class}; - - return $this->{$_cache}->{$class} = $t if $t; - - { - no strict 'refs'; - - my @isa = @{"${class}::ISA"}; - - while (@isa) { - my $sclass = shift @isa; - - $t = $this->{$templates}->{$sclass}; - - #cache and return - return $this->{$_cache}->{$class} = $t if $t; - - push @isa, @{"${sclass}::ISA"}; - } - ; - }; - } -} - -sub ProcessTemplate { - my ($this,$t,$obj,@args) = @_; - - return $this->$t($obj,@args); -} - -sub GetClassForObject { - my ($this,$object) = @_; - - return ref $object; -} - -package IMPL::Transform::NoTransformException; -use IMPL::declare { - base => { - 'IMPL::Exception' => sub { 'No transformation', @_ } - } -}; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Transform> - преобразование объектной структуры - -=head1 SYNOPSIS - -=begin code - -my $obj = new AnyObject; - -my $t = new Transform ( - SomeClass => sub { - my ($this,$object) = @_; - return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) }) - }, - DocClass => sub { - my ($this,$object) = @_; - return new DocPreview(Author => $object->Author, Text => $object->Data); - }, - -default => sub { - my ($this,$object) = @_; - return $object; - }, - -plain => sub { - my ($this,$object) = @_; - return $object; - } -); - -my $result = $t->Transform($obj); - -=end code - -=head1 DESCRIPTION - -Преобразование одного объекта к другому, например даных к их представлению. - -=cut
--- a/Lib/IMPL/TypeKeyedCollection.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -package IMPL::TypeKeyedCollection; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::lang; -use IMPL::declare { - require => { - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - _items => PROP_RW | PROP_DIRECT, - _cache => PROP_RW | PROP_DIRECT, - _reverse => PROP_RW | PROP_DIRECT - ] -}; - -sub CTOR { - my ($this,$items,$reverse) = @_; - - $items = {} - unless ref($items) eq 'HASH'; - - $this->{$_items} = $items; - $this->{$_reverse} = $reverse; -} - -sub Get { - my ($this,$type) = @_; - - die ArgException->new(type => 'Invalid type', $type) - if not $type or ref($type); - - if(my $val = $this->{$_cache}{$type}) { - return $val; - } else { - if ($this->_reverse) { - my $val = $this->{$_items}{$type}; - - unless(defined $val) { - my $matching; - while ( my ($k,$v) = each %{$this->{$_items}}) { - if (isclass($k,$type) && (not($matching) || isclass($k,$matching)) ) { - $matching = $k; - $val = $v; - } - } - } - - return $this->{$_cache}{$type} = $val; - - } else { - no strict 'refs'; - - my @isa = $type; - - while (@isa) { - my $sclass = shift @isa; - - $val = $this->{$_items}{$sclass}; - - return($this->{$_cache}{$type} = $val) - if defined $val; # zeroes and empty strings are also valid - - push @isa, @{"${sclass}::ISA"}; - } - return; - } - } -} - -sub Set { - my ($this,$type,$value) = @_; - - die ArgException->new(type => 'Invalid type', $type) - if not $type or ref($type); - - $this->{$_items}{$type} = $value; - - delete $this->{$_cache}; - - return $value; -} - -sub Delete { - my ($this,$type) = @_; - - if(defined delete $this->{$_items}{$type} ) { - delete $this->{$_cache}; - return 1; - } - return; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::TypeKeyedCollection> - коллекция, ключами которой являются типы. - -=head1 SYNOPSIS - -=begin code - -package Foo; - -package Bar; -our @ISA = qw(Foo); - -package Baz; -our @ISA = qw(Foo); - -package main; -use IMPL::require { - TypeKeyedCollection => 'IMPL::TypeKeyedCollection' -}; - -my $col = TypeKeyedCollection->new({ - Foo => 'base', - Bar => 'BAAAR' -}); - -print $col->Get('Foo'); # 'base' -print $col->Get('Bar'); # 'BAAAR' -print $col->Get('Baz'); # 'base' - -=end code - -=head1 DESCRIPTION - -Использует иерархию классов для определения наиболее подходяжего значения в -коллекции. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Application.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -package IMPL::Web::Application; -use strict; -use warnings; - -use CGI; -use Carp qw(carp); -use IMPL::Const qw(:prop); - -use IMPL::declare { - require => { - Locator => 'IMPL::Web::AutoLocator', - TAction => 'IMPL::Web::Application::Action', - HttpResponse => 'IMPL::Web::HttpResponse', - TFactory => '-IMPL::Object::Factory', - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - InvalidOperationException => '-IMPL::InvalidOperationException', - Loader => 'IMPL::Code::Loader' - }, - base => [ - 'IMPL::Config' => '@_', - 'IMPL::Object::Singleton' => undef - ], - props => [ - baseUrl => PROP_RW, - actionFactory => PROP_RW, - handlers => PROP_RW | PROP_LIST, - securityFactory => PROP_RW, - output => PROP_RW, - location => PROP_RO, - _handler => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - die IMPL::InvalidArgumentException->new( "handlers", - "At least one handler should be supplied" ) - unless $this->handlers->Count; - - $this->baseUrl('/') unless $this->baseUrl; - - $this->actionFactory(TAction) unless $this->actionFactory; - $this->location(Locator->new(base => $this->baseUrl)); -} - -sub CreateSecurity { - my $factory = shift->securityFactory; - return $factory ? $factory->new() : undef; -} - -sub ProcessRequest { - my ($this,$q) = @_; - - die ArgException->new(q => 'A query is required') - unless $q; - - my $handler = $this->_handler; - unless ($handler) { - $handler = _ChainHandler( $_, $handler ) foreach $this->handlers; - $this->_handler($handler); - } - - my $action = $this->actionFactory->new( - query => $q, - application => $this, - ); - - eval { - my $result = $handler->($action); - - die InvalidOperationException->new("Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted.") - unless eval { $result->isa(HttpResponse) }; - - $result->PrintResponse( $this->output ); - }; - - $action->Dispose(); - - if ($@) { - my $e = $@; - - HttpResponse->InternalError( - type => 'text/plain', - charset => 'utf-8', - body => $e - )->PrintResponse( $this->output ); - - } -} - -sub _ChainHandler { - my ( $handler, $next ) = @_; - - if ( ref $handler eq 'CODE' ) { - return sub { - my ($action) = @_; - return $handler->( $action, $next ); - }; - } - elsif ( eval { $handler->can('Invoke') } ) { - return sub { - my ($action) = @_; - return $handler->Invoke( $action, $next ); - }; - } - elsif ( eval { $handler->isa(TFactory) } ) { - return sub { - my ($action) = @_; - my $inst = $handler->new(); - return $inst->Invoke( $action, $next ); - } - } - elsif ( $handler - and not ref $handler - and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/ ) - { - my $class = $2; - if ( not $1 ) { - Loader->safe->Require($class); - die IMPL::InvalidArgumentException->( - "An invalid handler supplied", $handler - ) unless $class->can('Invoke'); - } - - return sub { - my ($action) = @_; - my $inst = $class->new(); - return $inst->Invoke( $action, $next ); - }; - } - else { - die new IMPL::InvalidArgumentException( "An invalid handler supplied", - $handler ); - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application> Базовай класс для веб-приложения - -=cut
--- a/Lib/IMPL/Web/Application/Action.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,227 +0,0 @@ -package IMPL::Web::Application::Action; -use strict; - -use Carp qw(carp); -use URI; -use JSON; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::Web::CGIWrapper(); -use IMPL::declare { - require => { - Disposable => '-IMPL::Object::Disposable', - HttpResponse => 'IMPL::Web::HttpResponse' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Disposable' => undef - ], - props => [ - application => PROP_RW, - security => PROP_RW, - query => PROP_RO, - context => PROP_RW, - _jsonData => PROP_RW, - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->context({}); - $this->security($this->application->CreateSecurity()); -} - -sub cookie { - my ($this,$name,$rx) = @_; - - $this->_launder(scalar( $this->query->cookie($name) ), $rx ); -} - -sub header { - my ($this,$header) = @_; - - $this->query->https ? $this->query->https($header) : $this->query->http($header); -} - -sub isSecure { - shift->query->https ? 1 : 0; -} - -sub isJson { - return shift->contentType =~ m{^application/json} ? 1 : 0; -} - -sub param { - my ($this,$name,$rx) = @_; - - my $value; - - if ( - $this->requestMethod eq 'GET' - or - $this->contentType eq 'multipart/form-data' - or - $this->contentType eq 'application/x-www-form-urlencoded' - ) { - $value = scalar( $this->query->param($name) ); - } else { - $value = scalar( $this->query->url_param($name) ); - } - - $this->_launder($value, $rx ); -} - -sub urlParam { - my ($this,$name,$rx) = @_; - - $this->_launder(scalar( $this->query->url_param($name) ), $rx); -} - -sub urlParams { - shift->query->url_param(); -} - -sub rawData { - my ($this, $decode) = @_; - - local $IMPL::Web::CGIWrapper::NO_DECODE = $decode ? 0 : 1; - if ($this->requestMethod eq 'POST') { - return $this->query->param('POSTDATA'); - } elsif($this->requestMethod eq 'PUT') { - return $this->query->param('PUTDATA'); - } -} - -sub jsonData { - my ($this) = @_; - - if ($this->isJson ) { - my $data = $this->_jsonData; - unless($data) { - $data = JSON->new()->decode($this->rawData('decode encoding')); - $this->_jsonData($data); - } - - return $data; - } - - return; -} - -sub requestMethod { - my ($this) = @_; - return $this->query->request_method; -} - -sub contentType { - return shift->query->content_type(); -} - -sub pathInfo { - my ($this) = @_; - return $this->query->path_info; -} - -sub baseUrl { - my ($this) = @_; - - return $this->query->url(-base => 1); -} - -sub applicationUrl { - shift->application->baseUrl; -} - -sub applicationFullUrl { - my ($this) = @_; - - return URI->new_abs($this->application->baseUrl, $this->query->url(-base => 1)); -} - -# creates an url that contains server, schema and path parts -sub CreateFullUrl { - my ($this,$path) = @_; - - return $path ? URI->new_abs($path,$this->applicationFullUrl) : $this->applicationFullUrl; -} - -# creates an url that contains only a path part -sub CreateAbsoluteUrl { - my ($this,$path) = @_; - - return $path ? URI->new_abs($path,$this->applicationUrl) : $this->applicationUrl; -} - -sub Redirect { - my ($this,$path) = @_; - return HttpResponse->Redirect( - location => $this->CreateFullUrl($path) - ); -} - -sub _launder { - my ($this,$value,$rx) = @_; - - if ( $value ) { - if ($rx) { - if ( my @result = ($value =~ m/$rx/) ) { - return @result > 1 ? \@result : $result[0]; - } else { - return; - } - } else { - return $value; - } - } else { - return; - } -} - -sub Dispose { - my ($this) = @_; - - $this->security->Dispose() - if $this->security and $this->security->can('Dispose'); - - $_->Dispose() foreach grep is($_,Disposable), values %{$this->context}; - - $this->next::method(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Action> - Обертка вокруг C<CGI> запроса. - -=head1 DESCRIPTION - -C<[Infrastructure]> -Свзяывет CGI запрос, приложение, орабатывающее его и ответ, который будет отправлен клиенту. - -=head1 MEMBERS - -=head2 C<CTOR(%args)> - -Инициализирует новый экземпляр. Именованными параметрами передаются значения -свойств. - -=head2 C< [get]application> - -Экземпляр приложения создавшего текущий объект - -=item C< [get] query > - -Экземпляр C<CGI> запроса - -=back - - -=cut
--- a/Lib/IMPL/Web/Application/HttpResponseResource.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -package IMPL::Web::Application::HttpResponseResource; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - HttpResponse => 'IMPL::Web::HttpResponse' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Web::Application::ResourceInterface' => undef - ], - props => [ - response => PROP_RW - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->response($args{response} || HttpResponse->NoContent); -} - -sub FetchChildResource { - return shift; -} - -sub InvokeHttpVerb { - return shift->response; -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Web/Application/Resource.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,402 +0,0 @@ -package IMPL::Web::Application::Resource; -use strict; - -use constant { - ResourceClass => __PACKAGE__ -}; -use Scalar::Util qw(blessed); - -use IMPL::lang qw(:hash :base); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException', - NotFoundException => 'IMPL::Web::NotFoundException', - ResourceInterface => '-IMPL::Web::Application', - HttpResponse => 'IMPL::Web::HttpResponse', - HttpResponseResource => 'IMPL::Web::Application::HttpResponseResource', - Loader => 'IMPL::Code::Loader' - }, - base => [ - 'IMPL::Web::Application::ResourceBase' => '@_' - ], - props => [ - access => PROP_RW, - verbs => PROP_RW, - children => PROP_RW - ] -}; - -__PACKAGE__->static_accessor(verbNames => [qw(get post put delete options head)]); -__PACKAGE__->static_accessor(httpMethodPrefix => 'Http'); - -sub CTOR { - my ($this, %args) = @_; - - my %verbs; - my $httpPrefix = $this->httpMethodPrefix; - - foreach my $verb (@{$this->verbNames}) { - my $method = exists $args{$verb} ? $args{$verb} : $this->can($httpPrefix . ucfirst($verb)); - $verbs{$verb} = $method - if $method; - } - - hashApply(\%verbs,$args{verbs}) - if ref($args{verbs}) eq 'HASH' ; - - $this->children($args{children} || $this->GetChildResources()); - - $this->access($args{access}) - if $args{access}; - - $this->verbs(\%verbs); -} - -sub _isInvokable { - my ($this,$method) = @_; - - return - (blessed($method) and $method->can('Invoke')) || - ref($method) eq 'CODE' -} - -sub _invoke { - my ($this,$method,@args) = @_; - - if(blessed($method) and $method->can('Invoke')) { - return $method->Invoke($this,@args); - } elsif(ref($method) eq 'CODE' || (not(ref($method)) and $this->can($method))) { - return $this->$method(@args); - } else { - die OpException->new("Can't invoke the specified method: $method"); - } -} - -sub HttpGet { - shift->model; -} - -sub AccessCheck { - my ($this,$verb) = @_; - - $this->_invoke($this->access,$verb) - if $this->access; -} - -sub Fetch { - my ($this,$childId) = @_; - - my $children = $this->children - or die NotFoundException->new( $this->location->url, $childId ); - - if (ref($children) eq 'HASH') { - if(my $child = $children->{$childId}) { - return $this->_isInvokable($child) ? $this->_invoke($child, $childId) : $child; - } else { - die NotFoundException->new( $this->location->url, $childId ); - } - } elsif($this->_isInvokable($children)) { - return $this->_invoke($children,$childId); - } else { - die OpException->new("Invalid resource description", $childId, $children); - } -} - -sub FetchChildResource { - my ($this,$childId) = @_; - - my $info = $this->Fetch($childId); - - return $info - if (is($info,ResourceInterface)); - - $info = { - response => $info, - class => HttpResponseResource - } - if is($info,HttpResponse); - - return $this->CreateChildResource($info, $childId) - if ref($info) eq 'HASH'; - - die OpException->new("Invalid resource description", $childId, $info); -} - -sub CreateChildResource { - my ($this,$info, $childId) = @_; - - my $params = hashApply( - { - parent => $this, - id => $childId, - request => $this->request, - class => ResourceClass - }, - $info - ); - - $params->{model} = $this->_invoke($params->{model}) - if $this->_isInvokable($params->{model}); - - my $factory = Loader->default->Require($params->{class}); - - return $factory->new(%$params); -} - -sub GetChildResources { - return {}; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Resource> - Ресурс C<REST> веб приложения - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Resource => 'IMPL::Web::Application::Resource', - Security => 'IMPL::Security', - NotFoundException => 'IMPL::Web::NotFoundException', - ForbiddenException => 'IMPL::Web::ForbiddenException' -}; - -my $model = Resource->new( - get => sub { }, - verbs => { - # non-standart verbs placed here - myverb => sub { } - }, - #child resources can be a hash - children => { - user => { - # a resource class may be specified optionally - # class => Resource, - model => sub { - return Security->principal - }, - # the default get implementation is implied - # get => sub { shift->model }, - access => sub { - my ($this,$verb) = @_; - die ForbiddenException->new() - if Security->principal->isNobody - } - }, - catalog => { - get => sub { - my $ctx = shift->application->ConnectDb()->AutoPtr(); - - return $ctx->products->find_rs({ in_stock => 1 }); - }, - # chid resource may be created dynamically - children => sub { - # binds model against the parent reource and id - my ($this,$id) = @_; - - ($id) = ($id =~ /^(\w+)$/) - or die NotFoundException->new($id); - - my $ctx = shift->application->ConnectDb()->AutoPtr(); - - my $item = $ctx->products->fetch($id); - - die NotFoundException->new() - unless $item; - - # return parameters for the new resource - return { - model => $item, - get => sub { shift->model } - }; - } - }, - # dynamically binds whole child resource. The result of binding is - # the new resource or a hash with arguments to create one - posts => sub { - my ($this,$id) = @_; - - # this approach can be used to create a dynamic resource relaying - # on the type of the model - - return Resource->new( - id => $id, - parent => $this, - get => sub { shift->model } - ); - - # ditto - # parent and id will be mixed in automagically - # return { get => sub { shift->model} } - }, - post_only => { - get => undef, # remove GET verb implicitly - post => sub { - my ($this) = @_; - } - } - } -); - -=end code - -Альтернативный вариант для создания класса ресурса. - -=begin code - -package MyResource; - -use IMPL::declare { - require => { - ForbiddenException => 'IMPL::Web::ForbiddenException' - }, - base => [ - 'IMPL::Web::Application::Resource' => '@_' - ] -}; - -sub ds { - my ($this) = @_; - - $this->context->{ds} ||= $this->application->ConnectDb(); -} - -sub InvokeHttpVerb { - my $this = shift; - - $this->ds->Begin(); - - my $result = $this->next::method(@_); - - # in case of error the data context will be disposed and the transaction - # will be reverted - $this->ds->Commit(); - - return $result; -} - -# this method is inherited by default -# sub HttpGet { -# shift->model -# -# } - -sub HttpPost { - my ($this) = @_; - - my %data = map { - $_, - $this->request->param($_) - } qw(name description value); - - die ForbiddenException->new("The item with the scpecified name can't be created'") - if(not $data{name} or $this->ds->items->find({ name => $data{name})) - - $this->ds->items->insert(\%data); - - return $this->NoContent(); -} - -sub Fetch { - my ($this,$childId) = @_; - - my $item = $this->ds->items->find({name => $childId}) - or die NotFoundException->new(); - - # return parameters for the child resource - return { model => $item, role => "item food" }; -} - -=end code - -=head1 MEMBERS - -=head2 C<[get,set]verbs> - -Хеш с C<HTTP> методами. При попытке вызова C<HTTP> метода, которого нет в этом -хеше приводит к исключению C<IMPL::Web::NotAllowedException>. - -=head2 C<[get,set]access> - -Метод для проверки прав доступа. Если не задан, то доспуп возможен для всех. - -=head2 C<[get,set]children> - -Дочерние ресурсы. Дочерние ресурсы могут быть описаны либо в виде хеша, либо -в виде метода. - -=head3 C<HASH> - -Данный хещ содержит в себе таблицу идентификаторов дочерних ресурсов и их -описаний. - -Описание каждого ресурса представляет собой либо функцию, либо параметры для -создания ресурса C<CraeteChildResource>. Если описание в виде функции, то она -должна возвращать либо объект типа ресурс либо параметры для его создания. - -=head3 C<CODE> - -Если дочерние ресурсы описаны в виде функции (возможно использовать имя метода -класса текущего ресурса), то для получения дочернего ресурса будет вызвана -функция с параметрами C<($this,$childId)>, где C<$this> - текущий ресурс, -C<$childId> - идентификатор дочернего ресурса, который нужно вернуть. - -Данная функция должна возвратить либо объект типа ресурс, либо ссылку на хеш с -параметрами для создания оного при помощи метода -C<CreateChildResource($params,$childId)>. - -=head2 C<[virtual]Fetch($childId)> - -Метод для получения дочернего ресурса. - -Возвращает параметры для создания дочернего ресурса, либо уже созданный ресурс. -Создание дочернего ресурса происходит при помощи метода C<CreateChildResource()> -который добавляет недостающие параметры к возвращенным в данным методом и -создает новый ресурс - -=head2 C<CreateChildResource($params,$id)> - -Создает новый дочерний ресурс с указанным идентификатором и параметрами. -Автоматически заполняет параметры - -=over - -=item * C<parent> - -=item * C<id> - -=item * C<request> - -=back - -Тип создаваемого ресурса C<IMPL::Web::Application::Resource>, либо указывается -в параметре C<class>. - -=head2 C<[virtual]HttpGet()> - -Реализует C<HTTP> метод C<GET>. По-умолчанию возвращает модель. - -Данный метод нужен для того, чтобы ресурс по-умолчанию поддерживал метод C<GET>, -что является самым частым случаем, если нужно изменить данное поведение, нужно: - -=over - -=item * Передать в параметр конструктора C<get> значение undef - -=item * Переопределить метод C<HttpGet> - -=item * При проверке прав доступа выдать исключение - -=back - -=cut -
--- a/Lib/IMPL/Web/Application/ResourceBase.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,262 +0,0 @@ -package IMPL::Web::Application::ResourceBase; -use strict; - -use URI; -use Carp qw(carp); -use IMPL::lang qw(:hash :base); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - OperationException => '-IMPL::InvalidOperationException', - NotAllowedException => 'IMPL::Web::NotAllowedException', - - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Web::Application::ResourceInterface' => undef - ], - props => [ - request => PROP_RO, - application => PROP_RO, - parent => PROP_RO, - model => PROP_RO, - id => PROP_RO, - location => PROP_RO, - role => PROP_RO | PROP_LIST - ] -}; - -sub CTOR { - my ( $this, %args ) = @_; - - die ArgumentException->new(request => 'A request object must be specified') - unless $args{request}; - - $this->request( $args{request} ); - $this->parent( $args{parent} ) if $args{parent}; - $this->model( $args{model} ) if $args{model}; - $this->id( $args{id} ) if $args{id}; - $this->application( $args{request}->application ); - -# если расположение явно не указано, то оно вычисляется автоматически, -# либо остается не заданным - $this->location( $args{location} - || eval { $this->parent->location->Child( $this->id ) } ); - - if (my $role = $args{role}) { - if (ref($role) eq 'ARRAY') { - $this->role($role); - } elsif (not ref($role)) { - $this->role(split(/\s+/, $role)); - } else { - die ArgumentException->new( role => 'A invalid value is provided, expected ARRAY or SCALAR'); - } - } -} - -sub InvokeHttpVerb { - my ( $this, $verb ) = @_; - - my $operation = $this->verbs->{ lc($verb) }; - - die NotAllowedException->new( - allow => join( ',', $this->GetAllowedMethods ) ) - unless $operation; - - $this->AccessCheck($verb); - my $request = $this->request; - -# в случае, когда один ресурс вызывает HTTP метод другого ресурса, нужно -# сохранить оригинальный resourceLocation - $request->context->{resourceLocation} ||= $this->location; - -# это свойство специфично только для REST приложений. -# сохранение текущего ресурса не повлечет за собой существенных расходов, -# т.к. они просто освободятся несколько позже. - if ( not $request->context->{resource} ) { - $request->context->{resource} = $this; - } - - return _InvokeDelegate( $operation, $this, $request ); -} - -sub security { - shift->request->security -} - -sub context { - shift->request->context -} - -sub verbs { - {} # возвращаем пстой список операций -} - -sub GetAllowedMethods { - map( uc, keys %{ shift->verbs } ); -} - -sub AccessCheck { - -} - -sub Seek { - my ($this, $role) = @_; - - my @roles; - - if (ref($role) eq 'ARRAY') { - @roles = @{$role}; - } elsif (not ref($role)) { - @roles = split(/\s+/, $role); - } else { - die ArgumentException->new( role => 'A invalid value is provided, expected ARRAY or SCALAR'); - } - - - for(my $r = $this; $r; $r = $r->parent) { - return $r if $r->HasRole(@roles); - } - return; -} - -sub HasRole { - my ($this, @roles) = @_; - my %cache = map { $_, 1 } @{$this->role}; - return scalar(grep not($cache{$_}), @roles) ? 0 : 1; -} - -sub _InvokeDelegate { - my $delegate = shift; - - return $delegate->(@_) if ref $delegate eq 'CODE'; - return $delegate->Invoke(@_) if eval { $delegate->can('Invoke') }; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Resource> - Web-ресурс. - -=head1 SYNOPSIS - -Класс для внутреннего использования. Объединяет в себе контракт и модель данных. -Основная задача - обработать поступающий от контроллера запрос на вызов C<HTTP> -метода. - -Экземпляры данного класса передаются в качестве параметров делегатам -осуществляющим привязку к модели в C<IMPL::Web::Application::ResourceContract> -и C<IMPL::Web::Application::OperationContract>. - -=head1 DESCRIPTION - -Весь функционал ресурса, поддерживаемые им C<HTTP> методы определяются -контрактом. Однако можно реализовывать ресурсы, которые не имеют контракта -или он отличается от того, что предоставляется стандартно -C<IMPL::Web::Application::ResourceContract>. - -Каждый ресурс является контейнером, тоесть позволяет получить дочерний ресурс -по идентифифкатору, если таковой имеется, тоесть ресурс, у которого нет дочерних -ресурсов на самом деле рассматривается как пустой контейнер. - -С ресурсом непосредственно взаимодействует котроллер запросов -C<IMPL::Web::Handler::RestController>, вызывая два метода. - -=over - -=item * C<FetchChildResource($childId)> - -Данный метод возвращает дочерний ресурс, соответствующий C<$childId>. -Текущая реализация использует метод C<FindChildResourceInfo> контракта текущего -ресурса, после чего создает дочерний ресурс. - -Если дочерний ресурс не найден, вызывается исключение -C<IMPL::Web::NotFoundException>. - -=item * C<InvokeHttpVerb($verb,$action)> - -Обрабатывает запрос к ресурсу. Для этого используется контракт ресурса, в -нем выбирается соответсвующий C<IMPL::Web::Application::OperationContract>. -Затем найденный контракт для указанной операции используется для обработки -запроса. - -=back - -Если объект реализует два вышеуказанных метода, он является веб-ресурсом, а -детали его реализации, котнракт и прочее уже не важно, поэтому можно реализовать -собственный класс ресурса, например унаследованный от -C<IMPL::Web::Application::CustomResource>. - -=head1 MEMBERS - -=head2 C<[get]request> - -Объект C<IMPL::Web::Application::Action> представляющий запрос к серверу. - -=head2 C<[get]application> - -Ссылка на приложение, к которому относится данный ресурс. Получается -автоматически из объекта запроса. - -=head2 C<[get]contract> - -Обязательное свойство для ресурса, ссылается, на контракт, соответствующий -данному ресурсу, используется для выполнения C<HTTP> методов и получения -дочерних ресурсов. - -=head2 C<[get]id> - -Обязательное свойство ресурса, идентифицирует его в родительском контейнере, -для корневого ресурса может иметь произвольное значение. - -=head2 C<[get]parent> - -Ссылка на родительский ресурс, для корневого ресурса не определена. - -=head2 C<[get]model> - -Ссылка на объект предметной области, представляемый данным ресурсом. Данное -свойство не является обязательным и может быть не задано. - -=head2 C<[get]location> - -Объект типа C<IMPL::Web::AutoLocator> или аналогичный описывающий адрес текущего -ресурса, может быть как явно передан при создании ресурса, так и вычислен -автоматически (только для ресурсов имеющих родителя). Следует заметить, что -адрес ресурса не содержит параметров запроса, а только путь. - -=head2 C<[get,list]role> - -Список ролей ресурса. Роль это условный маркер, который позволяет определить -функции выполняемые ресурсом, например контейнер, профиль пользователя и т.п. - -Используется при построении цепочек навигации, а также при поиске с использованием -метода C<seek>. - -=head2 C<seek($role)> - -Ищет ресурс в цепочке родителей (включая сам ресурс) с подходящими ролями. - -Роли могут быть переданы в виде массива или строки, где роли разделены пробелами - -=head2 C<[get]FetchChildResource($id)> - -Возвращает дочерний ресурс, по его идентификатору. - -Данная реализация использует контракт текущего ресурса для поиска информации о -дочернем ресурсе C<< $this->contract->FindChildResourceInfo($id) >>. - -Затем осуществляется привязка к моделе, тоесть, выполняется делегат, для -получения модели дочернего ресурса, а затем осуществляется привязка к контракту, -при этом в делегат, который должен вернуть контракт дочернего ресурса передаются -текущий ресурc и модель дочернего ресурса. - -=cut
--- a/Lib/IMPL/Web/Application/ResourceInterface.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ -package IMPL::Web::Application::ResourceInterface; -use strict; - -use IMPL::require { - Exception => 'IMPL::Exception', - NotImplException => '-IMPL::NotImplementedException' -}; - -sub InvokeHttpVerb { - die NotImplException->new(); -} - -sub FetchChildResource { - die NotImplException->new(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::ResourceInterface> - Интерфейс для Web-ресурса. - -=head1 SYNOPSIS - -=begin code - -package MyApp::Web::Resource; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - NotAllowedException => 'IMPL::Web::NotAllowedException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Web::Application::ResourceInterface' => undef - ], - props => [ - model => PROP_ALL - ] -}; - -sub InvokeHttpVerb { - my ($this,$verb,$action) = @_; - - if($verb eq 'GET') { - return $this->model; - } else { - die NotAllowedException->new(allow => 'GET'); - } -} - -sub FetchChildResource { - # no child resources - return; -} - -=end code - -=head1 DESCRIPTION - -Данный модуль объявляет только интерфейс, тоесть в нем есть заглушки для функций -которые необходимо реализовать. - -Для создания класса, который может быть использоваться для создания Web-ресурсов -нужно унаследовать данный интерфейс и реализовать его методы. - -=head1 MEMBERS - -=head2 C<InvokeHttpVerb($verb,$action)> - -Выполняет операцию над ресурсом и возвращает результат ее выполнения. -Результатом может быть произвольный объект, который будет передан по цепочке -обработчиков приложения для формирования ответа вервера, либо -C<IMPL::Web::HttpResponse>, который описывает (не обязательно полностью) ответ. -В любом случае результат будет передан далее в цепочку обработчиков и может -быть изменен. - -=head2 C<FetchChildResource($childId)> - -Используется для получения дочернего ресурса (который содержится в данном -контейнере). Метод должен возвращать либо Web-ресурс -C<IMPL::Web::Application::ResourceInterface>, либо C<undef> если дочерний ресурс -не найден. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/AutoLocator.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,241 +0,0 @@ -package IMPL::Web::AutoLocator; -use strict; - -use overload '""' => 'toString'; - -use IMPL::Const qw(:prop); -use IMPL::lang qw(:hash); -use IMPL::clone qw(clone); -use URI; -use URI::Escape; -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => '@_' - ], - props => [ - base => PROP_RO, - view => PROP_RW, - query => PROP_RW, - hash => PROP_RW - ] -}; - -sub Clone { - my $this = shift; - - return clone($this); -} - -sub Child { - my $this = shift; - my $child = shift or die ArgumentException->new("a child resource identifier is required"); - die ArgumentException->new("a child resource can't be a reference") if ref $child; - - # safe - #$child = uri_escape_utf8($child); - - my %args; - - $args{base} = $this->base =~ /\/$/ ? $this->base . $child : $this->base . '/' . $child; - $args{view} = $this->view if $this->view; - $args{hash} = $this->hash if $this->hash; - - if (@_) { - my $query = shift; - - $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; - } - - return $this->new(%args); -} - -sub Sibling { - my $this = shift; - my $child = shift or die ArgumentException->new("a child resource identifier is required"); - die ArgumentException->new("a child resource can't be a reference") if ref $child; - - # safe - #$child = uri_escape($child); - - my %args; - - if($this->base =~ /(.*?)(\/[^\/]*)?$/) { - $args{base} = join('/',$1,$child); - } else { - $args{base} = $child; - } - - $args{view} = $this->view if $this->view; - $args{hash} = $this->hash if $this->hash; - - if (@_) { - my $query = shift; - - $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; - } - - return $this->new(%args); - -} - -sub Query { - my ($this,$query) = @_; - - my %args; - - $args{base} = $this->base; - $args{view} = $this->view if $this->view; - $args{hash} = $this->hash if $this->hash; - $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; - - return $this->new(%args); -} - -sub SetView { - my ($this,$newView) = @_; - - $this->view($newView); - - return $this; -} - -sub url { - my ($this) = @_; - - my $url = URI->new($this->view ? $this->base . "." . $this->view : $this->base); - $url->query_form($this->query); - $url->fragment($this->hash); - - return $url; -} - -sub ToAbsolute { - my ($this,$baseUrl) = @_; - - return URI->new_abs( $this->url, $baseUrl ); -} - -sub toString { - shift->url->as_string(); -} - -sub AUTOLOAD { - our $AUTOLOAD; - - (my $method) = ($AUTOLOAD =~ m/(\w+)$/); - - return if $method eq 'DESTROY'; - - my $this = shift; - return $this->Child($method,@_); -} - - - -1; - -__END__ - -=head1 NAME - -C<IMPL::Web::AutoLocator> - Обертка вокруг адреса ресурса. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Locator => 'IMPL::Web::AutoLocator' -}; - -my $bugTracker = Locator->new(base => "http://myhost.org/bugzilla")->SetView("cgi"); - -my $bug = $bugTracker->show_bug({id = 1}); - -my $wikiPages = Locator->new(base => "http://myhost.org/wiki/bin/view"); - -my $page = $wiki->Main->HowTo; - -my $images = Locator->new(base => "http://static.myhost.org/images", view => "png"); - -my $editIco = $images->icons->small->edit; - -=end code - -=head1 DESCRIPTION - -Для удобстав навигации по ресурсам, полностью отражает классическую структуру -иерархически организованных ресурсов. позволяет гибко работать с параметрами -запроса и хешем. Для постоты чтения реализует метод C<AUTOLOAD> для доступа -к дочерним ресурсам. - -=head1 MEMBERS - -=head2 C<CTOR(%args)> - -Создает новый объект расположение. Позволяет задать путь, расширение, параметры -запроса и фрагмент ресурса. - -=over - -=item * C<base> - -Строка с базовым адресом для дочерних ресурсов. - -=item * C<view> - -Задает суфикс, обозначающий представление ресурса, аналогично расширению у -файлов. Данный суффикс может использоваться контроллером для выбора -представления ресурса. - -=item * C<query> - -Ссылка на хеш с параметрами запроса - -=item * C<hash> - -Часть C<uri> обозначающая фрагмент документа (все, что идет после символа C<#>). - -=back - -=head2 C<Child($child[,$query])> - -Получает расположение дочернего ресурса. При этом cоздается новый объект адреса ресурса. - -=head2 C<SetView($view)> - -Позволяет указать представление (расширение) у текущего адреса ресурса. Изменяет -представление и возвращает измененный адрес ресурса. - -=head2 C<[get]base> - -Базовый адрес, относительно которого будут получены дочерние ресурсы. - -=head2 C<[get,set]view> - -Представление для ресурсов, аналогично расширению у файлов. - -=head2 C<[get,set]query> - -Ссылка на хеш с параметрами для C<GET> запроса. - -=head2 C<[get,set]hash> - -Часть адреса ресурса, отвечающая за фрагмент. - -=head2 C<[get]url> - -Объект C<URI> для текущего адреса. - -=head2 C<AUTLOAD> - -Перенаправляет вызовы методов в метод C<Child> передавая первым параметром имя метода. - -=cut -
--- a/Lib/IMPL/Web/BadRequestException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::Web::BadRequestException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -use IMPL::Resources::Strings { - message => "The request could not be understood due to malformed syntax" -}; - -sub status { - "400 Bad Request"; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::BadRequestException> - 400 Bad Request - -=head1 DESCRIPTION - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/CGIApplication.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package IMPL::Web::CGIApplication; -use strict; - -use IMPL::declare { - require => { - CGIWrapper => 'IMPL::Web::CGIWrapper' - }, - base => [ - 'IMPL::Web::Application' => '@_' - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->output(\*STDOUT) unless $this->output; -} - -sub Run { - my ($this) = @_; - - my $query = CGIWrapper->new(); - - $query->charset('utf-8'); - - $this->ProcessRequest($query); -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Web/CGIWrapper.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ -package IMPL::Web::CGIWrapper; -use strict; - -use parent qw(CGI); -use Encode; - -our $NO_DECODE = 0; - -sub param { - my $this = shift; - - return $this->SUPER::param(@_) if $NO_DECODE; - - if (wantarray) { - my @result = $this->SUPER::param(@_); - - return map Encode::is_utf8($_) - ? $_ - : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result; - } - else { - my $result = $this->SUPER::param(@_); - - return Encode::is_utf8($result) - ? $result - : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC ); - } - -} - -sub upload { - my $this = shift; - - local $NO_DECODE = 1; - my $oldCharset = $this->charset(); - $this->charset('ISO-8859-1'); - - my $fh = $this->SUPER::upload(@_); - - $this->charset($oldCharset); - return $fh; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::CGIWrapper> - обетрка вокруг стандартного объекта C<CGI> - -=head1 DESCRIPTION - -Наследуется от C<CGI>, и переопределяет метод C<param> для декодирования -строковых параметров. В остальном функциональность аналогична стандартному -модулю C<CGI>. - -=head1 MEMBERS - -=head2 C<$NO_DECODE> - -Глобальная переменная для отключения декодирования параметров. - -=begin code - -{ - local $IMPL::Web::CGIWrapper::NO_DECODE = 1; - my $raw = $q->param('binary'); -} - -=end code - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/DOM/FileNode.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,193 +0,0 @@ -package IMPL::Web::DOM::FileNode; -use parent qw(IMPL::DOM::Node); - -__PACKAGE__->PassThroughArgs; - -use IMPL::Class::Property; -use File::Temp qw(tempfile); - -BEGIN { - public property parameterName => { - get => sub { - my ($this) = @_; - $this->_parameterName() or - $this->_parameterName( - join '/', ( map { - (defined $_->nodeProperty('instanceId')) ? - $_->nodeName . '['.$_->nodeProperty('instanceId').']': - $_->nodeName - } $this->_selectParents, $this ) - ); - } - }; - private property _parameterName => prop_all; - public property fileName => { - get => sub { - my ($this) = @_; - return $this->document->query->param($this->parameterName); - } - }; - public property fileHandle => { - get => sub { - my ($this) = @_; - return $this->document->query->upload($this->parameterName); - } - }; -} - -sub invokeTempFile { - my ($this,$sub,$target) = @_; - - die new IMPL::InvalidArgumentException("A reference to a function should be specified") unless $sub && ref $sub eq 'CODE'; - - $target ||= $this; - - my $query = $this->document->nodeProperty('query') or die new IMPL::InvalidOperationException("Failed to get a CGI query from the document"); - my $hFile = $query->upload($this->parameterName) or die new IMPL::IOException("Failed to open the uploaded file",$query->cgi_error,$this->parameterName,$this->nodeProperty('instanceId')); - - my ($hTemp,$tempFileName) = tempfile(); - binmode($hTemp); - - print $hTemp $_ while <$hFile>; - - $hTemp->flush(); - seek $hTemp, 0,0; - { - local $_ = $tempFileName; - $sub->($this,$tempFileName,$hTemp); - } -} - -sub _selectParents { - my ($node) = @_; - - my @result; - - unshift @result, $node while $node = $node->parentNode; - - return @result; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::DOM::FileNode> - узел, использующийся для представления параметра запроса в котором передан файл. - -=head1 SINOPSYS - -=begin code xml - -<!-- input.schema.xml --> -<schema> - <SimpleType type="file" nativeType="IMPL::Web::DOM::FileNode"/> - <ComplexNode name="user"> - <Node type="file" name="avatar"/> - </ComplexNode> -</schema> - -=end code xml - -=begin code - -# handle.pl -use IMPL::DOM::Transform::PostToDOM (); -use IMPL::DOM::Schema; -use CGI; -use File::Copy qw(copy); - -my $t = new IMPL::DOM::Transform::PostToDOM( - undef, - IMPL::DOM::Schema->LoadSchema('input.schema.xml'), - 'user' -); - -my $doc = $t->Transform(CGI->new()); - -if ($t->Errors->Count) { - # handle errors -} - -$doc->selectSingleNode('avatar')->invokeTempFile( - sub { - my($node,$fname,$fhandle) = @_; - - # do smth with file - copy($_,'avatar.jpg'); - - # same thing - # copy($fname,'avatar.jpg'); - } -); - -=end code - -=head1 DESCRIPTION - -Данный класс используется для представлении параметров C<CGI> запросов при преобзаовании -запроса в ДОМ документ преобразованием C<IMPL::DOM::Transform::PostToDOM>. - -Узлы данного типа расширяют стандатрный C<IMPL::DOM::Node> несколькими свойствами и -методами для доступа к файлу, переданному в виде параметра запроса. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get] parameterName> - -Имя параметра C<CGI> запроса соответствующего данному узлу. - -=item C<[get] fileName> - -Имя файла из параметра запроса - -=item C<[get] fileHandle> - -Указатель на файл из параметра запроса - -=back - -=head2 METHODS - -=over - -=item C<invokeTempFile($callback,$target)> - -Сохраняет файл, переданный в запросе во временный, вызывает C<$callback> для обработки временного файла. - -=over - -=item C<$callback> - -Ссылка на функцию которая будет вызвана для обработки временного файла. C<callback($target,$fname,$fhandle)> - -=over - -=item C<$fname> - -Имя временного файла - -=item C<$fhandle> - -Указатель на временный файл - -=back - -Также пременная C<$_> содержит имя временного файла. - -=item C<$target> - -Значение этого параметра будет передано первым параметром функции C<$callback>. - -=back - -=back - -=cut
--- a/Lib/IMPL/Web/Exception.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,60 +0,0 @@ -package IMPL::Web::Exception; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::AppException' => '@_' - ], - props => [ - headers => PROP_ALL - ] -}; - -sub status { - "500 Internal error"; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Exception> - Базовый класс для всех web-исключений, для ошибок вызванных -по вине клиента. - -=head1 SYNOPSIS - -Вызов исключения - -=begin code - -use IMPL::require { - WebException => 'IMPL::Web::Exception' -}; - -sub MyWebHandler { - # ... - - die WebException->new("something is wrong"); - - # ... -} - -=end code - -=head1 MEMBERS - -=head2 C<status()> - -Возвращает C<HTTP> код ошибки. Каждый класс иключений должен переопределить данный метод. - -=head2 C<[get,set]headers> - -Ссылка на хеш с параметрами заголовка. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/ForbiddenException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::Web::ForbiddenException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -use IMPL::Resources::Strings { - message => "You don't have access to this resource" -}; - -sub status { - "403 Forbidden" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::ForbiddenException> - операция не разрешается. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/ErrorHandler.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,127 +0,0 @@ -package IMPL::Web::Handler::ErrorHandler; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::Exception(); -use IMPL::declare { - require => { - WebException => 'IMPL::Web::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - IOException => '-IMPL::IOException', - HttpResponse => 'IMPL::Web::HttpResponse', - Security => 'IMPL::Security' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - }, - props => [ - errors => PROP_RW, - view => PROP_RW, - fallback => PROP_RW, - contentType => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - die ArgumentException->new("view") unless $this->view; - die ArgumentException->new("fallback") unless $this->fallback; - - $this->errors({}) unless $this->errors; - -} - -sub Invoke { - my ($this,$action,$next) = @_; - - undef $@; - my $result; - eval { - $result = $next ? $next->($action) : undef; - }; - - if (my $err = $@) { - - my $vars = { - error => $err, - result => $result, - request => sub { $action }, - app => $action->application, - location => $action->context->{resourceLocation}, - resource => $action->context->{resource}, - document => {}, - session => sub { Security->context }, - user => sub { Security->principal }, - security => sub { $action->security } - }; - - my $status = "500 Internal Server Error"; - - if (eval { $err->isa(WebException) }) { - $status = $err->status; - } - - my ($code) = ($status =~ m/^(\d+)/); - - my $text = $this->view->display( - $err, - $this->errors->{$code} || $this->fallback, - $vars - ); - - $result = HttpResponse->new( - status => $status, - type => $this->contentType, - charset => 'utf-8', - headers => eval{ $err->headers } || {}, - body => $text - ); - } - - return $result; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::ErrorHandler> - обертка для обработки исключений. - -=head1 SYNOPSIS - -Используется в цеопчке обработчиков приложения. - -=begin code xml - - <handlers type="ARRAY"> - <item type="IMPL::Web::Handler::ErrorHandler"> - <contentType>text/html</contentType> - <loader refid="tt-loader"/> - <errors type="HASH"> - <error extname="500">errors/500</error> - <error extname="404">errors/404</error> - <error extname="403">errors/403</error> - </errors> - <fallback>errors/500</fallback> - </item> - </handlers> - -=end code xml - -=head1 DESCRIPTION - -Позволяет создать представление для ресурса в случае ошибки, для этого -используется соответствие представлений и кодов ошибок. - -В результате обработчик либо прозрачно передает результат вышестоящего -обработчика нижестоящему, либо создает C<IMPL::Web::HttpResponse> с -соответствующим статусом и содержанием. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/JSONView.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,70 +0,0 @@ -package IMPL::Web::Handler::JSONView; -use strict; -use JSON; - -use IMPL::lang qw(is); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - HttpResponse => 'IMPL::Web::HttpResponse', - ViewResult => '-IMPL::Web::ViewResult', - Loader => 'IMPL::Code::Loader' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - transform => PROP_RW - ] -}; - -sub contentType { - 'application/json' -} - -sub Invoke { - my ($this,$action,$next) = @_; - - my $result = $next ? $next->($action) : undef; - - - my $model = ( ref $result and is($result,ViewResult) ) - ? $result->model - : $result; - - $model = [$model] unless ref $model; - - if (my $factory = $this->transform) { - Loader->safe->Require($factory) unless ref $factory; - my $t = $this->transform->new(); - $model = $t->Transform($model); - } - - my %params = ( - type => $this->contentType, - charset => 'utf-8', - body => JSON->new->utf8->pretty->encode($model) - ); - - if(is($result,ViewResult)) { - $params{status} = $result->status if $result->status; - $params{headers} = $result->headers if $result->headers; - $params{cookies} = $result->cookies if $result->cookies; - } - - return HttpResponse->new( - %params - ); -} - -1; - -__END__ - -=pod - -=head1 - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/LocaleHandler.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -package IMPL::Web::Handler::LocaleHandler; -use strict; - -use IMPL::Const qw(:prop); -use DateTime; -use IMPL::declare { - require => { - Resources => 'IMPL::Resources' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - props => [ - locales => PROP_RO | PROP_LIST, - default => PROP_RO, - cookie => PROP_RO - ] -}; - -sub Invoke { - my ($this,$action,$nextHandler) = @_; - - my $locale; - - if ($this->cookie and my $cookie = $action->cookie($this->cookie)) { - ($locale) = grep /^$cookie/i, $this->locales; - } - - unless($locale) { - my @matches; - - my $best = [$this->default,0]; - - if(my $header = $action->header('Accept-Language')) { - foreach my $part (split(/\s*,\s*/, $header)) { - my ($lang,$quality) = ($part =~ /([a-z]+(?:\-[a-z]+)*)(?:\s*;\s*q=(0\.[\d]+|1))?/i ); - - $quality ||=1; - - foreach my $tag ($this->locales) { - if ( $tag =~ m/^$lang/i ) { - push @matches, [$tag,$quality]; - } - } - } - - foreach my $match (@matches) { - if ($match->[1] > $best->[1]) { - $best = $match; - } - } - - } - - $locale = $best->[0]; - } - - if($locale) { - Resources->SetLocale($locale); - #$locale =~ tr/-/_/; - DateTime->DefaultLocale($locale); - } - - return $nextHandler->($action); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::LocaleHandler> - handles locale for the request - -=head1 SYNOPSIS - -=begin code xml - - <handlers type="ARRAY"> - <item type="IMPL::Web::Handler::LocaleHandler"> - <locales type="ARRAY"> - <item>en-US</item> - <item>ru-RU</item> - </locales> - <default>en-US</default> - <cookie>lang</cookie> - </item> - </handlers> - -=end code xml - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/RestController.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,148 +0,0 @@ -package IMPL::Web::Handler::RestController; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Locator => 'IMPL::Web::AutoLocator', - ResourceInterface => 'IMPL::Web::Application::ResourceInterface', - Exception => 'IMPL::Exception', - ArgumentExecption => '-IMPL::InvalidArgumentException', - NotFoundException => 'IMPL::Web::NotFoundException', - Loader => 'IMPL::Code::Loader' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - }, - props => [ - resourceFactory => PROP_RO, - trailingSlash => PROP_RO - ] -}; - -sub CTOR { - my ($this) = @_; - - die ArgumentException->new(resourceFactory => "A web-resource is required") - unless $this->resourceFactory; - #unless eval { $this->resourceFacotry->isa(ResourceInterface) }; - -} - -sub GetResourcePath { - my ($this,$action) = @_; - - my $pathInfo = $action->pathInfo; - my @segments; - - if (length $pathInfo) { - - @segments = split(/\//, $pathInfo, $this->trailingSlash ? -1 : 0); - - # remove first segment if it is empty - shift @segments if @segments && length($segments[0]) == 0; - } - - return @segments; -} - - -sub Invoke { - my ($this,$request) = @_; - - my $method = $request->requestMethod; - - my @segments = $this->GetResourcePath($request); - - my $factory = $this->resourceFactory; - - $factory = Loader->default->Require($factory) - unless ref($factory) || eval { $factory->can('new') }; - - my $res = $factory->new( - id => 'root', - request => $request, - location => Locator->new(base => $request->application->baseUrl), - ); - - while(@segments) { - my $id = shift @segments; - $res = $res->FetchChildResource($id); - } - - $res = $res->InvokeHttpVerb($method); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::RestController> - Обрабатывает C<HTTP> запрос передавая -его соответствующему ресурсу. - -=head1 SYNOPSIS - -Используется в конфигурации приложения как элемент цепочки обработчиков. -Как правило располагается на самом верхнем уровне. - -=begin code xml - - <handlers type="ARRAY"> - <item type="IMPL::Web::Handler::RestController"> - <resourceFactory>My::App::Web::RootResource</resourceFactory> - </item> - <item type="IMPL::Web::Handler::JSONView" /> - <item type="IMPL::Web::Handler::SecureCookie" /> - <item type="IMPL::Web::Handler::ErrorHandler" /> - </handlers> - -=end code xml - - -=head1 DESCRIPTION - -Использует C<PATH_INFO> для определения нужного ресурса, затем предает -найденному ресурсу управление для обработки запроса. - -Если ресурс не найден, то возникает исключение C<IMPL::Web::NotFoundException>. - -Для определения нужного ресурса контроллер разбивает C<PATH_INFO> на фрагменты -и использует каждый фрагмент для получения дочернего ресурса начиная с корневого. -Для чего используется метод -C<< IMPL::Web::Application::ResourceInterface->FetchChildResource($childId) >>. - -Дерево ресурсов сущестувет независимо от обрабатываемого запроса, однако оно -может полностью или частично загружаться в начале обработки запроса и -освобождаться по окончании обработки запроса. Поэтому при получении дочерних -ресурсов не участвует C<HTTP> запрос, он адресуется только последнему ресурсу. - -=begin text - -/music/audio.mp3 -> ['music','audio.mp3'] - -=end text - -=head1 MEMEBERS - -=head2 C<[get]resourceFactory> - -Фабрика для создания корневого ресурса приложения, полученный ресурс должен -реализовывать интерфейс C<IMPL::Web::Application::ResourceInterface>. - -Фабрика может сохранять ссылку на корневой ресурс и каждый раз не создавать -его, а возвращать уже существующий. Это вполне оправдано, если хранение -дерева ресурсов требует меньше ресурсов, чем его создание и при этом приложение -остается в памяти между C<HTTP> запросами. - -=head2 C<[get]trailingSlash> - -Если данная переменная имеет значение C<true>, то слеш в конце пути к ресурсу -будет интерпретироваться, как дочерний ресурс с пустым идентификатором. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/SecureCookie.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,201 +0,0 @@ -package IMPL::Web::Handler::SecureCookie; -use strict; - - -use Digest::MD5 qw(md5_hex); -use IMPL::Const qw(:prop); -use IMPL::Security::Auth qw(:Const GenSSID); -use IMPL::declare { - require => { - SecurityContext => 'IMPL::Security::Context', - User => 'IMPL::Security::Principal', - AuthSimple => 'IMPL::Security::Auth::Simple', - Exception => 'IMPL::Exception', - OperationException => '-IMPL::InvalidOperationException', - HttpResponse => '-IMPL::Web::HttpResponse' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - }, - props => [ - salt => PROP_RO, - _security => PROP_RW, - _cookies => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->salt('DeadBeef') unless $this->salt; -} - -sub ValidateCookie { - my ($this,$sid,$cookie,$sign) = @_; - - return 1 if $sid and $cookie and $sign and $sign eq md5_hex($this->salt,$sid,$cookie,$this->salt); - - return 0; -} - -sub AuthCookie { - my ($this,$sid,$cookie,$sign, $context) = @_; - - if (eval { $context->auth->isa(AuthSimple) }) { - my ($result,$challenge) = $context->auth->DoAuth($cookie); - return $result; - } - - return AUTH_FAIL; -} - -sub Invoke { - my ($this,$action,$nextHandler) = @_; - - return unless $nextHandler; - - my $context; - $this->_security($action->security); - - - my $sid = $action->cookie('sid',qr/(\w+)/); - my $cookie = $action->cookie('sdata',qr/(\w+)/); - my $sign = $action->cookie('sign',qw/(\w+)/); - - if ( $this->ValidateCookie($sid,$cookie,$sign) ) { - # TODO: add a DeferredProxy to deffer a request to a data source - if ( $context = $this->_security->sessions->GetById($sid) ) { - if ( eval { $context->auth->isa(AuthSimple) } ) { - my ($result,$challenge) = $context->auth->DoAuth($cookie); - - $context->authority($this); - - if ($result == AUTH_FAIL) { - $context = undef; - } - } else { - undef $context; - } - } - - } - - $context ||= SecurityContext->new(principal => User->nobody, authority => $this); - - my $httpResponse = eval { $context->Impersonate($nextHandler,$action); }; - my $e = $@; - - die $e if $e; - - die OperationException->new("A HttpResponse instance is expected") - unless ref $httpResponse && eval { $httpResponse->isa(HttpResponse) }; - - return $this->_WriteResponse($httpResponse); -} - -sub InitSession { - my ($this,$user,$roles,$auth,$challenge) = @_; - - my ($status,$answer); - - if ($auth) { - ($status,$answer) = $auth->DoAuth($challenge); - } else { - $status = AUTH_SUCCESS; - } - - die OperationException->new("This provider doesn't support multiround auth") - if ($status == AUTH_INCOMPLETE || $answer); - - if ($status == AUTH_SUCCESS) { - my $sid = GenSSID(); - my $cookie = GenSSID(); - - $this->_cookies({ - sid => $sid, - sdata => $cookie - }); - - my $context = $this->_security->sessions->Create({ - sessionId => $sid, - principal => $user, - auth => AuthSimple->Create(password => $cookie), - authority => $this, - rolesAssigned => $roles - }); - - $context->Apply(); - - } - - return $status; -} - -sub CloseSession { - my ($this) = @_; - if(my $session = SecurityContext->current) { - $this->_cookies({ - sid => undef, - sdata => undef - }) - } -} - -sub _WriteResponse { - my ($this,$response) = @_; - - if (my $data = $this->_cookies) { - - my $sign = $data->{sid} && md5_hex( - $this->salt, - $data->{sid}, - $data->{sdata}, - $this->salt - ); - - $response->cookies->{sid} = $data->{sid}; - $response->cookies->{sdata} = $data->{sdata}; - $response->cookies->{sign} = $sign; - } - - return $response; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::SecureCookie> - -=head1 DESCRIPTION - -Возобновляет сессию пользователя на основе информации переданной через Cookie. - -Использует механизм подписи информации для проверки верности входных данных перед -началом каких-либо действий. - -Данный обработчик возвращает результат выполнения следдующего обработчика. - - - -=head1 MEMBERS - -=head2 C<[get,set] salt> - -Скаляр, использующийся для подписи данных. - - -=head2 C<InitSession($user,$roles,$auth,$challenge)> - -Инициирует сессию, поскольку данный модуль отвечает за взаимодействие с клиентом -при проверки аутентификации, ему передаются данные аутентификации для -продолжения обмена данными с клиентом. Если создается новая сессия, по -инициативе веб-приложения, то C<$auth> должно быть пусто. - -=cut
--- a/Lib/IMPL/Web/Handler/View.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,323 +0,0 @@ -package IMPL::Web::Handler::View; -use strict; - -use Carp qw(carp); -use List::Util qw(first); -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Factory => 'IMPL::Web::View::ObjectFactory', - HttpResponse => 'IMPL::Web::HttpResponse', - Loader => 'IMPL::Code::Loader', - ViewResult => 'IMPL::Web::ViewResult', - Security => 'IMPL::Security' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - - props => [ - contentType => PROP_RO, - contentCharset => PROP_RO, - view => PROP_RO, - layout => PROP_RO, - selectors => PROP_RO, - defaultDocument => PROP_RW, - _selectorsCache => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->_selectorsCache([ map $this->ParseRule($_), @{$this->selectors || []} ]); -} - -sub Invoke { - my ( $this, $action, $next ) = @_; - - my $result = $next ? $next->($action) : undef; - - my $model; - if( ref $result and eval { $result->isa(ViewResult) } ) { - $model = $result->model; - } else { - $model = $result; - $result = ViewResult->new(model => $model); - } - - my $vars = { - result => $result, - request => sub { $action }, - app => $action->application, - location => $action->context->{resourceLocation}, - resource => $action->context->{resource}, - layout => $this->layout, - document => {}, - session => sub { Security->context }, - user => sub { Security->principal }, - security => sub { $action->security } - }; - - my %responseParams = ( - type => $this->contentType, - charset => $this->contentCharset, - body => $this->view->display( - $model, - $this->SelectView( $action, ref $model ), - $vars - ) - ); - - $responseParams{status} = $result->status if $result->status; - $responseParams{cookies} = $result->cookies if ref $result->cookies eq 'HASH'; - $responseParams{headers} = $result->headers if ref $result->headers eq 'HASH'; - - return HttpResponse->new( - %responseParams - ); -} - -sub SelectView { - my ($this,$action) = @_; - - my @path; - - for(my $r = $action->context->{resource}; $r ; $r = $r->parent ) { - unshift @path, { - name => $r->id, - class => typeof($r->model) - }; - } - - @path = map { name => $_}, split /\/+/, $action->query->path_info() - unless (@path); - - return $this->MatchPath(\@path,$this->_selectorsCache) || $this->defaultDocument; -} - -sub ParseRule { - my ($this, $rule) = @_; - - my ($selector,$data) = split /\s+=>\s+/, $rule; - - my @parts; - my $first = 1; - my $weight = 0; - foreach my $part ( split /\//, $selector ) { - # если первым символом является / - # значит путь в селекторе абсолютный и не нужно - # добавлять "любой" элемент в начало - - if($part) { - $weight ++; - push @parts,{ any => 1 } if $first; - } else { - push @parts,{ any => 1 } unless $first; - next; - } - - my ($name,$class) = split /@/, $part; - - if ( my ( $varName, $rx ) = ( $name =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) { - #this is a regexp - - push @parts, { - rx => $rx, - var => $varName, - class => $class, - }; - } else { - push @parts, { - name => length($name) ? $name : undef, - class => $class, - }; - } - } continue { - $first = 0; - } - - return { selector => \@parts, data => $data, weight => $weight }; -} - -sub MatchPath { - my ($this,$path,$rules) = @_; - - $path ||= []; - $rules ||= []; - - my @next; - - foreach my $segment (@$path) { - foreach my $rule (@$rules) { - my @selector = @{$rule->{selector}}; - - my $part = shift @selector; - - # if this rule doesn't have a selector - next unless $part; - - if ($part->{any}) { - #keep the rule for the next try - push @next, $rule; - - $part = shift @selector while $part->{any}; - } - - my $newRule = { - selector => \@selector, - data => $rule->{data}, - weight => $rule->{weight}, - vars => { %{$rule->{vars} || {}} } - }; - - my $success = 1; - if (my $class = $part->{class}) { - $success = isclass($segment->{class},$class); - } - - if($success && (my $name = $part->{name})) { - $success = $segment->{name} eq $name; - } elsif ($success && (my $rx = $part->{rx})) { - if( my @captures = ($segment->{name} =~ m/($rx)/) ) { - $newRule->{vars}->{$part->{var}} = \@captures - if $part->{var}; - } else { - $success = 0; - } - } - - push @next, $newRule if $success; - - } - $rules = [@next]; - undef @next; - } - - my $result = ( - sort { - $b->{weight} <=> $a->{weight} - } - grep { - scalar(@{$_->{selector}}) == 0 - } - @$rules - )[0]; - - if($result) { - my $data = $result->{data}; - $data =~ s/{(\w+)(?:\:(\d+))?}/ - my ($name,$index) = ($1,$2 || 0); - - if ($result->{vars}{$name}) { - $result->{vars}{$name}[$index]; - } else { - ""; - } - /gex; - - return $data; - } else { - return; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::TTView> - использует шаблоны для построения представления. - -=head1 SYNOPSIS - -=begin code xml - -<item id="html-view" type="IMPL::Web::Handler::View"> - <contentType>text/html</contentType> - <view id="tt-loader" type="IMPL::Web::View::TTView"> - <options type="HASH"> - <INCLUDE_PATH type="IMPL::Config::Reference"> - <target>IMPL::Config</target> - <AppBase>view</AppBase> - </INCLUDE_PATH> - <INTERPOLATE>1</INTERPOLATE> - <POST_CHOMP>1</POST_CHOMP> - <ENCODING>utf-8</ENCODING> - </options> - <ext>.tt</ext> - <initializer>global.tt</initializer> - <layoutBase>layouts</layoutBase> - </view> - <defaultDocument>default</defaultDocument> - <selectors type="ARRAY"> - <item>@HASH => dump</item> - <item>@My::Data::Product => product/info</item> - <item>{action:.*} @My::Data::Product => product/{action}</item> - </selectors> -</item> - -=end code xml - -=head1 DESCRIPTION - -Подбирает шаблон для представления результата, полученного при выполнении следующего обработчика. При -выборе используется принцип похожий на селекторы C<CSS>, основывающийся на именах ресурсов и их типах -данных. - -Данный обработчик понимает определенные свойства контекста: - -=over - -=item * C<resourceLocation> - -В данном свойстве может быть передана информация о текущем расположении ресурса, -для которого строится представление. Эта информация будет доступна в шаблоне -через свойство документа C<location>. - -=item * C<environment> - -В данном совойстве контекста передается дополнительная информация об окружении -ресурса, например, которую задали родительские ресурсы. Использование данного -свойства позволяет не загромождать ресурс реализацией функциональности по -поддержке окружения. Это свойство может быть ссылкой на функцию, что позволяет -формировать контекст только по необходимости, при этом указанная функция будет -выполнена только один раз, при первом обращении. - -=back - -=head1 SELECTORS - -=begin text - -syntax::= selector => template - -selector::= ([>]segment-template[@class-name]) - -segment-template::= {'{'name:regular-expr'}'|segment-name} - -name::= \w+ - -segment-name::= \S+ - -class-name::= name[(::name)] - -url-template@class => template - -shoes => product/list -/shop//{action:*.}@My::Data::Product => product/{action} - -stuff >list => product/list -details => product/details - -=end text - - -=cut -
--- a/Lib/IMPL/Web/Handler/ViewSelector.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -package IMPL::Web::Handler::ViewSelector; -use strict; - -use IMPL::Const qw(:prop); - -use IMPL::declare { - require => { - NotAcceptable => 'IMPL::Web::NotAcceptableException', - HttpResponse => 'IMPL::Web::HttpResponse' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - props => [ - views => PROP_RW | PROP_LIST, - fallback => PROP_RW, - types => PROP_RW - ] -}; - -sub Invoke { - my ( $this, $action, $next ) = @_; - - my $result = $next ? $next->($action) : undef; - - my $model; - - return $result if eval { $result->isa(HttpResponse) }; - - my $handler; - my $path = $action->pathInfo; - - if ( $this->types and $path =~ m/\.(\w+)$/ ) { - my $forced; - if ( $forced = $this->types->{$1} and $action->query->Accept($forced) ) - { - ($handler) = - grep eval { $_->can('contentType') } - && $_->contentType eq $forced, $this->views; - } - } - - if ( not $handler ) { - - my @handlers = - sort { $b->{preference} <=> $a->{preference} } map { - { - handler => $_, - preference => eval { $_->can('contentType') } - ? $action->query->Accept( $_->contentType ) - : 0 - } - } $this->views; - - my $info = shift @handlers; - $handler = $info ? $info->{handler} : undef; - - } - - die NotAcceptable->new( - map { - eval { $_->can('contentType') } ? $_->contentType : () - } $this->views - ) unless $handler; - - return $handler->Invoke( $action, sub { $result } ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Handler::ViewSelector> - Выбор нужного представления на основе заголовка C<Accept> - -=head1 DESCRIPTION - -Использует заголовок запроса C<Accept> для выбора подходящего представления, если задано свойство C<types>, -пытается в первую очередь по расширению определить, какое представление подходит. - -В случаях, когда не требуется строить представление для данных (например, при перенаправлении к другому -ресурсу или если нет данных), нужно, чтобы данному обработчику был возвращен -L<IMPL::Web::Application::ActionResult>, который будет просто передан далее. - -=head1 MEMBERS - -=head2 C<[get,set,list]views> - -Список представлений, которые могут быть возвращены. - -=head2 C<[get,set]types> - -Хеш с соотвествием между расширением и типом содержимого, для подсказки при выборе представления. - -=cut
--- a/Lib/IMPL/Web/HttpResponse.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -use strict; -package IMPL::Web::HttpResponse; - -use CGI(); -use IMPL::lang qw(:declare :hash); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - status => PROP_ALL, - type => PROP_ALL, - charset => PROP_ALL, - cookies => PROP_ALL, - headers => PROP_ALL, - body => PROP_ALL - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->headers({}) unless $this->headers(); - $this->cookies({}) unless $this->cookies(); -} - -sub PrintResponse { - my ($this,$out) = @_; - - my $q = CGI->new({}); - - my %headers = %{$this->headers}; - - if(my $cookies = $this->cookies) { - $headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies; - } - - $headers{'-status'} = $this->status || '200 OK'; - $headers{'-type'} = $this->type || 'text/html'; - - if(my $charset = $this->charset) { - $q->charset($charset); - binmode $out, ":encoding($charset)"; - } else { - $q->charset(''); - binmode $out; - } - - print $out $q->header(\%headers); - - if(my $body = $this->body) { - if(ref $body eq 'CODE') { - $body->($out); - } else { - print $out $body; - } - } -} - -#used to map a pair name valie to a valid cookie object -sub _createCookie { - return UNIVERSAL::isa($_[1], 'CGI::Cookie') - ? $_[1] - : ( defined $_[1] - ? CGI::Cookie->new(-name => $_[0], -value => $_[1] ) - : CGI::Cookie->new(-name => $_[0], -expires => '-1d', -value => '') - ); -} - -sub InternalError { - my ($self,%args) = @_; - - $args{status} ||= '500 Internal Server Error'; - - return $self->new(%args); -} - -sub Redirect { - my ($self,%args) = @_; - - return $self->new( - status => $args{status} || '303 See other', - headers => { - location => $args{location} - } - ); -} - -sub NoContent { - my ($self,%args) = @_; - - return $self->new( - status => $args{status} || '204 No Content' - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::HttpResponse> - Результат обработки C<HTTP> запроса. - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа, -например - -Данный объект используется для формирования и передачи данных C<HTTP> ответа -напрямую. Основными полями являются C<body> и C<status>. - -Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект -может содержать свойства относящиеся к процессу обработки запроса, например -механизму формирования представления. - -=head1 MEMBERS - -=head2 C<[get,set]status> - -Статус который будет отправлен сервером клиенту, например, C<200 OK> или -C<204 No response>. Если не указан, то будет C<200 OK>. - -=head2 C<[get,set]type> - -Тип содержимого, которое будет передано клиенту, если не указано, будет -C<text/html>. - -=head2 C<[get,set]charset> - -Кодировка в которой будут переданны данные. Следует задавать если и только, если -передается текстовая информация. Если указана кодировка, то она будет -автоматически применена к потоку, который будет передан методу C<PrintResponse>. - -=head2 C<[get,set]cookies> - -Опционально. Ссылка на хеш с печеньками. - -=head2 C<[get,set]headers> - -Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат -имен полей как у модуля C<CGI>. - -=begin code - -$response->header->{custom_header} = "my value"; - -#will produce the following header - -Custom-header: my value - -=end code - -=head2 C<[get,set]body> - -Тело ответа. Может быть как простой скаляр, который будет приведен к строке и -выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на -процедуру, в таком случае будет вызвана эта процедура и ей будет передан -первым параметром поток для вывода тела ответа. - -=head2 C<PrintResponse($outStream)> - -Формирует заголовок и выводит ответ сервера в указанный параметром поток. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/NotAcceptableException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -package IMPL::Web::NotAcceptableException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -sub status { - "406 Not acceptable" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::NotAcceptableException> Исключение в случае, если запрошенный ресурс не может -быть выдан в указанном виде. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/NotAllowedException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,30 +0,0 @@ -package IMPL::Web::NotAllowedException; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Web::Exception' => '@_' - ] -}; - -use IMPL::Resources::Strings { - message => "The requested method isn't allowed" -}; - -sub CTOR { - my $this = shift; - my %args = @_; - - $this->headers({ - allow => $args{allow} - }); -} - -sub status { - "405 Method Not Allowed" -} - -1; - -__END__ \ No newline at end of file
--- a/Lib/IMPL/Web/NotFoundException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -package IMPL::Web::NotFoundException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - }, -}; - -use IMPL::Resources::Strings { - message => 'The specified resource isn\'t found.' -}; - -sub status { - "404 Not found" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::NotFoundException> Исключение для несущесьвующего ресурса. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/OutOfRangeException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -package IMPL::Web::OutOfRangeException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - }, -}; - -sub CTOR { - my ($this,$range) = @_; - - #TODO: validate args - - $this->headers({ - content_range => { $range->{units} . ' */' . $range->{length} } - }); -} - -use IMPL::Resources::Strings { - message => 'The specified range is invalid' -}; - -sub status { - "416 Requested Range Not Satisfiable" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::OutOfRangeException> A server SHOULD return a response with this -status code if a request included a Range request-header field (section 14.35), -and none of the range-specifier values in this field overlap the current extent -of the selected resource, and the request did not include an If-Range -request-header field. (For byte-ranges, this means that the first- byte-pos of -all of the byte-range-spec values were greater than the current length of the -selected resource.) - -=head1 DESCRIPTION - -When this status code is returned for a byte-range request, the response SHOULD -include a Content-Range entity-header field specifying the current length of the -selected resource (see section 14.16). This response MUST NOT use the -multipart/byteranges content- type. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/PreconditionException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package IMPL::Web::PreconditionException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -use IMPL::Resources::Strings { - message => "Precondition Failed" -}; - -sub status { - "412 Precondition Failed" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::PreconditionException> - The precondition given in one or more of -the request-header fields evaluated to false when it was tested on the server. - -This response code allows the client to place preconditions on the current -resource metainformation (header field data) and thus prevent the requested -method from being applied to a resource other than the one intended. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Security.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -package IMPL::Web::Security; -use strict; - -use IMPL::Security::Auth qw(:Const); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - NotImplementedException => '-IMPL::NotImplementedException', - ArgException => '-IMPL::InvalidArgumentException', - SecurityContext => 'IMPL::Security::AbstractContext' - }, -}; - -use constant { - ERR_NO_SUCH_USER => -1, - ERR_NO_SEC_DATA => -2, - ERR_NO_AUTHORITY => -3, - ERR_NO_SEC_CONTEXT => -4, - ERR_AUTH_FAIL => -5 -}; - -sub interactiveAuthPackage { - die NotImplementedException->new(); -} - -sub users { - die NotImplementedException->new(); -} - -sub roles { - die die NotImplementedException->new(); -} - -sub sessions { - die NotImplementedException->new(); -} - -sub AuthUser { - my ($this,$name,$challenge,$roles,$package) = @_; - - $package ||= $this->interactiveAuthPackage; - $roles ||= []; - - my $user = $this->users->GetById($name) - or return { - status => AUTH_FAIL, - code => ERR_NO_SUCH_USER - }; - - my $auth; - if ( my $secData = $user->GetSecData($package) ) { - $auth = $package->new($secData); - } else { - return { - status => AUTH_FAIL, - code => ERR_NO_SEC_DATA, - user => $user - }; - } - - return { - status => AUTH_FAIL, - code => ERR_NO_SEC_CONTEXT - } unless SecurityContext->current; - - return { - status => AUTH_FAIL, - code => ERR_NO_AUTHORITY - } unless SecurityContext->current->authority; - - my $status = SecurityContext->current->authority->InitSession( - $user, - $roles, - $auth, - $challenge - ); - - return { - status => $status, - code => ($status == AUTH_FAIL ? ERR_AUTH_FAIL : 0), - user => $user - }; -} - -sub Logout { - my ($this) = @_; - - my $session = SecurityContext->current; - if($session && $session->authority) { - $session->authority->CloseSession($session); - - $this->sessions->Delete($session); - } -} - -sub CreateSecData { - my ($this,$package,$params) = @_; - - die ArgException->new(params => 'A hash reference is required') - unless ref($params) eq 'HASH'; - - return $package->CreateSecData(%$params); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Security> Модуль для аутентификации и авторизации веб запроса. - -=head1 DESCRIPTION - -Текущий модуль обеспечивает функции верхнего уровня для работы с системой -безопасности. Поскольку модуль является абстрактым, конкретные функции -хранения и реализацию объектов модели безопасности должно обеспечить само -приложение. - -Сама система безопасности в веб приложении состоит из двух частей - -=over - -=item Модель системы безопасности - -Предоставляет такие объкты безопасности, как пользователь, сессия роль, -определяет правила проверки прав доступа субъекта к объекту. - -=item Модуль безопасности - -Контекст безопасности создается именно этим модулем. - -Как правило встраивается в транспортный уровеь в виде обработчика -C<IMPL::Web::Handler> и реализует непосредственно протокол аутентификации и -обмена с пользователем. - -Также модуль безопасности использует модель для хранения сессий и данных -аутентификции. - -=back - -=head1 MEMBERS - -=head2 C<AuthUser($name,$package,$challenge)> - -Инициирует создание новой сессии используя провайдера безопасности текущего -контекста безопасности. - -=over - -=item C<$name> - -Имя пользователя, которое будет использоваться при поиске его в БД. - -=item C<$package> - -Имя модуля аутентификации, например, C<IMPL::Security::Auth::Simple>. - -=item C<$challenge> - -Данные, полученные от клиента, которые будут переданы модулю аутентификации для -начала процесса аутентификации и создания сессии. - -=back - -Функция возвращает хеш с элементами - -=over - -=item C<status> - -Статус аутентификации - отражает общее состояние процесса ацтентификации, - -=over - -=item C<AUTH_FAIL> - -Аутентификация неудачная, сессия не создана. - -=item C<AUTH_INCOMPLETE> - -Аутентификация требует дополнительных шагов, сессия создана, но еще не доверена. - -=item C<AUTH_SUCCESS> - -Аутентификация успешно проведена, сессия создана. - -=back - -=item C<code> - -=back - -=cut
--- a/Lib/IMPL/Web/Security/Session.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -package IMPL::Web::Security::Session; -use strict; -use parent qw(); - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Security::AbstractContext' => '@_' - ] -}; - -push @{__PACKAGE__->abstractProps}, sessionId => PROP_RW, security => PROP_RW; - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Security::Session> - Сессия пользователя. - -=head1 SINOPSYS - -=begin code - -# define a custom session for the application - -package App::Session; -use parent qw(IMPL::Web::Security::Session); - -use IMPL::Class::Property; - -BEGIN { - public property transactionId => prop_all; -} - -=end code - -=head1 DESCRIPTION - -C<use parent qw(IMPL::Security::Context)> - -Представляет собой контекст безопасности, имеет идентификатор. Является базовым классом -для расширения дополнительными атрибутами. - -=head1 MEMBERS - -=over - -=item C<[get] sessionId> - -Идентификатор сессии - -=item C<[get] security> - -Экземпляр C<IMPL::Web::Security> в рамках которого создана сессия (откуда взят -пользователь и роли). - -=back - -=cut
--- a/Lib/IMPL/Web/UnauthorizedException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -package IMPL::Web::UnauthorizedException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -sub status { - "401 Unauthorized" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::UnauthorizedException> - запрос требует идентификации пользователя. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/UnsupportedMediaException.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ -package IMPL::Web::UnsupportedMediaException; -use strict; - -use IMPL::declare { - base => { - 'IMPL::Web::Exception' => '@_' - } -}; - -sub status { - "415 Unsupported Media Type" -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::UnsupportedMediaException> - 415 Unsupported Media Type - -=head1 DESCRIPTION - -The request entity has a media type which the server or resource does not -support. For example, the client uploads an image as C<image/svg+xml>, but the -server requires that images use a different format. -L<http://en.wikipedia.org/wiki/List_of_HTTP_status_codes> - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/View/Metadata/BaseMeta.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,140 +0,0 @@ -package IMPL::Web::View::Metadata::BaseMeta; -use strict; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - NotImplException => '-IMPL::NotImplementedException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - model => PROP_RO, - modelType => PROP_RO, - name => PROP_RO, - label => PROP_RO, - container => PROP_RO, - template => PROP_RO, - - _childMap => PROP_RO, - _childNames => PROP_RO - ] -}; - -sub CTOR { - my ($this,$model,$type,$args) = @_; - - $this->model($model); - $this->modelType($type); - $this->_childMap({}); - - #mixin other args - if ($args) { - $this->$_($args->{$_}) foreach grep $args->{$_}, qw(name label container template); - } -} - -sub GetProperty { - my ($this,$name) = @_; - - $this->GetProperties() - unless $this->_childNames; - - return $this->_childMap->{$name}; -} - -sub GetProperties { - my ($this) = @_; - - if ($this->_childNames) { - return [ map $this->_childMap->{$_}, @{$this->_childNames} ]; - } else { - my @childNames; - my %childMap; - my @result; - - foreach my $child (@{$this->PopulateProperties()}) { - $childMap{$child->name} = $child; - push @childNames, $child->name; - push @result, $child; - } - - $this->_childMap(\%childMap); - $this->_childNames(\@childNames); - return \@result; - } -} - -sub PopulateProperties { - my ($this) = @_; - - die NotImplException->new(); -} - -sub GetItems { - my ($this) = @_; - - die NotImplException->new(); -} - -sub GetItem { - my ($this,$index) = @_; - - die NotImplException->new(); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Метаданные описывают модель, ее свойства, используются для построения -представления. - -=over - -=item * type - -Опционально. Тип модели. В случаях, когда модель не определена, данное свойство -позволяет определить ее тип. - -=item * label - -Опционально. Имя модели для отображения. - -=item * template - -Шаблон, который следует использовать для отображения модели. - -=item * fields - -Коллекция с информацией по свойствам (полям) модели. Данный хеш используется -для определения представления при использовании C<display_for('field')>. - -=back - -Метаданные публикуются провайдером, кроме того они могут быть расширены -дополнительными свойствами. - -=head1 MEMBERS - -=head2 C<GetChild($name)> - -Возвращает метаданные для дочернего элемента, например свойства объекта - -=head2 C<GetChildren()> - -Возвращает ссылку на массив с метаданными для дочерних элементов - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/View/Metadata/FormMeta.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,319 +0,0 @@ -package IMPL::Web::View::Metadata::FormMeta; -use strict; - -use IMPL::lang; -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException', - SchemaNavigator => 'IMPL::DOM::Navigator::SchemaNavigator', - DOMNode => '-IMPL::DOM::Node' - }, - base => [ - 'IMPL::Web::View::Metadata::BaseMeta' => '@_' - ], - props => [ - nodes => PROP_RO, - decl => PROP_RO, - schema => PROP_RO, - errors => PROP_RO, - group => PROP_RO - ] -}; - -use constant { - Meta => __PACKAGE__ -}; - -sub CTOR { - my ($this,$model,$type,$args) = @_; - - if ($args) { - $this->$_($args->{$_}) foreach grep $args->{$_}, qw(decl schema nodes errors group); - } - - $this->$_() || die ArgException->new($_ => "The $_ is required") - foreach qw(schema); -} - -sub GetSchemaProperty { - my ($this,$name) = @_; - - return $this->decl ? $this->decl->nodeProperty($name) || $this->schema->nodeProperty($name) : $this->schema->nodeProperty($name); -} - -sub template { - shift->GetSchemaProperty('template'); -} - -sub label { - shift->GetSchemaProperty('label'); -} - -sub inputType { - shift->GetSchemaProperty('inputType'); -} - -sub inputValue { - my ($this) = @_; - - if($this->isMultiple) { - return [ - map { - $_ ? $_->nodeValue || $_->nodeProperty('rawValue') : undef - } - @{$this->model || []} - ] - } else { - return $this->model ? $this->model->nodeValue || $this->model->nodeProperty('rawValue') : undef; - } -} - -sub isMultiple { - my ($this) = @_; - $this->decl && $this->decl->isMultiple; -} - -sub isOptional { - my ($this) = @_; - not($this->decl) || $this->decl->isOptional; -} - -sub GetOwnErrors { - my ($this) = @_; - - my $nodes = $this->nodes; - - my $errors = [ - grep _IsOwnError($nodes,$this->decl,$_), @{$this->errors || []} - ]; - - return $errors; -} - -sub _IsOwnError { - my ($nodes,$source,$err) = @_; - - return 1 if ($err->node && grep($err->node == $_, @$nodes)) || (not(@$nodes) && $err->schemaNode && $err->schemaNode == $source ); - - return 0; -} - -sub _IsErrorRelates { - my ($nodes,$source,$err) = @_; - - # this is an own error - return 1 if _IsOwnError($nodes,$source,$err); - - # this error relates to the child control - - return 0 unless @$nodes; - - for (my $n = $err->parent; $n ; $n = $n->parentNode) { - return 1 if grep($n == $_, @$nodes); - } - - return 0; -} - -sub PopulateProperties { - my ($this) = @_; - - my @props; - - # return empty list of properties in case of multiple values - return \@props if $this->isMultiple; - - my $navi = SchemaNavigator->new($this->schema); - - foreach my $decl (@{$this->schema->content->childNodes}) { - - my $schema = $navi->NavigateName($decl->name); - $navi->SchemaBack(); - - my @nodes = $this->model && $this->model->selectNodes( sub { $_->schemaNode == $decl } ); - - my %args = ( - name => $decl->name, - decl => $decl, - schema => $schema, - nodes => [@nodes], - errors => [grep _IsErrorRelates(\@nodes,$decl,$_), @{$this->errors || []}] - ); - - my ($model,$type); - - if ($decl->isMultiple) { - $model = [@nodes]; - $type = 'ARRAY'; - $args{holdingType} = $schema->type; - } else { - $model = shift @nodes; - $type = $schema->type; - } - - push @props, Meta->new($model,$type,\%args); - } - - return \@props; -} - -sub GetItems { - my ($this) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $i = 0; - - return [ - map $this->_GetItemMeta($_,$i++), @{$this->nodes} - ]; -} - -sub GetItem { - my ($this,$index) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $node = $this->nodes->[$index]; - - return $this->_GetItemMeta($node,$index); -} - -sub _GetItemMeta { - my ($this,$node,$index) = @_; - - my @nodes; - push @nodes,$node if $node; - - return Meta->new( - $node, - $this->schema->type, - { - name => $index, - schema => $this->schema, - errors => [grep _IsErrorRelates([$node],$this->decl,$_), @{$this->errors ||[]} ], - group => $this, - nodes => \@nodes - } - ); -} - -sub GetMetadataForModel { - my ($self,$model,$args) = @_; - - $args ||= {}; - - my $modelType = delete $args->{modelType}; - - if($model) { - die ArgException->new(model => "A node is required") - unless is($model,DOMNode); - - $args->{decl} ||= $model->schemaNode; - $args->{schema} ||= $model->schemaType; - } - - return $self->new( - $model, - $modelType, - $args - ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Расширенные метаданные модели для элементов формы, помимо стандартных свойств -сожержит в себе информацию о схеме. - -=head1 MEMBERS - -=head2 C<[get]errors> - -Ссылка на массив с ошибками при проверке схемы. Ошибки относятся ко всем -узлам в текущей модели, включая вложенные и т.п. - -=head2 C<[get]model> - -Ссылка на элемент документа, либо на массив с элементами для множественных -значений (C<isMultiple = true>). В том случае, когда документ был не -корректен и для не множественного элемента было передено несколько значений, -данное свойство будет содержать только первое. - -=head2 C<[get]nodes> - -Ссылка на массив с узлами документа. В теории количество узлов может быть -произвольным, поскольку документ может быть некорректным, т.е. их может -быть более одного в то время, как C<isMultiple = false> или, напротив, ни -одного при C<isOptional = false>. - -Как правило для построения формы данное свойство не требуется. - -=head2 C<[get]modelType> - -Название типа данных из схемы документа (C<< schema->name >>), если тип не имеет название, то это -C<ComplexNode> для сложных узлов и C<SimpleNode> для простых. - -Для моделей с множественными значениями это свойство не задано. Тип элементов -храниться в свойстве C<holdingType> - -=head2 C<[get]decl> - -Объявление элемента формы, объявление может совпадать со схемой в случае, -когда это был C<SimpleNode> или C<ComplexNode>, иначе это C<Node> ссылающийся -на заранее обпределенный тип. - -=head2 C<[get]schema> - -Схема текущего элемента, C<СomlexType>, C<SimpleType>, C<ComplexNode> или -C<SimpleNode>. - -=head2 C<[get]isOptional> - -Данный элемент может не иметь ни одного значения - -=head2 C<[get]isMultiple> - -Данный элемент может иметь более одного значения. Модель с множественными -значениями является сложным элементом, в котором дочерними моделями являются -не свойства а сами элементы, в данном случае они их именами будут индексы. - -=begin code - -for(my $i=0; $i< 10; $i++) { - display_for($i,'template'); -} - -sub display_for { - my ($index,$tmpl) = @_; - - if ($index =~ /^\d+$/) { - return render($tmpl, metadata => { $meta->GetItem($index) }); - } else { - return render($tmpl, metadata => { $meta->GetProperty($index) }); - } -} - -=end code - -=head2 C<GetOwnErrors()> - -Возвращает ошибки относящиеся к самому элементу C<model>, это принципиально -для контейнеров и в случаях, когда модель не корректна и в ней присутствуют -лишние значения. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/View/Metadata/ObjectMeta.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,133 +0,0 @@ -package IMPL::Web::View::Metadata::ObjectMeta; -use strict; - -use IMPL::lang; -use IMPL::Const qw(:prop :access); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException', - OpException => '-IMPL::InvalidOperationException', - PropertyInfo => 'IMPL::Class::PropertyInfo', - AbstractObject => '-IMPL::Object::Abstract' - }, - base => [ - 'IMPL::Web::View::Metadata::BaseMeta' => sub { - my ($model,$type,$args) = @_; - $type ||= typeof($model); - return ($model,$type,$args); - } - ], - props => [ - isMultiple => PROP_RO, - holdingType => PROP_RO - ] -}; - -use constant { - Meta => __PACKAGE__ -}; - -sub CTOR { - my ($this,$model,$type,$args) = @_; - - $type = $this->modelType; - - $args->{isMultiple} ||= $type && $type eq 'ARRAY'; - - if ($args) { - $this->$_($args->{$_}) foreach grep $args->{$_}, qw(isMultiple holdingType); - } -} - -sub PopulateProperties { - my ($this) = @_; - - my %seen; - my @props; - - my $modelType = $this->modelType; - - if ( isclass($modelType,AbstractObject) ) { - foreach my $pi ( - $this->modelType->GetMeta( - PropertyInfo, - sub { not($seen{$_}++) and $_->access == ACCESS_PUBLIC }, - 1 - ) - ) { - my $pv = $this->model && $pi->getter->($this->model); - my $pt; - - my %args = (name => $pi->name); - if ($pi->isList) { - $pt = 'ARRAY'; - $args{isMultiple} = 1; - $args{holdingType} = $pi->type; - } else { - $pt = $pi->type; - } - - push @props, Meta->new($pv, $pt, \%args); - } - } elsif ( $modelType && $modelType eq 'HASH' ) { - while ( my ($k,$v) = each %{$this->model || {}} ) { - push @props, Meta->new($v,undef,{name => $k}); - } - } - - return \@props; -} - -sub GetItems { - my ($this) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $i = 0; - - return [ - map $this->_GetItemMeta($_,$i++), @{$this->model || []} - ]; -} - -sub GetItem { - my ($this,$index) = @_; - - die OpException->new("The operation must be performed on the container") - unless $this->isMultiple; - - my $item = @{$this->model || []}[$index]; - - return $this->_GetItemMeta($item,$index); -} - -sub _GetItemMeta { - my ($this,$item,$index) = @_; - - return Meta->new( - $item, - $this->holdingType, - { - name => $index, - container => $this - } - ); -} - -sub GetMetadataForModel { - my ($self,$model,$args) = @_; - - $args ||= {}; - - return $self->new( - $model, - delete $args->{modelType}, - $args - ) -} - -1; - -__END__
--- a/Lib/IMPL/Web/View/ObjectFactory.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package IMPL::Web::View::ObjectFactory; -use strict; - -our $AUTOLOAD; - -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - OpException => '-IMPL::InvalidOperationException' - }, - base =>[ - 'IMPL::Object::Factory' => '@_' - ] -}; - -use IMPL::Resources::Strings { - MsgNoMethod => 'Method "%method%" isn\'t found in "%target%"' -}; - -sub AUTOLOAD { - my $this = shift; - my ($method) = ($AUTOLOAD =~ m/(\w+)$/); - - return if $method eq 'DESTROY'; - my $target = $this->factory; - if ( $target->can($method) ) { - return $target->$method(@_); - } else { - die OpException->new( MsgNoMethod( method => $method, target => $target ) ); - } -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Web/View/TTContext.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,519 +0,0 @@ -package IMPL::Web::View::TTContext; -use strict; -use Template::Base; -use Carp qw(carp); -use File::Spec(); -use IMPL::Resources::Format qw(FormatMessage); -use IMPL::Resources::Strings(); - -use IMPL::Exception(); -use IMPL::lang qw(is typeof hashApply hashMerge); -use IMPL::declare { - require => { - Document => '-Template::Document', - TypeKeyedCollection => 'IMPL::TypeKeyedCollection', - ArgException => '-IMPL::InvalidArgumentException', - Resources => 'IMPL::Resources', - Loader => 'IMPL::Code::Loader', - MetadataBase => '-IMPL::Web::View::Metadata::BaseMeta', - Metadata => 'IMPL::Web::View::Metadata::ObjectMeta', - StringMap => 'IMPL::Resources::StringLocaleMap' - }, - base => [ - 'Template::Context' => '@_' - ] -}; - -BEGIN { - no strict 'refs'; - # modules is a global (for the whole document) templates cache - # tt_cache is a local (for the current context only) templtes cache - foreach my $prop (qw( - root - base - tt_ext - tt_cache - parent - prefix - cache - includes - modules - aliases - id - metadata - model - templateInfo - )) { - my $t = $prop; - - *{__PACKAGE__ . '::' . $prop} = sub { - my $this = shift; - return @_ ? $this->stash->set($t, @_) : $this->stash->get($t); - } - } -} - -sub clone { - my $this = shift; - my $params = shift; - - $this->localise(); - - my $args = { %{$this} }; - - $this->delocalise(); - - my $class = ref($this); - - delete $args->{CONFIG}; - - my $clone = $class->new($args); - - $clone->stash->update($params) if $params; - - return $clone; -} - -sub get_next_id { - my ($this) = @_; - - my $id = $this->stash->get('document.nextId') || 0; - $this->stash->set('document.nextId', $id + 1); - return "w-$id"; -} - -sub find_template { - my ($this,$name, $nothrow) = @_; - - my $cache = $this->tt_cache; - - $this->tt_cache($cache = {}) unless $cache; - - if(my $tpl = $cache->{$name}) { - return $tpl; - } - - my @inc = ($this->base, @{$this->includes || []}); - #my @inc = @{$this->includes || []}; - - my $ext = $this->tt_ext || ""; - - #warn "find: $name"; - - my $file; - - foreach my $dir (@inc) { - $file = $dir ? "$dir/$name" : $name; - - my @parts = split(/\/+/,$file); - - my $templateName = pop @parts; - - my $base = join('/',@parts); - - $file = $ext ? "$file.$ext" : $file; - - #warn " file: $file"; - - if (exists($this->modules->{$file})) { - my $info = $this->modules->{$file}; - return $cache->{$name} = $info - if $info; - } else { - if( my $tt = eval { $this->template($file) } ) { - #warn " found: $file"; - my $class; - if ($class = $tt->class) { - $class = $this->aliases->{$class} || $class; - Loader->safe->Require($class); - } - my $info = { - base => $base, - name => $templateName, - template => $tt, - initialized => 0, - class => $class, - file => $file - }; - $this->modules->{$file} = $info; - return $cache->{$name} = $info; - } else { - my $err = $@; - - #warn " not found: $err"; - - for(my $t = $err; is($t,'Template::Exception'); $t = $t->info ) { - die $err unless $t->type eq Template::Constants::ERROR_FILE; - } - $this->modules->{$file} = undef; - } - } - } - - $this->throw(Template::Constants::ERROR_FILE, "$name: not found") - unless $nothrow; - return; -} - -sub display_for { - my $this = shift; - my $path = shift; - my ($template, $args); - - if (ref $_[0] eq 'HASH') { - $args = shift; - } else { - $template = shift; - $args = shift; - } - - my $prefix = $this->prefix; - - my $info; - my $meta = $this->resolve_model($path,$args) - or return "[not found '$path']"; - - $info->{prefix} = join('.', grep($_, $prefix, $path)); - $info->{model} = $meta->model; - $info->{metadata} = $meta; - - $template ||= $info->{template}; - $template = $template ? $this->find_template($template) : $this->find_template_for($info->{metadata}); - - return $this->render( - $template, - hashApply( - $info, - $args - ) - ); -} - -sub display_model { - my $this = shift; - my $model = shift; - my ($template, $args); - - if (ref $_[0] eq 'HASH') { - $args = shift; - } else { - $template = shift; - $args = shift; - } - - #copy - $args = { %{$args || {}} }; - - $args->{prefix} = join('.',grep($_,$this->prefix,$args->{path})) - unless defined $args->{prefix}; - - if (is($model,MetadataBase)) { - $args->{model} = $model->model; - $args->{metadata} = $model; - } else { - $args->{model} = $model; - $args->{metadata} = Metadata->GetMetadataForModel($model); - } - - $template = $template ? $this->find_template($template) : $this->find_template_for($args->{metadata}); - - return $this->render( - $template, - $args - ); -} - -# обеспечивает необходимый уровень изоляции между контекстами -# $code - код, который нужно выполнить в новом контексте -# $env - хеш с переменными, которые будут переданы в новый контекст -# в процессе будет создан клон корневого контекста, со всеми его свойствами -# затем новый контекст будет локализован и в него будут добавлены новые переменные из $env -# созданный контекст будет передан параметром в $code -sub invoke_environment { - my ($this,$code,$env) = @_; - - $env ||= {}; - - my $ctx = ($this->root || $this)->clone(); - - my @includes = @{$this->includes || []}; - - if ($this->base) { - unshift @includes, $this->base; - } - - my $out = eval { - $ctx->localise( - hashApply( - { - includes => \@includes, - aliases => $this->aliases || {}, - root => $this->root || $ctx, - modules => $this->modules || {}, - cache => TypeKeyedCollection->new(), - display_for => sub { - $ctx->display_for(@_); - }, - render => sub { - $ctx->render(@_); - }, - display_model => sub { - $ctx->display_model(@_); - }, - tt_cache => {}, - labels => sub { - $ctx->load_labels(@_); - } - }, - $env - ) - ); - - &$code($ctx); - }; - - my $e = $@; - $ctx->delocalise(); - - die $e if $e; - - return $out; -} - -# использует указанный шаблон для создания фрагмента документа -# шаблон может быть как именем, так и хешем, содержащим информацию -# о шаблоне. -# отдельно следует отметить, что данный метод создает новый контекст -# для выполнения шаблона в котором задает переменные base, parent, id -# а также создает переменные для строковых констант из labels -# хеш с переменными $args будет передан самому шаблону в момент выполнения -# если у шаблона указан класс элемента управления, то при выполнении шаблона -# будет создан экземпляр этого класса и процесс выполнения шаблона будет -# делегирован методу Render этого экземпляра. -sub render { - my ($this,$template,$args) = @_; - - $args ||= {}; - - my $info = ref $template ? $template : $this->find_template($template); - - if (ref($info) ne 'HASH') { - carp "got an invalid template object: $info (" . ref($info) . ")"; - $info = { - template => $info, - base => $this->base, - initialized => 1 - }; - } - - return $this->invoke_environment( - sub { - my $ctx = shift; - - unless($info->{initialized}) { - if(my $init = $info->{template}->blocks->{INIT}) { - $info->{initialized} = 1; - eval { - $ctx->visit($info->{template}->blocks); - $ctx->include($init); - }; - $ctx->leave(); - } - } - - if (my $class = $info->{class}) { - $class->new($ctx,$info->{template},$args)->Render({}); - } else { - return $ctx->include($info->{template},$args); - } - }, - { - base => $info->{base}, - parent => $this, - id => $this->get_next_id, - templateInfo => $info - } - ) -} - -sub resolve_model { - my ($this,$prefix) = @_; - - die ArgException->new(prefix => "the prefix must be specified") - unless defined $prefix; - - my $meta = $this->metadata; - unless($meta) { - $meta = Metadata->GetMetadataForModel($this->model); - $this->metadata($meta); - } - - foreach my $part (grep length($_), split(/\.|\[(\d+)\]/, $prefix)) { - last unless $meta; - if ($part =~ /^\d+$/) { - $meta = $meta->GetItem($part); - } else { - $meta = $meta->GetProperty($part); - } - } - - return $meta; -} - -sub find_template_for { - my ($this,$meta, $nothrow) = @_; - - die ArgException->new(meta => 'An invalid metadata is supplied') - unless is($meta,MetadataBase); - - return $this->find_template($meta->template) - if ($meta->template); - - my $type = $meta->modelType; - - return $this->find_template('templates/plain') unless $type; - - if (my $template = $this->cache->Get($type)) { - return $template; - } else { - - no strict 'refs'; - - my @isa = $type; - - while (@isa) { - my $sclass = shift @isa; - - (my $name = $sclass) =~ s/:+/_/g; - my ($shortName) = ($sclass =~ m/(\w+)$/); - - $template = $this->find_template("templates/$name",1) || $this->find_template("templates/$shortName",1); - - if ($template) { - $this->cache->Set($sclass,$template); - return $template; - } - - #todo $meta->GetISA to implement custom hierachy - push @isa, @{"${sclass}::ISA"}; - } - - } - $this->throw(Template::Constants::ERROR_FILE, "can't find a template for the model $type") - unless $nothrow; - - return; -} - -sub get_real_file { - my ($this,$fname) = @_; - - return unless length $fname; - - my @path = split(/\/+/,$fname); - - foreach my $provider (@{$this->load_templates || []}) { - foreach my $dir (@{$provider->paths || []}) { - my $realName = File::Spec->catfile($dir,@path); - return $realName if -f $realName; - } - } -} - -sub load_labels { - my ($this,$data) = @_; - - die ArgException->new("A hash reference is required") - unless ref($data) eq 'HASH'; - - my $stringMap = StringMap->new($data); - - $this->stash->update({ - map { - my $id = $_; - $id, - sub { - $stringMap->GetString($id,@_); - }; - } keys %$data - }); - - my $ti = $this->templateInfo || {}; - - if (my $fullName = $this->get_real_file($ti->{file})) { - my ($vol,$dir,$fname) = File::Spec->splitpath($fullName); - - my $name = $this->templateInfo->{name}; - - my $localePath = File::Spec->catpath($vol, File::Spec->catdir($dir,'locale'),''); - - $stringMap->name($name); - $stringMap->paths($localePath); - } - return; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::View::TTContext> - доработанная версия контекста - -=head1 DESCRIPTION - -Расширяет функции C<Template::Context> - -=begin plantuml - -@startuml - -object RootContext { - document - globals -} - -object DocumentContext { - base - extends -} - -object ControlContext { - base - extends -} - -RootContext o-- DocumentContext -RootContext o-- ControlContext - -Document -- DocumentContext -Control - ControlContext - -Loader . RootContext: <<creates>> -Loader . Document: <<creates>> -Loader -up- Registry - -@enduml - -=end plantuml - -=head1 MEMBERS - -=head2 C<[get,set]base> - -Префикс пути для поиска шаблонов - -=head2 C<template($name)> - -Сначала пытается загрузить шаблон используя префикс C<base>, затем без префикса. - -=head2 C<clone()> - -Создает копию контекста, при этом C<stash> локализуется, таким образом -клонированный контекст имеет собственное пространство имен, вложенное в -пространство родительского контекста. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/View/TTControl.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,122 +0,0 @@ -package IMPL::Web::View::TTControl; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::lang qw(:hash :base); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - context => PROP_RO, - template => PROP_RO - ] -}; - -our $AUTOLOAD_REGEX = qr/^[a-z]/; - -sub CTOR { - my ($this,$context,$template,$args) = @_; - - $this->context($context) - or die ArgException->new(context => 'A context is required'); - $this->template($template) - or die ArgException->new(template => 'A template is required'); - - if (ref $args eq 'HASH') { - while(my ($key, $value) = each %$args) { - next if grep $_ eq $key, qw(context template); - $this->$key($value); - } - } -} - -sub _PopulateMethods { - my ($this,@methods) = @_; - - $this->_stash->update({ - map { - my $name = $_; - $name, - sub { - $this->$name(@_); - } - } @methods - }); -} - -sub _stash { - $_[0]->context->stash; -} - -sub Render { - my ($this,$args) = @_; - return $this->context->include($this->template,$args); -} - -our $AUTOLOAD; -sub AUTOLOAD { - my ($prop) = ($AUTOLOAD =~ m/(\w+)$/); - - die Exception->new("Method not found: $AUTOLOAD") unless $prop=~/$AUTOLOAD_REGEX/ and $_[0]; - - no strict 'refs'; - - my $method = sub { - my $that = shift; - if (@_ == 0) { - return $that->_stash->get($prop); - } elsif (@_ == 1) { - return $that->_stash->set($prop,shift); - } else { - return $that->_stash->get([$prop,[@_]]); - } - }; - - *{$AUTOLOAD} = $method; - - goto &$method; -} - - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::View::TTControl> расширяет функциональность шаблонов - -=head1 SYNPOSIS - -=begin code - -package My::View::Menu; -use IMPL::declare { - base => [ - 'IMPL::Web::View::TTControl' => '@_' - ] -}; - -sub Render { - my ($this,$args) = @_; - - $this->PrepareItems($args); - - return $this->next::method($args); -} - -sub PrepareItems - -=end code - -=head1 DESCRIPTION - - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/View/TTView.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -package IMPL::Web::View::TTView; -use strict; - -use JSON; -use IMPL::lang qw(hashMerge is); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - Context => 'IMPL::Web::View::TTContext', - Loader => 'IMPL::Code::Loader', - Factory => 'IMPL::Web::View::ObjectFactory' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - ], - props => [ - options => PROP_RW, - viewBase => PROP_RW, - layoutBase => PROP_RW, - layout => PROP_RW, - tt_ext => PROP_RW, - includes => PROP_RW | PROP_LIST, - globals => PROP_RW - ] -}; - -sub CTOR { - my ($this) = @_; - - $this->tt_ext('tt') unless defined $this->tt_ext; -} - -sub display { - my ($this,$model,$template,$args) = @_; - - my $context = Context->new($this->options); - eval { - $context->process('globals' . '.' . $this->tt_ext, $args); - }; - my $layout = delete $args->{layout} || $this->layout; - - return $context->invoke_environment( - sub { - my $ctx = shift; - if ($layout) { - return $ctx->invoke_environment( - sub { - return shift->render( - $layout, - hashMerge( - { - content => sub { - $ctx->invoke_environment( - sub { - return shift->display_model($model,$template); - }, - { - base => $this->viewBase - } - ) - }, - model => $model - } - ) - ); # render - }, - { - base => $this->layoutBase, - } - ); - } else { - return $ctx->invoke_environment( - sub { - return shift->display_model($model,$template); - }, - { - base => $this->viewBase - } - ); - } - },hashMerge( - $this->globals, - hashMerge( - $args, - { - includes => scalar($this->includes), - tt_ext => $this->tt_ext, - debug => sub { - warn @_; - }, - is => sub { - my ($obj,$class) = @_; - if (is($class,Factory)) { - return is($obj,$class->factory); - } else { - return is($obj,$class); - } - }, - import => sub { - return Factory->new(Loader->safe->Require(shift)); - }, - toJSON => sub { - return JSON->new()->utf8->pretty->encode(shift); - } - } - ) - ) - ); -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Web/View/TemplateView.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -package IMPL::Web::View::TemplateView; -use strict; - -use Carp qw(carp); - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Web::ViewResult' => '@_' - ], - props => [ - template => PROP_RW, - ] -}; - -sub CTOR { - carp "deprecated"; -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Web/ViewResult.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -package IMPL::Web::ViewResult; -use strict; - -use IMPL::Const qw(:prop); -use Carp qw(carp); - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - model => PROP_RW, - _location => PROP_RW, - cookies => PROP_RW, - headers => PROP_RW, - status => PROP_RW - ] -}; - -sub location { - carp "location property is absolute"; - return shift->_location(@_); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::ViewResult> - описание представления результата. - -=head1 SYNOPSIS - -=begin code - -sub HttpGet { - my ($this, $action) = @_; - - return IMPL::Web::ViewResult->new( - model => $model - ); -} - -=end code - -=head1 DESCRIPTION - -Сожержит в себе информацию для представления модели. Также включает поля для -заголовков ответа C<cookies>, C<headers>, C<status>. - -=head1 MEMBERS - -=head2 C<[get,set]model> - -Модель ресурса, как правило это результат выполнения C<Http> метода. - -=head2 C<[get,set]cookies> - -Хеш с печеньками, которые будут добавлены в C<HTTP> ответ. - -=head2 C<[get,set]headers> - -Заголовки которые нужно добавить в заголовки C<HTTP> ответа. - -=head2 C<[get,set]status> - -Код C<HTTP> ответа. - -=cut
--- a/Lib/IMPL/XML/SaxParser.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,149 +0,0 @@ -package IMPL::XML::SaxParser; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - XMLReader => 'XML::LibXML::Reader', - Exception => 'IMPL::Exception', - ArgException => '-IMPL::InvalidArgumentException' - }, - base => [ 'IMPL::Object' => undef ], - props => [ _reader => PROP_RW ] -}; - -BEGIN { - XMLReader->import; -} - -sub Parse { - my ( $this, $options ) = @_; - - my $reader = $this->_reader( XMLReader->new($options) ); - - if ( $reader->read() > 0) { - $this->ProcessRootNode($reader); - } -} - -sub ProcessRootNode { - my ( $this, $reader ) = @_; - warn "not implemented"; -} - -sub ReadChildren { - my ( $this, $handler ) = @_; - - my $reader = $this->_reader; - - # содержимое можеть быть только у не пустых элементов - if($reader->nodeType == XML_READER_TYPE_ELEMENT && !$reader->isEmptyElement) { - # нужно прочитать все, что ниже, для этого запоминаем текущий уровень - my $currentLevel = $reader->depth; - - # при чтении и проверке данного условия "съедается" закрывающий теэг текущего узла - while($reader->read && $reader->depth > $currentLevel) { - # при обходе дочерних узлов нужно пропустить закрывающие узлы - $this->$handler($reader) - if $handler and $reader->nodeType != XML_READER_TYPE_END_ELEMENT; - } - } -} - -sub ReadTextNode { - my ($this) = @_; - - my $text = ""; - - my $handler; - $handler = sub { - my ( $me, $reader ) = @_; - if ( $reader->nodeType == XML_READER_TYPE_TEXT ) { - $text .= $reader->value; - } else { - $this->ReadChildren($handler); - } - }; - - $this->ReadChildren($handler); - - return $text; -} - -sub ReadComplexContent { - goto &ReadComplexNode; -} - -sub ReadComplexNode { - my ( $this, $schema ) = @_; - - if ( ref $schema eq 'HASH' ) { - my %data; - - my ($handlers,$aliases); - while(my ($selector,$handler) = each %$schema) { - my ($alias,$node) = split /:/, $selector; - $node ||= $alias; - $handlers->{$node} = $handler; - $aliases->{$node} = $alias; - } - - $this->ReadChildren( - sub { - my ( $me, $node ) = @_; - - my $name = $node->localName; - my $alias = $aliases->{$name}; - if ( my $handler = $handlers->{$name} ) { - if (ref $handler eq 'ARRAY') { - push @{$data{$alias}}, $me->ReadComplexNode($$handler[0]); - } else { - $data{$alias} = $me->ReadComplexNode($handler); - } - } else { - $me->ReadChildren(); - } - } - ); - - return \%data; - } - elsif ( ref $schema eq 'CODE' or not ref $schema ) { - return $this->$schema($this->_reader); - } - else { - die ArgException->new( schema => 'An invalid schema is supplied' ); - } -} - -sub attribute { - shift->_reader->getAttribute(shift); -} - -1; - -__END__ - -=pod - -=head1 NAME - -=head1 DESCRIPTION - -=head1 MEMBERS - -=head2 ReadComplexNode($schema) - -=begin code - -{ - comments => sub { shift->ReadTextNode }, - data => [ { - location => sub { $_[1]->getAttribute('href')} , - timestamp => 'ReadTextNode' - } ] -} - -=end code - -=cut
--- a/Lib/IMPL/_core/version.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -package IMPL::_core::version; - -our $VERSION = '0.04'; - -sub import { - *{scalar(caller).'::VERSION'} = \$VERSION; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::_core::version> - Модуль с версией библиотеки C<IMPL>. - -=head1 DESCRIPTION - -Модуль исключительно для внутреннего использования. - -Все модули подключившие данный модуль разделяют с ним версию. - -=cut
--- a/Lib/IMPL/clone.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -package IMPL::clone; - -use Scalar::Util qw(blessed reftype refaddr); - -use base qw(Exporter); -our @EXPORT_OK = qw(&clone); - -{ - my %handlers = ( - HASH => sub { - my $class = blessed($_[0]); - - my $new = $_[1]->{ refaddr($_[0]) } = {}; - while (my ($key,$val) = each %{$_[0]}) { - $new->{$key} = clone($val,$_[1]); - } - $class ? bless $new, $class : $new; - }, - ARRAY => sub { - my $class = blessed($_[0]); - - my $new = $_[1]->{ refaddr($_[0]) } = []; - - push @$new, clone($_,$_[1]) foreach @{$_[0]}; - - $class ? bless( $new, $class ) : $new; - }, - SCALAR => sub { - my $class = blessed($_[0]); - - my $v = ${$_[0]}; - $class ? bless \$v, $class : \$v; - }, - REF => sub { - my $class = blessed($_[0]); - my $v; - my $new = $_[1]->{ refaddr($_[0]) } = \$v; - $v = clone ( ${$_[0]},$_[1] ); - $class ? bless \$v, $class : \$v; - - }, - REGEXP => sub { - $_[0]; - } - ); - - sub clone { - return unless @_; - - return $_[0] unless ref $_[0]; - - return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_); - } - -} - -1;
--- a/Lib/IMPL/declare.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,216 +0,0 @@ -package IMPL::declare; -use strict; - -use Scalar::Util qw(set_prototype); -use Carp qw(carp); -use IMPL::Class::PropertyInfo(); -use IMPL::Const qw(:access); -use IMPL::require(); - -BEGIN { - *_require = *IMPL::require::_require; - *_trace = *IMPL::require::_trace; -} - -sub import { - my ( $self, $args ) = @_; - - return unless $args; - - die "A hash reference is required" unless ref $args eq 'HASH'; - - no strict 'refs'; - no warnings 'once'; - - my $caller = caller; - - my $aliases = $args->{require} || {}; - - $IMPL::require::PENDING{$caller} = 1; - _trace("declare $caller"); - $IMPL::require::level++; - - while ( my ( $alias, $class ) = each %$aliases ) { - _trace("$alias => $class"); - $IMPL::require::level ++; - my $c = _require($class); - - *{"${caller}::$alias"} = set_prototype( - sub { - $c; - }, - '' - ); - $IMPL::require::level --; - } - - my $base = $args->{base} || {}; - - my %ctor; - my @isa; - - if ( ref $base eq 'ARRAY' ) { - carp "Odd elements number in require" - unless scalar(@$base) % 2 == 0; - while ( my ( $class, $mapper ) = splice @$base, 0, 2 ) { - _trace("parent $class"); - $IMPL::require::level ++; - $class = $aliases->{$class} || _require($class); - $IMPL::require::level --; - - push @isa, $class; - $ctor{$class} = $mapper; - } - } - elsif ( ref $base eq 'HASH' ) { - while ( my ( $class, $mapper ) = each %$base ) { - _trace("parent $class"); - $IMPL::require::level ++; - $class = $aliases->{$class} || _require($class); - $IMPL::require::level --; - - push @isa, $class; - $ctor{$class} = $mapper; - } - } - - %{"${caller}::CTOR"} = %ctor; - push @{"${caller}::ISA"}, @isa; - - if(ref($args->{meta}) eq 'ARRAY') { - $caller->SetMeta($_) foreach @{$args->{meta}}; - } - - my $props = $args->{props} || []; - - if ( $props eq 'HASH' ) { - $props = [%$props]; - } - - die "A hash or an array reference is required in the properties list" - unless ref $props eq 'ARRAY'; - - carp "Odd elements number in properties declaration of $caller" - unless scalar(@$props) % 2 == 0; - - if (@$props) { - $self->_implementProps($props,$caller); - } - - if ($args->{_implement}) { - $self->_implementProps($caller->abstractProps,$caller); - $caller->abstractProps([]); - } - - $IMPL::require::level--; - delete $IMPL::require::PENDING{$caller}; -} - -sub _implementProps { - my ($self, $props, $caller) = @_; - - for ( my $i = 0 ; $i < @$props - 1 ; $i = $i + 2 ) { - my ( $prop, $spec ) = @{$props}[ $i, $i + 1 ]; - - $caller->ClassPropertyImplementor->Implement( - $spec, - { - name => $prop, - class => $caller, - access => $prop =~ /^_/ - ? ACCESS_PRIVATE - : ACCESS_PUBLIC - } - ); - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::declare> - описывает класс - -=head1 SYNOPSIS - -=begin code - -package My::Bar; - -use IMPL::declare { - require => { - TFoo => 'My::Foo', - TBox => 'My::Box' - }, - base => { - TFoo => '@_', - 'IMPL::Object' => undef, - } -} - -sub CreateBox { - my ($this) = @_; - return TBox->new($this); -} - -=end code - -Специальная ситрока C<@_> означает передачу параметров конструктора текущего класса конструктору -базового класса без изменений. - -=head1 DESCRIPTION - -Описывает текущий пакет(модуль) как класс. В качестве параметра получает ссылку на хеш, -в которой храняться метаданные для объявления класса. - -=head1 METADATA - -=head2 C<require> - -Содержит ссылку на хеш с синонимами модулей, которые будут доступны в текушем модуле, -аналогично использованию C<IMPL::require>. Однако, если модуль не требует загрузки при -помощи C<require> нужно использовать префикс C<'-'> в его имени - -=begin code - -{ - require => { - TObject => 'IMPL::Object', # will be loaded with require - TFoo => '-My:App::Data::Foo' # will not use 'require' to load module - } -} - -=end code - -=head2 C<base> - -Обисывает базове классы для текущего класса. Если данный параметр - ссылка массив, то -этот массив будет превращен в массив C<@ISA>. Если данный параметр - ссылка на хеш, то -его ключи опичавют список базовых классов, а значения - преобразование параметров для -вызова базовых конструкторов. - -В качестве имен базовых классов могут быть как полные имена модулей, так и назначенные -ранее псевдонимы. Использование префикса C<'-'> перед B<полным именем модуля> означает, -что модуль не требуется загружать, в случае с псевдонимами, префикс C<'-'> уже был указан -при их объявлении. - -=begin code - -{ - require => { - TFoo => '-My:App::Data::Foo' # will not use 'require' to load module - }, - base => { - TFoo => '@_', # pass parameters unchanged - 'My::Base::Class' => sub { name => $_[0], data => $_[1] }, # remap parameters - '-My::Extentions' => undef, # do not pass any parameters - } -} - -=end code - -=cut
--- a/Lib/IMPL/lang.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,251 +0,0 @@ -package IMPL::lang; -use strict; -use warnings; - -use parent qw(Exporter); -use IMPL::_core::version; -use IMPL::clone qw(clone); -use Scalar::Util qw(blessed); -use Carp qw(carp); - -our @EXPORT = qw(&is &isclass &typeof); -our %EXPORT_TAGS = ( - base => [ - qw( - &is - &clone - &isclass - &typeof - ) - ], - - declare => [ - qw( - &public - &protected - &private - &property - &static - &property - &_direct - &ACCESS_PUBLIC - &ACCESS_PROTECTED - &ACCESS_PRIVATE - &PROP_GET - &PROP_SET - &PROP_OWNERSET - &PROP_LIST - &PROP_ALL - &PROP_RO - &PROP_RW - &PROP_DIRECT - ) - ], - compare => [ - qw( - &equals - &equals_s - &hashCompare - ) - ], - hash => [ - qw( - &hashApply - &hashMerge - &hashDiff - &hashCompare - &hashParse - &hashSave - ) - ] -); - -our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; - -use IMPL::Const qw(:all); - -sub is($$) { - carp "A typename can't be undefined" unless $_[1]; - blessed($_[0]) and $_[0]->isa( $_[1] ); -} - -sub isclass { - carp "A typename can't be undefined" unless $_[1]; - local $@; - eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; -} - -sub typeof(*) { - local $@; - eval { $_[0]->_typeof } || blessed($_[0]) || ref($_[0]); -} - -sub public($) { - my $info = shift; - $info->{access} = ACCESS_PUBLIC; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub private($) { - my $info = shift; - $info->{access} = ACCESS_PRIVATE; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub protected($) { - my $info = shift; - $info->{access} = ACCESS_PROTECTED; - my $implementor = delete $info->{implementor}; - $implementor->Implement($info); -} - -sub _direct ($) { - my $info = shift; - $info->{direct} = 1; - return $info; -} - -sub property($$) { - my ($propName,$attributes) = @_; - - $attributes = { - get => $attributes & PROP_GET, - set => $attributes & PROP_SET, - isList => $attributes & PROP_LIST - } unless ref $attributes; - - my $class = caller; - - return hashMerge ( - $attributes, - { - implementor => $class->ClassPropertyImplementor, - name => $propName, - class => scalar(caller), - } - ); -} - -sub static($$) { - my ( $name, $value ) = @_; - my $class = caller; - $class->static_accessor( $name, $value ); -} - -sub equals { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - - return $_[0] == $_[1]; - } else { - return 0 if defined $_[1]; - - return 1; - } -} - -sub equals_s { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - - return $_[0] eq $_[1]; - } else { - return 0 if defined $_[1]; - - return 1; - } -} - -sub hashDiff { - my ($src,$dst) = @_; - - $dst = $dst ? { %$dst } : {} ; - $src ||= {}; - - my %result; - - foreach my $key ( keys %$src ) { - if (exists $dst->{$key}) { - $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); - delete $dst->{$key}; - } else { - $result{"-$key"} = 1; - } - } - - $result{"+$_"} = $dst->{$_} foreach keys %$dst; - - return \%result; -} - -sub hashMerge { - return hashApply( { %{$_[0] || {}} }, $_[1] ); -} - -sub hashApply { - my ($target,$diff) = @_; - - return $target unless ref $diff eq 'HASH'; - - while ( my ($key,$value) = each %$diff) { - $key =~ /^(\+|-)?(.*)$/; - my $op = $1 || '+'; - $key = $2; - - if ($op eq '-') { - delete $target->{$key}; - } else { - $target->{$key} = $value; - } - } - - return $target; -} - -sub hashCompare { - my ($l,$r,$cmp) = @_; - - $cmp ||= \&equals_s; - - return 0 unless scalar keys %$l == scalar keys %$r; - &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; - - return 1; -} - -sub hashParse { - my ($s,$p,$d) = @_; - - $p = $p ? qr/$p/ : qr/\n+/; - $d = $d ? qr/$d/ : qr/\s*=\s*/; - - return { - map split($d,$_,2), split($p,$s) - }; -} - -sub hashSave { - my ($hash,$p,$d) = @_; - - return "" unless ref $hash eq 'HASH'; - - $p ||= "\n"; - $d ||= " = "; - - return - join( - $p, - map( - join( - $d, - $_, - $hash->{$_} - ), - keys %$hash - ) - ); -} - -1;
--- a/Lib/IMPL/require.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -package IMPL::require; -use Scalar::Util qw(set_prototype); -use strict; -#require IMPL::Code::Loader; - -use Carp qw(carp); - -our %PENDING; -our $LOADER_LOG; - -our $level = 0; - -sub import { - my ($self, $aliases) = @_; - - return unless $aliases; - - die "A hash reference is required" unless ref $aliases eq 'HASH'; - - my $caller = caller; - - $PENDING{$caller} = 1; - - no strict 'refs'; - - while( my ($alias, $class) = each %$aliases ) { - _trace("$alias => $class"); - $level++; - - $class = _require($class); - - *{"${caller}::$alias"} = set_prototype(sub { - $class - }, ''); - - $level--; - } - - delete $PENDING{$caller}; -} - -sub _require { - my ($class) = @_; - - if ( not $class =~ s/^-// ) { - ( my $file = $class ) =~ s/::|'/\//g; - _trace("already pending") and return $class - if $PENDING{$class}; - $PENDING{$class} = 1; - _trace("loading $file.pm"); - $level++; - require "$file.pm"; - $level--; - _trace("loaded $file.pm"); - delete $PENDING{$class}; - } - $class; -} - -sub _trace { - my ($message) = @_; - - $LOADER_LOG->print("\t" x $level ,"$message\n") if $LOADER_LOG; - - return 1; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::require> загружает и назначет псевдонимы модулям. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - TFoo => 'My::Nested::Package::Foo', - FS => 'File::Spec' -}; - -my $obj = My::Nested::Package::Foo->new('foo'); -$obj = TFoo->new('foo'); # ditto - -FS->catdir('one','two','three'); - -=end code - -=head1 DESCRIPTION - -Загружает модули с помощью C<require> и создает константы которые возвращаю полное имя модуля. - - -=cut \ No newline at end of file
--- a/Lib/IMPL/template.pm Mon Aug 31 20:22:16 2015 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -package IMPL::template; -use strict; -use warnings; - -use IMPL::Class::Template(); - -sub import { - shift; - my %args = @_; - - my $class = caller; - - my @paramNames = grep m/\w+/, @{$args{parameters} || []}; - my $declare = $args{declare}; - my @isa = (@{$args{base} || []}, $class); - my %instances; - - no strict 'refs'; - - push @{"${class}::ISA"}, 'IMPL::Class::Template'; - - *{"${class}::$_"} = sub { die IMPL::InvalidOperationException("A template parameter isn't available here") } - foreach @paramNames; - - *{"${class}::spec"} = sub { - my ($self,@params) = @_; - - my $specClass = $self->makeName(@params); - - return $specClass if $instances{$specClass}; - - $instances{$specClass} = 1; - - for (my $i=0; $i < @paramNames; $i++) { - my $param = $params[$i]; - *{"${specClass}::$paramNames[$i]"} = sub { $param }; - } - - @{"${specClass}::ISA"} = @isa; - - &$declare($specClass) if $declare; - return $specClass; - }; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::template> директива для объявления шаблона. - -=head1 SYNPOSIS - -=begin code - -package KeyValuePair; - -use IMPL::Class::Property; - -use IMPL::template ( - parameters => [qw(TKey TValue))], - base => [qw(IMPL::Object IMPL::Object::Autofill)], - declare => sub { - my ($class) = @_; - public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } ); - public $class->CreateProperty(value => prop_all, { type => $class->TValue} ); - - $class->PassThroughArgs; - } -); - -BEGIN { - public property id => prop_get | owner_set, { type => 'integer'}; -} - -__PACKAGE__->PassThroughArgs; - -package MyCollection; - -use IMPL::Class::Property; - -use IMPL::lang; -use IMPL::template( - parameters => [qw(TKey TValue)], - base => [qw(IMPL::Object)], - declare => sub { - my ($class) = @_; - my $item_t = spec KeyValuePair($class->TKey,$class->TValue); - - public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } ); - - $class->static_accessor( ItemType => $item_t ); - } -) - -sub Add { - my ($this,$key,$value) = @_; - - die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey; - die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue; - - $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) ); -} - -package main; - -use IMPL::require { - TFoo => 'Some::Package::Foo', - TBar => 'Some::Package::Bar' -}; - -my $TCol = spec MyCollection(TFoo, TBar); - -=end code - -=head1 DESCRIPTION - -Шаблоны используются для динамической генерации классов. Процесс создания класса -по шаблону называется специализацией, при этом создается новый класс: - -=over - -=item 1 - -Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона - -=item 2 - -Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона - -=item 3 - -Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров - -=item 4 - -Вызывается метод для конструирования специализиции - -=back - -=head1 MEMBERS - -=over - -=item C<spec(@params)> - -Метод, создающий специализацию шаблона. Может быть вызван как оператор. - -=back - -=cut
--- a/_test/temp.pl Mon Aug 31 20:22:16 2015 +0300 +++ b/_test/temp.pl Fri Sep 04 19:40:23 2015 +0300 @@ -1,37 +1,32 @@ #!/usr/bin/perl use strict; -use YAML::XS; -$YAML::XS::DumpCode = 1; +use Time::HiRes qw(gettimeofday tv_interval); +use constant COUNT => 20000000; + +my $t; + +$t = [gettimeofday]; + +for ( my $i = 0 ; $i < COUNT ; $i++ ) { + my $o = []; + $o->[0] = 10; + $o->[20] = 11; +} + +print "Arrays: ", tv_interval( $t, [gettimeofday] ), "\n"; -my $conf = { - '@include' => [qw(security view)], - runtime => { - type => 'IMPL::Web::Application', - params => { - handlers => {depdendency => 'filters'} - } - }, - filters => [ - { type => 'IMPL::Web::CookieAuth' }, - { type => 'IMPL::Web::Security' }, - { type => 'IMPL::Web::LocaleHandler', - params => { - locales => [ - 'en-US', - 'ru-RU' - ], - default => 'en-US' - } - }, - { type => 'IMPL::Web::ContentNegotiation' }, - { type => 'IMPL::Web::RestController' } - ], - custom => { - factory => sub { return "hi!" } - } -}; +$t = [gettimeofday]; + -print Dump($conf); +for ( my $i = 0 ; $i < COUNT ; $i++ ) { + my $o = {}; + $o->{a} = 10; + $o->{b} = 11; +} -1; \ No newline at end of file +print "Hashes: ", tv_interval( $t, [gettimeofday] ), "\n"; + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,15 @@ +package IMPL; +use strict; + +use IMPL::_core qw(setDebug); +use IMPL::_core::version; + +sub import { + my ($opts) = @_; + + if (ref $opts eq 'HASH') { + setDebug($$opts{Debug}) if exists $$opts{Debug}; + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/AppException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,144 @@ +package IMPL::AppException; +use strict; +use mro 'c3'; +use overload + '""' => 'ToString', + 'bool' => sub { return 1; }, + 'fallback' => 1; + +use Carp qw(longmess shortmess); +use Scalar::Util qw(refaddr); + +use IMPL::Const qw(:prop); +use IMPL::Resources::Strings { + message => "Application exception" +}; + +use IMPL::declare { + base => [ + 'IMPL::Object' => undef + ], + props => [ + source => PROP_RO, + callStack => PROP_RO, + ] +}; + +sub new { + my $self = shift; + + my $instance = $self->next::method(@_); + + $instance->source(shortmess); + $instance->callStack(longmess); + + return $instance; +} + +sub ToString { + my ($this) = @_; + + return join("\n", $this->message, $this->callStack); +} + +sub throw { + my $self = shift; + + die $self->new(@_); +} + +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 Fri Sep 04 19:40:23 2015 +0300 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/DirectPropertyInfo.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,10 @@ +package IMPL::Class::DirectPropertyInfo; +use strict; + +use parent 'IMPL::Class::PropertyInfo'; +our %CTOR = ('IMPL::Class::PropertyInfo' => '@_'); + +__PACKAGE__->mk_accessors(qw(fieldName directAccess)); + + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/Member.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,38 @@ +package IMPL::Class::Member; +use strict; +use parent qw(Exporter); +our @EXPORT = qw(&public &private &protected &_direct); + + +use IMPL::Const qw(:access); + +require IMPL::Class::MemberInfo; + +sub public($) { + my $info = shift; + $info->{access} = ACCESS_PUBLIC; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub private($) { + my $info = shift; + $info->{access} = ACCESS_PRIVATE; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub protected($) { + my $info = shift; + $info->{access} = ACCESS_PROTECTED; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub _direct($) { + my $info = shift; + $info->{direct} = 1; + return $info; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/MemberInfo.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,84 @@ +package IMPL::Class::MemberInfo; +use strict; + +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 + attributes + ) +); + +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; + + $this->attributes({}) unless defined $this->attributes; + $this->access(3) unless $this->access; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Class::MemberInfo> - информация о члене класса. + +=head1 DESCRIPTION + +Данный класс является базовым для таких классов как C<IMPL::Class::PropertyInfo>, C<IMPL::Class::MethodInfo> и +предназначен для хренения метаданных. + +Данный класс наследуется от C<IMPL::Object::Accessor> и не содержит в себе метаданных о своих членах. + +=head1 MEMBERS + +=over + +=item C<[get,set] name> + +Имя члена. + +=item C<[get,set] access> + +Default public. + +Атрибут доступа ( public | private | protected ) + +=item C<[get,set] class> + +Класс владелец + +=item C<[get,set] attributes> + +Дополнительные атрибуты + +=item C<Implement()> + +При реализации собственного субкласса, данный метод может быть переопределен для +реализации дополнительной обработки (например, создание методов доступа для свойств). + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/Meta.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,344 @@ +package IMPL::Class::Meta; +use strict; + +use Carp qw(carp confess); +use IMPL::clone qw(clone); + +my %class_meta; +my %class_data; + +sub SetMeta { + my ($class,$meta_data) = @_; + $class = ref $class || $class; + + # тут нельзя использовать стандартное исключение, поскольку для него используется + # класс IMPL::Object::Accessor, который наследуется от текущего класса + confess "The meta_data parameter should be an object" if not ref $meta_data; + + push @{$class_meta{$class}{ref $meta_data}},$meta_data; +} + +sub set_meta { + goto &SetMeta; +} + +sub GetMeta { + my ($class,$meta_class,$predicate,$deep) = @_; + $class = ref $class if ref $class; + no strict 'refs'; + my @result; + + if ($predicate) { + push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) ); + } else { + push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ); + } + + if ($deep) { + push @result, map { $_->can('GetMeta') ? $_->GetMeta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'}; + } + + wantarray ? @result : \@result; +} + +sub get_meta { + goto &GetMeta; +} + +sub class_data { + my $class = shift; + $class = ref $class || $class; + + carp 'The method is obsolete, use static_accessor($name,$value,\'clone\') instead'; + + if (@_ > 1) { + my ($name,$value) = @_; + return $class_data{$class}{$name} = $value; + } else { + my ($name) = @_; + + if( exists $class_data{$class}{$name} ) { + $class_data{$class}{$name}; + } else { + if ( my $value = $class->_find_class_data($name) ) { + $class_data{$class}{$name} = clone($value); + } else { + undef; + } + } + } +} + +sub static_accessor { + my ($class,$name,$value,$inherit) = @_; + + $inherit ||= 'inherit'; + + my $method = "static_accessor_$inherit"; + + return $class->$method($name,$value); +} + +sub static_accessor_clone { + my ($class,$name,$value) = @_; + $class = ref $class || $class; + + no strict 'refs'; + + *{"${class}::${name}"} = sub { + my $self = shift; + + $self = ref $self || $self; + + if (@_ > 0) { + if ($class ne $self) { + $self->static_accessor_clone( $name => $_[0] ); # define own class data + } else { + $value = $_[0]; + } + } else { + return $self ne $class + ? $self->static_accessor_clone($name => clone($value)) + : $value; + } + }; + return $value; +}; + +sub static_accessor_inherit { + my ($class,$name,$value) = @_; + + no strict 'refs'; + + *{"${class}::$name"} = sub { + my $self = shift; + + if (@_ > 0) { + $self = ref $self || $self; + + if ($class ne $self) { + $self->static_accessor_inherit( $name => $_[0] ); # define own class data + } else { + $value = $_[0]; + } + } else { + $value ; + } + }; + return $value; +} + +sub static_accessor_own { + my ($class,$name,$value) = @_; + + no strict 'refs'; + + *{"${class}::$name"} = sub { + my $self = shift; + $self = ref $self || $self; + + if ($class ne $self) { + if (@_ > 0) { + $self->static_accessor_own( $name => $_[0] ); # define own class data + } else { + return; + } + } else { + if ( @_ > 0 ) { + $value = $_[0]; + } else { + return $value; + } + } + }; + + return $value; +} + +sub _find_class_data { + my ($class,$name) = @_; + + no strict 'refs'; + + exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"}; + + my $val; + $val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"}; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Class::Meta> - информация хранимая на уровне класса. + +=head1 SYNOPSIS + +=begin code + +package InfoMeta; + +use parent qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property name => prop_get | owner_set; +} + +package InfoExMeta; +use parent qw(InfoMeta); + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property description => prop_all; +} + +package Foo; + +__PACKAGE__->set_meta(new InfoMeta(name => 'info')); +__PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' )); + +package main; + +# get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta +my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx'; + +# get all InfoExMeta meta +@info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx' + +# get filtered meta +@info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info' + +=end code + +=head1 DESCRIPTION + +Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты, +притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные. + +Существует возможность выборки метаданных с учетом унаследованных от базовых классов + +=head1 MEMBERS + +=head2 C<set_meta($meta_data)> + +Добавляет метаданные C<$meta_data> к классу. + +=head2 C<get_meta($meta_class,$predicate,$deep)> + +Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения +метаданных базовых классов. + +=over + +=item C<$meta_class> + +Тип метаданных + +=item C<$predicate> + +Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата +ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра +объект с метаданными, возвращает C<true> - включить метаданные в результа, C<false> - пропустить +метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными. + +=begin code + +my @info = Foo->get_meta( + 'InfoMeta', + sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta') + 1 # deep search +); + +my @info = Foo->get_meta( + 'InfoMeta', + sub { + my $item = shift; + ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta') + }, + 1 # deep search +); + +=end code + +=item C<$deep> + +Осуществлять поиск по базовым классам. + +=back + +=head2 C<static_accessor($name[,$value[,$inherit]])> + +Создает статическое свойство с именем C<$name> и начальным значением C<$value>. + +Параметр C<$inherit> контролирует то, как наследуются значения. + +=over + +=item * C<inherit> + +По умолчанию. Означает, что если для класса не определено значение, оно будет +получено от родителя. + +=item * C<clone> + +Если для класса не определено значение, то оно будет клонировано из +родительского значения при первом обращении. Полезно, когда родитель задает +значение по-умолчанию, которое разделяется между несколькими потомками, +которые модифицирю само значение (например значением является ссылка на хеш, +а потомки добавляют или меняют значения в этом хеше). + +=item * C<own> + +Каждый класс имеет свое собственное значение не зависящее от того, что было +у предка. Начальное значение для этого статического свойства C<undef>. + +=back + +Данный метод является заглушкой, он передает управление +C<static_accessor_inherit>, C<static_accessor_clone>, C<static_accessor_own> +соответственно. Эти методы можно вызывать явно +C<static_accessor_*($name[,$value])>. + + +=begin code + +package Foo; +use parent qw(IMPL::Class::Meta); + +__PACKAGE__->static_accessor( info => { version => 1 } ); +__PACKAGE__->static_accessor( mappings => { toString => \&ToString }, 'clone' ); +__PACKAGE__->static_accessor( _instance => undef, 'own' ); + +sub ToString { + "[object Foo]"; +} + +sub default { + my ($self) = @_; + + $self = ref $self || $self; + return $self->_instance ? $self->_instance : $self->_instance($self->new()); +} + +package Bar; +use parent qw(Foo); + +__PACKAGE__->info({language => 'English', version => 2}); # will define own 'info' but will loose original data. +__PACKAGE__->mappings->{sayHello} = \&SayHello; # will not affect Foo->mappings; + +package main; + +my $foo = Foo->default; # will be a Foo object +my $bar = Bar->default; # will be a Bar object + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/MethodInfo.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,13 @@ +use strict; +package IMPL::Class::MethodInfo; + +use parent qw(IMPL::Class::MemberInfo); + +__PACKAGE__->PassThroughArgs; + +__PACKAGE__->mk_accessors(qw( + returnType + parameters +)); + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/Property.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,55 @@ +package IMPL::Class::Property; +use strict; +use parent qw(Exporter); + +BEGIN { + our @EXPORT = qw(property prop_get prop_set owner_set prop_none prop_all prop_list CreateProperty); +} + +use IMPL::lang qw(:hash); +use IMPL::Const qw(:prop); +use Carp qw(carp); +require IMPL::Class::Member; + +sub import { + __PACKAGE__->export_to_level(1,@_); + IMPL::Class::Member->export_to_level(1,@_); +} + +sub prop_get { 1 }; +sub prop_set { 2 }; +sub owner_set { 10 }; +sub prop_none { 0 }; +sub prop_all { 3 }; +sub prop_list { 4 }; + +sub property($$) { + my ($propName,$attributes) = @_; + + my $class = caller; + + return hashMerge ( + $class->ClassPropertyImplementor->NormalizeSpecification($attributes), + { + implementor => $class->ClassPropertyImplementor, + name => $propName, + class => scalar(caller), + } + ); +} + +sub CreateProperty { + my ($class,$propName,@attributes) = @_; + + $class + ->ClassPropertyImplementor + ->Implement( + @attributes, + { + name => $propName, + class => $class, + } + ); +}; + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/PropertyInfo.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,38 @@ +package IMPL::Class::PropertyInfo; +use strict; + +BEGIN { + our @ISA = qw(IMPL::Class::MemberInfo); +} + +require IMPL::Class::MemberInfo; + +our %CTOR = ( 'IMPL::Class::MemberInfo' => '@_' ); + +__PACKAGE__->mk_accessors( + qw( + type + getter + setter + ownerSet + isList + ) +); +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Class::PropertyInfo> - метаданные о свойствах объектов. Используются для отражения и +проверки данных объектов. + +=head1 DESCRIPTION + +В зависимости от типа каждый объект предоставляет способ хранения данных, например хеши позволяют +хранить состояние в виде ассоциативного массива и т.д. Информация о свойстве предоставляет определенный +уровень абстракции. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Class/Template.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,113 @@ +package IMPL::Class::Template; +use strict; +use IMPL::lang; +use IMPL::_core::version; + +sub makeName { + my ($class,@params) = @_; + + $_ =~ s/^.*::(\w+)$/$1/ foreach @params; + return join('',$class,@params); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Class::Template> базовый класс для шаблонов. + +=head1 SYNPOSIS + +=begin code + +package KeyValuePair; + +use IMPL::Class::Property; + +use IMPL::template ( + parameters => [qw(TKey TValue))], + base => [qw(IMPL::Object IMPL::Object::Autofill)], + declare => sub { + my ($class) = @_; + public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } ); + public $class->CreateProperty(value => prop_all, { type => $class->TValue} ); + + $class->PassThroughArgs; + } +); + +BEGIN { + public property id => prop_get | owner_set, { type => 'integer'}; +} + +__PACKAGE__->PassThroughArgs; + +package MyCollection; + +use IMPL::Class::Property; + +use IMPL::lang; +use IMPL::template( + parameters => [qw(TKey TValue)], + base => [qw(IMPL::Object)], + declare => sub { + my ($class) = @_; + my $item_t = spec KeyValuePair($class->TKey,$class->TValue); + + public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } ) + + $class->static_accessor( ItemType => $item_t ); + } +) + +sub Add { + my ($this,$key,$value) = @_; + + die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey; + die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue; + + $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) ); +} + +=end code + +=head1 DESCRIPTION + +Шаблоны используются для динамической генерации классов. Процесс создания класса +по шаблону называется специализацией, при этом создается новый класс: + +=over + +=item 1 + +Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона + +=item 2 + +Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона + +=item 3 + +Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров + +=item 4 + +Вызывается метод для конструирования специализиции + +=back + +=head1 MEMBERS + +=over + +=item C<spec(@params)> + +Метод, создающий специализацию шаблона. Может быть вызван как оператор. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Code/AccessorPropertyImplementor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Code/BasePropertyImplementor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,149 @@ +package IMPL::Code::BasePropertyImplementor; +use strict; + +use IMPL::Const qw(:prop :access); +use Scalar::Util qw(looks_like_number); + +use constant { + CodeNoGetAccessor => 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;', + CodeNoSetAccessor => 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;', + CodeCustomGetAccessor => '$this->$get(@_);', + CodeCustomSetAccessor => '$this->$set(@_);', + CodeValidator => '$this->$validator(@_);', + CodeOwnerCheck => "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;" +}; + +sub CodeSetAccessor { + die new IMPL::Exception("Standard accessors not supported",'Set'); +} + +sub CodeGetAccessor { + die new IMPL::Exception("Standard accessors not supported",'Get'); +} + +sub CodeGetListAccessor { + die new IMPL::Exception("Standard accessors not supported",'GetList'); +} + +sub CodeSetListAccessor { + die new IMPL::Exception("Standard accessors not supported",'SetList'); +} + +sub factoryParams { qw($class $name $set $get $validator) }; + +our %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;" +); + +sub NormalizeSpecification { + my ($this,$spec) = @_; + + return $spec if ref($spec); + + if (looks_like_number($spec)) { + return { + get => $spec & PROP_GET, + set => $spec & PROP_SET, + isList => $spec & PROP_LIST, + ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET), + direct => $spec & PROP_DIRECT + }; + } else { + return {}; + } +} + +sub CreateFactoryId { + my ($self, $spec) = @_; + + join( '', + map( + ($_ + ? ( _isCustom($_) + ? 'x' + : 's') + : '_'), + @$spec{qw(get set)} + ), + $spec->{access} || ACCESS_PUBLIC, + $spec->{validator} ? 'v' : '_', + $spec->{isList} ? 'l' : '_', + $spec->{ownerSet} ? 'o' : '_' + ); +} + +sub _isCustom { + ref($_[0]) eq 'CODE' || not(ref($_[0]) || looks_like_number($_[0])); +} + +sub CreateFactory { + my ($self,$spec) = @_; + + return $self->CreateFactoryImpl( + ($spec->{get} + ? ( _isCustom($spec->{get}) + ? $self->CodeCustomGetAccessor + : ($spec->{isList} + ? $self->CodeGetListAccessor + : $self->CodeGetAccessor + ) + ) + : $self->CodeNoGetAccessor + ), + ($spec->{set} + ? ( _isCustom($spec->{set}) + ? $self->CodeCustomSetAccessor + : ($spec->{isList} + ? $self->CodeSetListAccessor + : $self->CodeSetAccessor + ) + ) + : $self->CodeNoSetAccessor + ), + $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '', + $spec->{validator} ? $self->CodeValidator : '', + $spec->{ownerSet} ? $self->CodeOwnerCheck : '' + ); +} + +sub CreateFactoryImpl { + my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_; + + my $strParams = join(',',$self->factoryParams); + + my $factory = <<FACTORY; + +sub { + my ($strParams) = \@_; + return 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 NAME + +C<IMPL::Code::BasePropertyImplementor> набор впомогательныйх статических методов +для генерации свойств. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Code/DirectPropertyImplementor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,96 @@ +package IMPL::Code::DirectPropertyImplementor; +use strict; + +require IMPL::Object::List; + +use IMPL::lang qw(:hash); +use IMPL::require { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo' +}; + +use parent qw(IMPL::Code::BasePropertyImplementor); + +use constant { + CodeGetAccessor => 'return ($this->{$field});', + CodeSetAccessor => 'return ($this->{$field} = $_[0])', + CodeGetListAccessor => 'return( + wantarray ? + @{ $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + } : + ( $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + ) + );', + CodeSetListAccessor => '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 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 = 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Code/Loader.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,79 @@ +package IMPL::Code::Loader; +use strict; +use warnings; + +use IMPL::Const qw(:prop); +use File::Spec; +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException' + }, + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + }, + props => [ + verifyNames => PROP_RO, + prefix => PROP_RO, + _pending => PROP_RW + ] +}; + +my $default; +sub default { + $default ||= new IMPL::Code::Loader; +} + +my $safe; +sub safe { + $safe ||= new IMPL::Code::Loader(verifyNames => 1); +} + +sub CTOR { + my ($this) = @_; + + $this->_pending({}); +} + +sub Require { + my ($this,$package) = @_; + + 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; + + my $file = join('/', split(/::/,$package)) . ".pm"; + + require $file; + + return $package; +} + +sub ModuleExists { + my ($this,$package) = @_; + + my $file = join('/', split(/::/,$this->GetFullName($package))) . ".pm"; + + -f File::Spec->catfile($_,$file) and return 1 foreach @INC; + + return 0; +} + +sub GetFullName { + my ($this,$package) = @_; + + if ($this->verifyNames) { + $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/ + or die ArgumentException->new(package => 'Invalid package name') ; + } + + return $this->prefix . '::' . $package if $this->prefix; +} + +1; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,291 @@ +package IMPL::Config; +use strict; +use warnings; +use mro; + +use Carp qw(carp); + +use IMPL::lang qw(is); +use IMPL::Exception; +use IMPL::Const qw(:access); +use IMPL::declare { + require => { + PropertyInfo => 'IMPL::Class::PropertyInfo', + XmlFormatter => 'IMPL::Serialization::XmlFormatter', + Serializer => '-IMPL::Serializer', + Activator => '-IMPL::Config::Activator', + + Exception => 'IMPL::Exception', + IOException => '-IMPL::IOException' + }, + base => [ + 'IMPL::Object::Accessor' => undef, + 'IMPL::Object::Serializable' => undef, + 'IMPL::Object::Autofill' => '@_' + ] +}; + +use File::Spec(); + + +our $ConfigBase ||= ''; +our $AppBase; + +sub LoadXMLFile { + my ($self,$file) = @_; + + my $class = ref $self || $self; + + my $serializer = Serializer->new( + formatter => XmlFormatter->new( + IdentOutput => 1, + SkipWhitespace => 1 + ) + ); + + open my $hFile,'<',$file or die IOException->new("Failed to open file",$file,$!); + + my $obj; + eval { + $obj = $serializer->Deserialize($hFile); + }; + + if ($@) { + my $e=$@; + die Exception->new("Can't load the configuration file",$file,$e); + } + return $obj; +} + +sub SaveXMLFile { + my ($this,$file) = @_; + + my $serializer = Serializer->new( + formatter => XmlFormatter->new( + IdentOutput => 1, + SkipWhitespace => 1 + ) + ); + + open my $hFile,'>',$file or die IOException->new("Failed to open file",$file,$!); + + $serializer->Serialize($hFile, $this); +} + +sub xml { + my $this = shift; + my $serializer = Serializer->new( + formatter => XmlFormatter->new( + IdentOutput => 1, + SkipWhitespace => 1 + ) + ); + my $str = ''; + open my $hFile,'>',\$str or die IOException->new("Failed to open stream",$!); + + $serializer->Serialize($hFile, $this); + + undef $hFile; + + return $str; +} + +sub save { + my ($this,$ctx) = @_; + + my $val; + + $val = $this->rawGet($_) and $ctx->AddVar($_ => $val) foreach map $_->Name, $this->get_meta( + PropertyInfo, + sub { + $_->access == ACCESS_PUBLIC and + $_->setter; + }, + 1); +} + +sub spawn { + my ($this,$file) = @_; + unless ($file) { + ($file = ref $this || $this) =~ s/:+/./g; + $file .= ".xml"; + } + return $this->LoadXMLFile( File::Spec->catfile($ConfigBase,$file) ); +} + +sub get { + my $this = shift; + + if (@_ == 1) { + my $obj = $this->SUPER::get(@_); + return is($obj,Activator) ? $obj->activate : $obj; + } else { + my @objs = $this->SUPER::get(@_); + return map is($_,Activator) ? $_->activate : $_, @objs ; + } +} + +sub rawGet { + my $this = shift; + return $this->SUPER::get(@_); +} + +sub Exists { + $_[0]->SUPER::get($_[1]) ? 1 : 0; +} + +sub AppBase { + carp "obsolete"; + shift; + File::Spec->catdir($AppBase,@_); +} + +sub AppDir { + shift; + File::Spec->catdir($AppBase,@_); +} + +sub AppFile { + shift; + File::Spec->catfile($AppBase,@_); +} + +sub ConfigBase { + carp "obsolete"; + shift; + File::Spec->catdir($ConfigBase,@_); +} + +sub ConfigDir { + shift; + File::Spec->catdir($ConfigBase,@_); +} + +sub ConfigFile { + shift; + File::Spec->catfile($ConfigBase,@_); +} + +1; +__END__ + +=pod + +=head1 NAME + +C<IMPL::Config> - базовый класс для настраиваемого приложения. + +=head1 SYNOPSIS + +=begin code + +# define application + +package MyApp; +use parent qw(IMPL::Config); + +use IMPL::Class::Property; +use IMPL::Config::Class; + +BEGIN { + public property SimpleString => prop_all; + public property DataSource => prop_all; +} + +sub CTOR { + my $this = shift; + + $this->DataSource( + new IMPL::Config::Activator( + factory => 'MyDataSource', + parameters=>{ + host => 'localhost', + user => 'dbuser' + } + ) + ) unless $this->Exists('DataSource'); +} + +# using application object + +my $app = spawn MyApp('default.xml'); + +$app->Run(); + +=end code + +Ниже приведен пример файла C<default.xml> содержащего настройки приложения + +=begin code xml + +<app type='MyApp'> + <SimpleString>The application</SimpleString> + <DataSource type='IMPL::Config::Activator'> + <factory>MyDataSourceClass</factory> + <parameters type='HASH'> + <host>localhost</host> + <user>dbuser</user> + </parameters> + </DataSource> +</app> + +=end code xml + +=head1 DESCRIPTION + +C<[Serializable]> + +C<[Autofill]> + +C<use parent IMPL::Object::Accessor> + +Базовый класс для приложений. Использует подход, что приложение +является объектом, состояние которого предтавляет собой конфигурацию, +а методы - логику. + +Данный класс реализует функционал десериализации (и сериализации) экземпляра +приложения из XML документа. Для этого используется механизм C<IMPL::Serialization>. +При этом используются опции C<IMPL::Serialization::XmlFormatter> C<IdentOutput> и +C<SkipWhitespace> для записи документа в легко читаемом виде. + +Поскольку в результате восстановления приложения восстанавливаются все элементы +из файла конфигурации, то это может потребовать значительных ресурсов для +создания частей, которые могут никогда не понадобиться. Например, не требуется инициализация +источника данных для передачи пользователю статических данных, сохраненных на диске. + +Для решения этой проблемы используются специальные объекты C<IMPL::Config::Activator>. + +Если у приложения описано свойство, в котором хранится C<IMPL::Config::Activator>, то +при первом обращении к такому свойству, будет создан объект вызовом метода +C<< IMPL::Config::Activator->activate() >> и возвращен как значение этого свойства. +Таким образом реализуется прозрачная отложенная активация объектов, что позволяет +экономить ресурсы. + +=head1 MEMBERS + +=over + +=item C<[static] LoadXMLFile($fileName) > + +Создает из XML файла C<$fileName> экземпляр приложения + +=item C<SaveXMLFile($fileName)> + +Сохраняет приложение в файл C<$fileName> + +=item C<[get] xml > + +Сохраняет конфигурацию приложения в XML строку. + +=item C<[static,operator] spawn($file)> + +Синоним для C<LoadXMLFile>, предполагается использование как оператора. + +=item C<rawGet($propname,...)> + +Метод для получения значений свойств приложения. Данный метод позволяет избежать +использование активации объектов через C<IMPL::Config::Activator>. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/ActivationContext.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,68 @@ +package IMPL::Config::ActivationContext; + +use IMPL::Const qw(:prop); +use IMPL::Exception(); +use IMPL::declare { + require => { + PropertyBag => 'IMPL::Config::ServicesBag' + }, + base => { + 'IMPL::Object' => '@_' + }, + props => { + _services => PROP_RW, + _cache => PROP_RW, + _stack => PROP_RW + } +}; + +sub GetService { + my ($this,$serviceId) = @_; + + $this->_services-> +} + +sub EnterScope { + my ($this, $name, $localize) = @_; + + my $info = { name => $name }; + + if ($localize) { + $info->{services} = $this->_services; + + $this->_services(PropertyBag->new($this->_services)); + } + + $this->_stack->Push($info); +} + +sub LeaveScope { + my ($this) = @_; + + my $info = $this->_stack->Pop() + or die IMPL::InvalidOperationException(); + + if ($info->{services}) + $this->_services($info->{services}); +} + +1; +__END__ + +=pod + +=head1 NAME + +C<IMPL::Config::ActivationContext> - an activation context for the service + +=head1 SYNOPSIS + +For the internal use only + +=head1 MEMBERS + +=head2 METHODS + +=head3 GetService($serviceId) + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Activator.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,91 @@ +package IMPL::Config::Activator; +use strict; + +use Scalar::Util qw(reftype); +use IMPL::lang; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Loader => 'IMPL::Code::Loader', + Exception => 'IMPL::Exception' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::PublicSerializable' => undef + ], + props => [ + factory => PROP_RW, + parameters => PROP_RW, + singleCall => PROP_RW, + _object => PROP_RW + ] +}; + +use constant { + SELF_CLASS => __PACKAGE__, +}; + +sub CTOR { + my $this = shift; + + die Exception->new("A factory parameter is required") unless $this->factory; + +} + + +sub activate { + my $this = shift; + + unless ($this->_object) { + my @args; + + my $params = $this->parameters; + if (ref $params eq 'HASH') { + while ( my ($key,$value) = each %$params ) { + push @args,$key, is($value,SELF_CLASS) ? $value->activate : $value; + } + } elsif (ref $params eq 'ARRAY') { + push @args, map is($_,SELF_CLASS) ? $_->activate : $_, @$params; + } else { + push @args, is($params,SELF_CLASS) ? $params->activate : $params; + } + + push @args, map is($_,SELF_CLASS) ? $_->activate : $_, @_ if @_; + + my $factory = $this->factory; + Loader->default->Require($factory) + unless ref($factory); + + my $instance = $factory->new(@args); + + $this->_object($instance) + unless $this->singleCall; + + return $instance; + } else { + return $this->_object; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Config::Activator> - объект, используемый для получения других объектов. + +=head1 DESCRIPTION + +Служит дополнительным уровнем абстракции в тех случаях, когда нужный объект +заранее не известен или его создание должно происходить по требованию. +От обычной фабрики отличается также тем, что рассматривает формальные параметры +на наличие активаторов и выполняет их при активации. + +Кроме того можно указать, что процесс активации должен происходить при каждом +обращении. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Container.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,34 @@ +package IMPL::Config::Container; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Config::Container> - dependency injection container + +=head1 SYNOPSIS + +=head2 METHODS + +=head3 GetService($serviceId) + +=over + +=item * $serviceId + +A string indetifier of the service, it can be in two forms: class name or service name, +for the class name it should be prefixed with C<@>, for example: C<@Foo::Bar>. + +=back + +The activation container maintains two maps, one for classes and the other for names. +The first one is useful when we searching for an implementation the second one when +we need a particular service. + +=head3 RegisterService($descriptor) + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Descriptor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,51 @@ +package IMPL::Config::Descriptor; + + + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Config::Descriptor> - the abstract base types for the service descriptors + +=head1 SYNOPSIS + +=begin code + +package MyDescriptor; + +use IMPL::declare { + base => { + 'IMPL::Config::Descriptor' => '@_' + } +}; + +sub Activate { + my ($this,$context) = @_; + + my $service = $context->GetService('service'); + my + +} + +=end code + +=head1 MEMBERS + +=head1 SEE ALSO + +=over + +=item * L<ReferenceDescriptor> - describes a reference to the service + +=item * L<ServiceDescriptor> - descibes a service factory + +=item * L<ValueDescriptor> - describes a value + +=back + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Include.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,18 @@ +package IMPL::Config::Include; +use strict; +use warnings; +use IMPL::require { + Conf => 'IMPL::Config', + Exception => 'IMPL::Exception' +}; + + +sub restore { + my ($self,$data) = @_; + + die Exception->new("A file name is required") if ref $data || not $data; + + return Conf->spawn($data); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Path.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,29 @@ +package IMPL::Config::Path; +use strict; +use IMPL::Config(); + +use IMPL::require { + Exception => 'IMPL::Exception', + OpException => '-IMPL::InvalidOperationException' +}; + +sub restore { + my ($self,$data,$surrogate) = @_; + + die OpException->new("Invalid content") unless ref $data eq 'ARRAY' && @$data == 2; + + my ($base,$path) = @$data; + + my %types = ( + appBase => 'AppDir', + configBase => 'ConfigDir' + ); + + my $method = $types{$base}; + + die OpException->new("Unsupported path type",$base) unless $method; + + return IMPL::Config->$method($path); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Reference.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,92 @@ +package IMPL::Config::Reference; +use strict; + +use IMPL::Exception; + +sub restore { + my ($self,$data,$surrogate) = @_; + + my @path; + + my ($tagTarget,$target) = splice @$data, 0, 2; + + die new IMPL::Exception('A traget tag must be the first tag in the reference specification') unless $tagTarget eq 'target'; + while(my ($method,$args) = splice @$data, 0, 2 ) { + $target = $self->_InvokeMember($target,{ method => $method, args => $args}); + } + return $target; +} + +sub _InvokeMember { + my ($self,$object,$member) = @_; + + my $method = $member->{method}; + return + ref $object eq 'HASH' ? + $object->{$method} + : + $object->$method( + exists $member->{args} ? + _as_list($member->{args}) + : + () + ) + ; +} + +sub _as_list { + ref $_[0] ? + (ref $_[0] eq 'HASH' ? + %{$_[0]} + : + (ref $_[0] eq 'ARRAY'? + @{$_[0]} + : + $_[0] + ) + ) + : + ($_[0]); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Config::Reference> - ссылка на внешний объект, вычисляемый на этапе десериализации данных. + +=head1 SYNOPSIS + +=begin code xml + +<Application> + <processingStack type="IMPL::Config::Reference"> + <target>IMPL::Config</target> + <LoadXMLFile>stdprocessing.xml</LoadXMLFile> + </processingStack> +</Application> + +=end code xml + +=head1 DESCRIPTION + +Позволяет на указвать ссылки на вычисляемые объекты, например, загружаемые из файлов. Ссылки такого рода +будут вычислены на этапе десериализации еще до того, как будет создан объект верхнего уровня, поэтому +следует избегать таких ссылок на сам (его свойства и методы) десериализуемый объект. + +=head1 MEMBERS + +=head2 C<restore($class,$data,$surrogate)> + +Использует данные переданные в параметре дата C<$data> для вычисления свойства. Данный метод - стандартный +метод для десериализации объекта, а параметр C<$data> содержит пары значений C<(имя_узла,значение_узла)>, +первая пара обязательно является узлом C<target>, а его значение - целевой объект, который будет +использован для вычисления конечного значения. + +=back + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/Resolve.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,77 @@ +package IMPL::Config::Resolve; +use strict; +use parent qw(IMPL::Object IMPL::Object::Serializable); + +use IMPL::Class::Property; +use IMPL::Exception; +use Carp qw(carp); + +BEGIN { + public property path => prop_all|prop_list; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + my $list = $this->path; + + while(my $name = shift ) { + my $args = shift; + $list->Append({ method => $name, (defined $args ? (args => $args) : ()) }); + } + + #die new IMPL::InvalidArgumentException("The argument is mandatory","path") unless $this->path->Count; +} + +sub Invoke { + my ($this,$target,$default) = @_; + + my $result = $target; + $result = $this->_InvokeMember($result,$_) || return $default foreach $this->path; + + return $result; +} + +sub _InvokeMember { + my ($self,$object,$member) = @_; + + my $method = $member->{method}; + + local $@; + return eval { + ref $object eq 'HASH' ? + $object->{$method} + : + $object->$method( + exists $member->{args} ? + _as_list($member->{args}) + : + () + ) + }; +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar($_->{method},$_->{args}) foreach $this->path; +} + +sub _as_list { + ref $_[0] ? + (ref $_[0] eq 'HASH' ? + %{$_[0]} + : + (ref $_[0] eq 'ARRAY'? + @{$_[0]} + : + $_[0] + ) + ) + : + ($_[0]); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Config/ServicesBag.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,158 @@ +package IMPL::Config::ServicesBag; + +require v5.9.5; + +use mro; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Object' => undef + ], + props => [ + _prototype => PROP_RW, + _nameMap => PROP_RW, + _typeMap => PROP_RW, + _props => PROP_RW, + ] +}; + +sub CTOR { + my ( $this, $prototype ) = @_; + + $this->_prototype($prototype) if $prototype; + $this->_nameMap( {} ); + $this->_typeMap( {} ); +} + +sub GetDescriptorByName { + my ( $this, $name ) = @_; + + my $d = $this->_nameMap->{$name}; + return $d if $d and $d->{valid}; + + my $parent = $this->_prototype; + + if ( $parent and $d = $parent->GetDescriptorByName($name) ) { + return $this->_nameMap->{$name} = $d; + } + + return undef; +} + +sub GetDescriptorByType { + my ( $this, $type ) = @_; + + my $d = $this->_typeMap->{$type}; + return $d if $d and $d->{valid}; + + my $parent = $this->_prototype; + if ( $parent and $d = $parent->GetDescriptorByType($type) ) { + return $this->_typeMap->{$type} = $d; + } + + return undef; +} + +sub RegisterValue { + my ( $this, $value, $name, $type ) = @_; + + my $d = { owner => $this, value => $value, valid => 1 }; + + if ($type) { + my $map = $this->_typeMap; + my $isa = mro::get_linear_isa($type); + $d->{isa} = $isa; + + # the service record which is superseded by the current one + my $replaces = $this->GetDescriptorByType($type); + + foreach my $t (@$isa) { + if ( my $prev = $this->GetDescriptorByType($t) ) { + + # keep previous registrations if they are valid + next if not $replaces or $prev != $replaces; + } + + $map->{$t} = $d; + } + + if ($replaces) { + + # invalidate cache + $replaces->{owner}->UpdateDescriptor($replaces); + } + } + + if ($name) { + my $prev = $this->_nameMap->{$name}; + $d->{name} = $name; + $this->_nameMap->{$name} = $d; + $prev->{owner}->UpdateDescriptor($prev) if $prev; + } + + return $d; +} + +sub UpdateDescriptor { + my ( $this, $d ) = @_; + + my $d2 = {}; + + # copy descriptor + while ( my ( $k, $v ) = each %$d ) { + $d2->{$k} = $v; + } + + # update named entries + my $name = $d->{name}; + if ( $name and $this->_nameMap->{$name} == $d ) { + $this->_nameMap->{$name} = $d2; + } + + # update type entries + if ( my $isa = $d->{isa} ) { + my $map = $this->_typeMap; + foreach my $t (@$isa) { + next unless $map->{$t} == $d; + $map->{$t} = $d2; + } + } + + $d->{valid} = 0; +} + +1; + +__END__ + +=pod + +=head1 NAME + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Коллекция сервисов построена на прототиптровании экземпляров, т.е. при создании +новой коллекции может указваться базовая коллекция в которой будет происходить +поиск сервисов в случае их отсутсвия в основной. Для оптимизации данного процесса +сервисы кешируются, чтобы избежать можестрвенных операций поиска по иерархии +коллекций, для этого каждый сервис описывается дескриптором: + +=over + +=item * isa массив типов сервиса, если он регистрировался как сервис + +=item * value значение + +=item * valid признак того, что дескриптор действителен + +=item * owner коллекция, которая создала данный дескриптор + +=back + +Если запрашиваемый десриптор не найден это является ошибкой, поэтому негативные +ответы не кешируются + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Const.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,58 @@ +package IMPL::Const; +use strict; + +use parent qw(Exporter); + +our %EXPORT_TAGS = ( + all => [ + qw( + &ACCESS_PUBLIC + &ACCESS_PROTECTED + &ACCESS_PRIVATE + &PROP_GET + &PROP_SET + &PROP_OWNERSET + &PROP_LIST + &PROP_ALL + &PROP_DIRECT + ) + ], + prop => [ + qw( + &PROP_GET + &PROP_SET + &PROP_OWNERSET + &PROP_LIST + &PROP_ALL + &PROP_RO + &PROP_RW + &PROP_DIRECT + ) + ], + access => [ + qw( + &ACCESS_PUBLIC + &ACCESS_PROTECTED + &ACCESS_PRIVATE + ) + ] + +); + +our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; + +use constant { + ACCESS_PUBLIC => 1, + ACCESS_PROTECTED => 2, + ACCESS_PRIVATE => 3, + PROP_GET => 1, + PROP_SET => 2, + PROP_OWNERSET => 10, + PROP_LIST => 4, + PROP_ALL => 3, + PROP_RW => 3, + PROP_RO => 11, + PROP_DIRECT => 16 +}; + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Document.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,132 @@ +package IMPL::DOM::Document; +use strict; +use warnings; + +use IMPL::lang; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + DOMNode => 'IMPL::DOM::Node' + }, + base => [ + DOMNode => '@_' + ], + props => [ + schemaDocument => PROP_RW + ] +}; + +sub document { + return $_[0]; +} + +sub Create { + my ($this,$nodeName,$class,$refProps) = @_; + + if ( ref $class eq 'HASH' ) { + $refProps = $class; + $class = undef; + } + + $class ||= DOMNode; + $refProps ||= {}; + + delete $refProps->{nodeName}; + + die new IMPL::Exception("class is not specified") unless $class; + return $class->new( + nodeName => $nodeName, + document => $this, + %$refProps + ); +} + +sub save { + my ($this,$writer) = @_; + + $writer->xmlDecl(undef,'yes'); + $this->SUPER::save($writer); + $writer->end(); +} + +{ + my $empty; + sub Empty() { + return $empty ? $empty : ($empty = __PACKAGE__->new(nodeName => 'Empty')); + } +} + +1; +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Document> DOM документ. + +=head1 DESCRIPTION + +Документ, позволяет создавать узлы определенных типов, что позволяет абстрагироваться +от механизмов реального создания объектов. Т.о. например C<IMPL::DOM::Navigator::Builder> +может формировать произвольные документы. + +=head1 SYNOPSIS + +=begin code + +package MyDocument; +use parent qw(IMPL::DOM::Document); + +sub Create { + my $this = shift; + my ($name,$class,$hashProps) = @_; + + if ($class eq 'Info') { + return MyInfo->new($name,$hashProps->{date},$hashProps->{description}); + } else { + # leave as it is + return $this->SUPER::Create(@_); + } +} + +=end code + +=head1 METHODS + +=over + +=item C< Create($nodeName,$class,$hashProps) > + +Реализация по умолчанию. Создает узел определеннго типа с определенным именем и свойствами. + +=begin code + +sub Create { + my ($this,$nodeName,$class,$hashProps) = @_; + + return $class->new ( + nodeName => $nodeName, + document => $this, + %$hashProps + ); +} + +=end code + +=item C< save($writer) > + +Сохраняет документ в виде XML узла и вызывает C<< $writer->end() >>. + +=over + +=item C<$writer> + +Объект с интерфейсом C<XML::Writer> который будет использован для записи +содержимого документа + +=back + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Navigator.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,276 @@ +package IMPL::DOM::Navigator; +use strict; +use warnings; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; +BEGIN { + private _direct property _path => prop_all; + private _direct property _state => prop_all; + private _direct property _savedstates => prop_all; + public property Current => {get => \&_getCurrent}; +} + +sub CTOR { + my ($this,$CurrentNode) = @_; + + die IMPL::InvalidArgumentException->new("A starting node is a required paramater") unless $CurrentNode; + + $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; +} + +sub _initNavigator { + my ($this,$CurrentNode) = @_; + + die IMPL::InvalidArgumentException->new("A starting node is a required paramater") unless $CurrentNode; + + $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; + delete $this->{$_path}; + delete $this->{$_savedstates}; +} + +sub _getCurrent { + $_[0]->{$_state}{alternatives}[$_[0]->{$_state}{current}] +} + +sub Navigate { + my ($this,@path) = @_; + + return unless @path; + + my $node; + + foreach my $query (@path) { + if (my $current = $this->Current) { + + my @alternatives = $current->selectNodes($query); + + unless (@alternatives) { + $current = $this->advanceNavigator or return; + @alternatives = $current->selectNodes($query); + } + + push @{$this->{$_path}},$this->{$_state}; + $this->{$_state} = { + alternatives => \@alternatives, + current => 0, + query => $query + }; + + $node = $alternatives[0]; + } else { + return; + } + } + + $node; +} + +sub selectNodes { + my ($this,@path) = @_; + + return $this->Current->selectNodes(@path); +} + +sub internalNavigateNodeSet { + my ($this,@nodeSet) = @_; + + push @{$this->{$_path}}, $this->{$_state}; + + $this->{$_state} = { + alternatives => \@nodeSet, + current => 0 + }; + + $nodeSet[0]; +} + +sub fetch { + my ($this) = @_; + + my $result = $this->Current; + $this->advanceNavigator; + return $result; +} + +sub advanceNavigator { + my ($this) = @_; + + $this->{$_state}{current}++; + + if (@{$this->{$_state}{alternatives}} <= $this->{$_state}{current}) { + if ( exists $this->{$_state}{query} ) { + my $query = $this->{$_state}{query}; + + $this->Back or return; # that meams the end of the history + + undef while ( $this->advanceNavigator and not $this->Navigate($query)); + + return $this->Current; + } + return; + } + + return $this->Current; +} + +sub doeach { + my ($this,$code) = @_; + local $_; + + do { + for (my $i = $this->{$_state}{current}; $i < @{$this->{$_state}{alternatives}}; $i++) { + $_ = $this->{$_state}{alternatives}[$i]; + $code->(); + } + $this->{$_state}{current} = @{$this->{$_state}{alternatives}}; + } while ($this->advanceNavigator); +} + +sub Back { + my ($this,$steps) = @_; + + if ($this->{$_path} and @{$this->{$_path}}) { + if ( (not defined $steps) || $steps == 1) { + $this->{$_state} = pop @{$this->{$_path}}; + } elsif ($steps > 0) { + $steps = @{$this->{$_path}} - 1 if $steps >= @{$this->{$_path}}; + + $this->{$_state} = (splice @{$this->{$_path}},-$steps)[0]; + } + $this->Current if defined wantarray; + } else { + return; + } +} + +sub PathToString { + my ($this,$delim) = @_; + + $delim ||= '/'; + + join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); +} + +sub pathLength { + my ($this) = @_; + $this->{$_path} ? scalar @{$this->{$_path}} : 0; +} + +sub GetNodeFromHistory { + my ($this,$index) = @_; + + if (my $state = $this->{$_path} ? $this->{$_path}->[$index] : undef ) { + return $state->{alternatives}[$state->{current}] + } else { + return; + } +} + +sub clone { + my ($this) = @_; + + my $newNavi = __PACKAGE__->surrogate; + + $newNavi->{$_path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; + $newNavi->{$_state} = { %{$this->{$_state}} }; + + return $newNavi; + +} + +sub saveState { + my ($this) = @_; + + my %state; + + $state{path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; + $state{state} = { %{$this->{$_state}} }; + + push @{$this->{$_savedstates}}, \%state; +} + +sub restoreState { + my ($this) = @_; + + if ( my $state = pop @{$this->{$_savedstates}||[]} ) { + $this->{$_path} = $state->{path}; + $this->{$_state} = $state->{state}; + } +} + +sub applyState { + my ($this) = @_; + + pop @{$this->{$_savedstates}||[]}; +} + +sub dosafe { + my ($this,$transaction) = @_; + + $this->saveState(); + + my $result; + + eval { + $result = $transaction->(); + }; + + if ($@) { + $this->restoreState(); + return; + } else { + $this->applyState(); + return $result; + } +} + +1; + +__END__ +=pod + +=head1 DESCRIPTION + +Объект для хождения по дереву DOM объектов. + +Результатом навигации является множество узлов (альтернатив). + +Состоянием навигатора является текущий набор узлов, позиция в данном наборе, +а также запрос по которому были получены данные результаты. + +Если при навигации указан путь сосящий из нескольких фильтров, то он разбивается +этапы простой навигации по кадой из частей пути. На каждом элементарном этапе +навигации образуется ряд альтернатив, и при каждом следующем этапе навигации +альтернативы предыдущих этапов могут перебираться, до получения положительного +результата навигации, в противном случае навигация считается невозможной. + +=head1 METHODS + +=over + +=item C<<$obj->new($nodeStart)>> + +Создает объект навигатора с указанной начальной позицией. + +=item C<<$obj->Navigate([$query,...])>> + +Перейти в новый узел используя запрос C<$query>. На данный момент запросом может +быть только имя узла и будет взят только первый узел. Если по запросу ничего не +найдено, переход не будет осуществлен. + +Возвращает либо новый узел в который перешли, либо C<undef>. + +=item C<<$obj->Back()>> + +Возвращается в предыдущий узел, если таковой есть. + +Возвращает либо узел в который перешли, либо C<undef>. + +=item C<<$obj->advanceNavigator()>> + +Переходит в следующую альтернативу, соответствующую текущему запросу. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Navigator/Builder.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,167 @@ +package IMPL::DOM::Navigator::Builder; +use strict; +use warnings; + +use IMPL::Const qw(:prop); + +use parent qw(IMPL::DOM::Navigator); +use IMPL::Class::Property; +require IMPL::DOM::Navigator::SchemaNavigator; +require IMPL::DOM::Schema::ValidationError; +use IMPL::DOM::Document; + +BEGIN { + private _direct property _schemaNavi => PROP_RW; + private _direct property _docClass => PROP_RW; + public _direct property Document => PROP_RO; + public _direct property ignoreUndefined => PROP_RO; +} + +our %CTOR = ( + 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document->Empty; } +); + +sub CTOR { + my ($this,$docClass,$schema,%opts) = @_; + + $this->{$_docClass} = $docClass; + $this->{$_schemaNavi} = $schema ? IMPL::DOM::Navigator::SchemaNavigator->new($schema) : undef; + + $this->{$ignoreUndefined} = $opts{ignoreUndefined} if $opts{ignoreUndefined}; +} + +sub NavigateCreate { + my ($this,$nodeName,%props) = @_; + + if (my $schemaType = $this->{$_schemaNavi}->NavigateName($nodeName)) { + my $class = $schemaType->can('nativeType') ? $schemaType->nativeType || 'IMPL::DOM::Node' : 'IMPL::DOM::Node'; + + my $schemaNode = $this->{$_schemaNavi}->SourceSchemaNode; + + $props{schemaType} = $schemaType; + $props{schemaNode} = $schemaNode; + + my $node; + if (! $this->{$Document}) { + # keep reference to the schema document + $props{schemaDocument} = $this->{$_schemaNavi}->schema; + $node = $this->{$Document} = $this->{$_docClass}->new(nodeName => $nodeName,%props); + $this->_initNavigator($node); + } else { + die new IMPL::InvalidOperationException('Can\'t create a second top level element') unless $this->Current; + $node = $this->{$Document}->Create($nodeName,$class,\%props); + $this->Current->appendChild($node); + $this->internalNavigateNodeSet($node); + } + + return $node; + } else { + die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName) + if !$this->ignoreUndefined; + return; + } +} + +sub Back { + my ($this) = @_; + + $this->{$_schemaNavi}->SchemaBack(); + $this->SUPER::Back(); +} + +sub saveState { + my ($this) = @_; + + $this->{$_schemaNavi}->saveState; + $this->SUPER::saveState; +} + +sub restoreState { + my ($this) = @_; + + $this->{$_schemaNavi}->restoreState; + $this->SUPER::restoreState; +} + +sub document { + goto &Document; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C< IMPL::DOM::Navigator::Builder > - Навигатор, строящий документ по указанной схеме. + +=head1 SYNOPSIS + +=begin code + +my $builder = new IMPL::DOM::Navigator::Builder(new MyApp::Document,$schema); +my $reader = new IMPL::DOM::XMLReader(Navigator => $builder); + +$reader->ParseFile("document.xml"); + +my @errors = $schema->Validate($builder->Document); + +=end code + +=head1 DESCRIPTION + +Построитель DOM документов по указанной схеме. Обычно используется в связке +с объектами для чтения такими как C<IMPL::DOM::XMLReader>. + +=head1 MEMBERS + +=head2 C< CTOR($classDocument,$schema, %opts) > + +Создает новый объект, принимает на вход класс документа (или фабрику, например +L<IMPL::Object::Factory>) и схему. В процессе процедуры построения документа +будет создан объект документа. + +Необязательные именованные параметры + +=over + +=item C<ignoreUndefined> + +C<NavigateCreate> не будет вызывать исключение, если запрашиваемый узел не +найден в схеме, но будет возвращать C<undef>. + +=back + +=head2 C< NavigateCreate($nodeName,%props) > + +Создает новый узел с указанным именем и переходит в него. В случае если в схеме +подходящий узел не найден, то вызывается исключение или будет возвращено +C<undef> см. C<ignoreUndefined>. + +При этом по имени узла ищется его схема, после чего определяется класс для +создания экземпляра узла и созданный узел доавляется в документ. При создании +нового узла используется метод документа C<< IMPL::DOM::Document->Create >> + +Свойства узла передаются при создании через параметр C<%props>, но имя +создаваемого узла НЕ может быть переопределено свойством C<nodeName>, оно будет +проигнорировано. + +Свойства узла будут преобразованы при помощи заданных в схеме заполнителей +C<inflator>. + +=head2 C<[get]document > + +Свойство, которое содержит документ по окончании процедуры построения. + +=head2 C<[get]buildErrors> + +Ошибки, возникшие в процессе построения документа. + +=head2 C<[get]ignoreUndefined> + +Опция, заданная при создании построителя, отвечающая за обработку узлов +не найденных в схеме. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Navigator/SchemaNavigator.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,152 @@ +package IMPL::DOM::Navigator::SchemaNavigator; +use strict; +use warnings; + +use IMPL::Class::Property; + +require IMPL::DOM::Schema::ComplexType; +require IMPL::DOM::Schema::NodeSet; +require IMPL::DOM::Schema::AnyNode; + +use IMPL::declare { + base => [ + 'IMPL::DOM::Navigator' => '@_' + ] +}; + +BEGIN { + public _direct property Schema => prop_get; + private _direct property _historySteps => prop_all; +} + +sub CTOR { + my ($this,$schema) = @_; + + $this->{$Schema} = $schema->isa('IMPL::DOM::Schema::ComplexNode') ? $schema->document : $schema; + + die new IMPL::InvalidArgumentException("A schema object is required") unless ref $this->{$Schema} && eval { $this->{$Schema}->isa('IMPL::DOM::Schema') }; +} + +my $schemaAnyNode = IMPL::DOM::Schema::ComplexType->new(type => '::AnyNodeType', nativeType => 'IMPL::DOM::ComplexNode')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new() + ) +); + +sub NavigateName { + my ($this,$name) = @_; + + die new IMPL::InvalidArgumentException('name is required') unless defined $name; + + # perform a safe navigation + #return dosafe $this sub { + my $steps = 0; + # if we are currently in a ComplexNode, first go to it's content + if ($this->Current->isa('IMPL::DOM::Schema::ComplexNode')) { + # navigate to it's content + # ComplexNode + $this->internalNavigateNodeSet($this->Current->content); + $steps ++; + } + + # navigate to node + if ( + my $node = $this->Navigate( sub { + $_->isa('IMPL::DOM::Schema::Node') and ( + $_->name eq $name + or + $_->nodeName eq 'AnyNode' + or + ( $_->nodeName eq 'SwitchNode' and $_->selectNodes( sub { $_->name eq $name } ) ) + ) + }) + ) { + $steps ++; + if ($node->nodeName eq 'AnyNode') { + # if we navigate to the anynode + # assume it to be ComplexType by default + $node = $node->type ? $this->{$Schema}->resolveType($node->type) : $schemaAnyNode; + $this->internalNavigateNodeSet($node); + $steps ++; + } elsif ($node->nodeName eq 'SwitchNode') { + # if we are in the switchnode + # navigate to the target node + $node = $this->Navigate(sub { $_->name eq $name }); + $steps ++; + } + + die IMPL::Exception->new("A node is expected") + unless $node; + if ($node->nodeName eq 'Node') { + # if we navigate to a reference + # resolve it + $node = $this->{$Schema}->resolveType($node->type); + $this->internalNavigateNodeSet($node); + $steps++; + } + + push @{$this->{$_historySteps}},$steps; + + # return found node schema + return $node; + } else { + return; # abort navigation + } + #} +} + +sub SchemaBack { + my ($this) = @_; + + $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; +} + +sub SourceSchemaNode { + my ($this) = @_; + + if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or + $this->Current->isa('IMPL::DOM::Schema::ComplexType') + ) { + # we are redirected + return $this->GetNodeFromHistory(-1); + } else { + return $this->Current; + } +} + +sub schema { + goto &Schema; +} + +1; +__END__ + +=pod + +=head1 DESCRIPTION + +Помимо стандартных методов навигации позволяет переходить по элементам документа, +который данной схемой описывается. + +=head1 METHODS + +=over + +=item C<NavigateName($name)> + +Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>. + +=item C<SchemaBack> + +Возвращается на позицию до последней операции C<NavigateName>. Данный метод нужен +посокольку операция навигации по элементам описываемым схемой может приводить к +нескольким операциям навигации по самой схеме. + +=item C<SourceSchemaNode> + +Получает схему узла из которого было выполнено перенаправление, например, C<IMPL::DOM::Schema::Node>. +В остальных случаях совпадает со свойством C<Current>. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Navigator/SimpleBuilder.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,40 @@ +package IMPL::DOM::Navigator::SimpleBuilder; +use strict; +use warnings; + +use parent qw(IMPL::DOM::Navigator); + +use IMPL::Class::Property; + +require IMPL::DOM::Navigator::SchemaNavigator; +use IMPL::DOM::Document; + +BEGIN { + public _direct property Document => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document::Empty; } +); + +sub NavigateCreate { + my ($this,$nodeName,%props) = @_; + + my $node; + if (! $this->{$Document}) { + $node = $this->{$Document} = IMPL::DOM::Document->new(nodeName => $nodeName,%props); + $this->_initNavigator($node); + } else { + die new IMPL::InvalidOperationException('Can create a second top level element') unless $this->Current; + $node = $this->{$Document}->Create($nodeName,'IMPL::DOM::Node',\%props); + $this->Current->appendChild($node); + $this->internalNavigateNodeSet($node); + } + return $node; +} + +sub inflateValue { + $_[1]; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Node.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,505 @@ +package IMPL::DOM::Node; +use strict; +use warnings; + +use Scalar::Util qw(weaken); + +use IMPL::lang; +use IMPL::Object::List; + +use IMPL::Exception(); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + PropertyInfo => '-IMPL::Class::PropertyInfo' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + nodeName => PROP_RO | PROP_DIRECT, + document => PROP_RO | PROP_DIRECT, + isComplex => { get => \&_getIsComplex }, + nodeValue => PROP_RW | PROP_DIRECT, + childNodes => { get => \&_getChildNodes, isList => 1, direct => 1 }, + parentNode => PROP_RO | PROP_DIRECT, + schemaNode => PROP_RO | PROP_DIRECT, + schemaType => PROP_RO | PROP_DIRECT, + _propertyMap => PROP_RW | PROP_DIRECT + ] +}; + +our %Axes = ( + parent => \&selectParent, + siblings => \&selectSiblings, + child => \&childNodes, + document => \&selectDocument, + ancestor => \&selectAncestors, + descendant => \&selectDescendant +); + +sub CTOR { + my ($this,%args) = @_; + + $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); + $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; + if ( exists $args{document} ) { + $this->{$document} = delete $args{document}; + weaken($this->{$document}); + } + + while ( my ($key,$value) = each %args ) { + $this->nodeProperty($key,$value); + } +} + +sub insertNode { + my ($this,$node,$pos) = @_; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + $this->childNodes->InsertAt($pos,$node); + + $node->_setParent( $this ); + + return $node; +} + +sub appendChild { + my ($this,$node) = @_; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + my $children = $this->childNodes; + $children->Push($node); + + $node->_setParent( $this ); + + return $node; +} + +sub appendNode { + goto &appendChild; +} + +sub appendRange { + my ($this,@range) = @_; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; + + foreach my $node (@range) { + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + $node->_setParent( $this ); + } + + $this->childNodes->Push(@range); + + return $this; +} + +sub _getChildNodes { + my ($this) = @_; + + $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; + return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes}; +} + +sub childNodesRef { + my ($this) = @_; + return scalar $this->_getChildNodes; +} + +sub removeNode { + my ($this,$node) = @_; + + if ($this == $node->{$parentNode}) { + $this->childNodes->RemoveItem($node); + $node->_setParent(undef); + return $node; + } else { + die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); + } +} + +sub replaceNodeAt { + my ($this,$index,$node) = @_; + + my $nodeOld = $this->childNodes->[$index]; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + # unlink node from previous parent + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + # replace (or set) old node + $this->childNodes->[$index] = $node; + + # set new parent + $node->_setParent( $this ); + + # unlink old node if we have one + $nodeOld->_setParent(undef) if $nodeOld; + + # return old node + return $nodeOld; +} + +sub removeAt { + my ($this,$pos) = @_; + + if ( my $node = $this->childNodes->RemoveAt($pos) ) { + $node->_setParent(undef); + return $node; + } else { + return undef; + } +} + +sub removeLast { + my ($this) = @_; + + if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { + $node->_setParent(undef); + return $node; + } else { + return undef; + } +} + +sub removeSelected { + my ($this,$query) = @_; + + my @newSet; + my @result; + + if (ref $query eq 'CODE') { + &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; + } elsif (defined $query) { + $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; + } else { + my $children = $this->childNodes; + $_->_setParent(undef) foreach @$children; + delete $this->{$childNodes}; + return wantarray ? @$children : $children; + } + + $_->_setParent(undef) foreach @result; + + $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; + + return wantarray ? @result : \@result; +} + +sub resolveAxis { + my ($this,$axis) = @_; + return $Axes{$axis}->($this) +} + +sub selectNodes { + my $this = shift; + my $path; + + if (@_ == 1) { + $path = $this->translatePath($_[0]); + } else { + $path = [@_]; + } + + my @set = ($this); + + while (@$path) { + my $query = shift @$path; + @set = map $_->selectNodesAxis($query), @set; + } + + return wantarray ? @set : \@set; +} + +sub selectSingleNode { + my $this = shift; + my @result = $this->selectNodes(@_); + return $result[0]; +} + +sub selectNodesRef { + my $this = shift; + + my @result = $this->selectNodes(@_); + return \@result; +} + +sub translatePath { + my ($this,$path) = @_; + + # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare + return [$path]; +} + +sub selectNodesAxis { + my ($this,$query,$axis) = @_; + + $axis ||= 'child'; + + die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis}; + + my $nodes = $this->resolveAxis($axis); + + my @result; + + if (ref $query eq 'CODE') { + @result = grep &$query($_), @{$nodes}; + } elsif (ref $query eq 'ARRAY' ) { + my %keys = map (($_,1),@$query); + @result = grep $keys{$_->nodeName}, @{$nodes}; + } elsif (ref $query eq 'HASH') { + while( my ($axis,$filter) = each %$query ) { + push @result, $this->selectNodesAxis($filter,$axis); + } + } elsif (defined $query) { + @result = grep $_->nodeName eq $query, @{$nodes}; + } else { + return wantarray ? @{$nodes} : $nodes; + } + + return wantarray ? @result : \@result; +} + +sub selectParent { + my ($this) = @_; + + if ($this->parentNode) { + return wantarray ? $this->parentNode : [$this->parentNode]; + } else { + return wantarray ? () : []; + } +} + +sub selectSiblings { + my ($this) = @_; + + if ($this->parentNode) { + return $this->parentNode->selectNodes( sub { $_ != $this } ); + } else { + return wantarray ? () : []; + } +} + +sub selectDocument { + my ($this) = @_; + + if ($this->document) { + return wantarray ? $this->document : [$this->document]; + } else { + return wantarray ? () : []; + } +} + +sub selectDescendant { + wantarray ? + map $_->selectAll(), $_[0]->childNodes : + [map $_->selectAll(), $_[0]->childNodes] +} + +sub selectAll { + map(selectAll($_),@{$_[0]->childNodes}) , $_[0] +} + +sub selectAncestors { + my $parent = $_[0]->parentNode; + + wantarray ? + ($parent ? ($parent->selectAncestors,$parent) : ()) : + [$parent ? ($parent->selectAncestors,$parent) : ()] +} + +sub firstChild { + @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; +} + +sub _getIsComplex { + ($_[0]->{$childNodes} and $_[0]->{$childNodes}->Count) ? 1 : 0; +} + +sub _updateDocRefs { + my ($this) = @_; + + # this method is called by the parent node on his children, so we need no to check parent + $this->{$document} = $this->{$parentNode}->document; + + # prevent cyclic + weaken($this->{$document}) if $this->{$document}; + + map $_->_updateDocRefs, @{$this->{$childNodes}} if $this->{$childNodes}; +} + +sub _setParent { + my ($this,$node) = @_; + + + if (($node || 0) != ($this->{$parentNode} || 0)) { + my $newOwner; + if ($node) { + $this->{$parentNode} = $node; + $newOwner = $node->document || 0; + + # prevent from creating cyclicreferences + weaken($this->{$parentNode}); + + } else { + delete $this->{$parentNode}; + + #keep document + $newOwner = $this->{$document}; + } + + if (($this->{$document}||0) != $newOwner) { + $this->{$document} = $newOwner; + weaken($this->{$document}) if $newOwner; + $_->_updateDocRefs foreach @{$this->childNodes}; + } + } +} + +sub text { + my ($this) = @_; + + join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes})); +} + +sub nodeProperty { + my $this = shift; + my $name = shift; + + return unless defined $name; + + if (my $method = $this->can($name)) { + unshift @_,$this; + # use goto to preserve calling context + goto &$method; + } + # dynamic property + if (@_) { + # set + return $this->{$_propertyMap}{$name} = shift; + } else { + return $this->{$_propertyMap}{$name}; + } +} + +sub listProperties { + my ($this) = @_; + + my %props = map {$_->name, 1} $this->GetMeta(PropertyInfo, sub { $_->attributes->{dom} },1); + + return (keys %props,keys %{$this->{$_propertyMap}}); +} + +sub save { + my ($this,$writer) = @_; + + if ( not ( $this->isComplex or defined $this->{$nodeValue} ) ) { + $writer->emptyTag( + $this->{$nodeName}, + map { + $_, + $this->nodeProperty($_) + } grep defined $this->nodeProperty($_), $this->listProperties + ); + } else { + $writer->startTag( + $this->{$nodeName}, + map { + $_, + $this->nodeProperty($_) + } grep defined $this->nodeProperty($_), $this->listProperties + ); + $writer->characters($this->{$nodeValue}) if $this->{$nodeValue}; + + $_->save($writer) foreach $this->childNodes; + + $writer->endTag($this->{$nodeName}); + } +} + +sub qname { + $_[0]->{$nodeName}; +} + +sub path { + my ($this) = @_; + + if ($this->parentNode) { + return $this->parentNode->path.'.'.$this->qname; + } else { + return $this->qname; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Node> Элемент DOM модели + +=head1 DESCRIPTION + +Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели. + +=head1 MEMBERS + +=head2 PROPERTIES + +=over + +=item C<[get] nodeName> + +Имя узла. Задается при создании. + +=item C<[get] document> + +Документ к которому принадлежит узел. Задается при поздании узла. + +=item C<[get] isComplex> + +Определяет является ли узел сложным (тоесть есть ли дети). + +C<true> - есть, C<false> - нет. + +=item C<[get,set] nodeValue> + +Значение узла, обычно простой скаляр, но ничто не мешает туда +устанавливать любое значение. + +=item C<[get,list] childNodes> + +Список детей, является списокм C<IMPL::Object::List>. + +=item C<[get] parentNode> + +Ссылка на родительский элемент, если таковой имеется. + +=item C<[get] schemaType> + +Ссылка на узел из C<IMPL::DOM::Schema>, представляющий схему данных текущего узла. Может быть C<undef>. + +=item C<[get] schemaNode> + +Ссылка на узел из C<IMPL::DOM::Schema>, представляющий элемент схемы, объявляющий данный узел. Может быть C<undef>. + +Отличается от свойства C<schemaType> тем, что узел в случае ссылки на тип узла, данной свойство будет содержать +описание ссылки C<IMPL::DOM::Schema::Node>, а свойство C<schema> например будет ссылаться на +C<IMPL::DOM::Schema::ComplexType>. + +=back + +=head2 METHODS + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Property.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,37 @@ +package IMPL::DOM::Property; +use strict; +use warnings; + +require IMPL::Exception; + +use parent qw(Exporter); +our @EXPORT_OK = qw(_dom); + +sub _dom($) { + my ($prop_info) = @_; + $prop_info->{dom} = 1; + return $prop_info; +} + +1; +__END__ +=pod + +=head1 SYNOPSIS + +package TypedNode; + +use parent qw(IMPL::DOM::Node); +use IMPL::DOM::Property qw(_dom); + +BEGIN { + public _dom property Age => prop_all; + public _dom property Address => prop_all; + public property ServiceData => prop_all; +} + +=head1 DESCRIPTION + +Позволяет объявлять свойства, которые будут видны в списке свойств. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,371 @@ +package IMPL::DOM::Schema; +use strict; +use warnings; + +use File::Spec; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + ComplexNode => 'IMPL::DOM::Schema::ComplexNode', + ComplexType => 'IMPL::DOM::Schema::ComplexType', + SimpleNode => 'IMPL::DOM::Schema::SimpleNode', + SimpleType => 'IMPL::DOM::Schema::SimpleType', + Node => 'IMPL::DOM::Schema::Node', + AnyNode => 'IMPL::DOM::Schema::AnyNode', + NodeList => 'IMPL::DOM::Schema::NodeList', + NodeSet => 'IMPL::DOM::Schema::NodeSet', + Property => 'IMPL::DOM::Schema::Property', + SwitchNode => 'IMPL::DOM::Schema::SwitchNode', + Validator => 'IMPL::DOM::Schema::Validator', + Builder => 'IMPL::DOM::Navigator::Builder', + XMLReader => 'IMPL::DOM::XMLReader', # XMLReader references Schema + Loader => 'IMPL::Code::Loader', + StringMap => 'IMPL::Resources::StringLocaleMap' + }, + base => [ + 'IMPL::DOM::Document' => sub { + nodeName => 'schema' + } + ], + props => [ + _typesMap => PROP_RW | PROP_DIRECT, + baseDir => PROP_RW | PROP_DIRECT, + schemaName => PROP_RW | PROP_DIRECT, + baseSchemas => PROP_RO | PROP_LIST | PROP_DIRECT, + stringMap => { + get => '_getStringMap', + direct => 1 + } + ] +}; + +my $validatorLoader = Loader->new(prefix => Validator, verifyNames => 1); + +#TODO rename and remove +sub resolveType { + goto &ResolveType; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$baseDir} = ($args{baseDir} || '.'); +} + +# compat +sub ResolveType { + my ($this,$typeName) = @_; + + my $type = $this->{$_typesMap}{$typeName}; + return $type if $type; + + foreach my $base ($this->baseSchemas) { + last if $type = $base->ResolveType($typeName); + } + + die IMPL::KeyNotFoundException->new($typeName) + unless $type; + return $this->{$_typesMap}{$typeName} = $type; +} + +sub Create { + my ($this,$nodeName,$class,$refArgs) = @_; + + die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Node'); + + if ($class->isa('IMPL::DOM::Schema::Validator')) { + $class = $validatorLoader->GetFullName($nodeName); + unless (eval {$class->can('new')}) { + eval { + $validatorLoader->Require($nodeName); + }; + my $e = $@; + die new IMPL::Exception("Invalid validator",$class,$e) if $e; + } + } + + return $this->SUPER::Create($nodeName,$class,$refArgs); +} + +sub _getStringMap { + my ($this) = @_; + + return $this->{$stringMap} + if $this->{$stringMap}; + + my $map = StringMap->new(); + if ($this->baseDir and $this->schemaName) { + + $map->paths( File::Spec->catdir($this->baseDir,'locale') ); + $map->name( $this->schemaName ); + } + + return $this->{$stringMap} = $map; +} + +sub Process { + my ($this) = @_; + + # process instructions + $this->Include($_) foreach map $_->nodeProperty('source'), $this->selectNodes('Include'); + + # build types map + $this->{$_typesMap} = { map { $_->type, $_ } $this->selectNodes(sub { $_[0]->nodeName eq 'ComplexType' || $_[0]->nodeName eq 'SimpleType' } ) }; +} + +sub Include { + my ($this,$file) = @_; + + my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file)); + + $this->baseSchemas->Push( $schema ); +} + +sub LoadSchema { + my ($this,$file) = @_; + + $file = File::Spec->rel2abs($file); + + my $class = ref $this || $this; + + my $reader = XMLReader->new( + Navigator => Builder->new( + $class, + $class->MetaSchema + ), + SkipWhitespace => 1 + ); + + $reader->ParseFile($file); + + my $schema = $reader->Navigator->Document; + + my ($vol,$dir,$name) = File::Spec->splitpath($file); + + $name =~ s/\.xml$//; + + $schema->baseDir($dir); + $schema->schemaName($name); + + my @errors = $class->MetaSchema->Validate($schema); + + die new IMPL::Exception("Schema is invalid",$file,map( $_->message, @errors ) ) if @errors; + + $schema->Process; + + return $schema; +} + +sub Validate { + my ($this,$node) = @_; + + if ( my ($schemaNode) = $this->selectNodes(sub { $_->isa(Node) and $_[0]->name eq $node->nodeName })) { + $schemaNode->Validate($node); + } else { + return new IMPL::DOM::Schema::ValidationError(node => $node, message=> "A specified document (%Node.nodeName%) doesn't match the schema"); + } +} + +my $schema; + +sub MetaSchema { + + return $schema if $schema; + + $schema = __PACKAGE__->new(); + + $schema->appendRange( + ComplexNode->new(name => 'schema')->appendRange( + NodeSet->new()->appendRange( + Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), + SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( + Property->new(name => 'source') + ) + ), + ), + ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange( + NodeSet->new()->appendRange( + Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), + SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange( + Node->new(name => 'AnyNode', type => 'AnyNode'), + Node->new(name => 'SwitchNode',type => 'SwitchNode') + ) + ) + ), + ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange( + NodeSet->new()->appendRange( + Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), + ) + ), + ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( + NodeSet->new()->appendRange( + Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), + Node->new(name => 'AnyNode', type => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), + ) + ), + ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( + NodeList->new()->appendRange( + SwitchNode->new()->appendRange( + Node->new(name => 'NodeSet', type => 'NodeSet'), + Node->new(name => 'NodeList',type => 'NodeList'), + ), + Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), + AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + Property->new(name => 'type') + ), + ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange( + NodeList->new()->appendRange( + SwitchNode->new()->appendRange( + Node->new(name => 'NodeSet', type => 'NodeSet'), + Node->new(name => 'NodeList',type => 'NodeList'), + ), + Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), + AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + Property->new(name => 'name') + ), + ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange( + NodeList->new()->appendRange( + Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), + AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + Property->new(name => 'type') + ), + ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( + NodeList->new()->appendRange( + Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), + AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + Property->new(name => 'name') + ), + ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange( + NodeList->new()->appendRange( + AnyNode->new(maxOccur => 'unbounded', minOccur => 0) + ) + ), + ComplexType->new(type => 'Property', nativeType => 'IMPL::DOM::Schema::Property' )->appendRange( + NodeList->new()->appendRange( + AnyNode->new(maxOccur => 'unbounded', minOccur => 0) + ), + Property->new(name => 'name') + ), + SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange( + Property->new(name => 'name'), + Property->new(name => 'type') + ), + SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode') + ); + + $schema->Process; + + return $schema; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Schema> - Схема документа. + +=head1 DESCRIPTION + +C<use parent qw(IMPL::DOM::Document)> + +DOM схема - это документ, состоящий из определенных узлов, описывающая структуру +других документов. + +=head1 METHODS + +=over + +=item C<< $obj->Process() >> + +Обновляет таблицу типов из содержимого. + +=item C<< $obj->ResolveType($typeName) >> + +Возвращает схему типа c именем C<$typeName>. + +=back + +=head1 META SCHEMA + +Схема для описания схемы, эта схема используется для постороения других схем, выглядит приблизительно так + +=begin code xml + +<schema> + <ComplexNode name="schema"> + <NodeSet> + <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> + <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> + <Node minOcuur="0" maxOccur="unbounded" name="ComplexType" type="ComplexType"/> + <Node minOcuur="0" maxOccur="unbounded" name="SimpleType" type="SimpleType"/> + <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> + <SimpleNode minOcuur="0" maxOccur="unbounded" name="Include"/> + </NodeSet> + </ComplexNode> + + <ComplexType type="NodeContainer"> + <NodeSet> + <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> + <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> + <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> + </NodeSet> + </ComplexType> + + <ComplexType type="ComplexType"> + <NodeList> + <Node name="NodeSet" type="NodeContainer" minOcuur=0/> + <Node name="NodeList" type="NodeContainer" minOccur=0/> + <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> + </NodeList> + </ComplexType> + + <ComplexType type="ComplexNode"> + <NodeList> + <Node name="NodeSet" type="NodeContainer" minOcuur=0/> + <Node name="NodeList" type="NodeContainer" minOccur=0/> + <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> + </NodeList> + </ComplexType> + + <ComplexType type="SimpleNode"> + <NodeSet> + <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> + </NodeSet> + </ComplexType> + + <ComplexType type="SimpleType"> + <NodeSet> + <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> + </NodeSet> + </ComplexType> + + <ComplexType type="Validator"> + <NodeSet> + <AnyNode minOccur=0 maxOccur="unbounded"/> + </NodeSet> + </ComplexType> + +</schema> + +=end code xml + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/AnyNode.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,42 @@ +package IMPL::DOM::Schema::AnyNode; +use strict; +use warnings; + +use IMPL::declare { + base => [ + 'IMPL::DOM::Schema::Node' => sub { + my %args = @_; + $args{nodeName} ||= 'AnyNode'; + $args{name} = '::any'; + + %args; + } + ] +}; + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Узел с произвольным именем, для этого узла предусмотрена специальная проверка +в контейнерах. + +В контейнерах типа C<IMPL::DOM::Schema::NodeSet> этот узел можно использовать только один раз +причем его использование исключает использование узла C<IMPL::DOM::Schema::SwitchNode>. + +В контейнерах типа С<IMPL::DOM::Schema::NodeList> данный узел может применяться несколько раз +для решения таких задач как последовательности разноименных узлов с одним типом. + +<NodeList> + <SimpleNode name="firstName"/> + <SimpleNode name="age"/> + <AnyNode type="Notes" minOccur="0" maxOccur="unbounded"/> + <Node name="primaryAddress" type="Address"/> + <AnyNode/> +</NodeList> + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/ComplexNode.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,62 @@ +package IMPL::DOM::Schema::ComplexNode; +use strict; +use warnings; + +use IMPL::declare { + base => [ + 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'ComplexNode'; %args } + ], + props => [ + content => { + get => \&_getContent, + set => \&_setContent + } + ] +}; + + +sub _getContent { + $_[0]->firstChild; +} + +sub _setContent { + $_[0]->firstChild($_[1]); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + # для случаев анонимных типов, указанных прямо в узле + $ctx->{schemaNode} ||= $this; + $ctx->{schemaType} = $this; + + map $_->Validate($node,$ctx), @{$this->childNodes}; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Описывает сложный узел. Требует либо соответствие структуры, либо соответствия +типу. + +Дочерними элементами могут быть правила контроля свойств и т.п. +Первым дочерним элементом может быть только содержимое узла, см. C<content> + +=head2 PROPERTIES + +=over + +=item C<content> + +Содержимое узла, может быть либо C<IMPL::DOM::Schema::NodeSet> либо +C<IMPL::DOM::Schema::NodeList>, в зависимости от того важен порядок или нет. +Это свойство ссылается на первый дочерний элемент узла. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/ComplexType.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,64 @@ +package IMPL::DOM::Schema::ComplexType; +use strict; +use warnings; + +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + ValidationError => 'IMPL::DOM::Schema::ValidationError' + }, + base => [ + 'IMPL::DOM::Schema::ComplexNode' => sub { + my %args = @_; + $args{nodeName} ||= 'ComplexType'; + $args{minOccur} = 0; + $args{maxOccur} = 'unbounded'; + $args{name} ||= 'ComplexType'; + delete @args{qw(nativeType messageWrongType)}; + %args + } + ], + props => [ + nativeType => { get => 1, set => 1, direct => 1, dom => 1 }, + messageWrongType => { get => 1, set => 1, direct => 1, dom => 1 } + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->{$nativeType} = $args{nativeType}; + $this->{$messageWrongType} = $args{messageWrongType} || "A complex node '%node.path%' is expected to be %schemaType.nativeType%"; +} + +sub Validate { + my ($this, $node,$ctx) = @_; + + if ($this->{$nativeType}) { + return ValidationError->new ( + node => $node, + schemaNode => $ctx->{schemaNode} || $this, + schemaType => $this, + message => $this->_MakeLabel($this->messageWrongType) + ) unless $node->isa($this->{$nativeType}); + } + + return $this->SUPER::Validate($node,$ctx); +} + +sub qname { + $_[0]->nodeName.'[type='.$_[0]->type.']'; +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/Label.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,59 @@ +package IMPL::DOM::Schema::Label; +use strict; +use overload + '""' => 'ToString', + 'bool' => sub { return 1; }, + 'fallback' => 1; + +use IMPL::Const qw(:prop); +use IMPL::Exception(); +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + _map => PROP_RW, + _id => PROP_RW + ] +}; + +sub CTOR { + my ($this,$map,$id) = @_; + + die ArgException->new('map' => 'A strings map is required') + unless $map; + die ArgException->new('id' => 'A lable identifier is required') + unless $id; + + $this->_map($map); + $this->_id($id); +} + +our $AUTOLOAD; +sub AUTOLOAD { + my ($this) = @_; + + my ($method) = ($AUTOLOAD =~ /(\w+)$/); + return + if $method eq 'DESTROY'; + + warn $this->_id . ".$method"; + + return $this->new($this->_map,$this->_id . ".$method"); +} + +sub ToString { + my ($this) = @_; + return $this->_map->GetString($this->_id); +} + +sub Format { + my ($this,$args) = @_; + + return $this->_map->GetString($this->_id,$args); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/Node.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,124 @@ +package IMPL::DOM::Schema::Node; +use strict; +use warnings; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label' + }, + base => [ + 'IMPL::DOM::Node' => sub { + my %args = @_; + delete @args{qw( + minOccur + maxOccur + type + name + )} ; + $args{nodeName} ||= 'Node'; + %args + } + ], + props => [ + minOccur => { get => 1, set => 1, direct => 1, dom => 1}, + maxOccur => { get => 1, set => 1, direct => 1, dom => 1}, + type => { get => 1, set => 1, direct => 1, dom => 1}, + name => { get => 1, set => 1, direct => 1, dom => 1}, + label => { get => '_getLabel', direct => 1 } + ] +}; + +sub _getLabel { + my ($this) = @_; + + $this->{$label} ||= Label->new($this->document->stringMap, $this->name ); +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$minOccur} = defined $args{minOccur} ? $args{minOccur} : 1; + $this->{$maxOccur} = defined $args{maxOccur} ? $args{maxOccur} : 1; + $this->{$type} = $args{type}; + $this->{$name} = $args{name} or die new IMPL::InvalidArgumentException('Argument is required','name'); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + $ctx->{schemaNode} = $this; # запоминаем источник ссылки + + if (my $schemaType = $this->{$type} ? $this->document->ResolveType($this->{$type}) : undef ) { + my @errors = $schemaType->Validate($node,$ctx); + return @errors; + } else { + return (); + } +} + +sub isOptional { + my ($this) = @_; + + return $this->{$minOccur} ? 0 : 1; +} + +sub isMultiple { + my ($this) = @_; + + return ($this->{$maxOccur} eq 'unbounded' || $this->{$maxOccur} > 1 ) ? 1 : 0; +} + +sub qname { + $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; +} + +1; + +__END__ +=pod + +=head1 SYNOPSIS + +package SchemaEntity; +use parent qw(IMPL::DOM::Schema::Node); + +sub Validate { + my ($this,$node) = @_; +} + +=head1 DESCRIPTION + +Базовый класс для элементов схемы. Также позволяет объявлять узлы определенного типа. + +=head1 MEMBERS + +=head2 PROPERTIES + +=over + +=item C<[get,set] minOccur> + +C<default: 1>. + +Минимальное количество повторений узла. + +=item C<[get,set] maxOccur> + +C<default: 1>. + +Максимальное количество повторений узла + +=item C<[get,set] type> + +C<default: undef> + +Имя типа из схемы. + +=item C<[get,set] name> + +Имя узла. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/NodeList.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,114 @@ +package IMPL::DOM::Schema::NodeList; +use strict; +use warnings; + + +use IMPL::declare { + require => { + ValidationError => 'IMPL::DOM::Schema::ValidationError', + AnyNode => '-IMPL::DOM::Schema::AnyNode', + Label => 'IMPL::DOM::Schema::Label' + }, + base => [ + 'IMPL::DOM::Node' => sub { nodeName => 'NodeList' } + ], + props => [ + messageUnexpected => { get => 1, set => 1, dom => 1 }, + messageNodesRequired => { get => 1, set => 1, dom => 1} + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->messageUnexpected($args{messageUnexpected} || 'A %node.nodeName% isn\'t allowed in %node.parentNode.path%'); + $this->messageNodesRequired($args{messageNodesRequired} || 'A %schemaNode.name% is required in the node %parent.path%'); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + my @nodes = map { + {nodeName => $_->name, anyNode => $_->isa(AnyNode) , schemaNode => $_, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur, min => $_->minOccur, seen => 0 } + } @{$this->childNodes}; + + my $info = shift @nodes; + + foreach my $child ( @{$node->childNodes} ) { + #skip schema elements + while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) { + # if possible of course :) + return ValidationError->new ( + message => $this->_MakeLabel( $this->messageUnexpected ), + node => $child, + parent => $node, + schemaNode => $info->{schemaNode} + ) if $info->{min} > $info->{seen}; # we trying to skip a schema node which has a quantifier + + $info = shift @nodes; + } + + # return error if no more children allowed + return ValidationError->new ( + message => $this->_MakeLabel( $this->messageUnexpected ), + node => $child, + parent => $node + ) unless $info; + + # it's ok, we found schema element for child + + # validate + while (my @errors = $info->{schemaNode}->Validate( $child ) ) { + if( $info->{anyNode} and $info->{seen} >= $info->{min} ) { + # in case of any or switch node, skip it if possible + next if $info = shift @nodes; + } + return @errors; + } + + $info->{seen}++; + + # check count limits + return ValidationError->new( + message => $this->_MakeLabel( $this->messageUnexpected ), + node => $child, + parent => $node, + schemaNode => $info->{schemaNode}, + ) if $info->{max} and $info->{seen} > $info->{max}; + } + + # no more children left (but may be should :) + while ($info) { + return ValidationError->new( + message => $this->_MakeLabel( $this->messageNodesRequired ), + parent => $node, + schemaNode => $info->{schemaNode} + ) if $info->{seen} < $info->{min}; + + $info = shift @nodes; + } + return; +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Содержимое для сложного узла. Порядок важен. Дочерними элементами могут быть +только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/NodeSet.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,104 @@ +package IMPL::DOM::Schema::NodeSet; +use strict; +use warnings; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + ValidationError => 'IMPL::DOM::Schema::ValidationError', + AnyNode => '-IMPL::DOM::Schema::AnyNode' + }, + base => [ + 'IMPL::DOM::Node' => sub { nodeName => 'NodeSet' } + ], + props => [ + messageUnexpected => { get => 1, set => 1, dom => 1}, + messageMax => { get => 1, set => 1, dom => 1}, + messageMin => { get => 1, set => 1, dom => 1} + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->messageMax( $args{messageMax} || 'Too many %node.nodeName% nodes'); + $this->messageMin( $args{messageMin} || '%schemaNode.name% nodes expected'); + $this->messageUnexpected( $args{messageUnexpected} || 'A %node.nodeName% isn\'t allowed in %node.parentNode.path%'); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + my @errors; + + my %nodes; + my $anyNode; + + foreach (@{$this->childNodes}) { + if ($_->isa(AnyNode)) { + $anyNode = {schemaNode => $_, min => $_->minOccur, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , seen => 0 }; + } else { + $nodes{$_->name} = {schemaNode => $_, min => $_->minOccur, max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , seen => 0 }; + } + } + + foreach my $child ( @{$node->childNodes} ) { + if (my $info = $nodes{$child->nodeName} || $anyNode) { + $info->{seen}++; + push @errors,ValidationError->new( + schemaNode => $info->{schemaNode}, + node => $child, + parent => $node, + message => $this->_MakeLabel($this->messageMax) + ) if ($info->{max} and $info->{seen} > $info->{max}); + + if (my @localErrors = $info->{schemaNode}->Validate($child)) { + push @errors,@localErrors; + } + } else { + push @errors, ValidationError->new( + node => $child, + parent => $node, + message => $this->_MakeLabel($this->messageUnexpected) + ) + } + } + + foreach my $info (values %nodes) { + push @errors, ValidationError->new( + schemaNode => $info->{schemaNode}, + parent => $node, + message => $this->_MakeLabel($this->messageMin) + ) if $info->{min} > $info->{seen}; + } + + return @errors; +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Содержимое для сложного узла. Порядок не важен. Дочерними элементами могут быть +только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. + +При проверке данного правила, проверяются имеющиеся элементы на соответсие схемы +и количества встречаемости, после чего проверяются количественные ограничения +для несуществующих элементов. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/Property.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,67 @@ +package IMPL::DOM::Schema::Property; +use strict; +use warnings; + +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + DOMNode => 'IMPL::DOM::Node', + ValidationError => 'IMPL::DOM::Schema::ValidationError' + }, + base => [ + 'IMPL::DOM::Schema::SimpleNode' => sub { + my %args = @_; + + $args{maxOccur} = 1; + $args{minOccur} = delete $args{optional} ? 0 : 1; + $args{nodeName} ||= 'Property'; + + return %args; + } + ], + props => [ + messageRequired => { get => 1, set => 1, dom => 1 } + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->messageRequired($args{messageRequired} || 'A property %schemaNode.name% is required in the %node.qname%'); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + my $nodeValue = $node->nodeProperty($this->name); + + if (length $nodeValue) { + # we have a value so validate it + + # buld a pseudo node for the property value + my $nodeProp = DOMNode->new(nodeName => '::property', nodeValue => $nodeValue); + + return $this->SUPER::Validate($nodeProp); + + } elsif($this->minOccur) { + # we don't have a value but it's a mandatory property + return ValidationError->new( + message => $this->_MakeLabel($this->messageRequired), + node => $node, + schemaNode => $this + ); + } + return (); +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/SimpleNode.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,49 @@ +package IMPL::DOM::Schema::SimpleNode; +use strict; +use warnings; + +use IMPL::declare { + base => [ + 'IMPL::DOM::Schema::Node' => sub { + my %args = @_; + $args{nodeName} ||= 'SimpleNode'; + %args + } + ] +}; + +sub Validate { + my ($this,$node,$ctx) = @_; + + $ctx->{schemaNode} ||= $this; # для безымянных типов + + $ctx->{schemaType} = $this; + + my @result; + + push @result, $_->Validate($node,$ctx) foreach $this->childNodes; + + return @result; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::SimpleNode> - узел с текстом. + +=head1 DESCRIPTION + +Узел имеющий простое значение. Данный узел может содержать ограничения +на простое значение. + +Производит валидацию содержимого, при постоении DOM модели не имеет специального +типа и будет создан в виде C<IMPL::DOM::Node>. + +Также определяет как будет воссоздано значение узла в DOM модели. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/SimpleType.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,92 @@ +package IMPL::DOM::Schema::SimpleType; +use strict; +use warnings; + +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + ValidationError => 'IMPL::DOM::Schema::ValidationError' + }, + base => [ + 'IMPL::DOM::Schema::SimpleNode' => sub { + my %args = @_; + $args{nodeName} = 'SimpleType'; + $args{minOccur} = 0; + $args{maxOccur} = 'unbounded'; + $args{name} ||= 'SimpleType'; + delete @args{qw(nativeType messageWrongType)}; + %args + } + ], + props => [ + nativeType => { get => 1, set => 1, direct => 1, dom => 1}, + messageWrongType => { get => 1, set => 1, direct => 1, dom => 1 } + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->{$nativeType} = $args{nativeType} if $args{nativeType}; + $this->{$messageWrongType} = $args{messageWrongType} || "A simple node '%node.path%' is expected to be %schemaType.nativeType%"; +} + +sub Validate { + my ($this, $node, $ctx) = @_; + + if ($this->{$nativeType}) { + return ValidationError->new( + node => $node, + schemaNode => $ctx->{schemaNode} || $this, + schemaType => $this, + message => $this->_MakeLabel($this->messageWrongType) + ) unless $node->isa($this->{$nativeType}); + } + return $this->SUPER::Validate($node,$ctx); +} + +sub qname { + $_[0]->nodeName.'[type='.$_[0]->type.']'; +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Schema::SimpleType> - тип для простых узлов. + +=head1 DESCRIPTION + +Используется для описания простых узлов, которые можно отобразить в узлы +определенного типа при построении DOM документа. + +=head1 MEMBERS + +=over + +=item C<nativeType> + +Имя класса который будет представлять узел в DOM модели. + +=item C<messageWrongType> + +Формат сообщения которое будет выдано, если узел в дом модели не будет +соответствовать свойству C<nativeType>. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/SwitchNode.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,64 @@ +package IMPL::DOM::Schema::SwitchNode; +use strict; +use warnings; + +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + ValidationError => 'IMPL::DOM::Schema::ValidationError' + }, + base => [ + 'IMPL::DOM::Schema::AnyNode' => sub { + my %args = @_; + + $args{nodeName} ||= 'SwitchNode'; + + %args; + } + ], + props => [ + messageNoMatch => { get => 1, set => 1, dom => 1 } + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->messageNoMatch($args{messageNoMatch} || 'A node %node.nodeName% isn\'t expected in the %parent.path%'); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + if ( my ($schema) = $this->selectNodes(sub {$_[0]->name eq $node->nodeName} ) ) { + return $schema->Validate($node,$ctx); + } else { + return ValidationError->new( + node => $node, + message => $this->_MakeLabel($this->messageNoMatch) + ); + } +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Представляет узел, который может быть одним из узлов, которые лежат внутри него. +Это более строгий вариант C<IMPL::DOM::Schema::AnyNode>. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/ValidationError.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,138 @@ +package IMPL::DOM::Schema::ValidationError; +use strict; +use warnings; + +use overload + '""' => \&toString, + 'fallback' => 1; + +use IMPL::lang qw(is); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Label => '-IMPL::DOM::Schema::Label' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + node => PROP_RO | PROP_DIRECT, + schemaNode => PROP_RO | PROP_DIRECT, + schemaType => PROP_RO | PROP_DIRECT, + parent => PROP_RO | PROP_DIRECT, + message => PROP_RO | PROP_DIRECT + ] +}; +use IMPL::Resources::Format qw(FormatMessage); + +sub CTOR { + my ($this,%args) = @_; + + $this->{$node} = $args{node}; + $this->{$schemaNode} = $args{schemaNode} if $args{schemaNode}; + $this->{$schemaType} = $args{schemaType} if $args{schemaType}; + + if ($args{parent}) { + $this->{$parent} = $args{parent}; + } elsif ($args{node}) { + $this->{$parent} = $args{node}->parentNode; + } else { + die new IMPL::InvalidArgumentException("A 'parent' or a 'node' parameter is required"); + } + + if ($args{message}) { + $this->{$message} = is($args{message},Label) ? $args{message}->Format(\%args) : FormatMessage($args{message}, \%args) ; + } + +} + +sub toString { + (my $this) = @_; + return $this->message; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Schema::ValidationError> - Описывает ошибку в документе. + +=head1 DESCRIPTION + +При проверке документа на ошибки формирования возвращается массив с объектами +C<IMPL::DOM::Schema::ValidationError>, каждая из которых описывает одну ошибку +в документе. + +С помощью данного объекта осущетсвляется привязка элемента схемы, элемента документа +и сообщения о причине возникновения ошибки. + +Часть ошибок, таких как проверка содержимого на регулярные выражения, привязаны +непосредственно к элементу. Но есть ошибки которые привязываются к родительскому +контейнеру, например отсутсвие обязательного элемента. В таком случае ошибка +содержит свойство C<parent> и по свойству C<source> можно определить элемент +(например его имя), к которому относится ошибка. + +=head1 MEMBERS + +=over + +=item C<[get] node> + +Узел в документе который привел к ошибке. Как правило это либо простые узлы, либо +узлы, которые не могут присутствоать в данном месте по схеме. + +Данное свойство может быть C<undef>. + +=item C<[get] parent> + +Родительский узел в котором произошла ошибка. Используется в случаях, когда C<node> +не указан, например, если по схеме должен существовать дочерний узел с определенным +именем, а в реальном документе его нет. + +Также это свойство может использоваться при формировании сообщения. + +=item C<[get] schema> + +Схема для C<Node> или узла который должен присутсвовать если C<Node> не задан. + +=item C<[get] source> + +Схема, проверка которой привела к возникновению ошибки. Поскольку схемы могут +использовать ссылки, то данное свойство нужно для получения схемы узла, а не +схемы его типа. + +Тоесть проверка схемы узла C<IMPL::DOM::Schema::Node> приводит к проверке схемы +типа, например, C<IMPL::DOM::Schema::ComplexType>, а свойство C<Source> будет +указывать именно на C<IMPL::DOM::Schema::Node>. + +=item C<[get] message> + +Возвращает форматированное сообщение об ошибке. + +=item C<toString()> + +Преобразует ошибку к строке, возвращает значение свойства C<Message> + +=back + +=head1 REMARKS + +=begin code + +my $doc = IMPL::DOM::XMLReader->LoadDocument('data.xml'); +my $schema = IMPL::DOM::Schema->LoadSchema('schema.xml'); + +my @errors = $schema->Validate($doc); + +my $node = $doc->selectSingleNode('user','name'); + +# Получаем все ошибки относящиеся к данному узлу +my @nodeErrors = grep { ($_->node || $_->parent) == $node } @errors; + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/Validator.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,32 @@ +package IMPL::DOM::Schema::Validator; +use strict; + +require IMPL::Exception; +use IMPL::declare { + base => [ + 'IMPL::DOM::Node' => '@_' + ] +}; + +sub Validate { + my ($this,$node) = @_; + + die new IMPL::NotImplementedException(); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Schema::Validator> - Базовый класс для ограничений на простые значения. + +=head1 DESCRIPTION + +От основных элементов схемы его отличает то, что в конечном документе он не соответсвует +никаким узлам и поэтому у него отсутствуют свойства C<minOcuur,maxOccur,name>. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/Validator/Compare.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,264 @@ +package IMPL::DOM::Schema::Validator::Compare; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + ValidationError => 'IMPL::DOM::Schema::ValidationError' + }, + base => [ + 'IMPL::DOM::Schema::Validator' => sub { + my %args = @_; + $args{nodeName} ||= 'Compare'; + delete @args{qw(targetProperty op nodePath optional message)}; + %args; + } + ], + props => [ + targetProperty => PROP_RW, + op => PROP_RW, + nodePath => PROP_RW, + optional => PROP_RW, + _pathTranslated => PROP_RW, + _targetNode => PROP_RW, + _schemaNode => PROP_RW, + message => PROP_RW + ] +}; +use IMPL::Resources::Format qw(FormatMessage); + +our %Ops = ( + '=' => \&_equals, + 'eq' => \&_equalsString, + '!=' => \&_notEquals, + 'ne' => \&_notEqualsString, + '=~' => \&_matchRx, + '!~' => \&_notMatchRx, + '<' => \&_less, + '>' => \&_greater, + 'lt' => \&_lessString, + 'gt' => \&_greaterString +); + +my $rxOps = map qr/$_/, join( '|', keys %Ops ); + +sub CTOR { + my ($this,%args) = @_; + + $this->targetProperty($args{targetProperty} || 'nodeValue'); + $this->op( $Ops{ $args{op} || '=' } ) or die new IMPL::InvalidArgumentException("Invalid parameter value",'op',$args{op},$this->path); + $this->nodePath($args{nodePath}) or die new IMPL::InvalidArgumentException("The argument is required", 'nodePath', $this->path); + $this->message($args{message} || 'The value of %node.path% %schemaNode.op% %value% (%schemaNode.nodePath%)' ); + $this->optional($args{optional}) if $args{optional}; +} + +sub TranslatePath { + my ($this,$path) = @_; + + $path ||= ''; + + my @selectQuery; + + my $i = 0; + + foreach my $chunk (split /\//,$path) { + $chunk = 'document:*' if $i == 0 and not length $chunk; + next if not length $chunk; + + my $query; + my ($axis,$filter) = ( $chunk =~ /^(?:(\w+):)?(.*)$/); + + if ($filter =~ /^\w+|\*$/ ) { + $query = $filter eq '*' ? undef : $filter; + } elsif ( $filter =~ /^(\w+|\*)\s*((?:\[\s*\w+\s*(?:=|!=|=~|!~|eq|ne|lt|gt)\s*["'](?:[^\\'"]|\\[\\"'])*["']\])+)$/) { + my ($nodeName,$filterArgs) = ($1,$2); + + + my @parsedFilters = map { + my ($prop,$op,$value) = ($_ =~ /\s*(\w+)\s*(=|!=|=~|!~|eq|ne|lt|gt)\s*(?:["']((?:[^\\'"]|\\[\\"'])*)["'])/); + + $value =~ s/\\[\\'"]/$1/g; + { + prop => $prop, + op => $Ops{$op}, + value => $value + } + } grep ( $_, split ( /[\]\[]+/,$filterArgs ) ); + + $query = sub { + my ($node) = shift; + + $node->nodeName eq $nodeName or return 0 if $nodeName ne '*'; + $_->{op}->( + _resovleProperty($node,$_->{prop}), + FormatMessage($_->{value},{ + Schema => $this->parentNode, + Node => $this->_targetNode, + schema => $this->parentNode, + schemaType => $this->parentNode, + node => $this->_targetNode, + source => $this->_schemaNode, + schemaNode => $this->_schemaNode + },\&_resovleProperty) + ) or return 0 foreach @parsedFilters; + return 1; + }; + } else { + die new IMPL::Exception("Invalid query syntax",$path,$chunk); + } + + push @selectQuery, $axis ? { $axis => $query } : $query; + + $i++; + } + + return \@selectQuery; +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + my @result; + + my $schemaNode = $ctx->{schemaNode}; + my $schemaType = $ctx->{schemaType}; + + $this->_schemaNode($schemaNode); + + $this->_targetNode($node); + + my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath)); + + my ($foreignNode) = $node->selectNodes(@$query); + + + + if ($foreignNode) { + my $value = $this->nodeValue; + + if ($value) { + $value = FormatMessage($value, { Schema => $this->parentNode, Node => $this->_targetNode, ForeignNode => $foreignNode },\&_resovleProperty); + } else { + $value = $foreignNode->nodeValue; + } + + push @result, ValidationError->new( + node => $node, + foreignNode => $foreignNode, + value => $value, + schemaNode => $schemaNode, + schemaType => $schemaType, + message => $this->_MakeLabel($this->message) + ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value); + } elsif (not $this->optional) { + push @result, ValidationError->new( + node => $node, + value => '', + schemaNode => $schemaNode, + schemaType => $schemaType, + message => $this->_MakeLabel( $this->message ) + ); + } + + $this->_targetNode(undef); + $this->_schemaNode(undef); + + return @result; +} + +sub _resovleProperty { + my ($node,$prop) = @_; + + return $node->can($prop) ? $node->$prop() : $node->nodeProperty($prop); +} + +sub _matchRx { + $_[0] =~ $_[1]; +} + +sub _notMatchRx { + $_[0] !~ $_[1]; +} + +sub _equals { + $_[0] == $_[1]; +} + +sub _notEquals { + $_[0] != $_[0]; +} + +sub _equalsString { + $_[0] eq $_[1]; +} + +sub _notEqualsString { + $_[0] ne $_[1]; +} + +sub _less { + $_[0] < $_[1]; +} + +sub _greater { + $_[0] > $_[1]; +} + +sub _lessString { + $_[0] lt $_[1]; +} + +sub _greaterString { + $_[0] gt $_[1]; +} + +sub _lessEq { + $_[0] <= $_[1]; +} + +sub _greaterEq { + $_[0] >= $_[1]; +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Schema::Validator::Compare> - ограничение на содержимое текущего узла, +сравнивая его со значением другого узла. + +=head1 SYNOPSIS + +Пример типа описания поля с проверочным полем + +=begin code xml + +<schema> + <SimpleType type="retype_field"> + <Property name="linkedNode" message="Для узла %node.nodeName% необходимо задать свойство %schemaNode.name%"/> + <Compare op="eq" nodePath="sibling:*[nodeName eq '%node.linkedNode%']"/> + </SimpleType> +</schema> + +=begin code xml + +=head1 DESCRIPTION + +Позволяет сравнивать значение текущего узла со значением другого узла. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Schema/Validator/RegExp.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,57 @@ +package IMPL::DOM::Schema::Validator::RegExp; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Label => 'IMPL::DOM::Schema::Label', + ValidationError => 'IMPL::DOM::Schema::ValidationError' + }, + base => [ + 'IMPL::DOM::Schema::Validator' => sub { + my %args = @_; + $args{nodeName} ||= 'RegExp'; + %args; + } + ], + props => [ + message => { get => 1, set =>1, dom =>1 }, + launder => { get => 1, set =>1, dom =>1 }, + _rx => { get=> 1, set=> 1} + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->message($args{message} || "A %node.nodeName% doesn't match to the format %schemaNode.label%"); +} + +sub Validate { + my ($this,$node,$ctx) = @_; + + my $rx = $this->_rx() || $this->_rx( map qr{$_}, $this->nodeValue ); + + return ValidationError->new ( + node => $node, + schemaNode => $ctx->{schemaNode}, + schemaType => $ctx->{schemaType}, + message => $this->_MakeLabel($this->message) + ) unless (not $node->isComplex) and $node->nodeValue =~ /($rx)/; + + $node->nodeValue($1) if $this->launder; + + return (); +} + +sub _MakeLabel { + my ($this,$label) = @_; + + if ($label =~ /^ID:(\w+)$/) { + return Label->new($this->document->stringMap, $1); + } else { + return $label; + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Transform.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,33 @@ +package IMPL::DOM::Transform; +use strict; +use warnings; + +use parent qw(IMPL::Transform); + +__PACKAGE__->PassThroughArgs; + +sub GetClassForObject { + my ($this,$object) = @_; + + if (my $class = ref $object) { + if (UNIVERSAL::isa($object,'IMPL::DOM::Node')) { + return $object->nodeName; + } else { + return $class; + } + } else { + return undef; + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Преобразование для DOM документа, использует имя узла для применения подходящего преобразования. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Transform/ObjectToDOM.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,255 @@ +package IMPL::DOM::Transform::ObjectToDOM; +use strict; + +use IMPL::Const qw(:prop :access); +use IMPL::declare { + require => { + PropertyInfo => 'IMPL::Class::PropertyInfo', + Builder => 'IMPL::DOM::Navigator::Builder', + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException', + OperationException => '-IMPL::InvalidOperationException' + }, + base => [ + 'IMPL::Transform' => sub { + -plain => 'TransformPlain', + HASH => 'TransformHash', + -default => 'TransformDefault' + } + ], + props => [ + documentSchema => PROP_RO, + _schema => PROP_RW, + _navi => PROP_RW + ] +}; + +use constant { + SchemaNode => 'IMPL::DOM::Schema::Node', + ComplexNode => 'IMPL::DOM::Schema::ComplexNode' +}; + +sub CTOR { + my ($this,$docName,$docSchema,$transforms) = @_; + + my $docNodeSchema = $docSchema->selectSingleNode(sub { $_->isa(SchemaNode) and $_->name eq $docName } ) + or die OperationException->new("Can't find a node schema for the document '$docName'"); + + my $docClass = ($docNodeSchema->can('nativeType') ? $docNodeSchema->nativeType : undef) || 'IMPL::DOM::Document'; + + $this->documentSchema($docNodeSchema); + + $this->_navi( + Builder->new( + $docClass, + $docSchema, + ignoreUndefined => 1 + ) + ); + $this->_schema($docSchema); + + $this->_navi->NavigateCreate($docName); + $this->currentNode->nodeProperty(schemaDocument => $docSchema); +} + +sub TransformPlain { + my ($this,$data) = @_; + + $this->_navi->Current->nodeValue( $data ); + return $this->_navi->Current; +} + +sub currentNode { + shift->_navi->Current; +} + +sub TransformHash { + my ($this,$data) = @_; + + die ArgumentException->new(data => 'A HASH reference is required') + unless ref $data eq 'HASH'; + + return $this->StoreObject($this->currentNode,$data) + if !$this->currentNode->schemaType->isa(ComplexNode); + + KEYLOOP: foreach my $key (keys %$data) { + my $value = $data->{$key}; + + if (ref $value eq 'ARRAY') { + foreach my $subval (grep $_, @$value) { + + $this->_navi->saveState(); + + my $node = $this->_navi->NavigateCreate($key); + + unless(defined $node) { + #$this->_navi->Back(); + $this->_navi->restoreState(); + next KEYLOOP; + } + + $this->_navi->applyState(); + + $this->Transform($subval); + + $this->_navi->Back(); + } + } else { + $this->_navi->saveState(); + my $node = $this->_navi->NavigateCreate($key); + + unless(defined $node) { + #$this->_navi->Back(); + $this->_navi->restoreState(); + next KEYLOOP; + } + + $this->_navi->applyState(); + + $this->Transform($value); + + $this->_navi->Back(); + } + } + return $this->_navi->Current; +} + +# this method handles situatuions when a complex object must be stored in a +# simple node. +sub StoreObject { + my ($this,$node,$data) = @_; + + $node->nodeValue($data); + + return $node; +} + +sub TransformDefault { + my ($this,$data) = @_; + + return $this->StoreObject($this->currentNode,$data) + if !$this->currentNode->schemaType->isa(ComplexNode); + + if ( ref $data and eval { $data->can('GetMeta') } ) { + my %props = map { + $_->name, 1 + } $data->GetMeta(PropertyInfo, sub { $_->access == ACCESS_PUBLIC }, 1 ); + + + my %values = map { + $_, + scalar($data->$_()) + } keys %props; + + return $this->Transform(\%values); + } else { + die OperationException->new("Don't know how to transform $data"); + } + + return $this->_navi->Current; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Transform::ObjectToDOM> -преобразование объекта в DOM документ. + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + Schema => 'IMPL::DOM::Schema', + Config => 'IMPL::Config' +} + +my $data = { + id => '12313-232', + name => 'Peter', + age => 20 +}; + +my $schema = Schema->LoadSchema(Config->AppBase('schemas','person.xml')); +my $transorm = IMPL::DOM::Transform::ObjectToDOM->new('edit', $schema); + +my $form = $transform->Transform($data); + +my @errors; + +push @errors, $schema->Validate($doc); + +=end code + +=head1 DESCRIPTION + +Наследует C<IMPL::Transform>. Определяет базовые преобразования для хешей и +объектов, поддерживающих метаданные. + +Результатом выполнения преобразования является DOM документ. При построении +документа используется навигатор C<IMPL::DOM::Navigator::Builder> для +сопоставления схемы и свойств преобразуемого объекта. Элементы полученного +документа имеют ссылки на соответствующие им элементы схемы. + +После того, как документ построен и преобразование будет очищено, не останется +объектов, которые бы ссылались на документ со схемой, поскольку элементы схемы +имеют слабые ссылки на саму схему и не могут предотвратить ее удаление. +Для предотвращения очитски документа схемы, ссылка на него сохраняется в +атрибуте документа C<schemaDocument>, что обеспечит жизнь схемы на протяжении +жизни документа. + +Преобразование происходит рекурсивно, сначала используется метод +C<NavigateCreate> для создания элемента соответсвующего свойству объекта, +затем вызывается метод C<Transform> для преобразования значения свойства, при +этом C<currentNode> указывает на только что созданный элемент документа. + +Для изменения поведения преобразования можно добавлять новые обработчики, как +в случае со стандартным преобразованием, а также можно унаследовать текущий +класс для переопределения его некоторых методов. + +=head1 MEMBERS + +=head2 C<CTOR($docName,$schema)> + +Создает преобразование, при этом будет создан документ состоящий только из +корневого элемента с именем C<$docName> и будет найдена подходящий для него +элемент схемы C<$schema>. + +=over + +=item * C<$docName> + +Имя корневого узла документа, которое будет использовано для поиска +соответствующего элемента схемы C<$schema> + +=item * C<$schema> + +Схема, содержащая описание документа. Если в данной схеме нет описания корневого +элемента с именем C<$docName>, будет вызвано исключение. + +=back + +=head2 C<[get]documentSchema> + +Элемент схемы C<ComplexNode> соответствующий документу. Определяется в +конструкторе исходя из имени документа. + +=head2 C<[get]currentNode> + +Текущий элемент документа. После создания преобразования - это сам документ. +Данное свойство использется внутри преобразования для работы с текущим +элементом. + +=head2 C<[virtual]StoreObject($node,$data)> + +Метод, который вызывается преобразованием в случае если текущий узел документа +является простым, а значени которое ему соответсвует является объектом (ссылкой). + +По-умолчанию будет выполнено присваивание C<< $node->nodeValue($data) >>, однако +это можно заменить, например, на преобразование в строку. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Transform/PostToDOM.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,161 @@ +package IMPL::DOM::Transform::PostToDOM; +use strict; +use warnings; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Builder => 'IMPL::DOM::Navigator::Builder' + }, + base => [ + 'IMPL::Transform' => sub { + -plain => \&TransformPlain, + HASH => \&TransformContainer, + CGI => \&TransformCGI, + CGIWrapper => \&TransformCGI + } + ], + props => [ + documentClass => PROP_RO, + documentSchema => PROP_RO, + prefix => PROP_RO, + _navi => PROP_RW, + errors => PROP_RW | PROP_LIST, + _schema => PROP_RW + ] +}; + +sub CTOR { + my ($this,$docClass,$docSchema,$prefix) = @_; + $docClass ||= 'IMPL::DOM::Document'; + + $this->_navi( + IMPL::DOM::Navigator::Builder->new( + $docClass, + $docSchema + ) + ); + $this->_schema($docSchema); + $this->prefix($prefix) if $prefix; +} + +sub TransformContainer { + my ($this,$data) = @_; + + my $navi = $this->_navi; + + foreach my $key ( + sort { $a->[1] cmp $b->[1] || $a->[2] <=> $b->[2]} + map [$_,/(\w+)(?:\[(\d+)\])?/], keys %$data + ){ + my $value = $data->{$key->[0]}; + my $node = $navi->NavigateCreate($key->[1]); + + $node->nodeProperty(instanceId => $key->[2]) if defined $key->[2]; + + $this->Transform($value); + + $navi->Back(); + } + + return $navi->Current; +} + +sub TransformPlain { + my ($this,$data) = @_; + + $this->_navi->Current->nodeValue( $this->_navi->inflateValue($data) ); +} + +sub TransformCGI { + my ($this,$query) = @_; + + my $data={}; + + my $prefix = $this->prefix; + my $delim = $this->delimiter; + + foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { + length (my $value = $query->param($param)) or next; + + my @parts = split /\//,$param; + + my $node = $data; + while ( my $part = shift @parts ) { + if (@parts) { + $node = ($node->{$part} ||= {}); + } else { + $node->{$part} = $value; + } + } + } + + if (keys %$data > 1) { + $data = { document => $data }; + } + + my $doc = $this->Transform($data); + $doc->nodeProperty( query => $query ); + $this->errors->Append( $this->_navi->BuildErrors); + $this->errors->Append( $this->_schema->Validate($doc)); + return $doc; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Transform::PostToDOM> - Преобразование объекта C<CGI> в DOM документ. + +=head1 SINOPSYS + +=begin code + + my $schema = IMPL::DOM::Schema->LoadSchema('Data/user.add.schema.xml'); + + my $transform = IMPL::DOM::Transform::PostToDOM->new( + undef, # default class + $schema, + $schema->selectSingleNode('ComplexNode')->name + ); + + my $doc = $transform->Transform( + CGI->new({ + 'user/login' => 'bob', + 'user/fullName' => 'Bob Marley', + 'user/password' => 'secret', + 'user/password_retype' => 'secret', + 'user/birthday' => '1978-12-17', + 'user/email[1]' => 'bob@marley.com', + 'user/email[2]' => 'bob.marley@google.com', + process => 1 + }) + ); + +=end code + +=head1 DESCRIPTION + +Используется для преобразования CGI запроса в DOM документ. Для этого используются параметры запроса, имена которых +начинаются со значение из свойства C<prefix>. + +Имена параметров интерпретируются следующим образом + +=over + +=item 1 Имя параметра составляется из имени узла, имен всех его родителей и указанием номера экземпляра. + +=item 2 Имена узлов могут содержать только буквы, цифры и символ _ + +=item 3 В случае когда узел может повторяться несколько раз, в квадратных скобках указывается +послеовательный номер экземпляра. + +=item 4 Имена параметров объединяются через символ '/' + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/Transform/QueryToDOM.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,185 @@ +package IMPL::DOM::Transform::QueryToDOM; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + OutOfRangeException => '-IMPL::OutOfRangeException' + }, + base => [ + 'IMPL::DOM::Transform::ObjectToDOM' => '@_' + ], + props => [ + prefix => PROP_RO, + delimiter => PROP_RO + ] +}; + +our $MAX_INDEX = 1024; + +sub CTOR { + my ($this) = @_; + + $this->templates->{'CGI'} = 'TransformCGI'; + $this->templates->{'IMPL::Web::Application::Action'} = 'TransformAction'; + + $this->delimiter('[.]'); + $this->prefix(''); +} + +# inflate simple properties +sub TransformPlain { + my ($this,$data) = @_; + + $this->currentNode->nodeProperty( rawValue => $data ); + $this->currentNode->nodeValue( $data ); + return $this->currentNode; +} + +# do not store complex data as node values +sub StoreObject { + my ($this,$node,$data) = @_; + + return $node; +} + +#TODO: support a.b[0][1].c[1] + +sub TransformCGI { + my ($this,$query) = @_; + + my $data={}; + + my $prefix = $this->prefix; + my $delim = $this->delimiter; + + foreach my $param (grep index($_,$prefix) >= 0 , $query->param()) { + + my @value = grep length($_), $query->param($param) or next; + + my @parts = split /$delim/,$param; + + my $node = $data; + while ( my $part = shift @parts ) { + if (my ($name,$index) = ($part =~ m/^(\w+)(?:\[(\d+)\])?$/) ) { + if (@parts) { + if(defined $index) { + $this->ValidateIndex($index); + $node = ($node->{$name}[$index] ||= {}); + } else { + $node = ($node->{$name} ||= {}); + } + } else { + if(defined $index) { + $this->ValidateIndex($index); + $node->{$name}[$index] = (@value == 1 ? $value[0] : \@value); + } else { + $node->{$name} = (@value == 1 ? $value[0] : \@value); + } + } + } + } + } + + return $this->Transform($data); +} + +sub ValidateIndex { + my ($this,$index) = @_; + + die OutOfRangeException->new() + unless $index >= 0 and $index <= $MAX_INDEX; +} + +sub TransformAction { + my ($this,$action) = @_; + + return $this->Transform($action->isJson ? $action->jsonData : $action->query); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::DOM::Transform::QueryToDOM> - преобразование CGI запроса в DOM документ. + +=head1 SYNOPSIS + +=begin code + +use CGI(); +use IMPL::require { + Schema => 'IMPL::DOM::Schema', + Config => 'IMPL::Config', + QueryToDOM => 'IMPL::DOM::Transform::QueryToDOM' +} + +my $q = CGI->new(); + +my $schema = Schema->LoadSchema(Config->AppBase('schemas','person.xml')); +my $transorm = QueryToDOM->new('edit', $schema); + +my $form = $transform->Transform($q); + +my @errors; + +push @errors, $transform->buildErrors; +push @errors, $schema->Validate($doc); + + +=end code + +=head1 DESCRIPTION + +Наследует C<IMPL::DOM::Transform::ObjectToDOM>. Добавляет метод +C<TransformCGI> который применятеся к объектам типа C<CGI> (и производных). + +Запрос C<CGI> сначала приводится к хешу, затем полученный хеш преобразуется +в DOM документ при помощи вызова метода C<Transform>. + +Для этого выбираются параметры запроса, затем, имя каждого параметра +рассматривается в виде пути к свойству, создается структура из хешей и массивов +в которую по указанному пути кладется значение. + +Если параметр имеет несколько значений, значит свойство является массивом. + +Также изменено поведение некоторых методов преобразования. + +=over + +=item * C<TransformPlain($value)> + +Преобразование для простого значения свойства. Посокльку в запросе передаются +строковые значения, а схема документа может предполпгать другие типы, при +преобразовании значения параметра из запроса к значению узла используется +метод C<< $this->inflateNodeValue($value) >>, также помимо значения +C<< $this->currentNode->nodeValue >> задается атрибут +C<< $this->currentNode->nodeProperty( rawValue => $value) >>, для того, чтобы +была возможность получить оригинальное значение параметра запроса (например, +в случае когда его формат был не верным и C<nodeValue> будет C<undef>). + +=item * C<StoreObject($node,$object)> + +Данный метод вызывается если текущий узел (переданный в параметре C<$node>) +предполагает простое значение, однако в запросе для него было передано сложное +содержимое. Данная реализация просто игнорирует переданный объект C<$object> +и возвращает C<$node> без изменений. + +=back + +=head1 MEMBERS + +=head2 C<[get]delimiter> + +REGEX. Разделитель свойств в имени параметра, по-умолчанию C<'[.]'> + +=head2 C<[get]prefix> + +Строка, префикс имен параметров, которые участвуют в формировании документа. +По-умолчанию пусто. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/DOM/XMLReader.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,143 @@ +package IMPL::DOM::XMLReader; +use strict; +use warnings; + +use parent qw(IMPL::Object IMPL::Object::Autofill); + +use IMPL::Class::Property; +use XML::Parser; + +use IMPL::require { + Schema => 'IMPL::DOM::Schema', # IMPL::DOM::Schema references IMPL::DOM::XML::Reader + Builder => 'IMPL::DOM::Navigator::Builder', + SimpleBuilder => 'IMPL::DOM::Navigator::SimpleBuilder' +}; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public _direct property Navigator => prop_get | owner_set; + public _direct property SkipWhitespace => prop_get | owner_set; + private _direct property _current => prop_all; + private _direct property _text => prop_all; + private _direct property _textHistory => prop_all; +} + +sub Parse { + my ($this,$in) = @_; + + my $parser = new XML::Parser( + Handlers => { + Start => sub {shift; goto &OnStart($this,@_)}, + End => sub {shift; goto &OnEnd($this,@_)}, + Char => sub {shift; goto &OnChar($this,@_)} + } + ); + + $parser->parse($in); +} + +sub ParseFile { + my ($this,$in) = @_; + + my $parser = new XML::Parser( + Handlers => { + Start => sub {shift; unshift @_, $this; goto &_OnBegin;}, + End => sub {shift; unshift @_, $this; goto &_OnEnd;}, + Char => sub {shift; unshift @_, $this; goto &_OnChar;} + } + ); + + $parser->parsefile($in); +} + +sub _OnBegin { + my ($this,$element,%attrs) = @_; + + push @{$this->{$_textHistory}},$this->{$_text}; + $this->{$_text} = ""; + $this->{$_current} = $this->Navigator->NavigateCreate($element,%attrs); +} + +sub _OnEnd { + my ($this,$element) = @_; + $this->{$_current}->nodeValue($this->{$_text}) if length $this->{$_text} and (not $this->{$SkipWhitespace} or $this->{$_text} =~ /\S/); + $this->{$_text} = pop @{$this->{$_textHistory}}; + $this->{$_current} = $this->Navigator->Back; +} + +sub _OnChar { + my ($this,$val) = @_; + $this->{$_text} .= $val; +} + +sub LoadDocument { + my ($self,$file,$schema) = @_; + + my $parser; + if ($schema) { + $schema = IMPL::DOM::Schema->LoadSchema($schema) if not ref $schema; + $parser = $self->new( + Navigator => IMPL::DOM::Navigator::Builder->new( + 'IMPL::DOM::Document', + $schema + ) + ); + } else { + $parser = $self->new( + Navigator => IMPL::DOM::Navigator::SimpleBuilder->new() + ); + } + + $parser->ParseFile($file); + my $doc = $parser->Navigator->Document; + my @errors; + if ($schema) { + push @errors, $schema->Validate($doc); + } + + if (wantarray) { + return $doc,\@errors; + } else { + die new IMPL::Exception("Loaded document doesn't match the schema", @errors) if @errors; + return $doc; + } +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +my $reader = new IMPL::DOM::XMLReader(Navigator => $DomBuilder); +my $obj = $reader->parsefile("data.xml"); + +=head1 DESCRIPTION + +Простой класс, использующий навигатор для постороения документа. В зависимости от +используемого навигатора может быть получен различный результат. + +Навигатор должен поодерживать методы C<NavigateCreate> и C<Back> + +=head1 METHODS + +=over + +=item C<CTOR(Naviagtor => $builder)> + +Создает новый экземпляр парсера, с указанным навигатором для построения документа + +=item C<$obj->Parse($in)> + +Строит документ. На вход получает либо xml строку, либо HANDLE. + +=item C<$obj->ParseFile($fileName)> + +Строит документ из файла с именем C<$fileName>. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Exception.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,141 @@ +package IMPL::Exception; +use strict; +use overload + '""' => \&ToString, + 'fallback' => 1; +use Carp qw(longmess shortmess); +use Scalar::Util qw(refaddr); + +BEGIN { + require Error; +} + +use parent qw(IMPL::Object::Abstract Error Class::Accessor); + +BEGIN { + __PACKAGE__->mk_accessors( qw(Message Args CallStack Source) ); +} + +sub indent { + my ($str,$level) = @_; + $level ||= 0; + $str = '' unless defined $str; + join ("\n", map( " "x$level.$_ , split(/\n/,$str) ) ); +} + +sub new { + my $class = shift; + $class = ref $class || $class; + + my $this = $class->Error::new() or die "Failed to create an exception"; + + $this->callCTOR(@_); + $this->{-text} = $this->Message; + + local $Carp::CarpLevel = 0; + + $this->CallStack(longmess); + $this->Source(shortmess); + + return $this; +} + +sub CTOR { + my ($this,$message,@args) = @_; + $this->Message($message || ''); + die new IMPL::Exception("Fatal erorr: cyclic structure in the exceptions were detected, do not use \$\@ while throwing the exception!") if grep ref $_ ? refaddr($this) == refaddr($_) : 0 , @args; + $this->Args([map defined $_ ? $_ : 'undef', @args]); +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar(Message => $this->Message) if $this->Message; + $ctx->AddVar(Args => $this->Args) if @{$this->Args}; + $ctx->AddVar(Source => $this->Source); + $ctx->AddVar(CallStack => $this->CallStack); +} + +sub restore { + my ($class,$data,$instance) = @_; + + my %args = @$data; + + if ($instance) { + $instance->callCTOR($args{Message},@{$args{Args}}); + } else { + $instance = $class->new($args{Message},@{$args{Args}}); + } + + $instance->Source($args{Source}); + $instance->CallStack($args{CallStack}); + + return $instance; +} + +sub ToString { + my $this = shift; + + $this->toString(); +} + +sub toString { + my ($this,$notrace) = @_; + ($this->Message || ref $this) . join("\n",'',map { my $s = $_; local $_; indent("$s",1) } @{$this->Args} ) . ( $notrace ? '' : "\n" . $this->CallStack); +} + +package IMPL::InvalidOperationException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::InvalidArgumentException; +our @ISA = qw(IMPL::Exception); +our %CTOR = ( + 'IMPL::Exception' => sub { "An invalid argument", @_ } +); + +package IMPL::DuplicateException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::KeyNotFoundException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +our %CTOR = ( + 'IMPL::Exception' => sub { "A specified element isn't found", $_[0] } +); + +package IMPL::NotImplementedException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::SecurityException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::AccessDeniedException; +our @ISA = qw(IMPL::SecurityException); +our %CTOR = ( 'IMPL::SecurityException' => sub { 'Access denied' ,@_ } ); + +package Exception; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::DeprecatedException; +our @ISA = qw(IMPL::Exception); +our %CTOR = ( + 'IMPL::Exception' => sub { @_ ? @_ : "The method is deprecated" } +); + +package IMPL::WrongDataException; +our @ISA = qw(IMPL::Exception); +our %CTOR = ( + 'IMPL::Exception' => sub { "The input data is wrong", @_ } +); + +package IMPL::IOException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Mailer.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,69 @@ +package IMPL::Mailer; +use strict; + +use Encode qw (encode); +use Encode::MIME::Header; +use MIME::Base64 qw(encode_base64); +use Email::Simple; + +our $SENDMAIL; + +sub DeliverMessage { + my $message = shift; + + $message = shift if $message eq __PACKAGE__ or ref $message eq __PACKAGE__; + + my $email = new Email::Simple($message); + + $email->header_set('Content-Transfer-Encoding' => 'base64'); + $email->header_set('MIME-Version' => '1.0') if !$email->header('MIME-Version'); + $email->header_set('Content-Type' => 'text/plain; charset="utf-8"'); + my $raw = $email->body(); + utf8::encode($raw) if utf8::is_utf8($raw); + $email->body_set(encode_base64($raw)); + + foreach my $field ($email->header_names()) { + $email->header_set($field, map { encode('MIME-Header', utf8::is_utf8($_) ? $_ : Encode::decode('utf-8',$_) ) } $email->header($field) ); + } + + return SendMail($email,@_); +} + +sub _find_sendmail { + return $SENDMAIL if defined $SENDMAIL; + + my @path = split (/:/, $ENV{PATH}); + my $sendmail; + for (@path) { + if ( -x "$_/sendmail" ) { + $sendmail = "$_/sendmail"; + last; + } + } + return $sendmail; +} + +sub SendMail { + my ($message, %args) = @_; + my $mailer = _find_sendmail; + + local *SENDMAIL; + if( $args{'TestFile'} ) { + open SENDMAIL, '>', $args{TestFile} or die "Failed to open $args{TestFile}: $!"; + binmode(SENDMAIL); + print SENDMAIL "X-SendMail-Cmd: sendmail ",join(' ',%args),"\n"; + } else { + my @args = %args; + die "sendmail not found" unless $mailer; + die "Found $mailer but cannot execute it" + unless -x $mailer; + open SENDMAIL, "| $mailer -t -oi @args" + or die "Error executing $mailer: $!"; + } + print SENDMAIL $message->as_string + or die "Error printing via pipe to $mailer: $!"; + close SENDMAIL; + return 1; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,82 @@ +package IMPL::ORM; +use strict; +use warnings; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; +use Scalar::Util qw(weaken refaddr); + +use IMPL::Exception; + +our $Depth = 1; # загружать объект + 1 уровень детей +our $UseProxy = 1; + +BEGIN { + private property _ObjectCache => prop_all; + private property _MapInstances => prop_all; + private property _WorkUnit => prop_all; + public property Schema => prop_all; +} + +sub ObjectInfoById { + my ($this,$oid) = @_; + + return $this->_ObjectCache->{$oid}; +} + +sub ObjectInfo { + my ($this,$inst) = @_; + + die new IMPL::InvalidOperationException("This method can be used only for a reference") unless ref $inst; + + return $this->_MapInstances->{refaddr $inst}; +} + + +1; +__END__ + +=pod + +=head1 NAME + +C<IMPL::ORM> - Object Relational Mapping + +=head1 SYNOPSIS + +=begin code + +my $ds = IMPL::ORM::Storage::DBIC->new('My::Data',$dsn,$user,$pass,{Autocommit => 1}); + + +my $foo = $ds->Insert( + My::Data::Foo->new( + 'foo class' + ) +); + +my $bar = $ds->Insert( + My::Data::Bar->new( + 'bar class' + ) +) + +$bar->fooObject($foo); + +$ds->Save($bar); + +my $fooOther = $ds->Retrieve( + 'My::Data::Bar', + { + name => 'bar class', + fooObject => { + name => 'some foo' + } + } +) + +=end code + +=head1 DESCRIPTION + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Adapter/Generic.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,103 @@ +package IMPL::ORM::Adapter::Generic; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::ORM::Adapter::Generic> Адаптер для работы с данными объекта произвольного класса. + +=head1 DESCRIPTION + +Позволяет получать данные, изменения данных из объекта, а также записать данные в +объект и создать новый объект. + +=head1 MEMBERS + +=over + +=item C<CTOR($object,$hashOptions)> + +Создает новый адаптер к объекту C<$object> + +=item C<[get]object> + +Объект для которого создан данный адаптер, C<undef> если объект удален. + +=item C<[get]isChanged> + +Были ли обновления в объекте. + +=item C<[get]isDeleted> + +Является ли объект удаленным. + +=item C<[get]isNew> + +Является ли объект новым для БД. + +=item C<[get]initialState> + +Начальное состояние объекта, C<undef> если объект был создан. + +=item C<[get]currentState> + +Текущие состояние. C<undef> если объект удален. + +=item C<[get,list]history> + +История изменений. C<IMPL::Object::List> + +=item C<SaveChanges> + +Сохраняет изменения из объекта в текущее состояние, при этом изменения записываются в историю. + +B<returns> информацию об изменениях в объекте. + +=item C<Revert($version)> + +Возвращает объект в определенную версию. + +=item C<Delete> + +Удаляет объект, точнее помечает его для удаления до вызова C<Commit>. + +=item C<Commit> + +Сбрасывает историю изменений, и устанавливает соответсвующие свойства. + +=back + +=head1 Информация об изменениях объекта + +=begin code + +{ + version => 1, # object version + op => STORAGE_UPDATE, + data => { + entity1 => { + field1 => 'value 1' + }, + entity2 => { + field2 => 'value 2' + } + } +} + +=end code + +=head1 Информация об отображении объекта + +=begin code + +{ + prop_name => [ entity => 'field' ] +} + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Entity.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,47 @@ +package IMPL::ORM::Entity; +use strict; +use warnings; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Class => prop_get; + public _direct property Values => prop_get; + public _direct property Schema => prop_get; +} + +sub CTOR { + my ($this,$class,$schema) = @_; + + $this->{$Class} = $class; + (my $name = $class) =~ s/::/_/g; + $this->{$Name} = $name; + $this->Schema = $schema; + $this->{$Values} = { + map {$_->{name},{type => $_->{type}, virtual => $_->{virtual}}} @$schema + }; +} + +sub Store; +*Store = \&dbgStore; + +sub dbgStore { + my ($this,$prop,$value) = @_; + + if ( my $container = $this->{$Values}{$prop} ) { + $container->{oldValue} = $container->{value}; + $container->{value} = $value; + } else { + die new IMPL::InvalidOperationException("Property not found",$this->Name,$prop); + } +} + +sub Get { + my ($this,$prop) = @_; + + return $this->{$Values}{$prop}{value}; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Helpers.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,24 @@ +package IMPL::ORM::Helpers; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&Map &Box); + +sub Map($$) { + my ($TKey,$TValue) = @_; + + $TKey =~ s/:://g; + $TValue =~ s/:://g; + + return "IMPL::ORM::Map::${TKey}${TValue}"; +} + +sub Box($) { + my ($TValue) = @_; + $TValue =~ s/:://g; + return "IMPL::ORM::Box::$TValue"; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Object.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,115 @@ +package IMPL::ORM::Object; +use strict; +use warnings; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +require IMPL::ORM::Entity; +require IMPL::ORM::Schema::Entity; +require IMPL::ORM::Schema::Field; +require IMPL::ORM::Schema::Relation::HasMany; +require IMPL::ORM::Schema::Relation::HasOne; +require IMPL::ORM::Schema::Relation::Subclass; + +BEGIN { + private _direct property _entities => prop_all; + public property objectType => prop_all, {type => 'String'}; + + sub _PropertyImplementor { + 'IMPL::ORM::PropertyImplementor' + } +} + +my %schemaCache; + +sub CTOR { + my ($this) = @_; + + while ( my ($class,$schema) = $this->ormGetSchema ) { + $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema); + } +} + +sub ormStore { + my ($this,$class,$prop,$value) = @_; + + die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class}; + + $this->{$_entities}{$class}->Store($prop,$value); +} + +sub ormGet { + my ($this,$class,$prop,$value) = @_; + + return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef; +} + +sub entityName { + (my $self = ref $_[0] || $_[0]) =~ s/^.*?(\w+)$/$1/; + return $self; +} + +sub ormGetSchema { + my ($self,$dataSchema,$surrogate) = @_; + + my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName); + + # для текущего класса, проходим по всем свойствам + foreach my $ormProp ( + $self->get_meta( + 'IMPL::Class::PropertyInfo', + sub { + UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' ) + }, + 0 + ) + ){ + if ($ormProp->Mutators & prop_list) { + # отношение 1 ко многим + my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name); + $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); + } elsif (my $type = $dataSchema->isValueType($ormProp->Type)) { + # поле + $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$ormProp->Type) ); + } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { + # отношение ссылка + $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); + } else { + # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле. + die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type); + } + } + + # Формируем отношения наследования + { + # локализуем прагму + no strict 'refs'; + + my $class = ref $self || $self; + + # по всем классам + foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) { + my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super); + $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type)); + } + } + + return $schema; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Базовый объект для реляционного отображения, +содержит в себе реляционные записи представляющие данный объект. + +Каждый класс отображается в определенную сущность. Сущности хранят +состояние объектов в том виде в котором удобно записывать в реляционную базу. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/PropertyImplementor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,7 @@ +package IMPL::ORM::PropertyImplementor; +use strict; +use warnings; + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,153 @@ +package IMPL::ORM::Schema; +use strict; +use warnings; + +use parent qw(IMPL::DOM::Document); +use IMPL::Class::Property; +require IMPL::ORM::Schema::Entity; +require IMPL::ORM::Schema::ValueType; + +our %CTOR = ( + 'IMPL::DOM::Document' => sub { nodeName => 'ORMSchema' } +); + +BEGIN { + public property mapValueTypes => prop_get | owner_set; + public property mapReferenceTypes => prop_get | owner_set; + public property mapPending => prop_get | owner_set; + public property prefix => prop_get | owner_set; +} + +sub CTOR { + my ($this ) = @_; + $this->mapValueTypes({}); + $this->mapReferenceTypes({}); + $this->mapPending({}); +} + +# return an entity for the specified typename +# makes forward declaration if nesessary +sub resolveType { + my ($this,$typeName) = @_; + + $this = ref $this ? $this : $this->instance; + + if (my $entity = $this->mapReferenceTypes->{$typeName}) { + return $entity; + } elsif (UNIVERSAL::isa($typeName,'IMPL::ORM::Object')) { + return $this->declareReferenceType($typeName); + } else { + return undef; + } +} + +sub declareReferenceType { + my ($this,$typeName) = @_; + + my $entity = new IMPL::ORM::Schema::Entity($typeName->entityName); + + $this->mapPending->{$typeName} = $entity; + + $this->appendChild($entity); + + return $this->mapReferenceTypes->{$typeName} = $entity; +} + +sub _addReferenceType { + my ($this,$className) = @_; + + if ( my $entity = delete $this->mapPending->{$className} ) { + $className->ormGetSchema($this,$entity); + } else { + return $this->appendChild( $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this) ); + } + +} + +# returns valuetype name +sub isValueType { + my ($this,$typeName) = @_; + + $this = ref $this ? $this : $this->instance; + + return $this->mapValueTypes->{$typeName}; +} + +my %instances; +sub instance { + my ($class) = @_; + + return ($instances{$class} || ($instances{$class} = $class->new)); +} + +sub ValueTypes { + my ($this,%classes) = @_; + + $this = ref $this ? $this : $this->instance; + + while ( my ($typeName,$typeReflected) = each %classes ) { + $this->mapValueTypes->{$typeName} = $typeReflected; + $this->appendChild(IMPL::ORM::Schema::ValueType->new($typeName,$typeReflected)); + } +} + +sub Classes { + my ($this,@classNames) = @_; + + $this = ref $this ? $this : $this->instance; + + $this->_addReferenceType($this->prefix . $_) foreach @classNames; +} + +sub usePrefix { + my ($this,$prefix) = @_; + + $prefix .= '::' if $prefix and $prefix !~ /::$/; + + (ref $this ? $this : $this->instance)->prefix($prefix); +} + +sub CompleteSchema { + my ($this) = @_; + + $this = ref $this ? $this : $this->instance; + + $_->ormGetSchema($this,delete $this->mapPending->{$_}) foreach (keys %{$this->mapPending}); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::ORM::Schema> Схема отображения классов в реляционную структуру. + +=head1 DESCRIPTION + +Схема данных, представляет собой DOM документ, элементами которой +являются сущности. + +Каждый узел - это описание сущности. + +=begin code xml + +<Schema> + <Entity entityName="My_Data_Foo"> + <Field fieldName="Doo" fieldType="String"/> + <HasMany name="Boxes" target="My_Data_Box"/> + </Entity> + <Entity entityName="My_Data_Bar"> + <Subclass base="My_Data_Foo"/> + <Field fieldName="Timestamp" fieldType="Integer"/> + </Entity> + <Entity entityName="My_Data_Box"> + <Field fieldName="Capacity" fieldType="Integer"/> + </Entity> +</Schema> + +=end code xml + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/Entity.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,24 @@ +package IMPL::ORM::Schema::Entity; +use strict; +use warnings; + +use parent qw(IMPL::DOM::Node); +use IMPL::Class::Property; + +BEGIN { + public property entityName => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { + nodeName => 'Entity' + } +); + +sub CTOR { + my ($this,$name) = @_; + + $this->entityName($name); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/Field.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,30 @@ +package IMPL::ORM::Schema::Field; +use strict; +use warnings; + +use parent qw(IMPL::DOM::Node); +use IMPL::Class::Property; + +BEGIN { + public property fieldName => prop_get | owner_set; + public property fieldType => prop_get | owner_set; + public property fieldNullbale => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'Field' } +); + +sub CTOR { + my ($this,$name,$type,$nullable) = @_; + + $this->fieldName($name) or die new IMPL::InvalidArgumentException('A name is required for the field'); + $this->fieldType($type) or die new IMPL::InvalidArgumentException('A type is required for the field'); + $this->fieldNullbale(1) if $nullable; +} + +sub canHaveChildren { + 0; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/GenericClass.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,17 @@ +package IMPL::ORM::Schema::GenericClass; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::ORM::Schema::GenericClass> Построение схемы из произвольного класса. + +=head1 DESCRIPTION + +Читает метаданные класса и строит на их основании элементы схемы данных. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/Relation.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,12 @@ +package IMPL::ORM::Schema::Relation; +use strict; +use warnings; + +use parent qw(IMPL::DOM::Node); + +our %CTOR =( + 'IMPL::DOM::Node' => sub { nodeName => $_[0] } +); + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/Relation/HasMany.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,27 @@ +package IMPL::ORM::Schema::Relation::HasMany; +use strict; +use warnings; + +use parent qw(IMPL::ORM::Schema::Relation); +use IMPL::Class::Property; + +BEGIN { + public property target => prop_get | owner_set; + public property name => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::ORM::Schema::Relation' => sub { 'HasMany' } +); + +sub CTOR { + my ($this,$name,$target) = @_; + $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); + $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); +} + +sub canHaveChildren { + 0; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/Relation/HasOne.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,28 @@ +package IMPL::ORM::Schema::Relation::HasOne; +use strict; +use warnings; + +use parent qw(IMPL::ORM::Schema::Relation); +use IMPL::Class::Property; + +BEGIN { + public property target => prop_get | owner_set; + public property name => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::ORM::Schema::Relation' => sub { 'HasOne' } +); + +sub CTOR { + my ($this,$name,$target) = @_; + $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); + $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); +} + +sub canHaveChildren { + 0; +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/Relation/Subclass.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,26 @@ +package IMPL::ORM::Schema::Relation::Subclass; +use strict; +use warnings; + +use parent qw(IMPL::ORM::Schema::Relation); +use IMPL::Class::Property; + +BEGIN { + public property base => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::ORM::Schema::Relation' => sub { 'Subclass' } +); + +sub CTOR { + my ($this,$base) = @_; + + $this->base($base) or die new IMPL::InvalidArgumentException('A base is required for this relation'); +} + +sub canHaveChildren { + 0; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/TransformToSQL.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,181 @@ +package IMPL::ORM::Schema::TransformToSQL; +use strict; +use warnings; + +use parent qw(IMPL::DOM::Transform); +use IMPL::Class::Property; +use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary); + +require IMPL::SQL::Schema; + +BEGIN { + public property Types => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Transform' => sub { + ORMSchema => \&ORMSchemaTransform, + Entity => \&EntityTransform, + Field => \&FieldTransform, + HasOne => \&HasOneTransform, + HasMany => \&HasManyTransform, + Subclass => \&SubclassTransform, + ValueType => sub {} + } +); + +sub CTOR { + my ($this,$refTypeMap) = @_; + + $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required"); +} + +sub ORMSchemaTransform { + my ($this,$node) = @_; + + my $schema = IMPL::SQL::Schema->new(Name => ref $node); + + my @constraints; + + my %ctx = (Schema => $schema); + + # all tables + foreach my $entity ($node->selectNodes('Entity')) { + $schema->AddTable($this->Transform($entity,\%ctx)); + push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')}); + } + + # establish relations + $this->Transform($_,\%ctx) foreach @constraints; + + return $schema; +} + +sub EntityTransform { + my ($this,$node,$ctx) = @_; + + my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema}); + + $this->MakePrimaryKey($table); + + $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field'); + + return $table; +} + +sub FieldTransform { + my ($this,$field,$ctx) = @_; + + return { + Name => $field->fieldName, + Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType), + CanBeNull => $field->fieldNullable + }; +} + +sub HasOneTransform { + my ($this,$relation,$ctx) = @_; + + my $sqlSchema = $ctx->{Schema}; + my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; + my $tableForeign = $sqlSchema->Tables->{$relation->target}; + my $prefix = $relation->name; + + my @fkColumns = $tableForeign->PrimaryKey->columns; + + if (@fkColumns > 1) { + @fkColumns = map + $table->InsertColumn({ + Name => $prefix . $_->Name, + Type => $_->Type, + CanBeNull => 1 + }), @fkColumns; + } else { + @fkColumns = $table->InsertColumn({ + Name => $prefix, + Type => $fkColumns[0]->Type, + CanBeNull => 1 + }); + } + + $table->LinkTo($tableForeign,@fkColumns); +} + +sub HasManyTransform { + my ($this,$relation,$ctx) = @_; + + #similar to HasOne + + my $sqlSchema = $ctx->{Schema}; + my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; + my $tableForeign = $sqlSchema->Tables->{$relation->target}; + my $prefix = $relation->name; + + my @fkColumns = $table->PrimaryKey->columns; + + if (@fkColumns > 1 ) { + @fkColumns = map $tableForeign->InsertColumn({ + Name => $prefix . $_->Name, + Type => $_->Type, + CanBeNull => 1 + }), @fkColumns; + } else { + @fkColumns = $tableForeign->InsertColumn({ + Name => $prefix, + Type => $fkColumns[0]->Type, + CanBeNull => 1 + }); + } + + $tableForeign->LinkTo($table,@fkColumns); +} + +sub SubclassTransform { + # actually this rlations has only logical implementation +} + +sub MapType { + my ($this,$typeName) = @_; + + $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName); +} + +sub MakePrimaryKey { + my ($this,$table) = @_; + + $table->InsertColumn( {Name => '_Id', Type => Integer } ); + $table->SetPrimaryKey('_Id'); +} + +{ + my $std; + sub Std { + $std ||= __PACKAGE__->new({ + String => Varchar(255), + DateTime => DateTime, + Integer => Integer, + Float => Float(24), + Decimal => Float(53), + Real => Float(24), + Binary => Binary, + Text => Text + }); + } +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +=begin code + +my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance); + +=end code + +=cut +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Schema/ValueType.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,31 @@ +package IMPL::ORM::Schema::ValueType; + +use strict; + +use parent qw(IMPL::DOM::Node); + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'ValueType' } +); + +use IMPL::Class::Property; + +BEGIN { + public property typeName => prop_all; + public property typeReflected => prop_all; +} + +sub CTOR { + my ($this,$typeName,$typeReflected) = @_; + + $this->typeName($typeName); + $this->typeReflected($typeReflected); +} + +1; + +__END__ + +=pod + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Store/DBIC.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,13 @@ +package IMPL::ORM::DBIC; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::ORM::DBIC> - Хранилище данных на основе C<DBIx::Class>. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Store/SQL.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,30 @@ +package IMPL::ORM::Store::SQL; +use strict; +use warnings; + +use parent qw(IMPL::Object); + +use IMPL::Class::Property; + +BEGIN { + public property Connection => prop_all; +} + +sub loadObjects { + my ($this,$rObjects) = @_; +} + +sub search { + my ($this,$query) = @_; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION +Драйвер для SQL баз данных. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/ORM/Unit.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,20 @@ +package IMPL::ORM::Unit; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::ORM::Unit> Единица действий. + +=head1 DESCRIPTION + +C<[Infrastructure]> + +Позволяет записывать последовательность изменений. Используется C<IMPL::ORM> для реализации логических +транзакций. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,110 @@ +package IMPL::Object; +use strict; + +use parent qw(IMPL::Object::Abstract); +use IMPL::require { + ClassPropertyImplementor => 'IMPL::Code::DirectPropertyImplementor' +}; + +sub surrogate { + bless {}, ref $_[0] || $_[0]; +} + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + $self->callCTOR(@_); + + $self; +} + +1; + +__END__ + +=pod + +=head1 SINOPSYS + +=begin code + +package Foo; +use parent qw(IMPL::Object); + +sub CTOR { + my ($this,$arg) = @_; + print "Foo: $arg\n"; +} + +package Bar; +use parent qw(IMPL::Object); + +sub CTOR { + my ($this,$arg) = @_; + print "Bar: $arg\n"; +} + +package Baz; +use parent qw(Foo Bar); + +our %CTOR = ( + Foo => sub { my %args = @_; $args{Mazzi}; }, + Bar => sub { my %args = @_; $args{Fugi}; } +); + +package Composite; +use parent qw(Baz Foo Bar); + +our %CTOR = ( + Foo => undef, + Bar => undef +); + +sub CTOR { + my ($this,%args) = @_; + + print "Composite: $args{Text}\n"; +} + +package main; + +my $obj = new Composite( + Text => 'Hello World!', + Mazzi => 'Mazzi', + Fugi => 'Fugi' +); + +# will print +# +# Foo: Mazzi +# Bar: Fugi +# Bar: +# Composite: Hello World! + +=end code + +=head1 Description + +Базовый класс для объектов, основанных на хеше. + +=head1 Members + +=over + +=item operator C<new>(@args) + +Создает экземпляр объекта и вызывает конструктор с параметрами @args. + +=item operator C<surrogate>() + +Создает неинициализированный экземпляр объекта. + +=back + +=head1 Cavearts + +Нужно заметить, что директива C<use parent> работает не совсем прозрачно, если в нашем примере +класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от +C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:) + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Abstract.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,189 @@ +package IMPL::Object::Abstract; +use strict; +use warnings; + +use parent qw(IMPL::Class::Meta); +use Carp qw(croak); + +our $MemoryLeakProtection; +my $Cleanup = 0; + +my %cacheCTOR; + +my $t = 0; +sub cache_ctor { + my $class = shift; + + no strict 'refs'; + my @sequence; + + my $refCTORS = *{"${class}::CTOR"}{HASH}; + + foreach my $super ( @{"${class}::ISA"} ) { + my $superSequence = $cacheCTOR{$super} || cache_ctor($super); + + my $mapper = $refCTORS ? $refCTORS->{$super} : undef; + if (ref $mapper eq 'CODE') { + if ($mapper == *_pass_through_mapper{CODE}) { + push @sequence,@$superSequence; + } else { + push @sequence, sub { + my $this = shift; + $this->$_($mapper->(@_)) foreach @$superSequence; + } if @$superSequence; + } + } elsif ($mapper and not ref $mapper and $mapper eq '@_') { + push @sequence,@$superSequence; + } else { + warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; + push @sequence, sub { + my $this = shift; + $this->$_() foreach @$superSequence; + } if @$superSequence; + } + } + + push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; + + $cacheCTOR{$class} = \@sequence; + return \@sequence; +} + +sub dump_ctor { + my ($self) = @_; + $self = ref $self || $self; + + warn "dumping $self .ctor"; + warn "$_" foreach @{$cacheCTOR{$self}||[]}; +} + +sub callCTOR { + my $self = shift; + my $class = ref $self; + + $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)}; +} + +sub _init_dtor { + my ($class) = @_; + + no strict 'refs'; + + # avoid warnings for classes without destructors + no warnings 'once'; + + my @dtors; + + my @hierarchy = ($class); + my %visited; + + while(my $subclass = shift @hierarchy) { + if(*{"${subclass}::DTOR"}{CODE}) { + push @dtors, *{"${subclass}::DTOR"}{CODE}; + } + + push @hierarchy, @{"${subclass}::ISA"}; + } + + if (@dtors) { + + return *{"${class}::callDTOR"} = sub { + my ($self) = @_; + my $selfClass = ref $self; + if ($selfClass ne $class) { + goto &{$selfClass->_init_dtor()}; + } else { + map $_->($self), @dtors; + } + } + + } else { + return *{"${class}::callDTOR"} = sub { + my $self = ref $_[0]; + + goto &{$self->_init_dtor()} unless $self eq $class; + } + } +} + +__PACKAGE__->_init_dtor(); + +sub toString { + my $self = shift; + + return (ref $self || $self); +} + +sub _typeof { + ref $_[0] || $_[0]; +} + +sub isDisposed { + 0; +} + +sub DESTROY { + shift->callDTOR(); +} + +sub END { + $Cleanup = 1; +} + +sub _pass_through_mapper { + @_; +} + +sub PassArgs { + \&_pass_through_mapper; +} + +sub PassThroughArgs { + my $class = shift; + $class = ref $class || $class; + no strict 'refs'; + no warnings 'once'; + ${"${class}::CTOR"}{$_} = \&_pass_through_mapper foreach @{"${class}::ISA"}; +} + +package self; + +our $AUTOLOAD; +sub AUTOLOAD { + goto &{caller(). substr $AUTOLOAD,4}; +} + +package supercall; + +our $AUTOLOAD; +sub AUTOLOAD { + my $sub; + my $methodName = substr $AUTOLOAD,9; + no strict 'refs'; + $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'}; +} + +1; + +__END__ + +=pod +=head1 SYNOPSIS + +package MyBaseObject; +use parent qw(IMPL::Object::Abstract); + +sub new { + # own implementation of the new opeator +} + +sub surrogate { + # own implementation of the surrogate operator +} + +=head1 DESCRIPTION + +Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов +создания экземпляров. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Accessor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,26 @@ +package IMPL::Object::Accessor; +use strict; + +use parent qw( + IMPL::Object::Abstract + Class::Accessor +); + +use IMPL::require { + ClassPropertyImplementor => '-IMPL::Code::AccessorPropertyImplementor' +}; + +require IMPL::Code::AccessorPropertyImplementor; + +sub new { + my $class = shift; + my $self = $class->Class::Accessor::new( @_ == 1 && ref $_[0] && UNIVERSAL::isa($_[0],'HASH') ? $_[0] : ()); + $self->callCTOR(@_); + return $self; +} + +sub surrogate { + $_[0]->Class::Accessor::new; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/ArrayObject.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,19 @@ +package IMPL::Object::ArrayObject; +use strict; +use warnings; + +use parent qw(IMPL::Object::Abstract); + +sub new { + my $class = shift; + my $self = bless [], ref $class || $class; + $self->callCTOR(@_); + return $self; +} + +sub surrogate { + return bless [], ref $_[0] || $_; +} + +1; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/AutoDispose.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,38 @@ +package IMPL::Object::AutoDispose; +use strict; + +sub new { + my $self = shift; + + if (ref $self) { + return ${$self}->new(@_); + } else { + my $obj = shift; + return bless \$obj, $self; + } +} + +sub isa { + ${shift(@_)}->isa(@_); +} + +sub can { + ${shift(@_)}->can(@_); +} + +sub DESTROY { + ${shift(@_)}->Dispose(); +} + +sub AUTOLOAD { + our $AUTOLOAD; + my ($method) = ($AUTOLOAD =~ m/(\w+)$/); + + no strict 'refs'; + + goto &{*{$AUTOLOAD} = sub { + ${shift(@_)}->$method(@_); + }}; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Autofill.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,128 @@ +package IMPL::Object::Autofill; +use strict; +use Carp qw(cluck); + +BEGIN { + cluck "The autofilling is obsolete use explicit object initializers"; +} + +use IMPL::Const qw(:access); + +sub CTOR { + my $this = shift; + no strict 'refs'; + + my $fields = @_ == 1 ? $_[0] : {@_}; + + $this->_fill(ref $this,$fields); +} + +sub _fill { + my ($this,$class,$fields) = @_; + + $class->_autofill_method->($this,$fields); + + no strict 'refs'; + $this->_fill($_,$fields) foreach grep $_->isa('IMPL::Object::Autofill'), @{"${class}::ISA"}; +} + +sub DisableAutofill { + my $self = shift; + + no strict 'refs'; + my $class = ref $self || $self; + + *{"${class}::_impl_object_autofill"} = sub {}; +} + +sub _autofill_method { + my ($class) = @_; + + $class = ref $class if ref $class; + + # для автозаполнения нужен свой метод верхнего уровня + my $method; + { + no strict 'refs'; + $method = ${$class.'::'}{_impl_object_autofill}; + } + + if ($method) { + return $method; + } else { + my $text = <<HEADER; +package $class; +sub _impl_object_autofill { + my (\$this,\$fields) = \@_; +HEADER + + + if ($class->can('GetMeta')) { + # meta supported + foreach my $prop_info (grep { + $_->setter && ($_->access & ACCESS_PUBLIC); + } $class->GetMeta('IMPL::Class::PropertyInfo')) { + my $name = $prop_info->name; + if ($prop_info->isa('IMPL::Class::DirectPropertyInfo')) { + $text .= " \$this->$name(\$fields->{$name}) if exists \$fields->{$name};\n"; + } else { + 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"; + } + } + } + } else { + # meta not supported + #$text .= " ".'$this->$_($fields->{$_}) foreach keys %$fields;'."\n"; + } + $text .= "}\n\\&_impl_object_autofill;"; + return eval $text; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Object::Autofill> - автозаполнение объектов + +=head1 SYNOPSIS + +=begin code + +package MyClass; +use IMPL::declare { + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + } +}; + +BEGIN { + private property PrivateData => prop_all; + public property PublicData => prop_get; +} + +sub CTOR { + my $this = shift; + + print $this->PrivateData,"\n"; + print $this->PublicData,"\n"; +} + +my $obj = new MyClass(PrivateData => 'private', PublicData => 'public', Other => 'some data'); + +#will print +#private +#public + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Clonable.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,10 @@ +package IMPL::Object::Clonable; +use strict; + +use IMPL::lang qw(clone); + +sub Clone { + clone($_[0]); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Disposable.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,34 @@ +package IMPL::Object::Disposable; +use strict; +require IMPL::Object::AutoDispose; + +our $Strict = 1; + +sub Dispose { + my ($this) = @_; + + bless $this, 'IMPL::Object::Disposed'; +} + +sub DTOR { + my ($this) = @_; + + warn sprintf('The object %s were marked as disposable but isn\'t disposed properly', $this->can('ToString') ? $this->ToString() : (ref $this || $this) ); +} + +sub AutoPtr { + IMPL::Object::AutoDispose->new(shift); +} + +package IMPL::Object::Disposed; +our $AUTOLOAD; +sub AUTOLOAD { + return if $AUTOLOAD eq __PACKAGE__.'::DESTROY'; + die new IMPL::Exception('Object have been disposed',$AUTOLOAD); +} + +sub isDisposed { + 1; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/EventSource.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,191 @@ +package IMPL::Object::EventSource; +use strict; +require IMPL::Exception; +use IMPL::Class::Property; + +sub CreateEvent { + my ($class,$event) = @_; + + die new IMPL::Exception('A name is required for the event') unless $event; + + (my $fullEventName = "$class$event") =~ s/:://g; + + my $globalEventTable = new IMPL::Object::EventSource::EventTable($fullEventName); + my $propEventTable = $event.'Table'; + public CreateProperty($class,$propEventTable,prop_all); + public CreateProperty($class,$event, + { + get => sub { + my $this = shift; + if (not defined wantarray and caller(1) eq $class) { + (ref $this ? $this->$propEventTable() || $globalEventTable : $globalEventTable)->Invoke($this); + } else { + if (ref $this) { + if (my $table = $this->$propEventTable()) { + return $table; + } else { + $table = new IMPL::Object::EventSource::EventTable($fullEventName,$globalEventTable); + $this->$propEventTable($table); + return $table; + } + } else { + return $globalEventTable; + } + } + }, + set => sub { + (ref $_[0] ? $_[0]->$propEventTable() || $globalEventTable : $globalEventTable)->Invoke(@_); + } + } + ); +} + +sub CreateStaticEvent { + my ($class,$event) = @_; + + die new IMPL::Exception('A name is required for the event') unless $event; + + (my $fullEventName = "$class$event") =~ s/:://g; + + my $globalEventTable = new IMPL::Object::EventSource::EventTable($fullEventName); + + no strict 'refs'; + *{"${class}::$event"} = sub { + shift; + if (not @_) { + if (not defined wantarray and caller(1) eq $class) { + $globalEventTable->Invoke($class); + } else { + return $globalEventTable; + } + } else { + $globalEventTable->Invoke($class,@_); + } + }; +} + +package IMPL::Object::EventSource::EventTable; +use parent qw(IMPL::Object); +use IMPL::Class::Property; +use Scalar::Util qw(weaken); + +use overload + '+=' => \&opSubscribe, + 'fallback' => 1; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Handlers => { get => \&get_handlers }; + private _direct property Next => prop_all; + private _direct property NextId => prop_all; +} + +sub CTOR { + my $this = shift; + + $this->{$Handlers} = {}; + $this->{$Name} = shift; + $this->{$Next} = shift; + $this->{$NextId} = 1; +} + +sub get_handlers { + my $this = shift; + return values %{$this->{$Handlers}}; +} + +sub Invoke { + my $this = shift; + + my $tmp; + $tmp = $_ and local($_) or &$tmp(@_) foreach values %{$this->{$Handlers}}; + + $this->{$Next}->Invoke(@_) if $this->{$Next}; +} + +sub Subscribe { + my ($this,$consumer,$nameHandler) = @_; + + my $id = $this->{$NextId} ++; + + if (ref $consumer eq 'CODE') { + $this->{$Handlers}{$id} = $consumer; + } else { + $nameHandler ||= $this->Name or die new IMPL::Exception('The name for the event handler method must be specified'); + my $method = $consumer->can($nameHandler) or die new IMPL::Exception('Can\'t find the event handler method',$nameHandler,$consumer); + + weaken($consumer) if ref $consumer; + $this->{$Handlers}{$id} = sub { + unshift @_, $consumer; + $consumer ? goto &$method : delete $this->{$Handlers}{$id}; + }; + } + + return $id; +} + +sub Remove { + my ($this,$id) = @_; + return delete $this->{$Handlers}{$id}; +} +1; + +__END__ +=pod +=head1 SYNOPSIS +package Foo; +use parent qw(IMPL::Object IMPL::Object::EventSource); + +# declare events +__PACKAGE__->CreateEvent('OnUpdate'); +__PACKAGE__->CreateStaticEvent('OnNewObject'); + +sub CTOR { + my $this = shift; + // rise static event + $this->OnNewObject(); +} + +sub Update { + my ($this,$val) = @_; + + // rise object event + $this->OnUpdate($val); +} + +package Bar; + +// subscribe static event +Foo->OnNewObject->Subscribe(sub { warn "New $_[0] created" } ); + +sub LookForFoo { + my ($this,$foo) = @_; + + // subscribe object event + $foo->OnUpdate->Subscribe($this,'OnFooUpdate'); +} + +// event handler +sub OnFooUpdate { + my ($this,$sender,$value) = @_; +} + +=head1 DESCRIPTION +Позволяет объявлять и инициировать события. События делятся на статические и +локальные. Статические события объявляются для класса и при возникновении +данного события вызываются всегда все подписчики. Статические события могут быть +вызваны как для класса, так и для объекта, что приведет к одинаковым результатам. + +Локальные события состоят из статической (как статические события) и локальной +части. Если подписываться на события класса, то обработчики будут вызываться при +любых вариантах инициации данного события (как у статических событий). При +подписке на события объекта, обработчик будет вызван только при возникновении +событий у данного объекта. + +=head1 METHODS +=level 4 +=back + +=head1 EventTable + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Factory.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,209 @@ +package IMPL::Object::Factory; +use strict; + +use IMPL::Const qw(:prop); + +use IMPL::declare { + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Serializable' => undef + ], + props => [ + factory => PROP_RO, + parameters => PROP_RO, + method => PROP_RO + ] +}; + +# custom factory, overrides default +sub new { + my $self = shift; + + return ref $self ? $self->CreateObject(@_) : $self->IMPL::Object::new(@_); +} + +sub CTOR { + my ($this,$factory,$parameters,$method) = @_; + + $this->factory($factory) or die new IMPL::InvalidArgumentException("The argument 'factory' is mandatory"); + $this->parameters($parameters) if $parameters; + $this->method($method) if $method; +} + +# override default restore method +sub restore { + my ($class,$data,$surrogate) = @_; + + my %args = @$data; + + if ($surrogate) { + $surrogate->self::CTOR($args{factory},$args{parameters},$args{method}); + return $surrogate; + } else { + return $class->new($args{factory},$args{parameters},$args{method}); + } +} + +sub CreateObject { + my $this = shift; + + if (my $method = $this->method) { + $this->factory->$method($this->MergeParameters(@_)); + } else { + $this->factory->new($this->MergeParameters(@_)); + } +} + +sub MergeParameters { + my $this = shift; + + $this->parameters ? (_as_list($this->parameters),@_) : @_; +} + + +sub _as_list { + ref $_[0] ? + (ref $_[0] eq 'HASH' ? + %{$_[0]} + : + (ref $_[0] eq 'ARRAY'? + @{$_[0]} + : + $_[0] + ) + ) + : + ($_[0]); +} + + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +=begin code + +my $factory = new IMPL::Object::Factory( + 'MyApp::User', + { + isAdmin => 1 + } +); + +my $class = 'MyApp::User'; + +my $user; + +$user = $class->new(name => 'nobody'); # will create object MyApp::User + # and pass parameters (name=>'nobody') + +$user = $factory->new(name => 'root'); # will create object MyApp::User + # and pass paremeters (isAdmin => 1, name => 'root') + +=end code + +Или сериализованная форма в XML. + +=begin code xml + +<factory type="IMPL::Object::Factory"> + <factory>MyApp::User</factory>, + <parameters type="HASH"> + <isAdmin>1</isAdmin> + </parameters> +</factory> + +=end code xml + +=head1 DESCRIPTION + +C<[Serializable]> + +Класс, реализующий фабрику классов. + +Фабрика классов это любой объект, который имеет метод C< new > вызов которого приводит к созданию нового +объекта. Например каждый класс сам явялется фабрикой, поскольку, если у него вызвать метод +C< new >, то будет создан объект. Полученные объекты, в силу механизмов языка Perl, также +являются фабриками, притом такимиже, что и класс. + +Данный класс меняет поведение метода C< new > в зависимости от контекста вызова: статического +метода или метода объекта. При вызове метода C< new > у класса происходит создание объекта +фабрики с определенными параметрами. Далее объект-фабрика может быть использована для создания +объектов уже на основе параметров фабрики. + +=head1 MEMBERS + +=over + +=item C< CTOR($factory,$parameters,$method) > + +Создает новый экземпляр фабрики. + +=over + +=item C<$factory> + +Либо имя класса, либо другая фабрика. + +=item C<$parameters> + +Ссылка на параметры для создания объектов, может быть ссылкой на хеш, массив и т.д. + +Если является ссылкой на хеш, то при создании объектов данной фабрикой этот хеш +будет развернут в список и передан параметрами методу C<new>. + +Если является ссылкой на массив, то при создании объектов данной фабрикой этот массив +будет передан в списк и передан параметрами методу C<new>. + +Если является любым другим объектом или скаляром, то будет передан параметром методу +C<new> как есть. + +=item C<$method> + +Имя метода (или ссылка на процедуру), который будет вызван у C<$factory> при создании +текущей фабрикой нового объекта. + +=back + +=item C< [get] factory > + +Свойство, содержащее фабрику для создание новых объектов текущей фабрикой. Чаще всего оно содержит +имя класса. + +=item C< [get] parameters > + +Свойство, содержит ссылку на параметры для создания объектов, при создании объекта эти параметры будут +развернуты в список и переданы оператору C< new > фабрике из свойства C< factory >, за ними будут +следовать параметры непосредственно текущей фабрики. + +=item C<MergeParameters(@params)> + +Метод смешивающий фиксированные параметры с параметрами переданными методу C<new(@params)>. По умолчанию +добавляет пареметры фабрики в конец к фиксированным параметрам. Для изменения этого поведения требуется +переопределить данный метод. Также этот метод можно переопределить для передачи параметров, значения +которых вычисляются. + +=item C<new(@params)> + +Создает новый объект, используя свйство C<factory> как фабрику и передавая туда параметры +из свойства C<parameters> и списка C<@params>. Ниже приведен упрощенный пример, как это происходит. + +=begin code + +sub new { + my ($this,@params) = @_; + + my $method = $this->method || 'new'; + + return $this->factory->$method(_as_list($this->parameters), @params); +} + +=end code + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Fields.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,26 @@ +package IMPL::Object::Fields; +use strict; +use warnings; + +use parent qw(IMPL::Object::Abstract); + +sub new { + my $class = shift; + + $class = ref $class || $class; + + my $this = fields::new($class); + $this->callCTOR(@_); + + return $this; +} + +sub surrogate { + my $class = shift; + + $class = ref $class || $class; + + return fields::new($class); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/InlineFactory.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,44 @@ +package IMPL::Object::InlineFactory; +use strict; +use Carp qw(croak); + +sub new { + my $self = shift; + if(ref $self) { + return &$$self(@_); + } else { + my $factory = shift; + + croak "A code reference is required" + unless ref $factory eq 'CODE'; + + return bless \$factory, $self; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Object::InlineFactory> - реализация фабрики на основе процедуры. + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + InlineFactory => 'IMPL::Object::InlineFactory', + Foo => 'My::App::Foo' +}; + +my $factory = InlineFactory->new(sub { Foo->new(mode => 'direct', @_) }); + +my $obj = $factory->new(timeout => 10); # Foo->new(mode => 'direct', timeout => 10); + +=end code + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/List.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,124 @@ +package IMPL::Object::List; +use strict; +use warnings; + +use Carp qw(carp); +use parent qw(IMPL::Object::ArrayObject); +require IMPL::Exception; + +sub as_list { + return $_[0]; +} + +sub CTOR { + my ($this,$data) = @_; + + if ($data) { + die new IMPL::InvalidArgumentException("The parameter should be a reference to an array") unless UNIVERSAL::isa($data,"ARRAY"); + @$this = @$data; + } +} + +sub Append { + carp "Appen method is obsolete use Push instead"; + push @{$_[0]}, @_[1 .. $#_]; +} + +sub Push { + push @{$_[0]}, @_[1 .. $#_]; +} + +sub AddLast { + carp "Appen method is obsolete use Push instead"; + push @{$_[0]}, @_[1 .. $#_]; +} + +sub RemoveLast { + return pop @{$_[0]}; +} + +sub AddFirst { + return unshift @{$_[0]}, $_[1]; +} + +sub RemoveFirst { + return shift @{$_[0]}; +} + +sub Count { + return scalar @{$_[0]}; +} + +sub Item { + return $_[0]->[$_[1]]; +} + +sub InsertAt { + my ($this,$index,@val) = @_; + + splice @$this,($index||0),0,@val; +} + +sub RemoveAt { + my ($this,$index,$count) = @_; + + $count ||= 1; + + return splice @$this,$index,$count; +} + +sub RemoveItem { + my ($this,$item) = @_; + + @$this = grep $_ != $item, @$this; + + return $this; +} + +sub RemoveItemStr { + my ($this,$item) = @_; + + @$this = grep $_ ne $item, @$this; + + return $this; +} + +sub FindItem { + my ($this,$item) = @_; + + for (my $i = 0; $i < @$this; $i++ ) { + return $i if $this->[$i] == $item + } + return undef; +} + +sub FindItemStr { + my ($this,$item) = @_; + + for (my $i = 0; $i < @$this; $i++ ) { + return $i if $this->[$i] eq $item + } + return undef; +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar( item => $_ ) foreach @$this; +} + +sub restore { + my ($class,$data,$surrogate) = @_; + + my $i = 0; + + if ($surrogate) { + @$surrogate = grep { ($i++)%2 } @$data; + } else { + $surrogate = $class->new([grep { ($i++)%2 } @$data]); + } + + return $surrogate; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Meta.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,50 @@ +package IMPL::Object::Meta; +use strict; +use warnings; + +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->owner(scalar caller); + $meta->callCTOR(@_); + $caller->SetMeta($meta); +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +package Foo; + +meta BarAttribute('Simple bar attribute'); #mark Foo with BarAttribute + +=head1 DESCRIPTION + +Базовый класс для мета-свойств класса. Определяет оператор C< meta > для создания метаданных в вызвавшем классе. + +=head1 MEMBERS + +=over + +=item C< Container > + +Свойство заполняется до вызова конструктора и содержит имя модуля к которому применяется атрибут. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/PublicSerializable.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,38 @@ +package IMPL::Object::PublicSerializable; +use strict; + +use IMPL::Const qw(:access); + +sub restore { + my ($class,$data,$refSurrogate) = @_; + + if ($refSurrogate) { + $refSurrogate->callCTOR(@$data); + return $refSurrogate; + } else { + return $class->new(@$data); + } +} + +sub save { + my ($this,$ctx) = @_; + + my %seen; + + my $val; + + defined($val = $this->$_()) and $ctx->AddVar($_,$val) foreach + map $_->name,$this->GetMeta( + 'IMPL::Class::PropertyInfo', + sub { + $_->access == ACCESS_PUBLIC and + $_->getter and + $_->setter and + not $_->ownerSet and + not $seen{$_->name} ++ + }, + 1 + ); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Serializable.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,54 @@ +package IMPL::Object::Serializable; +use strict; +use warnings; + +require IMPL::Exception; +use IMPL::Class::Property; + +sub restore { + my ($class,$data,$refSurrogate) = @_; + + if ($refSurrogate) { + $refSurrogate->callCTOR(@$data); + return $refSurrogate; + } else { + return $class->new(@$data); + } +} + +sub save { + my ($this,$ctx,$predicate) = @_; + + ($this->_get_save_method)->($this,$ctx); +} + +sub _get_save_method { + my ($class) = @_; + + $class = ref $class || $class; + + no strict 'refs'; + if (my $method = *{"${class}::_impl_auto_save"}{CODE}) { + return $method; + } else { + my $code = <<SAVE_METHOD; +package $class; +sub _impl_auto_save { + my (\$this,\$ctx) = \@_; +SAVE_METHOD + + $code .= + 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; + +} +\\\&_impl_auto_save; +SAVE_METHOD + + return (eval $code || die new IMPL::Exception("Failed to generate serialization method",$class,$@)); + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/Singleton.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,81 @@ +package IMPL::Object::Singleton; +use strict; +use warnings; + +require IMPL::Exception; +use parent qw( + IMPL::Class::Meta +); + +__PACKAGE__->static_accessor_own(_instance => undef); + +sub InitInstance { + my $self = shift; + die IMPL::InvalidOperationException->new("Only one instance of the singleton can be created", $self) + if $self->_instance; + + $self->_instance($self->new(@_)); +} + +sub instance { + my $this = shift; + return $this->_instance || $this->_instance($this->Activate()); +} + +sub Activate { + die IMPL::NotImplementedException->new("Activation isn't implemented", shift); +} + +sub Release { + shift->_instance(undef); +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +=begin code + +package Foo; + +use parent qw(IMPL::Object IMPL::Object::Singleton); + +#.... + +Foo->isnatnce->some_work(); + +Foo->isnatnce->get_result(); + +=end code + +=head1 DESCRIPTION + +Реализует шаблон Singleton. Наследники данного класса могут иметь только один +экземпляр. Создать этот экземпляр можно явно, используюя конструктор, либо +автоматически при обращении к свойству C<instance>, для этого нужно +переопределить метод C<Activate()> + +=head1 MEMBERS + +=head2 C<CTOR()> + +Проверяет на единственность экземпляра класса, запоминает созданный экземпляр. + +=head2 C<[static,get]instance> + +Текущий экземпляр класса, если он еще не создан, то вызывает метод C<Activate>. + +=head2 C<[static,abstract]Activate()> + +Вызывается автоматически при обращении к свойству C<instance>, если экземпляр +объекта еще не был создан. + +=head2 C<[static]Release()> + +Освобождает текущий экземпляр. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Profiler.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,184 @@ +package IMPL::Profiler; + +use strict; +use warnings; +use Time::HiRes; +require Scalar::Util; + +our $Enabled; +our %TrappedModules; +our %InvokeInfo; +our $InvokeTime = 0; +our @TrapQueue; +our $Filter ||= qr//; +my $level; + +BEGIN { + $level = 0; + if ($Enabled) { + warn "profiler enabled"; + + unshift @INC, sub { + my ($self,$filename) = @_; + + (my $module = $filename) =~ s/\//::/g; + $module =~ s/\.\w+$//; + + return unless $module =~ $Filter; + + foreach my $dir (@INC) { + my $fullName = "$dir/$filename"; + if (-f $fullName) { + open my $hmod, $fullName or die "$fullName: $!" if $!; + + + + my @source; + local $/ = "\n"; + while (my $line = <$hmod>) { + last if $line =~ /^\s*__END__/; + push @source, $line; + } + + undef $hmod; + + push @source, + "IMPL::Profiler::trap_all(__PACKAGE__);\n", + "1;\n"; + + + return (sub { + if (@source) { + $_ = shift @source; + return 1; + } else { + return 0; + } + }, undef ); + } + } + }; + + no warnings 'once'; + *CORE::GLOBAL::caller = sub { + my $target = (shift || 0)+1; + my $realFrame = 1; + + for (my $i = 1; $i<$target; $i++) { + $realFrame ++; + my $caller = CORE::caller($realFrame-1) or return; + $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy + } + + my @frame = CORE::caller($realFrame) or return; + if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) { + my @next = CORE::caller($realFrame+1) or return; + @frame[0..2] = @next[0..2]; + } + + #warn " "x$level,"$frame[0] - $frame[3]"; + return wantarray ? @frame : $frame[0]; + }; + } +} + +sub trap_all { + return if not $Enabled; + no strict 'refs'; + foreach my $class (@_) { + next if $TrappedModules{$class}; + $TrappedModules{$class} = 1; + + eval "warn 'load $class'; require $class;" if not %{"${class}::"}; + die $@ if $@; + + no strict 'refs'; + my $table = \%{"${class}::"}; + trap($class,$_) foreach (grep eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference + } +} + +sub trap { + my ($class,$method) = @_; + + return if not $Enabled; + + return if $method eq 'import'; + + no strict 'refs'; + my $prevCode = \&{"${class}::${method}"}; + my $proto = prototype $prevCode; + + if (defined $proto and not $proto) { + return; + } + { + package IMPL::Profiler::Proxy; + no warnings 'redefine'; + my $sub = sub { + my $t0 = [Time::HiRes::gettimeofday]; + my @arr; + my $scalar; + my $entry = $prevCode; + my ($timeOwn,$timeTotal); + my $context = wantarray; + { + local $InvokeTime = 0; + #warn " "x$level,"enter ${class}::$method"; + $level ++; + if ($context) { + @arr = &$entry(@_); + } else { + if (defined $context) { + $scalar = &$entry(@_); + } else { + &$entry(@_); + } + } + $timeTotal = Time::HiRes::tv_interval($t0); + $timeOwn = $timeTotal - $InvokeTime; + } + $InvokeInfo{"${class}::${method}"}{Count} ++; + $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; + $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; + $InvokeTime += $timeTotal; + $level --; + #warn " "x$level,"leave ${class}::$method"; + return $context ? @arr : $scalar; + }; + if ($proto) { + Scalar::Util::set_prototype($sub => $proto); + } + *{"${class}::${method}"} = $sub; + } + +} + +sub PrintStatistics { + my $hout = shift || *STDERR; + print $hout "-- modules --\n"; + print $hout "$_\n" foreach sort keys %TrappedModules; + print $hout "\n-- stats --\n"; + print $hout + pad($_,50), + pad("$InvokeInfo{$_}{Count}",10), + pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10), + pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10), + "\n" + foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo; +} + +sub ResetStatistics { + $InvokeTime = 0; + %InvokeInfo = (); +} + +sub pad { + my ($str,$len) = @_; + if (length $str < $len) { + return $str.(' 'x ($len- length $str)); + } else { + return $str; + } +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Profiler/Memory.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,111 @@ +package IMPL::Profiler::Memory; + +use strict; +use Carp qw(longmess shortmess); +use Scalar::Util qw(refaddr weaken isweak); + +my %listeners; +my $trapped; + +BEGIN { + $trapped = 0; +} + +sub import { + if (not $trapped) { + *CORE::GLOBAL::bless = sub { + $_[1] |= caller unless $_[1]; + my $ref = CORE::bless $_[0],$_[1]; + + $_->track($ref) foreach values %listeners; + + return $ref; + }; + $trapped = 1; + } +} + +sub _ConnectListener { + my ($self,$listener) = @_; + + die "Invalid listener" unless ref $listener; + + $listeners{refaddr($listener)} = $listener; +} + +sub _RemoveListener { + my ($self,$listener) = @_; + + die "Invalid listener" unless ref $listener; + + delete $listeners{refaddr($listener)}; +} + +sub Monitor { + my ($self,$code) = @_; + + my $data = IMPL::Profiler::Memory::Data->new(); + + $data->Monitor($code); + + return $data; +} + +package IMPL::Profiler::Memory::Data; +use parent qw(IMPL::Object::Fields); + +use Data::Dumper(); +use Scalar::Util qw(refaddr weaken isweak); + +use fields qw( objects counter); + +sub CTOR { + my $this = shift; + $this->{objects} = []; + $this->{counter} = 0; +} + +sub track { + my $i = scalar @{$_[0]->{objects}}; + $_[0]->{objects}[$i] = $_[1]; + weaken($_[0]->{objects}[$i]); + $_[0]->{counter} ++; +} + +sub Purge { + my $this = shift; + + return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; +} + +sub Dump { + my $this = shift; + return Data::Dumper->Dump([$this->{objects}]); +} + +sub isLeak { + my ($this) = @_; + $this->Purge(); + return ( scalar(@{$this->{objects}}) > 0); +} + +sub Monitor { + my ($this,$code) = @_; + + die "A reference to a subroutine is required" unless ref $code; + + IMPL::Profiler::Memory->_ConnectListener($this); + eval { + $code->(); + }; + my $err = $@; + IMPL::Profiler::Memory->_RemoveListener($this); + + die $err if $err; + + return; +} + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Resources.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,28 @@ +package IMPL::Resources; +use strict; + +our $CurrentLocale ||= 'default'; + +sub currentLocale { + $CurrentLocale; +} + +sub SetLocale { + my ($self,$locale) = @_; + + $locale =~ tr/\-/_/; + + $CurrentLocale = $locale; +} + +sub InvokeInLocale { + my ($this,$locale,$code) = @_; + + local $CurrentLocale; + $this->SetLocale($locale); + + &$code() + if $code; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Resources/Format.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,41 @@ +package IMPL::Resources::Format; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&FormatMessage); + +sub FormatMessage { + my ($string,$args,$resolver) = @_; + + $args ||= {}; + $resolver ||= \&_defaultResolver; + $string ||= ''; + + $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]",$resolver)/ge; + + return $string; +} + +sub _getvalue { + my ($obj,$path,$default,$resolver) = @_; + + foreach my $chunk (split /\./,$path) { + return $default unless $obj; + if (ref $obj eq 'HASH') { + $obj = $obj->{$chunk}; + } else { + $obj = $resolver->($obj,$chunk); + } + } + return $obj||'<undef>'; +} + +sub _defaultResolver { + my ($obj,$prop) = @_; + + return eval { $obj->$prop() }; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Resources/StringLocaleMap.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,143 @@ +package IMPL::Resources::StringLocaleMap; +use strict; + +use List::Util qw(first); +use IMPL::lang qw(:base); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Resources => 'IMPL::Resources', + StringMap => 'IMPL::Resources::StringMap', + Exception => 'IMPL::Exception', + FS => 'File::Spec' + }, + base => { + 'IMPL::Object' => '@_' + }, + props => [ + _maps => PROP_RW, + name => PROP_RW, + paths => PROP_RW | PROP_LIST + ] +}; + +sub CTOR { + my ($this,$data,$parent) = @_; + + if (is($data, StringMap)) { + $this->_maps({ default => $data }); + } elsif ( ref($data) eq 'HASH' ) { + $this->_maps({ default => StringMap->new($data,$parent)}); + } else { + # в данном случае таблица строк по-умолчанию будет загружена + # из файла при необходимости + $this->_maps({}); + } +} + +sub GetString { + my ($this,$id,$args) = @_; + + my $locale = Resources->currentLocale || 'default'; + my $map; + + #warn "id: $id,\t\tlocale: $locale"; + + if(not $map = $this->_maps->{$locale}) { + my $default = $this->GetDefaultMap(); + $map = $this->LoadMap($locale,$default); + if (is($map,StringMap)) { + #nop + } elsif (ref($map) eq 'HASH') { + $map = StringMap->new($map,$default); + } elsif( not $map ) { + $map = $default; + } else { + die Exception->new("ResolveLocale returned unexpected data", $map); + } + + $this->_maps->{$locale} = $map; + } + + return $map->GetString($id,$args); +} + +sub GetDefaultMap { + my ($this) = @_; + + my $map = $this->_maps->{default}; + return $map + if $map; + + $map = $this->LoadMap('default') || StringMap->new({}); + $this->_maps->{default} = $map; + + return $map; +} + +sub LoadMap { + my ($this,$locale,$default) = @_; + + my @spec = split /_/, $locale; + + my @locales; + + do { + push @locales, join('_', @spec); + } while(pop @spec); + + my $file = first { -f } map { + my $path = $_; + + map { + my $name = FS->catfile($path,$_,$this->name); + ("$name.s", "$name.p"); + } @locales; + } $this->paths; + + if($file) { + if ($file =~ /\.s$/) { + return $this->LoadStringMap($file); + } else { + return $this->LoadPerlMap($file,$default); + } + } + + return; +} + +sub LoadPerlMap { + my ($self,$file,$parent) = @_; + + my $data = do $file; + my $e = $@; + die Exception->new("Failed to load file '$file'", $e) if $e; + die IOException->new("Failed to load file '$file'", $!) if not defined $data and $!; + die Exception->new("Failed to load file '$file'", "A hash data is expected") unless ref($data) eq 'HASH'; + + return StringMap->new($data,$parent); +} + +sub LoadStringMap { + my ($this,$fname) = @_; + + open my $hRes, "<:encoding(utf-8)", $fname or die "Failed to open file $fname: $!"; + local $_; + my %map; + my $line = 1; + while (<$hRes>) { + chomp; + $line ++ and next if /^\s*$/; + + if (/^([\w\.]+)\s*=\s*(.*)$/) { + $map{$1} = $2; + } else { + die "Invalid resource format in $fname at $line"; + } + $line ++; + } + + return \%map; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Resources/StringMap.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,140 @@ +package IMPL::Resources::StringMap; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + IOException => '-IMPL::IOException', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => '@_' + ], + props => [ + _data => PROP_RW, + _parent => PROP_RW + ] +}; + +sub CTOR { + my ($this,$data,$parent) = @_; + + die ArgException->new( data => 'A hash reference is required' ) + unless ref($data) eq 'HASH'; + + die ArgException->new( data => 'A hash must contain either scalars or subs') + if grep ref($_) && ref($_) ne 'CODE', values %$data; + + $this->_data($data); + $this->_parent($parent); +} + +sub GetString { + my ($this,$id,$args) = @_; + + if(my $format = $this->_data->{$id}) { + return ref($format) eq 'CODE' ? &$format($this,$args || {}) : $this->FormatString($format,$args); + } else { + return $this->_parent? $this->_parent->GetString($id,$args) : "[ $id ]"; + } + +} + +sub AddFormat { + my ($this,$id,$format) = @_; + + die ArgException->new( id => 'A format id is required' ) + unless $id; + + die ArgException->new( format => 'A format must be a scalar or a sub' ) + if ref($format) and ref($format) ne 'CODE'; + + $this->_data->{$id} = $format; +} + +sub FormatString { + my ($self,$text,$args) = @_; + + $args ||= {}; + $text ||= ''; + + $text =~ s/%(\w+(?:\.\w+)*)%/$self->GetValue($args,$1,"\[$1\]")/ge; + + return $text; + +} + +sub GetValue { + my ($self,$obj,$path,$default) = @_; + + foreach my $chunk (split /\./,$path) { + return $default unless $obj; + if (ref $obj eq 'HASH') { + $obj = $obj->{$chunk}; + } else { + $obj = $self->Resolve($obj,$chunk); + } + } + return $obj||'<undef>'; +} + +sub Resolve { + my ($self,$obj,$prop) = @_; + + return eval { $obj->$prop() }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Resources::StringMap> + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + StringMap => 'IMPL::Resources::StringMap' +}; + +my $data = { + TitleLabel => 'Search results', + ViewLabel => 'View %name%', # same as sub { $_[0]->Format('View %name%',$_[1]) } + ResultsCountLabel => sub { + my ($self,$args) = @_; + + $args ||= {}; + + if (not $args->{count}) { + return "No items found"; + } elsif($args->{count} == 1) { + return "Found one item"; + } else { + return $self->Format('Found %count% items', $args); + } + } +} + +my $def = StringMap->new({ + ResultsCountLabel => 'Found %count% items' +}); + +my $map = StringMap->new($data, $def); + +print $map->GetString('TitleLabel'); +print $map->GetString(ResultsCountLabel => { count => 0 }); # will print "No items found" + + +=end code + +=head1 DESCRIPTION + +=head1 MEMBERS + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Resources/Strings.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,142 @@ +package IMPL::Resources::Strings; +use strict; + +use File::Spec; +use List::Util qw(first); +use IMPL::require { + StringMap => 'IMPL::Resources::StringLocaleMap' +}; + +our @Locations; +my %maps; + +sub import { + my ($self,$refStrings,%options) = @_; + + no strict 'refs'; + + my $class = caller; + my $methods = $options{methods}; + + if (ref $refStrings eq 'HASH') { + my $map = $self->_GetMapForClass($class,$refStrings); + + while(my ($str,$format) = each %$refStrings) { + *{"${class}::$str"} = sub { + shift if $methods; + my $args = @_ == 1 ? shift : { @_ }; + + return $map->GetString($str,$args); + } + } + } +} + +sub _GetResourceLocations { + my ($self,$class) = @_; + + my @classNamespace = split /::/,$class; + + my $classShortName = pop @classNamespace; + + my @paths = map File::Spec->catdir($_,@classNamespace), @Locations; + + # Foo::Bar -> 'Foo/Bar.pm' + my $classModuleName = File::Spec->catfile(@classNamespace,"${classShortName}.pm"); + + # 'Foo/Bar.pm' -> '/full/path/to/Foo/Bar.pm' + my $fullModulePath = first { -f } map( File::Spec->catfile($_,$classModuleName), @INC ); + + if ($fullModulePath) { + + # '/full/path/to/Foo/Bar.pm' -> '/full/path/to/Foo/locale/' + my ($vol,$dir,$file) = File::Spec->splitpath($fullModulePath); + push @paths, File::Spec->catpath($vol,File::Spec->catdir($dir,'locale'),''); + } + + return \@paths, $classShortName; +} + +sub _GetMapForClass { + my ($self,$class,$data) = @_; + + my $map; + + unless ($map) { + + my ($paths,$name) = $self->_GetResourceLocations($class); + + $map = StringMap->new($data); + $map->name($name); + $map->paths($paths); + + $maps{$class} = $map; + + } + + return $map; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Resources::Strings> - Строковые ресурсы + +=head1 SYNOPSIS + +=begin code + +package Foo; + +use IMPL::Resources::Strings { + msg_say_hello => "Hello, %name%!", + msg_module_name => "Simple Foo class" +}; + +sub InviteUser { + my ($this,$uname) = @_; + + print msg_say_hello(name => $uname); + +} + +=end code + +=head1 DESCRIPTION + +Импортирует в целевой модуль функции, которые возвращают локализованные +параметризованные сообщения. + +При импорте ищутся модули по следующему алгоритму: + +В каталогах из массива C<@Locations> ищется файл с относительным путем +C<$Locale/$ModName>, где C<$Locale> - глобальная переменная +модуля C<IMPL::Resourses::Strings>, а переменная C<$ModName> получена +путем замены 'C<::>' в имени целевого модуля на 'C</>'. + +Если файл не был найден, то производится поиск в каталоге, где +расположен сам модуль, файла с относительным путем C<locale/$Locale/$ShortModName>, +где C<$ShortModeName> - последняя часть после 'C<::>' из имени целевого модуля. + +Если файл не найден, то используются строки, указанные при объявлении +сообщений в целевом модуле. + +=head1 FORMAT + +=begin code text + +msg_name = any text with named %params% +msg_hello = hello, %name%!!! +msg_resolve = this is a value of the property: %user.age% + +msg_short_err = %error.Message% +msg_full_err = %error% + +=end code text + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,185 @@ +use strict; +package IMPL::SQL::Schema; +use mro; + +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 (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'); + + } 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'); + $table = { %$table }; + $table->{'schema'} = $this; + $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; +} + +sub RemoveTable { + my ($this,$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); + + # drop foreign keys + map { $_->table->RemoveConstraint($_) } values %{$table->primaryKey->connectedFK} if $table->primaryKey; + + # drop table contents + $table->Dispose(); + + return 1; +} + +sub ResolveTable { + my ($this,$table) = @_; + + is($table,Table) ? $table : $this->{$_tables}{$table}; +} + +sub GetTable { + my ($this,$tableName) = @_; + return $this->{$_tables}{$tableName}; +} + +sub GetTables { + my ($this) = @_; + + 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}; + + my $table = delete $this->{$_tables}{$oldName}; + $table->_setName($newName); + $this->{$_tables}{$newName} = $table; +} + +sub Dispose { + my ($this) = @_; + + $_->Dispose foreach values %{$this->{$_tables}}; + + delete $this->{$_tables}; + + $this->next::method(); +} + +1; + +__END__ +=pod + +=head1 SYNOPSIS + +=begin code + +require IMPL::SQL::Schema; +use IMPL::SQL::Types qw(Varchar Integer); + +my $dbSchema = new IMPL::SQL::Schema; + +my $tbl = $dbSchema->AddTable({name => 'Person' }); +$tbl->AddColumn({ + name => 'FirstName', + canBeNull => 1, + type => Varchar(255) +}); +$tbl->AddColumn({ + name => 'Age', + type => Integer +}); + +# so on + +# and finally don't forget to + +$dbSchema->Dispose(); + +=end code + +=head1 DESCRIPTION + +Схема реляциоонной базы данных, орентированная на язык SQL, содержит описания таблиц +которые являются частью базы. Позволяет создавать и удалать таблицы. + +=head1 MEMBERS + +=over + +=item C<CTOR(%props)> + +Конструктор заполняет объект свойствами из C<props>. + +=item C<[get]name> + +Имя схемы. + +=item C<[get]version> + +Версия схемы. + +=item C<AddTable($table)> + +Доавляет таблицу в схему. C<$table> может быть либо таблице, либо хешем с набором +свойств для создания новой таблицы. Если таблица с таким именем уже существует в сехеме, +то вызывается исключение. + +=item C<GetTable($name)> + +Возвращает таблицу с именем C<$name> или C<undef>. + +=item C<GetTables()> + +Возвращает список таблиц. В скалярном контексте - ссылку на массив с таблицами. + +=item C<ResolveTable($table)> + +Если параметр C<$table> - таблица, то возвращается C<$table>, если C<$table> строка, то +ищется таблица с таким именем, если таблица не найдена, возвращается C<undef>. + +=item C<RenameTable($oldName,$newName)> + +Происходит переименование таблицы. Если C<$oldName> не существует, либо если C<$newName> +существует, вызывается исключение. + +=item C<RemoveTable($table)> + +Удаляется таблица C<$table> с удалением всех связей и ограничений. Если такой таблицы нет, +то вызывается исключение. C<$table> может быть либо именем таблицы, либо объектом. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Column.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,75 @@ +use strict; +package IMPL::SQL::Schema::Column; + +use IMPL::lang qw( :DEFAULT :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 + ] +}; + +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}); +} + +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}) + ); +} + +sub SetType { + my ($this,$newType) = @_; + + $this->{$type} = $newType; +} + +sub SetDefaultValue { + my ($this,$value) = @_; + + $this->{$defaultValue} = $value; +} + +sub SetNullable { + 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); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Constraint.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,87 @@ +package IMPL::SQL::Schema::Constraint; +use strict; +use warnings; + +use IMPL::lang; +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; + +sub CTOR { + my ($this,%args) = @_; + is( $args{table}, typeof IMPL::SQL::Schema::Table ) or + die new IMPL::InvalidArgumentException("table argument must be a table object"); + $this->{$name} = $args{'name'}; + $this->{$table} = $args{'table'}; + $this->columns( [map { ResolveColumn($this->table,$_) } @{$args{'columns'}}] ); +} + +sub ResolveColumn { + my ($Table,$Column) = @_; + + my $cn = is($Column,'IMPL::SQL::Schema::Column') ? $Column->name : $Column; + + my $resolved = $Table->GetColumn($cn); + die new IMPL::InvalidOperationException("The column is not found in the table", $cn, $Table->name) if not $resolved; + return $resolved; +} + +sub HasColumn { + my ($this,@Columns) = @_; + + my %Columns = map { $_, 1} @Columns; + + return scalar(grep { $Columns{$_->name} } $this->columns ) == scalar(@Columns); +} + +sub uniqName { + my ($this) = @_; + return $this->{$table}->name.'_'.$this->{$name}; +} + +sub Dispose { + my ($this) = @_; + + $this->columns([]); + + delete $$this{$table}; + + $this->SUPER::Dispose; +} + +sub SameValue { + my ($this,$other) = @_; + + return 0 unless $this->columns->Count == $other->columns->Count; + + for ( my $i=0; $i < $this->columns->Count; $i++ ) { + return 0 unless $this->columns->[$i]->name eq $other->columns->[$i]->name; + } + + return 1; +} + +sub ResolveAlias { + my ($self,$alias) = @_; + + return isclass($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; +} + +sub RegisterAlias { + my ($self,$alias) = @_; + + $aliases{$alias} = typeof($self); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,65 @@ +package IMPL::SQL::Schema::Constraint::ForeignKey; +use strict; +use warnings; + +use IMPL::lang qw(:declare is); + +use parent qw(IMPL::SQL::Schema::Constraint); + + +BEGIN { + public _direct property referencedPrimaryKey => PROP_GET; + public _direct property onDelete => PROP_GET; + public _direct property onUpdate => PROP_GET; +} + +__PACKAGE__->PassThroughArgs; +__PACKAGE__->RegisterAlias('fk'); + +sub CTOR { + my ($this,%args) = @_; + + die new Exception("Referenced table must be an instance of a table object") if not is($args{'referencedTable'},'IMPL::SQL::Schema::Table'); + + die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'referencedColumns'},'ARRAY') or not scalar(@{$args{'referencedColumns'}}); + + my @ReferencedColumns = map {IMPL::SQL::Schema::Constraint::ResolveColumn($args{'referencedTable'},$_)} @{$args{'referencedColumns'}}; + my $ForeingPK = $args{'referencedTable'}->primaryKey or die new Exception('The referenced table doesn\'t have a primary key'); + + scalar (@ReferencedColumns) == $this->columns->Count or die new Exception('A foreing key columns doesn\'t match refenced columns'); + my @ColumnsCopy = @ReferencedColumns; + + die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->type->SameValue((shift @ColumnsCopy)->type)} @{$this->columns}; + + @ColumnsCopy = @ReferencedColumns; + die new Exception('The foreign key must match to the primary key of the referenced table',$this->name) if grep { not $_->type->SameValue(shift(@ColumnsCopy)->type)} @{$ForeingPK->columns}; + + $this->{$referencedPrimaryKey} = $ForeingPK; + + $ForeingPK->ConnectFK($this); + + $this->onUpdate($args{onUpdate}) if $args{onUpdate}; + $this->onDelete($args{onDelete}) if $args{onDelete}; +} + +sub Dispose { + my ($this) = @_; + + $this->{$referencedPrimaryKey}->DisconnectFK($this) if not $this->{$referencedPrimaryKey}->isDisposed; + delete $this->{$referencedPrimaryKey}; + + $this->SUPER::Dispose; +} + +sub SameValue { + my ($this,$other) = @_; + + uc($this->onDelete || '') eq uc($other->onDelete || '')or return 0; + uc($this->onUpdate || '') eq uc($other->onUpdate || '') or return 0; + + return $this->SUPER::SameValue($other); +} + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Constraint/Index.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,15 @@ +package IMPL::SQL::Schema::Constraint::Index; +use strict; +use parent qw(IMPL::SQL::Schema::Constraint); + +__PACKAGE__->PassThroughArgs; +__PACKAGE__->RegisterAlias('index'); + +sub CTOR { + my $this = shift; + + my %colnames; + not grep { $colnames{$_}++ } $this->columns or die new Exception('Each column in the index can occur only once'); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,42 @@ +package IMPL::SQL::Schema::Constraint::PrimaryKey; +use strict; +use parent qw(IMPL::SQL::Schema::Constraint::Index); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; +__PACKAGE__->RegisterAlias('pk'); + +BEGIN { + public _direct property connectedFK => prop_get; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$connectedFK} = {}; +} + +sub ConnectFK { + my ($this,$FK) = @_; + + UNIVERSAL::isa($FK,'IMPL::SQL::Schema::Constraint::ForeignKey') or die new Exception('Aprimary key could be connected only to a foreign key'); + not exists $this->{$connectedFK}->{$FK->uniqName} or die new Exception('This primary key already conneted with the specified foreing key',$FK->name,$FK->table->name); + + $this->{$connectedFK}->{$FK->uniqName} = $FK; +} + +sub DisconnectFK { + my ($this,$FK) = @_; + + delete $this->{$connectedFK}->{$FK->uniqName}; +} + +sub Dispose { + my ($this) = @_; + + delete $this->{$connectedFK}; + + $this->SUPER::Dispose; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Constraint/Unique.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,8 @@ +package IMPL::SQL::Schema::Constraint::Unique; +use strict; +use parent qw(IMPL::SQL::Schema::Constraint::Index); + +__PACKAGE__->PassThroughArgs; +__PACKAGE__->RegisterAlias('unique'); + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Diff.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,192 @@ +package IMPL::SQL::Schema::Diff; +use strict; +use warnings; +use IMPL::lang qw(:compare :hash is typeof); + +use IMPL::SQL::Schema::Traits(); + +use IMPL::require { + Schema => 'IMPL::SQL::Schema', + ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', + PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', + UniqueConstraint =>'-IMPL::SQL::Schema::Constraint::Unique', + Index => '-IMPL::SQL::Schema::Constraint::Index', + TraitsForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', + TraitsPrimaryKey => '-IMPL::SQL::Schema::Traits::PrimaryKey', + TraitsUnique => '-IMPL::SQL::Schema::Traits::Unique', + TraitsIndex => '-IMPL::SQL::Schema::Traits::Index', + TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', + TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', + TraitsTable => '-IMPL::SQL::Schema::Traits::Table', + TraitsColumn => '-IMPL::SQL::Schema::Traits::Column', + TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', + TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', + TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', + TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', + TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn', + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' +}; + +sub Diff { + my ($self,$src,$dst) = @_; + + die ArgException->new( src => "A valid source schema is required") unless is($src,Schema); + die ArgException->new( dst => "A valid desctination schema is requried" ) unless is($src,Schema); + + my %dstTables = map { $_->name, $_ } $dst->GetTables; + + my @operations; + + foreach my $srcTable ( $src->GetTables) { + my $dstTable = delete $dstTables{$srcTable->name}; + + if (not $dstTable) { + # if a source table doesn't have a corresponding destination table, it should be deleted + push @operations, TraitsDropTable->new($srcTable->name); + } else { + # a source table needs to be updated + push @operations, $self->_DiffTables($srcTable,$dstTable); + } + + } + + foreach my $tbl ( values %dstTables ) { + push @operations, TraitsCreateTable->new( + TraitsTable->new( + $tbl->name, + [ map _Column2Traits($_), @{$tbl->columns} ], + [ map _Constraint2Traits($_), $tbl->GetConstraints()], + $tbl->{tag} + ) + ) + } + + return \@operations; +} + +sub _DiffTables { + my ($self,$src,$dst) = @_; + + my @dropConstraints; + my @createConstraints; + + my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); + my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); + + foreach my $cnSrcName (keys %srcConstraints) { + if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { + unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { + push @dropConstraints, + TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); + push @createConstraints, + TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); + } + } else { + push @dropConstraints,TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); + } + } + + foreach my $cnDst (values %dstConstraints) { + push @createConstraints, + TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); + } + + my @deleteColumns; + my @addColumns; + my @updateColumns; + + my %dstColumnIndexes = map { + my $col = $dst->GetColumnAt($_); + ($col->name, { column => $col, index => $_ }) + } 0 .. $dst->ColumnsCount-1; + + my @columns; + + # remove old columns, mark for update changed columns + for( my $i=0; $i < $src->ColumnsCount; $i++) { + my $colSrc = $src->GetColumnAt($i); + + if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { + $infoDst->{prevColumn} = $colSrc; + push @columns,$infoDst; + } else { + push @deleteColumns,TraitsAlterTableDropColumn->new($src->name,$colSrc->name); + } + } + + #insert new columns at specified positions + foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { + splice(@columns,$_->{index},0,$_); + push @addColumns, TraitsAlterTableAddColumn->new($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); + } + + # remember old indexes + for(my $i =0; $i< @columns; $i ++) { + $columns[$i]->{prevIndex} = $i; + } + + # reorder columns + @columns = sort { $a->{index} <=> $b->{index} } @columns; + + foreach my $info (@columns) { + if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { + my $op = TraitsAlterTableChangeColumn->new($src->name,$info->{column}->name); + + $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; + $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); + $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); + + my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); + $op->options($diff) if %$diff; + + push @updateColumns, $op; + } + } + + my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); + + return @result; +} + +sub _Column2Traits { + my ($column,%options) = @_; + + return TraitsColumn->new( + $column->name, + $column->type, + isNullable => $column->isNullable, + defaultValue => $column->defaultValue, + tag => $column->tag, + %options + ); +} + +sub _Constraint2Traits { + my ($constraint) = @_; + + my $map = { + ForeignKey , TraitsForeignKey, + PrimaryKey , TraitsPrimaryKey, + UniqueConstraint , TraitsUnique, + Index , TraitsIndex + }; + + my $class = $map->{typeof($constraint)} or die Exception->new("Can't map the constraint",typeof($constraint)); + + if ($class eq TraitsForeignKey) { + return $class->new( + $constraint->name, + [ map $_->name, $constraint->columns ], + $constraint->referencedPrimaryKey->table->name, + [ map $_->name, $constraint->referencedPrimaryKey->columns ] + ); + } else { + return $class->new( + $constraint->name, + [ map $_->name, $constraint->columns ] + ); + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/MySQL/CharType.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,27 @@ +package IMPL::SQL::Schema::MySQL::CharType; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::SQL::Schema::Type' => '@_' + ], + props => [ + encoding => PROP_RO + ] +}; + +my @CHAR_TYPES = qw(VARCHAR CHAR); + +sub CTOR { + my ($this) = @_; + + die ArgException->new(name => "The specified name is invalid", $this->name) + unless grep uc($this->name) eq $_, @CHAR_TYPES; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/MySQL/EnumType.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,23 @@ +package IMPL::SQL::Schema::MySQL::EnumType; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::SQL::Schema::Type' => '@_' + ], + props => [ + enumValues => PROP_RO | PROP_LIST + ] +}; + +our @ENUM_TYPES = qw(ENUM SET); + +sub CTOR { + my $this = shift; + + die ArgException->new(name => "The specified name is invalid", $this->name) + unless grep uc($this->name) eq $_, @ENUM_TYPES; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/MySQL/Formatter.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,561 @@ +package IMPL::SQL::Schema::MySQL::Formatter; +use strict; + +use IMPL::lang qw(is); +use IMPL::require { + Exception => 'IMPL::Exception', + OpException => '-IMPL::InvalidOperationException', + ArgException => '-IMPL::InvalidArgumentException', + PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', + UniqueIndex => '-IMPL::SQL::Schema::Constraint::Unique', + Index => '-IMPL::SQL::Schema::Constraint::Index', + ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', + CharType => '-IMPL::SQL::Schema::MySQL::CharType', + EnumType => '-IMPL::SQL::Schema::MySQL::EnumType', + TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', + TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', + TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', + TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', + TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', + TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', + TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn' +}; + +our %TRAITS_FORMATS = ( + TraitsDropTable, 'FormatDropTable', + TraitsCreateTable, 'FormatCreateTable', + TraitsAlterTableDropConstraint, 'FormatAlterTableDropConstraint', + TraitsAlterTableAddConstraint, 'FormatAlterTableAddConstraint', + TraitsAlterTableDropColumn, 'FormatAlterTableDropColumn', + TraitsAlterTableAddColumn, 'FormatAlterTableAddColumn', + TraitsAlterTableChangeColumn, 'FormatAlterTableChangeColumn' +); + +sub quote { + my $self = shift; + + if (wantarray) { + return map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; + } + else { + return join '', map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; + } +} + +sub quote_names { + my $self = shift; + + if (wantarray) { + return map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; + } + else { + return join '', map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; + } +} + +sub formatTypeNameInteger { + my ( $self, $type ) = @_; + + return + $type->name + . ( $type->maxLength ? '(' . $type->maxLength . ')' : '' ) + . ( $type->unsigned ? ' UNSIGNED' : '' ) + . ( $type->zerofill ? ' ZEROFILL' : '' ); +} + +sub formatTypeNameReal { + my ( $self, $type ) = @_; + + return $type->name + . ( $type->maxLength + ? '(' . $type->maxLength . ', ' . $type->scale . ')' + : '' ) + . ( $type->unsigned ? ' UNSIGNED' : '' ) + . ( $type->zerofill ? ' ZEROFILL' : '' ); +} + +sub formatTypeNameNumeric { + my ( $self, $type ) = @_; + $type->maxLength + or die ArgException->new( + type => 'The length and precission must be specified', + $type->name + ); + return $type->name + . ( $type->maxLength + ? '(' . $type->maxLength . ', ' . $type->scale . ')' + : '' ) + . ( $type->unsigned ? ' UNSIGNED' : '' ) + . ( $type->zerofill ? ' ZEROFILL' : '' ); +} + +sub formatTypeName { + my ( $self, $type ) = @_; + return $type->name; +} + +sub formatTypeNameChar { + my ( $self, $type ) = @_; + + return ($type->name . '(' + . $type->MaxLength . ')' + . ( is( $type, CharType ) ? $type->encoding : '' ) ); +} + +sub formatTypeNameVarChar { + my ( $self, $type ) = @_; + + return ($type->name . '(' + . $type->maxLength . ')' + . ( is( $type, CharType ) ? $type->encoding : '' ) ); +} + +sub formatTypeNameEnum { + my ( $self, $type ) = @_; + + die ArgException->new( type => 'Invalid enum type' ) + unless is( $type, EnumType ); + return ($type->name . '(' + . join( ',', map { $self->quote($_) } $type->enumValues ) + . ')' ); +} + +sub formatStringValue { + my ( $self, $value ) = @_; + + if ( ref $value eq 'SCALAR' ) { + return $$value; + } + else { + return $self->quote($value); + } +} + +sub formatNumberValue { + my ( $self, $value ) = @_; + + if ( ref $value eq 'SCALAR' ) { + return $$value; + } + else { + $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ + or die ArgException->new( + value => 'The specified value isn\'t a valid number', + $value + ); + return $value; + } +} + +our %TYPES_FORMATS = ( + TINYINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + SMALLINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + MEDIUMINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + INT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + INTEGER => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + BIGINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + REAL => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + DOUBLE => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + FLOAT => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + DECIMAL => { + formatType => \&formatTypeNameNumeric, + formatValue => \&formatNumberValue + }, + NUMERIC => { + formatType => \&formatTypeNameNumeric, + formatValue => \&formatNumberValue + }, + DATE => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TIME => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TIMESTAMP => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + DATETIME => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + CHAR => { + formatType => \&formatTypeNameChar, + formatValue => \&formatStringValue + }, + VARCHAR => { + formatType => \&formatTypeNameVarChar, + formatValue => \&formatStringValue + }, + TINYBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + BLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + MEDIUMBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + LONGBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TINYTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + MEDIUMTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + LONGTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + ENUM => { + formatType => \&formatTypeNameEnum, + formatValue => \&formatStringValue + }, + SET => { + formatType => \&formatTypeNameEnum, + formatValue => \&formatStringValue + } +); + +sub FormatTypeName { + my ( $self, $type ) = @_; + + my $fn = $TYPES_FORMATS{ $type->name }{formatType} + or die ArgException->new( type => "The specified type is unknown", + $type->name ); + + return $self->$fn($type); +} + +sub FormatValue { + my ( $self, $value, $type ) = @_; + + my $fn = $TYPES_FORMATS{ $type->name }{formatValue} + or die ArgException->new( type => "The specified type is unknown", + $type->name ); + + return $self->$fn( $value, $type ); +} + +sub FormatColumn { + my ( $self, $column ) = @_; + + my @parts = ( + $self->quote_names( $column->{name} ), + $self->FormatTypeName( $column->{type} ), + $column->{isNullable} ? 'NULL' : 'NOT NULL' + ); + + push @parts, $self->FormatValue( $column->{defaultValue}, $column->{type} ) + if $column->{defaultValue}; + + push @parts, 'AUTO_INCREMENT' + if $column->{tag} and $column->{tag}->{auto_increment}; + + return join ' ', @parts; +} + +sub FormatCreateTable { + my ( $self, $op ) = @_; + + my $table = $op->table; + + my @lines; + my @body; + + push @lines, "CREATE TABLE " . $self->quote_names($table->{name}) . "("; + + push @body, map { " " . $self->FormatColumn($_) } @{ $table->{columns} } + if $table->{columns}; + + push @body, map { " " . $self->FormatConstraint($_) } @{ $table->{constraints} } + if $table->{constraints}; + + push @lines, join(",\n", @body); + + push @lines, ");"; + + return join "\n", @lines; +} + +sub FormatDropTable { + my ( $self, $op ) = @_; + + return join ' ', 'DROP TABLE', $self->quote_names( $op->tableName ), ';'; +} + +sub FormatRenameTable { + my ( $self, $op ) = @_; + + return join ' ', + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'RENAME TO', + $self->quote_names( $op->tableNewName ), + ';'; +} + +sub FormatAlterTableAddColumn { + my ( $self, $op, $schema ) = @_; + + my @parts = ( + 'ALTER TABLE',$self->quote_names($op->tableName), 'ADD COLUMN', + $self->FormatColumn( $op->column ) + ); + + if ( defined $op->position ) { + + # mysql supports column reordering + # the new location is specified relative to the previous column + # to determine the name of the previous column we need to ask the schema + + my $table = $schema->GetTable( $op->tableName ); + + if ( $op->position == 0 ) { + push @parts, 'FIRST'; + } + else { + push @parts, 'AFTER'; + + my $prevColumn = $table->GetColumnAt( $op->position - 1 ); + push @parts, $self->quote_names( $prevColumn->{name} ); + } + } + + push @parts, ';'; + + return join ' ', @parts; +} + +sub FormatAlterTableDropColumn { + my ( $self, $op ) = @_; + + return join ' ', + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'DROP COLUMN', + $self->quote_names( $op->columnName ), + ';'; +} + +sub FormatAlterTableChangeColumn { + my ( $self, $op, $schema ) = @_; + + my $table = $schema->GetTable( $op->tableName ); + my $column = $table->GetColumn( $op->columnName ); + + my @parts = ( + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'MODIFY COLUMN', + $self->quote_names( $op->columnName ), + $self->FormatColumn( $self->_Column2Traits($column) ) + ); + + if ( defined $op->position ) { + + # mysql supports column reordering + # the new location is specified relative to the previous column + # to determine the name of the previous column we need to ask the schema + + if ( $op->position == 0 ) { + push @parts, 'FIRST'; + } + else { + push @parts, 'AFTER'; + + my $prevColumn = $table->GetColumnAt( $op->position - 1 ); + push @parts, $self->quote_names( $prevColumn->{name} ); + } + } + + push @parts, ';'; + return join ' ', @parts; +} + +sub FormatConstraint { + my ($self,$constraint) = @_; + + my @fkRules = + ( 'RESTRICT', 'CASCADE', 'SET NULL', 'SET DEFAULT', 'NO ACTION' ); + + my @parts; + + if ( $constraint->constraintClass eq ForeignKey ) { + push @parts, + 'CONSTRAINT', + $self->quote_names( $constraint->{name} ), + 'FOREIGN KEY', + $self->quote_names( $constraint->{name} ), + '(', + join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), + ')', + 'REFERENCES', $self->quote_names( $constraint->{foreignTable} ), '(', + join( ', ', + $self->quote_names( @{ $constraint->{foreignColumns} || [] } ) ), + ')'; + + if ( my $rule = $constraint->{onDelete} ) { + $rule = uc($rule); + grep $_ eq $rule, @fkRules + or die Exception->new( "Invalid onDelete rule specified", + $constraint->{name}, $rule ); + + push @parts, 'ON DELETE', $rule; + } + + if ( my $rule = $constraint->{onUpdate} ) { + $rule = uc($rule); + grep $_ eq $rule, @fkRules + or die Exception->new( "Invalid onUpdate rule specified", + $constraint->{name}, $rule ); + + push @parts, 'ON UPDATE', $rule; + } + + } + else { + if ( $constraint->constraintClass eq PrimaryKey ) { + push @parts, 'PRIMARY KEY'; + + } + elsif ( $constraint->constraintClass eq UniqueIndex ) { + push @parts, 'UNIQUE', $self->quote_names( $constraint->{name} ); + } + elsif ( $constraint->constraintClass eq Index ) { + push @parts, 'INDEX', $self->quote_names( $constraint->{name} ); + } + else { + die Exception->new( 'Invalid constraint type', + $constraint->constraintClass ); + } + + push @parts, + '(', + join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), + ')'; + } + + + return join ' ', @parts; +} + +sub FormatAlterTableAddConstraint { + my ( $self, $op ) = @_; + + return join(' ', + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'ADD', + $self->FormatConstraint($op->constraint), + ';' + ); +} + +sub FormatAlterTableDropConstraint { + my ( $self, $op, $constraintType ) = @_; + + my @parts = ( 'ALTER TABLE', $self->quote_names( $op->tableName ), 'DROP' ); + + if ( $constraintType eq PrimaryKey ) { + push @parts, 'PRIMARY KEY'; + } + elsif ( $constraintType eq ForeignKey ) { + push @parts, 'FOREIGN KEY', $self->quote_names( $op->constraintName ); + } + elsif ( $constraintType eq UniqueIndex or $constraintType eq Index ) { + push @parts, 'INDEX', $self->quote_names( $op->constraintName ); + } + else { + die Exception->new( + 'Invalid constraint type', $op->tableName, + $op->constraintName, $constraintType + ); + } + + push @parts, ';'; + + return join ' ', @parts; +} + +sub Format { + my $self = shift; + my ($op) = @_; + + my $formatter = $TRAITS_FORMATS{ref $op} + or die OpException->new("Don't know how to format the specified operation", $op); + + $self->$formatter(@_); +} + +sub _Column2Traits { + my ( $self, $column, %options ) = @_; + + return new IMPL::SQL::Schema::Traits::Column( + $column->name, + $column->type, + isNullable => $column->isNullable, + defaultValue => $column->defaultValue, + tag => $column->tag, + %options + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::SQL::Traits::MysqlFormatter> - преобразует операции над схемой в C<SQL> +выражения. + +=head1 DESCRIPTION + +Используется для форматирования операций изменения схемы БД. Осуществляет +правильное экранирование имен, форматирование значений, имен типов данных. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/MySQL/Processor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,150 @@ +package IMPL::SQL::Schema::MySQL::Processor; +use strict; + +use mro; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + MySQLFormatter => 'IMPL::SQL::Schema::MySQL::Formatter', + AlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', + AlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', + DropTable => '-IMPL::SQL::Schema::Traits::DropTable', + PrimitiveDropTable => '-IMPL::SQL::Schema::MySQL::Processor::PrimitiveDropTable', + CreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', + Table => '-IMPL::SQL::Schema::Traits::Table', + ForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', + + }, + base => [ + 'IMPL::SQL::Schema::Processor' => sub { $_[0] } + ], + props => [ + formatter => PROP_RO, + sqlBatch => PROP_RO + ] +}; +use IMPL::lang qw(is); + +sub CTOR { + my ( $this, $schema, %opts ) = @_; + + $this->formatter( $opts{formatter} || MySQLFormatter ); + $this->sqlBatch([]); +} + +sub AddSqlBatch { + my $this = shift; + + push @{$this->sqlBatch}, @_; +} + +sub ApplyOperation { + my ($this, $op, $iteration ) = @_; + + my @formatterParams; + + if ( is( $op, AlterTableDropConstraint ) ) { + my $constraint = $this + ->dbSchema + ->GetTable($op->tableName) + ->GetConstraint($op->constraintName); + + push @formatterParams, ref $constraint; + } else { + push @formatterParams, $this->dbSchema; + } + + if ( is( $op, CreateTable ) ) { + my @constraints; + my @fk; + my $table = $op->table; + + # отделяем создание внешних ключей от таблиц + + foreach my $c (@{$table->{constraints} || []}) { + if ( is($c,ForeignKey)) { + push @fk,$c; + } else { + push @constraints, $c; + } + } + + if (@fk) { + $op = CreateTable->new( + Table->new( + $table->{name}, + $table->{columns}, + \@constraints, + $table->{options} + ) + ); + + $this->AddPendingOperations( + map AlterTableAddConstraint->new($table->{name},$_), @fk + ); + } + } + + if (is($op, DropTable)) { + my $table = $this->dbSchema->GetTable($op->tableName); + + if(my $pk = $table->primaryKey) { + $this->ApplyOperation($_,$iteration) + foreach + map + AlterTableDropConstraint->new($_->table->name,$_->name), + values %{$pk->connectedFK || {}}; + } + } + + $this->next::method($op,$iteration); + + $this->AddSqlBatch( + $this->formatter->Format($op,@formatterParams) + ); +} + +package IMPL::SQL::Schema::MySQL::Processor::PrimitiveDropTable; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + tableName => PROP_RO, + ] +}; + +sub CTOR { + my ($this,$tableName) = @_; + + $this->tableName($tableName) or die ArgException->new("tableName is required"); +} + +sub CanApply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable( $this->tableName ) + or return 0; + + my $pk = $table->primaryKey + or return 1; + + my $canDrop = keys(%{$pk->connectedFK || {}}) ? 0 : 1; + + warn "Can drop ", $this->tableName + if $canDrop; + + return $canDrop; +} + +sub Apply { + my ($this,$schema) = @_; + + $schema->RemoveTable($this->tableName); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Processor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,99 @@ +package IMPL::SQL::Schema::Processor; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + dbSchema => PROP_RO, + updateBatch => PROP_RO, + pendingOperations => PROP_RO + ] +}; + +sub CTOR { + my ($this,$schema) = @_; + + $this->dbSchema($schema) + or die ArgException->new(schema => 'A DB schema is required'); + + $this->updateBatch([]); + $this->pendingOperations([]); +} + +sub AddUpdateBatch { + my $this = shift; + + push @{$this->updateBatch}, @_; +} + +sub AddPendingOperations { + my $this = shift; + + push @{$this->pendingOperations}, @_; +} + +sub ProcessBatch { + my ($this,$batch) = @_; + + $this->pendingOperations($batch); + my $i = 1; + while(@{$this->pendingOperations}) { + $batch = $this->pendingOperations; + $this->pendingOperations([]); + + my $noChanges = 1; + + foreach my $op (@$batch) { + if ($this->CanApplyOperation($op,$i)) { + $noChanges = 0; + + $this->ApplyOperation($op,$i); + } else { + $this->AddPendingOperations($op); + } + } + + if ($noChanges && @{$this->pendingOperations}) { + die Exception->new("No changes were made (iteration $i), but some operations are pending",@{$this->pendingOperations}); + } + + $i++; + } +} + +sub CanApplyOperation { + my ($this,$op) = @_; + + return $op->CanApply($this->dbSchema); +} + +sub ApplyOperation { + my ($this,$op) = @_; + + $op->Apply($this->dbSchema); + $this->AddUpdateBatch($op); +} + +1; + +__END__ + +=pod + +=head1 NAME + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Позволяет применит набор примитивных операций C<IMPL::SQL::Schema::Traits> к +схеме. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Table.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,273 @@ +package IMPL::SQL::Schema::Table; +use strict; + +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; + +sub CTOR { + my ($this,%args) = @_; + + $this->{$name} = $args{'name'} or die new IMPL::InvalidArgumentException('a table name is required'); + $this->{$schema} = $args{'schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); + + if ($args{columns}) { + die new IMPL::InvalidOperationException('A columns property should be a reference to an array') unless ref $args{columns} eq 'ARRAY'; + + $this->InsertColumn($_) foreach @{$args{columns}}; + } +} + +sub InsertColumn { + my ($this,$column,$index) = @_; + + $index = ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0) if not defined $index; + + die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0)); + + if (UNIVERSAL::isa($column,'IMPL::SQL::Schema::Column')) { + + } elsif (UNIVERSAL::isa($column,'HASH')) { + $column = new IMPL::SQL::Schema::Column(%{$column}); + } else { + die new IMPL::InvalidArgumentException("The invalid column parameter"); + } + + if (exists $this->{$columnsByName}->{$column->name}) { + die new IMPL::InvalidOperationException("The column already exists",$column->name); + } else { + $this->{$columnsByName}->{$column->name} = $column; + splice @{$this->{$columns}},$index,0,$column; + } + + return $column; +} + +sub RemoveColumn { + my ($this,$NameOrColumn,$Force) = @_; + + my $ColName; + if (UNIVERSAL::isa($NameOrColumn,'IMPL::SQL::Schema::Column')) { + $ColName = $NameOrColumn->name; + } elsif (not ref $NameOrColumn) { + $ColName = $NameOrColumn; + } + + if (exists $this->{$columnsByName}->{$ColName}) { + my $index = 0; + foreach my $column(@{$this->{$columns}}) { + last if $column->name eq $ColName; + $index++; + } + + my $column = $this->{$columns}[$index]; + if (my @constraints = $this->GetColumnConstraints($column)){ + $Force or die new IMPL::InvalidOperationException('Can\'t remove column which is used in the constraints',@constraints); + $this->RemoveConstraint($_) foreach @constraints; + } + + my $removed = splice @{$this->{$columns}},$index,1; + delete $this->{$columnsByName}->{$ColName}; + return $removed; + } else { + die new IMPL::InvalidOperationException("The column not found",$NameOrColumn->name); + } +} + +sub GetColumn { + my ($this,$name) = @_; + + return $this->{$columnsByName}->{$name}; +} + +sub GetColumnAt { + my ($this,$index) = @_; + + die new IMPL::InvalidArgumentException("The index is out of range") + if $index < 0 || $index >= ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0); + + return $this->{$columns}[$index]; +} + +sub SetColumnPosition { + my ($this,$nameOrColumn,$pos) = @_; + + my $colName; + if (is($nameOrColumn,'IMPL::SQL::Schema::Column')) { + $colName = $nameOrColumn->name; + } elsif (not ref $nameOrColumn) { + $colName = $nameOrColumn; + } else { + die IMPL::InvalidArgumentException->new(column => 'The specified column isn\'t found in the table'); + } + + die IMPL::InvalidArgumentException->new( 'pos' => 'The specified position is invalid') + if not defined $pos || $pos < 0 || $pos >= $this->columnsCount; + + my $index = 0; + foreach my $column(@{$this->{$columns}}) { + last if $column->name eq $colName; + $index++; + } + + if ($pos != $index) { + #position needs to be changed; + + my ($column) = splice @{$this->{$columns}}, $index, 1; + splice @{$this->{$columns}}, $pos, 0, $column; + } + + return; +} + +sub columnsCount { + my ($this) = @_; + + return scalar(@{$this->{$columns}}); +} + +sub ColumnsCount { + goto &columnsCount; +} + +sub AddConstraint { + my $this = shift; + if (@_ == 1) { + my ($Constraint) = @_; + + die new IMPL::InvalidArgumentException('The invalid parameter') if not is($Constraint,'IMPL::SQL::Schema::Constraint'); + + $Constraint->table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); + + if (exists $this->{$constraints}->{$Constraint->name}) { + die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->name); + } else { + if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { + not $this->{$primaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); + $this->{$primaryKey} = $Constraint; + } + + $this->{$constraints}->{$Constraint->name} = $Constraint; + } + } elsif( @_ == 2) { + my ($type,$params) = @_; + + $type = IMPL::SQL::Schema::Constraint->ResolveAlias($type) or + die new IMPL::Exception("Can't resolve a constraint alias",$_[0]); + + $params = {%{$params}}; + + $params->{table} = $this; + + $this->AddConstraint($type->new(%$params)); + } else { + die new IMPL::Exception("Wrong arguments number",scalar(@_)); + } +} + +sub RemoveConstraint { + my ($this,$Constraint,$Force) = @_; + + my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->name : $Constraint; + $Constraint = $this->{$constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); + + if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { + not scalar keys %{$this->{$primaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('Can\'t remove Primary Key unless some foreign keys referenses it'); + + delete $this->{$primaryKey}; + } + $Constraint->Dispose; + delete $this->{$constraints}->{$cn}; + return $cn; +} + +sub GetConstraint { + my ($this,$name) = @_; + + return $this->{$constraints}{$name}; +} + +sub GetConstraints { + my ($this) = @_; + + return wantarray ? values %{$this->{$constraints}} : [values %{$this->{$constraints}}]; +} + +sub GetColumnConstraints { + my ($this,@Columns) = @_; + + my @cn = map { UNIVERSAL::isa($_ ,'IMPL::SQL::Schema::Column') ? $_ ->name : $_ } @Columns; + exists $this->{$columnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; + + return grep {$_->HasColumn(@cn)} values %{$this->{$constraints}}; +} + +sub SetPrimaryKey { + my ($this,@ColumnList) = @_; + + $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(name => $this->{$name}.'_PK', table => $this, columns => \@ColumnList)); +} + +sub LinkTo { + my ($this,$table,@ColumnList) = @_; + $table->primaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); + my $constraintName = $this->{$name}.'_'.$table->name.'_FK_'.join('_',map {ref $_ ? $_->name : $_} @ColumnList); + $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(name => $constraintName, table => $this, columns => \@ColumnList, referencedTable => $table, referencedColumns => $table->primaryKey->columns->as_list)); +} + +sub Dispose { + my ($this) = @_; + + $_->Dispose() foreach values %{$this->{$constraints}}; + + undef %{$this}; + $this->SUPER::Dispose(); +} + +sub SameValue { + my ($this,$other) = @_; + + return 0 unless is($other, typeof($this)); + + return 0 unless $this->name eq $other->name; + return 0 unless $this->ColumnsCount eq $other->ColumnsCount; + + for (my $i = 0; $i < $this->ColumsCount; $i ++) { + return 0 unless $this->($i)->SameValue($other->GetColumnAt($i)); + } + + my %thisConstraints = map { $_->name, $_ } $this->GetConstraints(); + my %otherConstraints = map { $_->name, $_ } $other->GetConstraints(); + + foreach my $name ( keys %thisConstraints ) { + return 0 unless $otherConstraints{$name}; + return 0 unless $thisConstraints{$name}->SameValue(delete $otherConstraints{$name}); + } + + return 0 if %otherConstraints; + + return 1; +} + +1; + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Traits.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,742 @@ +package IMPL::SQL::Schema::Traits; +use strict; +use IMPL::_core::version; +use IMPL::Exception(); + +use parent qw(IMPL::Object); + +# required for use with typeof operator +use IMPL::SQL::Schema::Constraint::PrimaryKey(); +use IMPL::SQL::Schema::Constraint::Index(); +use IMPL::SQL::Schema::Constraint::Unique(); +use IMPL::SQL::Schema::Constraint::ForeignKey(); + +################################################### + +package IMPL::SQL::Schema::Traits::Table; +use base qw(IMPL::Object::Fields); + +use fields qw( + name + columns + constraints + options +); + +sub CTOR { + my ($this,$table,$columns,$constraints,$options) = @_; + + $this->{name} = $table or die new IMPL::InvalidArgumentException(table => "A table name is required"); + $this->{columns} = $columns if defined $columns; + $this->{constraints} = $constraints if defined $constraints; + $this->{options} = $options if defined $options; +} + +################################################### + +package IMPL::SQL::Schema::Traits::Column; +use base qw(IMPL::Object::Fields); + +use fields qw( + name + type + isNullable + defaultValue + tag +); + +sub CTOR { + my ($this, $name, $type, %args) = @_; + + $this->{name} = $name or die new IMPL::InvalidArgumentException("name"); + $this->{type} = $type or die new IMPL::InvalidArgumentException("type"); + $this->{isNullable} = $args{isNullable} if exists $args{isNullable}; + $this->{defaultValue} = $args{defaultValue} if exists $args{defaultValue}; + $this->{tag} = $args{tag} if exists $args{tag}; +} + +################################################## + +package IMPL::SQL::Schema::Traits::Constraint; +use base qw(IMPL::Object::Fields); + +use fields qw( + name + columns +); + +sub CTOR { + my ($this, $name, $columns) = @_; + + $this->{name} = $name; + $this->{columns} = $columns; # list of columnNames +} + +sub constraintClass { + die new IMPL::NotImplementedException(); +} + +################################################## + +package IMPL::SQL::Schema::Traits::PrimaryKey; + +use base qw(IMPL::SQL::Schema::Traits::Constraint); + +__PACKAGE__->PassThroughArgs; + +use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::PrimaryKey }; + +################################################## + +package IMPL::SQL::Schema::Traits::Index; + +use base qw(IMPL::SQL::Schema::Traits::Constraint); + +__PACKAGE__->PassThroughArgs; + +use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::Index }; + +################################################## + +package IMPL::SQL::Schema::Traits::Unique; + +use base qw(IMPL::SQL::Schema::Traits::Constraint); + +__PACKAGE__->PassThroughArgs; + +use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::Unique }; + +################################################## + +package IMPL::SQL::Schema::Traits::ForeignKey; + +use base qw(IMPL::SQL::Schema::Traits::Constraint); +use fields qw( + foreignTable + foreignColumns + onUpdate + onDelete +); + +use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::ForeignKey }; + +our %CTOR = ( + 'IMPL::SQL::Schema::Traits::Constraint' => sub { @_[0..1] } +); + +sub CTOR { + my ($this,$foreignTable,$foreignColumns,%args) = @_[0,3..$#_]; + + $this->{foreignTable} = $foreignTable; + $this->{foreignColumns} = $foreignColumns; + + $this->{onDelete} = $args{onDelete} if $args{onDelete}; + $this->{onUpdate} = $args{onUpdate} if $args{onUpdate}; +} + + +################################################## + +package IMPL::SQL::Schema::Traits::CreateTable; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Table => '-IMPL::SQL::Schema::Traits::Table', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + table => PROP_RO, + ] +}; +use IMPL::lang; + +sub CTOR { + my ($this,$table) = @_; + + die ArgException->new("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") + unless is($table, Table); + + $this->table($table); +} + +sub CanApply { + my ($this,$schema) = @_; + + return( $schema->GetTable( $this->table->{name} ) ? 0 : 1 ); +} + +sub Apply { + my ($this,$schema) = @_; + + my $args = {%{$this->table}}; + + my $constraints = delete $args->{constraints} || []; + + my $table = $schema->AddTable($args); + + $table->AddConstraint($_->constraintClass, $_) foreach @{$constraints}; +} + +################################################## + +package IMPL::SQL::Schema::Traits::DropTable; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + ] +}; + +sub CTOR { + my ($this,$tableName) = @_; + + $this->tableName($tableName) or die ArgException->new("tableName is required"); +} + +sub CanApply { + my ($this,$schema) = @_; + + return $schema->GetTable( $this->tableName ) ? 1 : 0; +} + +sub Apply { + my ($this,$schema) = @_; + + $schema->RemoveTable($this->tableName); +} + +################################################## + +package IMPL::SQL::Schema::Traits::RenameTable; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + tableNewName => PROP_RO, + ] +}; + +sub CTOR { + my ($this, $oldName, $newName) = @_; + + $this->tableName($oldName) or die ArgException->new("A table name is required"); + $this->tableNewName($newName) or die ArgException->new("A new table name is required"); +} + +sub CanApply { + my ($this, $schema) = @_; + + return ($schema->GetTable($this->tableName) and not $schema->GetTable($this->tableNewName) ? 1 : 0 ); +} + +sub Apply { + my ($this,$schema) = @_; + + $schema->RenameTable($this->tableName, $this->tableNewName); + +} + +################################################# + +package IMPL::SQL::Schema::Traits::AlterTableAddColumn; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Column => '-IMPL::SQL::Schema::Traits::Column', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + column => PROP_RO, + position => PROP_RO + ] +}; +use IMPL::lang; + + +sub CTOR { + my ($this,$tableName,$column) = @_; + + $this->tableName($tableName) or die ArgException->new("A table name is required"); + + die ArgException->new("A column should be a IMPL::SQL::Schema::Traits::Column object") + unless is($column, Column); + + $this->column($column); +} + +sub CanApply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + return $table->GetColumn( $this->column->{name} ) ? 0 : 1; +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die OpException->new("The specified table doesn't exists", $this->tableName); + + if ($this->position) { + $table->AddColumn($this->column); + } else { + $table->InsertColumn($this->column,$this->position); + } +} + +################################################# + +package IMPL::SQL::Schema::Traits::AlterTableDropColumn; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + FK => '-IMPL::SQL::Schema::Constraint::ForeignKey', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + columnName => PROP_RO, + ] +}; +use IMPL::lang; + + +sub CTOR { + my ($this,$table,$column) = @_; + + $this->tableName($table) or die ArgException->new(tableName => "A table name should be specified"); + $this->columnName($column) or die ArgException->new(columnName => "A column name should be specified"); +} + +sub CanApply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + $table->GetColumn($this->columnName) or + return 0; + + # столбец + return $table->GetColumnConstraints($this->columnName) + ? 0 + : 1 + ; +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die OpException->new("The specified table doesn't exists", $this->tableName); + + $table->RemoveColumn($this->columnName); +} + +################################################# + +package IMPL::SQL::Schema::Traits::AlterTableChangeColumn; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Constraint => '-IMPL::SQL::Schema::Traits::Constraint', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + columnName => PROP_RO, + columnType => PROP_RW, + defaultValue => PROP_RW, + isNullable => PROP_RW, + position => PROP_RW, + options => PROP_RW # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) + ] +}; +use IMPL::lang; + +sub CTOR { + my ($this, $table,$column,%args) = @_; + + $this->tableName($table) or die ArgException->new(tableName => "A table name is required"); + $this->columnName($column) or die ArgException->new(columnName => "A column name is required"); + + $this->$_($args{$_}) + for (grep exists $args{$_}, qw(columnType defaultValue isNullable options)); +} + +sub CanApply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + return $table->GetColumn($this->columnName) ? 1 : 0; +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die OpException->new("The specified table doesn't exists", $this->tableName); + + my $column = $table->GetColumn($this->columnName) + or die OpException->new("The specified column doesn't exists", $this->tableName, $this->columnName); + + $column->SetType($this->columnType) if defined $this->columnType; + $column->SetNullable($this->isNullable) if defined $this->isNullable; + $column->SetDefaultValue($this->defaultValue) if defined $this->defaultValue; + $column->SetOptions($this->options) if defined $this->options; + + $table->SetColumnPosition($this->position) + if ($this->position); + +} + +################################################# + +package IMPL::SQL::Schema::Traits::AlterTableAddConstraint; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Constraint => '-IMPL::SQL::Schema::Traits::Constraint', + ArgException => '-IMPL::InvalidArgumentException', + FK => '-IMPL::SQL::Schema::Traits::ForeignKey' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + constraint => PROP_RO + ] +}; +use IMPL::lang; + +sub CTOR { + my ($this,$table,$constraint) = @_; + + $this->tableName($table) or die ArgException->new( tableName => "A table name is required"); + + die ArgException->new(constaraint => "A valid " . Constraint . " is required") + unless is($constraint, Constraint); + + $this->constraint($constraint); +} + +sub CanApply { + my ($this, $schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + my $constraint = $this->constraint; + + my @columns = map $table->GetColumn($_), @{$constraint->{columns} || []}; + + # проверяем, что в таблице есть все столбцы для создания ограничения + return 0 if grep not($_), @columns; + + if (is($constraint,FK)) { + my $foreignTable = $schema->GetTable($constraint->{foreignTable}) + or return 0; + + my @foreignColumns = map $foreignTable->GetColumn($_), @{$constraint->{foreignColumns}||[]}; + + # внешняя таблица имеет нужные столбцы + return 0 + if grep not($_), @foreignColumns; + + # типы столбцов во внешней таблице совпадают с типами столбцов ограничения + return 0 + if grep not($columns[$_]->type->SameValue($foreignColumns[$_]->type)), (0 .. $#columns); + } + + return 1; +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); + + my $constraint = $this->constraint; + + if (is($constraint,FK)) { + my $args = { %$constraint }; + $args->{referencedTable} = $schema->GetTable(delete $args->{foreignTable}); + $args->{referencedColumns} = delete $args->{foreignColumns}; + $table->AddConstraint($constraint->constraintClass, $args); + } else { + $table->AddConstraint($constraint->constraintClass, $constraint); + } + +} + +################################################# + +package IMPL::SQL::Schema::Traits::AlterTableDropConstraint; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + PK => '-IMPL::SQL::Schema::Constraint::PrimaryKey' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + constraintName => PROP_RO + ] +}; +use IMPL::lang qw(is); + +sub CTOR { + my ($this,$table,$constraint) = @_; + + die new IMPL::InvalidArgumentException( tableName => "A table name is required" ) unless $table; + die new IMPL::InvalidArgumentException( constraintName => "A constraint name is required" ) unless $constraint; + + $this->tableName($table); + $this->constraintName($constraint); +} + +sub CanApply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + my $constraint = $table->GetConstraint($this->constraintName) + or return 0; + + # есть ли внешние ключи на данную таблицу + return ( + is($constraint,PK) + && values( %{$constraint->connectedFK || {}} ) + ? 0 + : 1 + ); +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); + + $table->RemoveConstraint($this->constraintName); +} + + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::SQL::Traits> - Операции над объектками SQL схемы. + +=head1 DESCRIPTION + +Изменения схемы могу быть представлены в виде последовательности примитивных операций. +Правила выполнения последовательности примитывных действий могут варьироваться +в зависимости от процессора, который их выполняет. Например C<IMPL::SQL::Schema::Traits::Processor>. + +Данные, которые содержаться в примитивных операциях не могут существовать независимо от схемы. + +=head1 OPERATIONS + +=head2 General + +Методы обще для всех примитивных операций. + +=head3 C<CanApply($schema)> + +Определяет возможность применения операции к указанной схеме. + +Возвращаемое значение: + +=over + +=item C<true> + +Операция приминима к схеме. + +=item C<false> + +Операция не может быть применена к схеме. + +=back + +=head3 C<Apply($schema)> + +Применяет операцию к указанной схеме. + +=head2 Primitive operations + +=head3 C<IMPL::SQL::Schema::Traits::CreateTable> + +Создает таблицу + +=head4 C<CTOR($table)> + +=head4 C<[get]table> + +C<IMPL::SQL::Schema::Traits::Table> - описание создаваемой таблицы + +=head3 C<IMPL::SQL::Schema::Traits::DropTable> + +Удалает таблицу по имени + +=head4 C<CTOR($tableName)> + +=head4 C<[get]tableName> + +Имя удаляемой таблицы + +=head3 C<IMPL::SQL::Schema::Traits::RenameTable> + +=head4 C<CTOR($tableName,$tableNewName)> + +=head4 C<[get]tableName> + +Имя таблицы, которую требуется переименовать + +=head4 C<[get]tableNewName> + +Новое имя таблицы + +=head3 C<IMPL::SQL::Schema::Traits::AlterTableAddColumn> + +Добавляет столбец в таблицу + +=head4 C<CTOR($tableName,$column,$position)> + +=head4 C<[get]tableName> + +Имя таблицы в которую нужно добавить столбец + +=head4 C<[get]column> + +C<IMPL::SQL::Schema::Traits::Column> - описание столбца который нужно добавить + +=head4 C<[get]position> + +Позиция на которую нужно вставить столбец + +=head3 C<IMPL::SQL::Schema::Traits::AlterTableDropColumn> + +Удаляет столбец из таблицы + +=head4 C<CTOR($tableName,$columnName)> + +=head4 C<[get]tableName> + +Имя таблицы в которой нужно удалить столбец + +=head4 C<[get]columnName> + +Имя столбца для удаления + +=head3 C<IMPL::SQL::Schema::Traits::AlterTableChangeColumn> + +Меняет описание столбца + +=head4 C<CTOR($tableName,$columnName,%args)> + +C<%args> - хеш, ключами которого являются оставшиеся свойства создаваемого объекта. + +=head4 C<[get]tableName> + +Имя таблицы в которой находится столбец. + +=head4 C<[get]columnName> + +Имя столбца для изменения + +=head4 C<[get]columnType> + +Новый тип столбца. Не задан, если тип не меняется + +=head4 C<[get]defaultValue> + +Значение по умолчанию. Не задано, если не меняется + +=head4 C<[get]isNullable> + +Может ли столбец содержать C<NULL>. Не задано, если не меняется. + +=head4 C<[get]options> + +Хеш опций, не задан, если опции не меняются. Данный хеш содержит разничу между +старыми и новыми значениями свойства C<tag> столбца. + + +=head3 C<IMPL::SQL::Schema::Traits::AlterTableAddConstraint> + +Базовый класс для операций по добавлению ограничений + +=head4 C<CTOR($tableName,$constraint)> + +=head4 C<[get]tableName> + +Имя таблицы в которую добавляется ограничение. + +=head4 C<[get]constraint> + +C<IMPL::SQL::Schema::Traits::Constraint> - описние ограничения, которое нужно добавить. + +=head3 C<IMPL::SQL::Schema::Traits::AlterTableDropConstraint> + +Удаляет ограничение на таблицу + +=head4 C<CTOR($tableName,$constraintName)> + +=head4 C<[get]tableName> + +Имя таблицы в которой требуется удалить ограничение. + +=head4 C<[get]constraintName> + +Имя ограничения для удаления. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Traits/Diff.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,174 @@ +package IMPL::SQL::Schema::Traits::Diff; +use strict; +use warnings; +use IMPL::lang qw(:compare :hash is typeof); + +use IMPL::SQL::Schema(); +use IMPL::SQL::Schema::Traits(); + +# defining a constant is a good style to enable compile checks +use constant { + schema_t => 'IMPL::SQL::Schema', + ConstraintForeignKey => 'IMPL::SQL::Schema::Constraint::ForeignKey', + TraitsForeignKey => 'IMPL::SQL::Schema::Traits::ForeignKey', + ConstraintPrimaryKey => 'IMPL::SQL::Schema::Constraint::PrimaryKey', + TraitsPrimaryKey => 'IMPL::SQL::Schema::Traits::PrimaryKey', + ConstraintUnique => 'IMPL::SQL::Schema::Constraint::Unique', + TraitsUnique => 'IMPL::SQL::Schema::Traits::Unique', + ConstraintIndex => 'IMPL::SQL::Schema::Constraint::Index', + TraitsIndex => 'IMPL::SQL::Schema::Traits::Index' +}; + +sub Diff { + my ($self,$src,$dst) = @_; + + die new IMPL::InvalidArgumentException( src => "A valid source schema is required") unless is($src,schema_t); + die new IMPL::InvalidArgumentException( dst => "A valid desctination schema is requried" ) unless is($src,schema_t); + + my %dstTables = map { $_->name, $_ } $dst->GetTables; + + my @operations; + + foreach my $srcTable ( $src->GetTables) { + my $dstTable = delete $dstTables{$srcTable->name}; + + if (not $dstTable) { + # if a source table doesn't have a corresponding destination table, it should be deleted + push @operations, new IMPL::SQL::Schema::Traits::DropTable($srcTable->name); + } else { + # a source table needs to be updated + push @operations, $self->_DiffTables($srcTable,$dstTable); + } + + } + + foreach my $tbl ( values %dstTables ) { + push @operations, new IMPL::SQL::Schema::Traits::CreateTable( + new IMPL::SQL::Schema::Traits::Table( + $tbl->name, + [ map _Column2Traits($_), @{$tbl->columns} ], + [ map _Constraint2Traits($_), $tbl->GetConstraints()], + $tbl->{tag} + ) + ) + } + + return \@operations; +} + +sub _DiffTables { + my ($self,$src,$dst) = @_; + + my @dropConstraints; + my @createConstraints; + + my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); + my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); + + foreach my $cnSrcName (keys %srcConstraints) { + if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { + unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { + push @dropConstraints, + new IMPL::SQL::Schema::Traits::AlterTableDropConstraint( $src->name, $cnSrcName ); + push @createConstraints, + new IMPL::SQL::Schema::Traits::AlterTableAddConstraint( $dst->name, _Constraint2Traits($cnDst) ); + } + } else { + push @dropConstraints,new IMPL::SQL::Schema::Traits::AlterTableDropConstraint( $src->name, $cnSrcName ); + } + } + + foreach my $cnDst (values %dstConstraints) { + push @createConstraints, + IMPL::SQL::Schema::Traits::AlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); + } + + my @deleteColumns; + my @addColumns; + my @updateColumns; + + my %dstColumnIndexes = map { + my $col = $dst->GetColumnAt($_); + ($col->name, { column => $col, index => $_ }) + } 0 .. $dst->ColumnsCount-1; + + my @columns; + + # remove old columns, mark for update changed columns + for( my $i=0; $i < $src->ColumnsCount; $i++) { + my $colSrc = $src->GetColumnAt($i); + + if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { + $infoDst->{prevColumn} = $colSrc; + push @columns,$infoDst; + } else { + push @deleteColumns,new IMPL::SQL::Schema::Traits::AlterTableDropColumn($src->name,$colSrc->name); + } + } + + #insert new columns at specified positions + foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { + splice(@columns,$_->{index},0,$_); + push @addColumns, new IMPL::SQL::Schema::Traits::AlterTableAddColumn($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); + } + + # remember old indexes + for(my $i =0; $i< @columns; $i ++) { + $columns[$i]->{prevIndex} = $i; + } + + # reorder columns + @columns = sort { $a->{index} <=> $b->{index} } @columns; + + foreach my $info (@columns) { + if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { + my $op = new IMPL::SQL::Schema::Traits::AlterTableChangeColumn($src->name,$info->{column}->name); + + $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; + $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); + $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); + + my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); + $op->options($diff) if %$diff; + + push @updateColumns, $op; + } + } + + my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); + + return @result; +} + +sub _Column2Traits { + my ($column,%options) = @_; + + return new IMPL::SQL::Schema::Traits::Column( + $column->name, + $column->type, + isNullable => $column->isNullable, + defaultValue => $column->defaultValue, + tag => $column->tag, + %options + ); +} + +sub _Constraint2Traits { + my ($constraint) = @_; + + my $map = { + ConstraintForeignKey , TraitsForeignKey, + ConstraintPrimaryKey , TraitsPrimaryKey, + ConstraintUnique , TraitsUnique, + ConstraintIndex , TraitsIndex + }; + + my $class = $map->{typeof($constraint)} or die new IMPL::Exception("Can't map the constraint",typeof($constraint)); + + return $class->new( + $constraint->name, + [ map $_->name, $constraint->columns ] + ) +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Traits/mysql.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,550 @@ +package IMPL::SQL::Schema::Traits::mysql::Handler; +use strict; +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +BEGIN { + public _direct property SqlBatch => prop_all; +} + +sub formatTypeNameInteger { + my ($type) = @_; + + return $type->Name.($type->MaxLength ? '('.$type->MaxLength.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); +} + +sub formatTypeNameReal { + my ($type) = @_; + + return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); +} + +sub formatTypeNameNumeric { + my ($type) = @_; + $type->MaxLength or die new IMPL::InvalidArgumentException('The length and precission must be specified',$type->Name); + return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); +} + +sub formatTypeName { + my ($type) = @_; + return $type->Name; +} + +sub formatTypeNameChar { + my ($type) = @_; + + return ( + $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::CHAR') ? $type->Encoding : '') + ); +} + +sub formatTypeNameVarChar { + my ($type) = @_; + + return ( + $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::VARCHAR') ? $type->Encoding : '') + ); +} + +sub formatTypeNameEnum { + my ($type) = @_; + die new Exception('Enum must be a type of either IMPL::SQL::Schema::Type::mysql::ENUM or IMPL::SQL::Schema::Type::mysql::SET') if not (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::ENUM') or UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::SET')); + return ( + $type->Name.'('.join(',',map {quote($_)} $type->Values).')' + ); +} + +sub quote{ + if (wantarray) { + return map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; + } else { + return join '',map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; + } +} + +sub quote_names { + if (wantarray) { + return map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; + } else { + return join '',map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; + } +} + +sub formatStringValue { + my ($value) = @_; + + if (ref $value) { + if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) { + return $value->as_string; + } else { + die new Exception('Can\'t format the object as a value',ref $value); + } + } else { + return quote($value); + } +} + + +sub formatNumberValue { + my ($value) = @_; + + if (ref $value) { + if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) { + return $value->as_string; + } else { + die new Exception('Can\'t format the object as a value',ref $value); + } + } else { + $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ or die new Exception('The specified value isn\'t a valid number',$value); + return $value; + } +} + + +my %TypesFormat = ( + TINYINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + SMALLINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + MEDIUMINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + INT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + INTEGER => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + BIGINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + REAL => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + DOUBLE => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + FLOAT => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + DECIMAL => { + formatType => \&formatTypeNameNumeric, + formatValue => \&formatNumberValue + }, + NUMERIC => { + formatType => \&formatTypeNameNumeric, + formatValue => \&formatNumberValue + }, + DATE => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TIME => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TIMESTAMP => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + DATETIME => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + CHAR => { + formatType => \&formatTypeNameChar, + formatValue => \&formatStringValue + }, + VARCHAR => { + formatType => \&formatTypeNameVarChar, + formatValue => \&formatStringValue + }, + TINYBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + BLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + MEDIUMBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + LONGBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TINYTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + MEDIUMTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + LONGTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + ENUM => { + formatType => \&formatTypeNameEnum, + formatValue => \&formatStringValue + }, + SET => { + formatType => \&formatTypeNameEnum, + formatValue => \&formatStringValue + } +); + + +=pod +CREATE TABLE 'test'.'New Table' ( + 'dd' INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, + `ff` VARCHAR(45) NOT NULL, + `ffg` VARCHAR(45) NOT NULL DEFAULT 'aaa', + `ddf` INTEGER UNSIGNED NOT NULL, + PRIMARY KEY(`dd`), + UNIQUE `Index_2`(`ffg`), + CONSTRAINT `FK_New Table_1` FOREIGN KEY `FK_New Table_1` (`ddf`) + REFERENCES `user` (`id`) + ON DELETE RESTRICT + ON UPDATE RESTRICT +) +ENGINE = InnoDB; +=cut +sub formatCreateTable { + my ($table,$level,%options) = @_; + + my @sql; + + # table body + push @sql, map { formatColumn($_,$level+1) } @{$table->Columns} ; + if ($options{'skip_foreign_keys'}) { + push @sql, map { formatConstraint($_,$level+1) } grep {not UNIVERSAL::isa($_,'IMPL::SQL::Schema::Constraint::ForeignKey')} values %{$table->Constraints}; + } else { + push @sql, map { formatConstraint($_,$level+1) } values %{$table->Constraints}; + } + + for(my $i = 0 ; $i < @sql -1; $i++) { + $sql[$i] .= ','; + } + + unshift @sql, "CREATE TABLE ".quote_names($table->Name)."("; + + if ($table->Tag) { + push @sql, ")"; + push @sql, formatTableTag($table->Tag,$level); + $sql[$#sql].=';'; + } else { + push @sql, ');'; + } + + return map { (" " x $level) . $_ } @sql; +} + +sub formatDropTable { + my ($tableName,$level) = @_; + + return " "x$level."DROP TABLE ".quote_names($tableName).";"; +} + +sub formatTableTag { + my ($tag,$level) = @_; + return map { " "x$level . "$_ = ".$tag->{$_} } grep {/^(ENGINE)$/i} keys %{$tag}; +} + +sub formatColumn { + my ($column,$level) = @_; + $level ||= 0; + return " "x$level.quote_names($column->Name)." ".formatType($column->Type)." ".($column->CanBeNull ? 'NULL' : 'NOT NULL').($column->DefaultValue ? formatValueToType($column->DefaultValue,$column->Type) : '' ).($column->Tag ? ' '.join(' ',$column->Tag) : ''); +} + +sub formatType { + my ($type) = @_; + my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); + $format->{formatType}->($type); +} + +sub formatValueToType { + my ($value,$type) = @_; + + my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); + $format->{formatValue}->($value); +} + +sub formatConstraint { + my ($constraint,$level) = @_; + + if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::ForeignKey')) { + return formatForeignKey($constraint,$level); + } else { + return formatIndex($constraint, $level); + } +} + +sub formatIndex { + my ($constraint,$level) = @_; + + my $name = quote_names($constraint->Name); + my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns}); + + if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') { + return " "x$level."PRIMARY KEY ($columns)"; + } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Unique') { + return " "x$level."UNIQUE $name ($columns)"; + } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Index') { + return " "x$level."INDEX $name ($columns)"; + } else { + die new IMPL::InvalidArgumentException('The unknown constraint', ref $constraint); + } + +} + +sub formatForeignKey { + my ($constraint,$level) = @_; + + my $name = quote_names($constraint->Name); + my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns}); + + not $constraint->OnDelete or grep { uc $constraint->OnDelete eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new IMPL::Exception('Invalid ON DELETE reference',$constraint->OnDelete); + not $constraint->OnUpdate or grep { uc $constraint->OnUpdate eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new IMPL::Exception('Invalid ON UPDATE reference',$constraint->OnUpdate); + + my $refname = quote_names($constraint->ReferencedPrimaryKey->Table->Name); + my $refcolumns = join(',',map quote_names($_->Name),@{$constraint->ReferencedPrimaryKey->Columns}); + return ( + " "x$level. + "CONSTRAINT $name FOREIGN KEY $name ($columns) REFERENCES $refname ($refcolumns)". + ($constraint->OnUpdate ? 'ON UPDATE'.$constraint->OnUpdate : ''). + ($constraint->OnDelete ? 'ON DELETE'.$constraint->OnDelete : '') + ); +} + +sub formatAlterTableRename { + my ($oldName,$newName,$level) = @_; + + return " "x$level."ALTER TABLE ".quote_names($oldName)." RENAME TO ".quote_names($newName).";"; +} + +sub formatAlterTableDropColumn { + my ($tableName, $columnName,$level) = @_; + + return " "x$level."ALTER TABLE ".quote_names($tableName)." DROP COLUMN ".quote_names($columnName).";"; +} + +=pod +ALTER TABLE `test`.`user` ADD COLUMN `my_col` VARCHAR(45) NOT NULL AFTER `name2` +=cut +sub formatAlterTableAddColumn { + my ($tableName, $column, $table, $pos, $level) = @_; + + my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); + + return " "x$level."ALTER TABLE ".quote_names($tableName)." ADD COLUMN ".formatColumn($column) .' '. $posSpec.";"; +} + +=pod +ALTER TABLE `test`.`manager` MODIFY COLUMN `description` VARCHAR(256) NOT NULL DEFAULT NULL; +=cut +sub formatAlterTableChangeColumn { + my ($tableName,$column,$table,$pos,$level) = @_; + my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); + return " "x$level."ALTER TABLE ".quote_names($tableName)." MODIFY COLUMN ".formatColumn($column).' '. $posSpec.";"; +} + +=pod +ALTER TABLE `test`.`manager` DROP INDEX `Index_2`; +=cut +sub formatAlterTableDropConstraint { + my ($tableName,$constraint,$level) = @_; + my $constraintName; + if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') { + $constraintName = 'PRIMARY KEY'; + } elsif (ref $constraint eq 'IMPL::SQL::Schema::Constraint::ForeignKey') { + $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name); + } elsif (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { + $constraintName = 'INDEX '.quote_names($constraint->Name); + } else { + die new IMPL::Exception("The unknow type of the constraint",ref $constraint); + } + return " "x$level."ALTER TABLE ".quote_names($tableName)." DROP $constraintName;"; +} + +=pod +ALTER TABLE `test`.`session` ADD INDEX `Index_2`(`id`, `name`); +=cut +sub formatAlterTableAddConstraint { + my ($tableName,$constraint,$level) = @_; + + return " "x$level."ALTER TABLE ".quote_names($tableName)." ADD ".formatConstraint($constraint,0).';'; +} + +sub CreateTable { + my ($this,$tbl,%option) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatCreateTable($tbl,0,%option)); + + return 1; +} + +sub DropTable { + my ($this,$tbl) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatDropTable($tbl,0)); + + return 1; +} + +sub RenameTable { + my ($this,$oldName,$newName) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatAlterTableRename($oldName,$newName,0)); + + return 1; +} + +sub AlterTableAddColumn { + my ($this,$tblName,$column,$table,$pos) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddColumn($tblName,$column,$table,$pos,0)); + + return 1; +} +sub AlterTableDropColumn { + my ($this,$tblName,$columnName) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropColumn($tblName,$columnName,0)); + + return 1; +} + +sub AlterTableChangeColumn { + my ($this,$tblName,$column,$table,$pos) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatAlterTableChangeColumn($tblName,$column,$table,$pos,0)); + + return 1; +} + +sub AlterTableAddConstraint { + my ($this,$tblName,$constraint) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddConstraint($tblName,$constraint,0)); + + return 1; +} + +sub AlterTableDropConstraint { + my ($this,$tblName,$constraint) = @_; + + push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropConstraint($tblName,$constraint,0)); + + return 1; +} + +sub Sql { + my ($this) = @_; + if (wantarray) { + @{$this->SqlBatch || []}; + } else { + return join("\n",$this->SqlBatch); + } +} + +package IMPL::SQL::Schema::Traits::mysql; +use parent qw(IMPL::SQL::Schema::Traits); +use IMPL::Class::Property; + +BEGIN { + public _direct property PendingConstraints => prop_none; +} + +our %CTOR = ( + 'IMPL::SQL::Schema::Traits' => sub { + my %args = @_; + $args{'Handler'} = new IMPL::SQL::Schema::Traits::mysql::Handler; + %args; + } +); + +sub DropConstraint { + my ($this,$constraint) = @_; + + if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { + return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED} $constraint->Columns; + my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns); + if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'IMPL::SQL::Schema::Constraint::ForeignKey')) { + my $fk = shift @constraints; + if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED) { + push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]}; + $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++; + + die new IMPL::Exception('Can\'t drop the primary key becouse of the foreing key',$fk->UniqName) if $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} > 2; + return 2; + } + } + } + $this->SUPER::DropConstraint($constraint); +} + +sub GetMetaTable { + my ($class,$dbh) = @_; + + return IMPL::SQL::Schema::Traits::mysql::MetaTable->new( DBHandle => $dbh); +} + +package IMPL::SQL::Schema::Traits::mysql::MetaTable; +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +BEGIN { + public _direct property DBHandle => prop_none; +} + +sub ReadProperty { + my ($this,$name) = @_; + + local $this->{$DBHandle}->{PrintError}; + $this->{$DBHandle}->{PrintError} = 0; + my ($val) = $this->{$DBHandle}->selectrow_array("SELECT value FROM _Meta WHERE name like ?", undef, $name); + return $val; +} + +sub SetProperty { + my ($this,$name,$val) = @_; + + if ( $this->{$DBHandle}->selectrow_arrayref("SELECT TABLE_NAME FROM information_schema.`TABLES` T where TABLE_SCHEMA like DATABASE() and TABLE_NAME like '_Meta'")) { + if ($this->{$DBHandle}->selectrow_arrayref("SELECT name FROM _Meta WHERE name like ?", undef, $name)) { + $this->{$DBHandle}->do("UPDATE _Meta SET value = ? WHERE name like ?",undef,$val,$name); + } else { + $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES ('$name',?)",undef,$val); + } + } else { + $this->{$DBHandle}->do(q{ + CREATE TABLE `_Meta` ( + `name` VARCHAR(255) NOT NULL, + `value` LONGTEXT NULL, + PRIMARY KEY(`name`) + ); + }) or die new IMPL::Exception("Failed to create table","_Meta"); + + $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val); + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Schema/Type.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,98 @@ +package IMPL::SQL::Schema::Type; +use strict; +use warnings; + +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; + + $this->{$scale} = 0 if not $this->{$scale}; +} + +sub SameValue { + my ($this,$other) = @_; + + return ( + $this->{$name} eq $other->name + and equals($this->{$maxLength},$other->{$maxLength}) + and equals($this->{$scale},$other->{$scale}) + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::SQL::Schema::Type> Описывает SQL типы данных + +=head1 SYNOPSIS + +=begin code + +use IMPL::SQL::Schema::Type; + +my $varchar_t = new IMPL::SQL::Schema::Type( name => 'varchar', maxLength => 255 ); + +my $real_t = new IMPL::SQL::Schema::Type( name => 'float', maxLength=> 10, scale => 4); # mysql: float(10,4) + +=end + +Данный класс используется для стандатрного описания SQL типов данных. В зависимости +от движка БД эти объекты могут быть представлены различными строковыми представлениями. + +=head1 MEMBERS + +=over + +=item C<CTOR(%props)> + +Конструктор, заполняет объект значениями которые были переданы в конструкторе. + +=item C<[get]name> + +Имя типа. Обязательно. + +=item C<[get]maxLength> + +Максимальная длина, используется только для типов, имеющих длину (либо переменную, +либо постоянную). + +=item C<[get]scale> + +Точность, количество знаков после запятой. Используется вместе с C<maxLength>. + +=item C<[get]unsigned> + +Используется с числовыми данными, обозначает беззнаковые типы. + +=item C<[get]zerofill> + +Нестандартный атрибут дополняющий числа лидирующими нулями до C<maxLength>. + +=item C<[get]tag> + +Хеш с дополнительными опциями. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/SQL/Types.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,39 @@ +package IMPL::SQL::Types; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime); + +require IMPL::SQL::Schema::Type; + +sub Integer() { + return IMPL::SQL::Schema::Type->new(name => 'INTEGER'); +} + +sub Varchar($) { + return IMPL::SQL::Schema::Type->new(name => 'VARCHAR', maxLength => shift); +} + +sub Float($) { + return IMPL::SQL::Schema::Type->new(name => 'FLOAT', scale => shift); +} + +sub Real() { + return IMPL::SQL::Schema::Type->new(name => 'REAL'); +} + +sub Text() { + return IMPL::SQL::Schema::Type->new(name => 'TEXT'); +} + +sub Binary() { + return IMPL::SQL::Schema::Type->new(name => 'BINARY'); +} + +sub DateTime() { + return IMPL::SQL::Schema::Type->new(name => 'DATETIME'); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,29 @@ +package IMPL::Security; +use strict; +use Carp qw(carp); + +##VERSION## + +require IMPL::Exception; +require IMPL::Security::Rule::RoleCheck; + +use IMPL::require { + Principal => 'IMPL::Security::Principal', + AbstractContext => 'IMPL::Security::AbstractContext', + Context => 'IMPL::Security::Context' +}; + +sub principal { + return + AbstractContext->current + && AbstractContext->current->principal + || Principal->nobody; +} + +sub context { + AbstractContext->current || Context->nobody; +} + +1; + +__END__ \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/AbstractContext.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,167 @@ +package IMPL::Security::AbstractContext; +use strict; +use warnings; + +use IMPL::Const qw(:prop); + +use IMPL::require { + Role => 'IMPL::Security::Role', + Principal => 'IMPL::Security::Principal', + Exception => 'IMPL::Exception', + NotImplementedException => '-IMPL::NotImplementedException' +}; + +use parent qw(IMPL::Class::Meta); + +__PACKAGE__->static_accessor_clone(abstractProps => [ + principal => PROP_RW, + rolesAssigned => PROP_RW | PROP_LIST, + auth => PROP_RW, + authority => PROP_RW +]); + +my $current; # current session if any + +sub Impersonate { + my ($this,$code,@args) = @_; + + my $old = $current; + $current = $this; + my $result; + my $e; + + { + local $@; + eval { + $result = $code->(@args); + }; + $e = $@; + } + $current = $old; + if($e) { + die $e; + } else { + return $result; + } +} + +sub Apply { + my ($this) = @_; + + $current = $this; +} + +sub isTrusted { + my ($this) = @_; + + if (my $auth = $this->auth) { + return $auth->isTrusted; + } else { + return 0; + } +} + +sub isNobody { + return (shift->principal == Principal->nobody ? 1 : 0); +} + +sub Satisfy { + my ($this,@roles) = @_; + + my $roleEffective = Role->new ( _effective => scalar $this->rolesAssigned ); + + return $roleEffective->Satisfy(@roles); +} + +sub current { + $current; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<abstract IMPL::Security::Context> - контекст безопасности. + +=head1 SINOPSYS + +=begin code + +package MyApp::Model::Session; +use strict; + +use IMPL::delare { + base => [ + 'MyApp::Model::BaseDBO' => '@_', + 'IMPL::Security::AbstractContext' => undef + ], + props { + IMPL::Security::AbstractContext->abstractProps, + qouta => PROP_GET + } +} + +package main; + +$app->model->GetSession('546a54df4')->Impersonate(sub{ + # do something +}); + +=end code + +=head1 DESCRIPTION + +Код приложения, которое выполняется + +Являет собой контекст безопасности, описывает пользователя и привелегии, так же +у программы есть текущий контекст безопасности, по умолчанию он C<nobody>. + +=head1 MEMBERS + +=head2 C<[get] principal> + +Идентификатор пользователя, владельца контекста. + +=head2 C<[get,set] rolesAssigned> + +Явно назначенные роли. Если список пуст, то считается, что используются роли +пользователя по-умолчанию. + +=head2 C<[get] auth> + +Объект асторизации C<IMPL::Security::Auth>, использованный при создании текущего контекста. + +=head2 C<[get] authority> + +Модуль безопасности, породивший данный контекст. Модуль безопасности, отвечающий +за создание контекста безопасности должен реализовывать метод +C<CreateContext($user,$auth,$roles)> + +=head2 C<[get] isTrusted> + +Возвращает значение является ли контекст доверенным, тоесть клиент +аутентифицирован и сессия установлена. Если C<false> значит, что сессия была +начата, однако не установлена до конца. + +=head2 C<Impersonate($code)> + +Делает контекст текущим и выполняет в нем функцию по ссылке C<$code>. По окончании +выполнения, контекст восстанавливается в предыдущий (не зависимо от того, что +с ним происходило во время выполнения C<$code>). + +=head2 C<Apply()> + +Заменяет текущий контекст на себя, но до конца действия метода C<Impersonate>, если +таковой был вызван. + +=head2 C<Satisfy(@roles)> + +Проверяет наличие необходимых ролей у контекста. Данный метод позволяет +абстрагироваться от механизмов связи контекста и ролей. Возвращает истинное +значение если список необходимых ролей у пользователя имеется. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/AbstractPrincipal.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,18 @@ +package IMPL::Security::AbstractPrincipal; +use strict; + +use parent qw(IMPL::Class::Meta); + +use IMPL::Const qw(:prop); + +__PACKAGE__->static_accessor_clone(abstractProps => [ + name => PROP_RW, + description => PROP_RW +]); + +sub isNobody { + +} + +1; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/AbstractRole.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,65 @@ +package IMPL::Security::AbstractRole; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::lang qw(equals_s); +use parent qw(IMPL::Class::Meta); + +__PACKAGE__->static_accessor_clone( abstractProps => [ + roleName => PROP_RW, + parentRoles => PROP_RW | PROP_LIST +]); + +sub Satisfy { + my ($this,@roles) = @_; + + return 1 unless $this->_FilterRoles( @roles ); + return 0; +} + +sub _FilterRoles { + my ($this,@roles) = @_; + + @roles = grep not (ref $_ ? equals_s($this->roleName,$_->roleName) : equals_s($this->roleName, $_) ), @roles; + + @roles = $_->_FilterRoles(@roles) or return foreach $this->parentRoles ; + + return @roles; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Security::Role> Роль + +=head1 DESCRIPTION + +Может включать в себя базовые роли. +Имеется метод для проверки наличия необходимых ролей в текущей роли. + +=head1 MEMBERS + +=over + +=item C<[get] roleName> + +Имя роли, ее идентификатор + +=item C<[get,list] parentRoles> + +Список родительских ролей + +=item C<Satisfy(@roles_list)> + +Проверяет наличие ролей указанных ролей из списка @roles_list. +Допускается использование как самих объектов, так и имен ролей. +Возвращает 0 в случае неудачи (хотябы одна роль не была удовлетворена), 1 при наличии необходимых ролей. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/Auth.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,132 @@ +package IMPL::Security::Auth; +use strict; + +use Digest::MD5 qw(md5_hex); + +use constant { + AUTH_SUCCESS => 1, + AUTH_INCOMPLETE => 2, + AUTH_FAIL => 3 +}; + +use parent qw(Exporter); + +our @EXPORT_OK = qw(&AUTH_SUCCESS &AUTH_INCOMPLETE &AUTH_FAIL &GenSSID); +our %EXPORT_TAGS = (Const => [qw(&AUTH_SUCCESS &AUTH_INCOMPLETE &AUTH_FAIL)]); + +{ + my $i = 0; + sub GenSSID { + return md5_hex(time,rand,$i++); + } +} + +sub DoAuth { + die new IMPL::NotImplementedException; +} + +sub isTrusted { + 0; +} + +sub Create { + my ($self,%args) = @_; + + return $self->new($self->CreateSecData(%args)); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Security::Auth> Базовыйы класс для объектов аутентификации. + +=head1 DESCRIPTION + +C<[Abstract]> + +Объект аутентификации служет для аутентификации клиента, в случае успеха +образуется сессия идентифицирующая клиента, которая представлена на стороне +сервера объектом аутентификации. + +Аутентификация носит итеративный характер, объект аутентификации сохраняет +состояние между итерациями. + +Результатом аутентификации является сессия, состояние этой сессии также хранит объект +аутентификации. + +В процессе авторизации клиент и сервер обмениеваются данными безопасности C<$challenge>. +И результатом каждой итерации является либо упех (C<AUTH_SUCCESS>), либо запрос на продолжение +(C<AUTH_INCOMPLETE>), либо неудача (C<AUTH_FAIL>). Количество итераций может быть разным, +зависит от пакета аутентификации. + +=head1 EXPORT + +=over + +=item C<:Const> + +Константы результата аутентификации + +=over + +=item C<AUTH_SUCCESS> + +Успешная аутентификация + +=item C<AUTH_INCOMPLETE> + +Требуются дополнительные шаги + +=item C<AUTH_FAIL> + +Аутентификация неуспешна. + +=back + +=back + +=head1 MEMBERS + +=over + +=item C<CTOR($SecData)> + +Создает пакет для авторизации на основе данных безопасности для пользователя. +C<$SecData> - Зависит от пакета аутентификации. + +=item C<[get] isTrusted> + +Флаг того, что аутентификация закончена успешно и сессия создана. Данный объект +может быть создан для аутентификации сессии. + +=item C<DoAuth($challenge)> + +Производит аутентификацию пользователя, возвращает результат +аутентификации, в виде массива ($status,$challenge). + +Даже после успешной аутентификации полученные данные C<$challenge> должны быть +отправлены клиенту для завершения аутентификации на стороне клиента. + +=item C<[static] CreateSecData(%args)> + +Создает данные безопасности, на основе параметров. Параметры зависят от пакета +аутентификации. Возвращает строку с данными безопасности. + +=item C<[static] Create(%args)> + +Создает объект аутентификации, на основе параметров. Параметры зависят от +пакета аутентификации. Внутри вызывает метод C<CreateSecData(%args)>. + +=item C<[static] SecDataArgs()> + +Возвращает хеш с описанием параметров для функции C<CreateSecData>. +Ключами являются имена параметров, значениями - типы. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/Auth/Simple.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,133 @@ +package IMPL::Security::Auth::Simple; +use strict; + +use Digest::MD5 qw(md5_hex); +use Encode qw(encode); + +use IMPL::Security::Auth qw(:Const); + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + WrongDataException => '-IMPL::WrongDataException' + }, + base => [ + 'IMPL::Security::Auth' => undef, + 'IMPL::Object' => undef + ], + props => [ + _stage => PROP_ALL, + _salt => PROP_ALL, + _image => PROP_ALL + ] +}; + +use constant { + STAGE_INIT => 1, + STAGE_DONE => 2 +}; + +sub CTOR { + my ($this,$secData) = @_; + + my ($stage,$salt,$img) = split /\|/,$secData; + + die WrongDataException->new() unless grep $_ == $stage, (STAGE_INIT, STAGE_DONE); + + $this->_stage($stage); + $this->_salt($salt); + $this->_image($img); + +} + +sub secData { + my ($this) = @_; + + return join ('|',$this->_stage, $this->_salt , $this->_image ); +} + +sub isTrusted { + my ($this) = @_; + + $this->_stage == STAGE_DONE ? 1 : 0; +} + +sub DoAuth { + my ($this,$challenge) = @_; + + my $salt = $this->_salt; + + if (md5_hex($salt,encode('utf-8', $challenge), $salt) eq $this->_image) { + if ($this->_stage == STAGE_INIT) { + $this->_stage(STAGE_DONE); + } + return (AUTH_SUCCESS, undef); + } else { + return (AUTH_FAIL, undef); + } +} + +sub CreateSecData { + my ($self,%args) = @_; + + die new IMPL::InvalidArgumentException("The parameter is required",'password') unless $args{password}; + + my $salt = $self->GenSSID(); + return return join ('|',STAGE_INIT, $salt, md5_hex($salt,encode('utf-8', $args{password}),$salt)); +} + +sub SecDataArgs { + password => 'SCALAR' +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Security::Auth::Simple> Модуль простой авторизации. + +=head1 DESCRIPTION + +Использует алгоритм MD5 для хранения образа пароля. + +=head1 MEMBERS + +=head2 C<CTOR($secData)> + +Создает объект аутентификации, передавая ему данные для инициализации. + +=head2 C<[get]secData> + +Возвращает данные безопасности, которые можно использовать для восстановления +состояния объекта. + +=head2 C<[get]isTrusted> + +Является ли объект доверенным для аутентификации сессии (тоесть хранит данные +для аутентификации сессии). + +=head2 C<DoAuth($challenge)> + +Аутентифицирует пользователя. Используется один этап. C<$challenge> +открытый пароль пользователя или cookie сессии. + +Возвращает C<($status,$challenge)> + +=over + +=item C<$status> + +Результат либо C<AUTH_SUCCESS>, либо C<AUTH_FAIL> + +=item C<$challenge> + +В случае успеха возвращает cookie (уникальный номер) сессии, либо C<undef> + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/Context.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,113 @@ +package IMPL::Security::Context; +use strict; +use warnings; + +use IMPL::require { + AbstractContext => 'IMPL::Security::AbstractContext', +}; + +use IMPL::declare { + require => { + Principal => 'IMPL::Security::Principal', + Role => 'IMPL::Security::Role', + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Security::AbstractContext' => undef, + ], + props => [ + @{AbstractContext->abstractProps()} + ] +}; + +__PACKAGE__->abstractProps([]); + + +my $nobody; + +sub CTOR { + my ($this) = @_; + + die ArgumentException->new("The parameter is required", 'principal') unless $this->principal; +} + +sub nobody { + my ($self) = @_; + $nobody = $self->new(principal => Principal->nobody) unless $nobody; + $nobody; +} + +sub isTrusted { + return 1; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Security::Context> - реализация контекста безопасности создаваемого в +приложении. + +=head1 SYNOPSIS + +=begin code + +my $context = IMPL::Security::Context->nobody; + +my $result = $context->Impersonate( + sub { + # do some untrusted code + } +); + +$context = IMPL::Security::Context->new( + principal => $user, + assignedRoles => [ + $backupRole, + $controlRole + ] +); + +$context->Impersonate( + sub { + + # do some authorized operations + + $service->backupData('current.bak'); + $service->stop(); + } +); + +=end code + +=head1 DESCRIPTION + +C<autofill> + +Данная реализация контекста безопасности не привязана ни к источнику данных +ни к пакету аутентификации и авторизации, ее приложение может создать в любой +момент, при этом система сама несет ответственность за последствия. + +Данный контекст нужен для выполнения системой служебных функций. + +=head1 MEMBERS + +см. также C<IMPL::Security::AbstractContext>. + +=head2 C<CTOR(%props)> + +Создает объект и заполняет его свойствами. C<principal> должен быть обязательно +указан. + +=head2 C<[static,get] nobody> + +Контекст для неаутентифицированных пользователей, минимум прав. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/Principal.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,60 @@ +package IMPL::Security::Principal; +use strict; +use warnings; + +use IMPL::Const qw(:prop); +use IMPL::require { + AbstractPrincipal => 'IMPL::Security::AbstractPrincipal' +}; +use IMPL::declare { + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Security::AbstractPrincipal' => undef + ], + props => [ + @{AbstractPrincipal->abstractProps()}, + isNobody => PROP_RW + ] +}; + +__PACKAGE__->abstractProps([]); + +my $nobody; + +sub nobody { + $nobody = $_[0]->new(name => 'nobody', description => '', isNobody => 1) unless $nobody; + return $nobody; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Security::Principal> Идентификатор пользователя + +C<[Autofill]> + +=head1 MEMBERS + +=over + +=item C<CTOR(%props)> + +Создает новый объект. + +=item C<[get] name> + +Возвращает имя пользователя. + +=item C<[get,set] description> + +Возвращает описание пользователя. + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/Role.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,60 @@ +package IMPL::Security::Role; +use strict; + +use IMPL::require { + AbstractRole => 'IMPL::Security::AbstractRole' +}; + +use IMPL::declare { + base => [ + 'IMPL::Object' => undef, + 'IMPL::Security::AbstractRole' => undef + ], + _implement => 1 +}; + +sub CTOR { + my ($this,$name,$parentRoles) = @_; + + $this->roleName($name) if $name; + $this->parentRoles($parentRoles) if $parentRoles; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Security::Role> - стандартная реализация роли безопасности. + +=head1 SYNOPSIS + +=begin code + +# create the megarole +my $role = IMPL::Security::Role->new(megarole => [ $adminRole, $directorRole ] ); + +#use it in context +my $context = IMPL::Security::Context->new( + principal => $user, + assignedRoles => [$user->roles, $megarole] +); + +$context->Impersonate( sub { + # do something forbidden +}); + +=end code + +=head1 DESCRIPTION + +Позволяет создавать объекты ролей без привязки к источникам данных и модулям +авторизации. Чаще всего используется при реализации каких либо механизмов +безопасности, где требуется создать временную роль. + +C<IMPL::Security::AbstractRole> + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Security/Rule/RoleCheck.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,18 @@ +package IMPL::Security::Rule::RoleCheck; +use strict; + +require IMPL::Security::Role; + +sub SatisfyAll { + my ($secPackage,$object,$desiredAccess,$context) = @_; + + my $roleEffective = new IMPL::Security::Role ( _effective => $context->rolesAssigned ); + + return $roleEffective->Satisfy(ExtractRoles($object)); +} + +sub _ExtractRoles { + return (); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Serialization.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,449 @@ +package IMPL::Serialization; +use strict; + +package IMPL::Serialization::Context; + +use IMPL::Exception(); +use Scalar::Util qw(refaddr); + +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 + ] +}; + +sub STATE_CLOSED () { 0 } +sub STATE_OPENED () { 1 } +sub STATE_COMPLEX () { 2 } +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; +} + +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; + } + return 0; + } + + 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; +} + +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; +} + +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 ); + } + } + 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) ); + } + } + + return 1; +} + +package IMPL::Deserialization::Context; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + Loader => 'IMPL::Code::Loader' + }, + base => [ 'IMPL::Object' => undef ], + props => [ + + # структура информации об объекте + # { + # 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; +} + +sub OnObjectBegin { + 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'}; + + push @{ $rhCurrentObj->{'Data'} }, $name, $refObj; + } else { + $rhCurrentObj->{'Data'} = [ $name, $refObj ]; + } + + 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->CreateSurrogate( $rhProps->{'type'} ); + } + } + + return 1; +} + +sub OnObjectData { + 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 $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; + } +} + +sub CreateSurrogate { + my ($this,$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: +# [ +# 'var_name',value, +# .... +# ] + +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 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; + } + 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; + } + 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 { + 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 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 Exception->new("Omitted mandatory parameter 'formatter'"); +} + +sub Serialize { + 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 = DeserializationContext->new(); + my $ObjReader = $this->_formatter->CreateReader( $hStream, $context ); + $ObjReader->Parse(); + return $context->root; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Serialization/XmlFormatter.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,200 @@ +package IMPL::Serialization::XmlObjectWriter; +use strict; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +use IMPL::Serialization; +use XML::Writer; +use IMPL::Exception; + +sub CONTAINER_EMPTY () { 1 } +sub CONTAINER_NORMAL () { 2 } + +BEGIN { + public _direct property Encoding => prop_all; + public _direct property hOutput => prop_all; + public _direct property IdentOutput => prop_all; + + private _direct property CurrentObject => prop_all; + private _direct property ObjectPath => prop_all; + private _direct property XmlWriter => prop_all; + private _direct property IdentLevel => prop_all; + private _direct property IdentNextTag => prop_all; +} + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + $self->CTOR(@_); + return $self; +} + +sub CTOR { + my $this = shift; + my %args = @_; + $this->{$hOutput} = $args{'hOutput'}; + $this->{$Encoding} = $args{'Encoding'}; + $this->{$CurrentObject} = undef; + $this->{$IdentOutput} = $args{'IdentOutput'}; + $this->{$IdentLevel} = 0; + $this->{$IdentNextTag} = 0; + #$this->{$ObjectPath} = []; + return 1; +} + +sub BeginObject { + my $this = shift; + my %args = @_; + + if (not $this->{$CurrentObject}) { + my $xmlWriter = new XML::Writer(OUTPUT => $this->{$hOutput}, ENCODING => $this->{$Encoding}); + $this->{$XmlWriter} = $xmlWriter; + $xmlWriter->xmlDecl(); + } + + push @{$this->{$ObjectPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; + + my %ObjectProperties = %args; + delete $ObjectProperties{'name'}; + delete $args{'container_type'}; + + $this->{$CurrentObject} = \%ObjectProperties; + + my $tagname; + if (_CheckName($args{'name'})) { + $tagname = $args{'name'}; + } else { + $tagname = 'element'; + $ObjectProperties{'extname'} = $args{'name'}; + } + + if ($args{'refid'}) { + $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; + $this->{$XmlWriter}->emptyTag($tagname,%ObjectProperties); + $ObjectProperties{'container_type'} = CONTAINER_EMPTY; + } else { + $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; + $this->{$XmlWriter}->startTag($tagname,%ObjectProperties); + $ObjectProperties{'container_type'} = CONTAINER_NORMAL; + } + + $this->{$IdentLevel} ++; + $this->{$IdentNextTag} = $this->{$IdentOutput}; + + return 1; +} + +sub EndObject { + my $this = shift; + + my $hCurrentObject = $this->{$CurrentObject} or return 0; + + $this->{$IdentLevel} --; + + if ( $hCurrentObject->{'container_type'} != CONTAINER_EMPTY ) { + $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; + $this->{$XmlWriter}->endTag(); + } + + $this->{$IdentNextTag} = $this->{$IdentOutput}; + + $this->{$CurrentObject} = pop @{$this->{$ObjectPath}} if exists $this->{$ObjectPath}; + $this->{$XmlWriter} = undef if (not $this->{$CurrentObject}); + + return 1; +} + +sub SetData { + my $this = shift; + #my $hCurrentObject = $this->{$CurrentObject} or return 0; + + if ($this->{$CurrentObject}->{'container_type'} == CONTAINER_NORMAL) { + $this->{$XmlWriter}->characters($_[0]) if defined $_[0]; + $this->{$IdentNextTag} = 0; + return 1; + } else { + return 0; + } +} + +sub _CheckName { + return 0 if not $_[0]; + return $_[0] =~ /^(_|\w|\d)+$/; +} + +package IMPL::Serialization::XmlObjectReader; +use parent qw(XML::Parser); + +sub new { + my $class = shift; + my %args = @_; + die new Exception("Handler parameter is reqired") if not $args{'Handler'}; + die new Exception("Handler parameter must be a reference") if not ref $args{'Handler'}; + + #my $this = $class->SUPER::new(Style => 'Stream', Pkg => 'Serialization::XmlObjectReader', 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); + my $this = $class->SUPER::new(Handlers => { Start => \&StartTag, End => \&EndTag, Char => \&Text} , 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); + return $this; +} + +sub Parse { + my $this = shift; + $this->parse($this->{'Non-Expat-Options'}->{'hInput'}); + return 1; +} + +sub StartTag { + my $this = shift; + my $name = shift; + my %Attr = @_; + $name = $Attr{'extname'} if defined $Attr{'extname'}; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectBegin($name,\%Attr); + return 1; +} + +sub EndTag { + my ($this,$name) = @_; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectEnd($name); + return 1; +} + +sub Text { + my ($this) = shift; + my $text = shift; + return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and $text =~ /^\n*\s*\n*$/; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($text); + return 1; +} + +package IMPL::Serialization::XmlFormatter; +use parent qw(IMPL::Object); + +use IMPL::Class::Property; + +BEGIN { + public _direct property Encoding => prop_all; + public _direct property SkipWhitespace => prop_all; + public _direct property IdentOutput => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->Encoding($args{'Encoding'} || 'utf-8'); + $this->SkipWhitespace($args{'SkipWhitespace'}); + $this->IdentOutput($args{'IdentOutput'}); + + return 1; +} + +sub CreateWriter { + my ($this,$hStream) = @_; + return new IMPL::Serialization::XmlObjectWriter(Encoding =>$this->Encoding() , hOutput => $hStream, IdentOutput => $this->IdentOutput()); +} + +sub CreateReader { + my ($this,$hStream,$refHandler) = @_; + return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace()); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/TargetException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,24 @@ +package IMPL::TargetException; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::AppException' => undef, + ], + props => [ + innerException => PROP_RO + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->innerException($args{innerException}); +} + +use IMPL::Resources::Strings { + message => "An invocation target throws an exception '%innerException.message%' \n%innerException.callStack%\n__END_OF_INNER_EXCEPTION__\n" +}; + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,104 @@ +package IMPL::Test; +use strict; +use warnings; + +use IMPL::lang qw(equals_s); +use IMPL::Const qw(:access); +require IMPL::Test::SkipException; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert &assertarray &GetCallerSourceLine); + +require IMPL::Test::Unit; +require IMPL::Test::Plan; +require IMPL::Test::TAPListener; + +sub test($$) { + my ($name,$code) = @_; + my $class = caller; + + $class->set_meta( + new IMPL::Test::Unit::TestInfo( $name, $code ) + ); +} + +sub shared($) { + my ($propInfo) = @_; + + 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->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)); +} + +sub failed($;@) { + die new IMPL::Test::FailException(@_); +} + +sub assert { + my ($condition,@params) = @_; + + die new IMPL::Test::FailException(@params ? @params : ("Assertion failed" , _GetSourceLine( (caller)[1,2] )) ) unless $condition; +} + +sub skip($;@) { + die new IMPL::Test::SkipException(@_); +} + +sub cmparray { + my ($a,$b) = @_; + + return 0 unless @$a == @$b; + + for (my $i=0; $i < @$a; $i++ ) { + return 0 unless + equals_s($a->[$i], $b->[$i]); + } + + return 1; +} + +sub assertarray { + my ($a,$b) = @_; + + + die IMPL::Test::FailException->new( + "Assert arrays failed", + _GetSourceLine( (caller)[1,2] ), + join(', ', map defined($_) ? $_ : '<undef>', @$a), + join(', ', map defined($_) ? $_ : '<undef>', @$b) + ) + unless cmparray($a,$b); +} + +sub _GetSourceLine { + my ($file,$line) = @_; + + open my $hFile, $file or return "failed to open file: $file: $!"; + + my $text; + $text = <$hFile> for ( 1 .. $line); + chomp $text; + $text =~ s/^\s+//; + return "line $line: $text"; +} + +sub GetCallerSourceLine { + my $line = shift || 0; + return _GetSourceLine( (caller($line + 1))[1,2] ) +} + +sub run_plan { + my (@units) = @_; + + my $plan = new IMPL::Test::Plan(@units); + + $plan->Prepare; + $plan->AddListener(new IMPL::Test::TAPListener); + $plan->Run; +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/BadUnit.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,65 @@ +package IMPL::Test::BadUnit; +use strict; +use warnings; + +use parent qw(IMPL::Test::Unit); +use IMPL::Class::Property; + +BEGIN { + public property UnitName => prop_all; + public property Message => prop_all; + public property Error => prop_all; +} + +our %CTOR = ( + 'IMPL::Test::Unit' => sub { + if (@_>1) { + # Unit construction + my ($unit,$message,$error) = @_; + return new IMPL::Test::Unit::TestInfo( + BadUnitTest => sub { + die new IMPL::Test::FailException($message,$unit,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) + } + ); + } else { + # test construction + return @_; + } + } +); + +sub CTOR { + my ($this,$name,$message,$error) = @_; + + $this->UnitName($name); + $this->Message($message); + $this->Error($error); +} + +sub save { + my ($this,$ctx) = @_; + + defined ($this->$_()) and $ctx->AddVar($_ => $this->$_()) foreach qw(UnitName Message); +} + +sub restore { + my ($class,$data,$inst) = @_; + + my %args = @$data; + + $inst ||= $class->surrogate; + $inst->callCTOR(@args{qw(UnitName Message)}); +} + +sub List { + my ($this) = @_; + my $error = $this->Error; + return new IMPL::Test::Unit::TestInfo( + BadUnitTest => sub { + die new IMPL::Test::FailException($this->Message,$this->UnitName,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) + } + ); +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/FailException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,22 @@ +package IMPL::Test::FailException; +use strict; +use warnings; + +use parent qw(IMPL::Exception); + +__PACKAGE__->PassThroughArgs; + +sub toString { + my $this = shift; + + $this->Message . join("\n",'',map IMPL::Exception::indent($_,1), @{$this->Args} ); +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar(Message => $this->Message); + $ctx->AddVar(Args => $this->Args) if @{$this->Args}; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/HarnessRunner.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,29 @@ +package IMPL::Test::HarnessRunner; +use strict; +use warnings; + +use parent qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); + +use TAP::Parser; +use Test::Harness; + +__PACKAGE__->PassThroughArgs; + + +sub CTOR { + my $this = shift; +} + +sub RunTests { + my ($this,@files) = @_; + + return runtests(@files); +} + +sub ExecuteTests { + my ($this,%args) = @_; + + return Test::Harness::execute_tests(%args); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/Plan.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,238 @@ +package IMPL::Test::Plan; +use strict; +use warnings; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +use IMPL::Exception; +use IMPL::Test::Result; +use IMPL::Test::BadUnit; +use Error qw(:try); + +use IMPL::Serialization; +use IMPL::Serialization::XmlFormatter; + +BEGIN { + public property Units => prop_all | prop_list; + public property Results => prop_all | prop_list; + public property Listeners => prop_all | prop_list; + private property _Cache => prop_all | prop_list; + private property _Count => prop_all; +} + +sub CTOR { + my $this = shift; + $this->Units(\@_); +} + +sub restore { + my ($class,$data,$instance) = @_; + + $instance ||= $class->surrogate; + + $instance->callCTOR(); + + my %args = @$data; + + $instance->Units($args{Units}); + $instance->Results($args{Results}) if $args{Results}; + $instance->Listeners($args{Listeners}) if $args{Listeners}; +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar(Units => [$this->Units]); + $ctx->AddVar(Results => [$this->Results]) if $this->Results; + $ctx->AddVar(Listeners => [$this->Listeners]) if $this->Listeners; +} + +sub AddListener { + my ($this,$listener) = @_; + + $this->Listeners($this->Listeners,$listener); +} + +sub Prepare { + my ($this) = @_; + + my $count = 0; + my @cache; + + foreach my $Unit ($this->Units){ + my %info; + + # preload module + undef $@; + + eval "require $Unit" unless (ref $Unit); + + # handle loading errors + $Unit = new IMPL::Test::BadUnit($Unit,"Failed to load unit",$@) if $@; + + $info{Unit} = $Unit; + try { + $info{Tests} = [$Unit->List]; + } otherwise { + my $err = $@; + $Unit = $info{Unit} = new IMPL::Test::BadUnit( + $Unit->can('UnitName') ? + $Unit->UnitName : + $Unit, + "Failed to extract tests", + $err + ); + $info{Tests} = [$Unit->List]; + }; + $count += @{$info{Tests}}; + push @cache, \%info if @{$info{Tests}}; + } + + $this->_Count($count); + $this->_Cache(\@cache); +} + +sub Count { + my ($this) = @_; + return $this->_Count; +} + +sub Run { + my $this = shift; + + die new IMPL::InvalidOperationException("You must call the prepare method before running the plan") unless $this->_Cache; + + $this->_Tell(RunPlan => $this); + + my @resultsTotal; + + foreach my $info ($this->_Cache) { + $this->_Tell(RunUnit => $info->{Unit}); + + my $data; + undef $@; + eval { + $data = $info->{Unit}->StartUnit; + }; + + my @results; + + if (not $@) { + + foreach my $test (@{$info->{Tests}}) { + my $name = $test->Name; + + #protected creation of the test + $test = eval { $info->{Unit}->new($test); } || new IMPL::Test::BadUnit( + $info->{Unit}->can('UnitName') ? + $info->{Unit}->UnitName : + $info->{Unit}, + "Failed to construct the test $name", + $@ + ); + + # invoke the test + $this->_Tell(RunTest => $test); + my $result = $test->Run($data); + $this->_Tell(EndTest => $test,$result); + + push @results,$result; + } + } else { + my $e = $@; + my $badTest = new IMPL::Test::BadUnit( + $info->{Unit}->can('UnitName') ? + $info->{Unit}->UnitName : + $info->{Unit}, + "Failed to initialize the unit", + $@ + ); + foreach my $test (@{$info->{Tests}}) { + + $this->_Tell(RunTest => $badTest); + my $result = new IMPL::Test::Result( + Name => $test->Name, + State => IMPL::Test::Result::FAIL, + Exception => $e + ); + $this->_Tell(EndTest => $badTest,$result); + push @results,$result; + } + } + + eval { + $info->{Unit}->FinishUnit($data); + }; + + undef $@; + + push @resultsTotal, { Unit => $info->{Unit}, Results => \@results}; + + $this->_Tell(EndUnit => $info->{Unit},\@results); + } + + $this->Results(\@resultsTotal); + $this->_Tell(EndPlan => $this); +} + +sub _Tell { + my ($this,$what,@args) = @_; + + $_->$what(@args) foreach $this->Listeners; +} + +sub SaveXML { + my ($this,$out) = @_; + + my $h; + + if (ref $out eq 'GLOB') { + $h = $out; + } elsif ($out and not ref $out) { + open $h, ">", $out or die new IMPL::Exception("Failed to open file",$out); + } else { + die new IMPL::InvalidOperationException("Invalid output specified"); + } + + my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); + $s->Serialize($h,$this); +} + +sub LoadXML { + my ($self,$in) = @_; + + my $h; + + if (ref $in eq 'GLOB') { + $h = $in; + } elsif ($in and not ref $in) { + open $h, ">", $in or die new IMPL::Exception("Failed to open file",$in); + } else { + die new IMPL::InvalidOperationException("Invalid input specified"); + } + + my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); + return $s->Deserialize($h); +} + +sub xml { + my $this = shift; + my $str = ''; + + open my $h,'>',\$str or die new IMPL::Exception("Failed to create stream"); + $this->SaveXML($h); + undef $h; + return $str; +} + +sub LoadXMLString { + my $self = shift; + my $str = shift; + + open my $h,'<',\$str or die new IMPL::Exception("Failed to create stream"); + return $self->LoadXML($h); +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/Result.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,32 @@ +package IMPL::Test::Result; +use strict; +use warnings; + +use parent qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +use constant { + SUCCESS => 0, + FAIL => 1, + ERROR => 2 +}; + +BEGIN { + public property Name => prop_all; + public property State => prop_all; + public property Exception => prop_all; + public property TimeExclusive => prop_all; + public property TimeInclusive => prop_all; +} + +sub CTOR { + my ($this) = @_; + + $this->TimeInclusive(0) unless defined $this->TimeInclusive; + $this->TimeExclusive(0) unless defined $this->TimeExclusive; +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/SkipException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,8 @@ +package IMPL::Test::SkipException; + +use parent qw(IMPL::Test::FailException); + +__PACKAGE__->PassThroughArgs; + +1; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/Straps/ShellExecutor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,32 @@ +package IMPL::Test::Straps::ShellExecutor; +use strict; +use warnings; + +use parent qw(IMPL::Object IMPL::Object::Serializable); + +if ($^O =~ /win32/i) { + require Win32::Console; +} + +sub Execute { + my ($this,$file) = @_; + + my $h; + + if ($^O =~ /win32/i) { + Win32::Console::OutputCP(65001); + unless ( open $h,'-|',$file ) { + return undef; + } + binmode $h,':encoding(utf-8)'; + } else { + unless ( open $h,'-|',$file ) { + return undef; + } + } + + return $h; +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/TAPListener.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,70 @@ +package IMPL::Test::TAPListener; +use strict; +use warnings; + +use parent qw(IMPL::Object IMPL::Object::Serializable); +use IMPL::Class::Property; +use IMPL::Test::Result; + +BEGIN { + private property _Output => prop_all; + private property _testNo => prop_all; +} + +sub CTOR { + my ($this,$out) = @_; + + $this->_Output($out || *STDOUT); + $this->_testNo(1); +} + +sub RunPlan { + my ($this,$plan) = @_; + + my $out = $this->_Output; + + print $out "1..",$plan->Count,"\n"; +} + +sub EndPlan { + +} + +sub RunUnit { + my ($this,$unit) = @_; + + my $out = $this->_Output; + + print $out "#\n",join("\n",map "# $_", split /\n/, "Running unit: " . $unit->UnitName, ),"\n#\n"; +} + +sub EndUnit { + +} + +sub RunTest { + +} + +sub EndTest { + my ($this,$test,$result) = @_; + + my $out = $this->_Output; + my $n = $this->_testNo; + + $this->_testNo($n+1); + + print $out ( + $result->State == IMPL::Test::Result::SUCCESS ? + "ok $n " . join("\n# ", split(/\n/, $result->Name) ) + : + (eval { $result->Exception->isa('IMPL::Test::SkipException') } ? "ok $n #SKIP: " : "not ok $n ") . join("\n# ", split(/\n/, $result->Name.": ".$result->Exception || '') ) + ),"\n"; + +} + +sub save { + +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Test/Unit.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,158 @@ +package IMPL::Test::Unit; +use strict; +use warnings; + +use parent qw(IMPL::Object); +use IMPL::Class::Property; + +use Time::HiRes qw(gettimeofday tv_interval); + +use Error qw(:try); +use Carp qw(carp); +use File::Spec(); +use IMPL::Test::Result(); +use IMPL::Test::FailException(); +use IMPL::Exception(); + +BEGIN { + public property Name => prop_all; + public property Code => prop_all; +} + +sub CTOR { + my ($this,$info) = @_; + + die new IMPL::InvalidArgumentException("TestInfo should be supplied as an argument") unless $info; + + $this->Name($info->Name || 'Annon'); + $this->Code($info->Code)or die new IMPL::InvalidOperationException("Can't create test without entry point"); +} + +sub UnitName { + my ($self) = @_; + $self->toString; +} + +sub Cleanup { + my ($this,$session) = @_; + + $session->{$_} = $this->$_() foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1); + + 1; +} + +sub StartUnit { + my $class = shift; + + return {}; +} + +sub InitTest { + my ($this,$session) = @_; + + $this->$_($session->{$_}) foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData',undef,1); +} + +sub FinishUnit { + my ($class,$session) = @_; + + 1; +} + +sub List { + my $self = shift; + + return $self->get_meta('IMPL::Test::Unit::TestInfo',undef,1); # deep search with no criteria +} + +sub Run { + my ($this,$session) = @_; + + my $t = [gettimeofday]; + return try { + $this->InitTest($session); + my $code = $this->Code; + + + my $t0 = [gettimeofday]; + my $elapsed; + + try { + $this->$code(); + $elapsed = tv_interval ( $t0 ); + } finally { + # we need to call Cleanup anyway + $this->Cleanup($session); + }; + + return new IMPL::Test::Result( + Name => $this->Name, + State => IMPL::Test::Result::SUCCESS, + TimeExclusive => $elapsed, + TimeInclusive => tv_interval ( $t ) + ); + } catch IMPL::Test::FailException with { + my $e = shift; + return new IMPL::Test::Result( + Name => $this->Name, + State => IMPL::Test::Result::FAIL, + Exception => $e, + TimeInclusive => tv_interval ( $t ) + ); + } otherwise { + my $e = shift; + return new IMPL::Test::Result( + Name => $this->Name, + State => IMPL::Test::Result::ERROR, + Exception => $e, + TimeInclusive => tv_interval ( $t ) + ); + } +} + +sub GetResourceFile { + my ($this,@path) = @_; + + my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); + return File::Spec->catfile($cwd,@path); +} + +sub GetResourceDir { + my ($this,@path) = @_; + + my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); + return File::Spec->catdir($cwd,@path); +} + +package IMPL::Test::Unit::TestInfo; +use parent qw(IMPL::Object::Meta); +use IMPL::Class::Property; + +require IMPL::Exception; + +BEGIN { + public property Name => prop_all; + public property Code => prop_all; +} + +sub CTOR { + my ($this,$name,$code) = @_; + + $this->Name($name); + $this->Code($code) or die new IMPL::InvalidArgumentException("The Code is a required parameter"); +} + +package IMPL::Test::Unit::SharedData; +use parent qw(IMPL::Object::Meta); +use IMPL::Class::Property; + +BEGIN { + public property DataList => prop_all | prop_list; +} + +sub CTOR { + my $this = shift; + + $this->DataList(\@_); +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Transform.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,134 @@ +package IMPL::Transform; +use strict; + +use parent qw(IMPL::Object); + +use IMPL::lang qw(:declare); + + +BEGIN { + public _direct property templates => PROP_ALL; + public _direct property default => PROP_ALL; + public _direct property plain => PROP_ALL; + private _direct property _cache => PROP_ALL; +} + +sub CTOR { + my $this = shift; + my $args = @_ == 1 ? shift : { @_ }; + + $this->{$plain} = delete $args->{-plain}; + $this->{$default} = delete $args->{-default}; + + $this->{$templates} = $args; +} + +sub Transform { + my ($this,$object,@args) = @_; + + if (not ref $object) { + die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$plain}; + my $template = $this->{$plain}; + return $this->$template($object,@args); + } else { + + my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object); + + return $this->ProcessTemplate($template,$object,@args); + } +} + +sub MatchTemplate { + my ($this,$object) = @_; + my $class = $this->GetClassForObject( $object ); + + if (my $t = $this->{$_cache}->{$class} ) { + return $t; + } else { + $t = $this->{$templates}->{$class}; + + return $this->{$_cache}->{$class} = $t if $t; + + { + no strict 'refs'; + + my @isa = @{"${class}::ISA"}; + + while (@isa) { + my $sclass = shift @isa; + + $t = $this->{$templates}->{$sclass}; + + #cache and return + return $this->{$_cache}->{$class} = $t if $t; + + push @isa, @{"${sclass}::ISA"}; + } + ; + }; + } +} + +sub ProcessTemplate { + my ($this,$t,$obj,@args) = @_; + + return $this->$t($obj,@args); +} + +sub GetClassForObject { + my ($this,$object) = @_; + + return ref $object; +} + +package IMPL::Transform::NoTransformException; +use IMPL::declare { + base => { + 'IMPL::Exception' => sub { 'No transformation', @_ } + } +}; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Transform> - преобразование объектной структуры + +=head1 SYNOPSIS + +=begin code + +my $obj = new AnyObject; + +my $t = new Transform ( + SomeClass => sub { + my ($this,$object) = @_; + return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) }) + }, + DocClass => sub { + my ($this,$object) = @_; + return new DocPreview(Author => $object->Author, Text => $object->Data); + }, + -default => sub { + my ($this,$object) = @_; + return $object; + }, + -plain => sub { + my ($this,$object) = @_; + return $object; + } +); + +my $result = $t->Transform($obj); + +=end code + +=head1 DESCRIPTION + +Преобразование одного объекта к другому, например даных к их представлению. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/TypeKeyedCollection.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,140 @@ +package IMPL::TypeKeyedCollection; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::lang; +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + _items => PROP_RW | PROP_DIRECT, + _cache => PROP_RW | PROP_DIRECT, + _reverse => PROP_RW | PROP_DIRECT + ] +}; + +sub CTOR { + my ($this,$items,$reverse) = @_; + + $items = {} + unless ref($items) eq 'HASH'; + + $this->{$_items} = $items; + $this->{$_reverse} = $reverse; +} + +sub Get { + my ($this,$type) = @_; + + die ArgException->new(type => 'Invalid type', $type) + if not $type or ref($type); + + if(my $val = $this->{$_cache}{$type}) { + return $val; + } else { + if ($this->_reverse) { + my $val = $this->{$_items}{$type}; + + unless(defined $val) { + my $matching; + while ( my ($k,$v) = each %{$this->{$_items}}) { + if (isclass($k,$type) && (not($matching) || isclass($k,$matching)) ) { + $matching = $k; + $val = $v; + } + } + } + + return $this->{$_cache}{$type} = $val; + + } else { + no strict 'refs'; + + my @isa = $type; + + while (@isa) { + my $sclass = shift @isa; + + $val = $this->{$_items}{$sclass}; + + return($this->{$_cache}{$type} = $val) + if defined $val; # zeroes and empty strings are also valid + + push @isa, @{"${sclass}::ISA"}; + } + return; + } + } +} + +sub Set { + my ($this,$type,$value) = @_; + + die ArgException->new(type => 'Invalid type', $type) + if not $type or ref($type); + + $this->{$_items}{$type} = $value; + + delete $this->{$_cache}; + + return $value; +} + +sub Delete { + my ($this,$type) = @_; + + if(defined delete $this->{$_items}{$type} ) { + delete $this->{$_cache}; + return 1; + } + return; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::TypeKeyedCollection> - коллекция, ключами которой являются типы. + +=head1 SYNOPSIS + +=begin code + +package Foo; + +package Bar; +our @ISA = qw(Foo); + +package Baz; +our @ISA = qw(Foo); + +package main; +use IMPL::require { + TypeKeyedCollection => 'IMPL::TypeKeyedCollection' +}; + +my $col = TypeKeyedCollection->new({ + Foo => 'base', + Bar => 'BAAAR' +}); + +print $col->Get('Foo'); # 'base' +print $col->Get('Bar'); # 'BAAAR' +print $col->Get('Baz'); # 'base' + +=end code + +=head1 DESCRIPTION + +Использует иерархию классов для определения наиболее подходяжего значения в +коллекции. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Application.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,149 @@ +package IMPL::Web::Application; +use strict; +use warnings; + +use CGI; +use Carp qw(carp); +use IMPL::Const qw(:prop); + +use IMPL::declare { + require => { + Locator => 'IMPL::Web::AutoLocator', + TAction => 'IMPL::Web::Application::Action', + HttpResponse => 'IMPL::Web::HttpResponse', + TFactory => '-IMPL::Object::Factory', + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + InvalidOperationException => '-IMPL::InvalidOperationException', + Loader => 'IMPL::Code::Loader' + }, + base => [ + 'IMPL::Config' => '@_', + 'IMPL::Object::Singleton' => undef + ], + props => [ + baseUrl => PROP_RW, + actionFactory => PROP_RW, + handlers => PROP_RW | PROP_LIST, + securityFactory => PROP_RW, + output => PROP_RW, + location => PROP_RO, + _handler => PROP_RW + ] +}; + +sub CTOR { + my ($this) = @_; + + die IMPL::InvalidArgumentException->new( "handlers", + "At least one handler should be supplied" ) + unless $this->handlers->Count; + + $this->baseUrl('/') unless $this->baseUrl; + + $this->actionFactory(TAction) unless $this->actionFactory; + $this->location(Locator->new(base => $this->baseUrl)); +} + +sub CreateSecurity { + my $factory = shift->securityFactory; + return $factory ? $factory->new() : undef; +} + +sub ProcessRequest { + my ($this,$q) = @_; + + die ArgException->new(q => 'A query is required') + unless $q; + + my $handler = $this->_handler; + unless ($handler) { + $handler = _ChainHandler( $_, $handler ) foreach $this->handlers; + $this->_handler($handler); + } + + my $action = $this->actionFactory->new( + query => $q, + application => $this, + ); + + eval { + my $result = $handler->($action); + + die InvalidOperationException->new("Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted.") + unless eval { $result->isa(HttpResponse) }; + + $result->PrintResponse( $this->output ); + }; + + $action->Dispose(); + + if ($@) { + my $e = $@; + + HttpResponse->InternalError( + type => 'text/plain', + charset => 'utf-8', + body => $e + )->PrintResponse( $this->output ); + + } +} + +sub _ChainHandler { + my ( $handler, $next ) = @_; + + if ( ref $handler eq 'CODE' ) { + return sub { + my ($action) = @_; + return $handler->( $action, $next ); + }; + } + elsif ( eval { $handler->can('Invoke') } ) { + return sub { + my ($action) = @_; + return $handler->Invoke( $action, $next ); + }; + } + elsif ( eval { $handler->isa(TFactory) } ) { + return sub { + my ($action) = @_; + my $inst = $handler->new(); + return $inst->Invoke( $action, $next ); + } + } + elsif ( $handler + and not ref $handler + and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/ ) + { + my $class = $2; + if ( not $1 ) { + Loader->safe->Require($class); + die IMPL::InvalidArgumentException->( + "An invalid handler supplied", $handler + ) unless $class->can('Invoke'); + } + + return sub { + my ($action) = @_; + my $inst = $class->new(); + return $inst->Invoke( $action, $next ); + }; + } + else { + die new IMPL::InvalidArgumentException( "An invalid handler supplied", + $handler ); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application> Базовай класс для веб-приложения + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Application/Action.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,227 @@ +package IMPL::Web::Application::Action; +use strict; + +use Carp qw(carp); +use URI; +use JSON; + +use IMPL::lang; +use IMPL::Const qw(:prop); +use IMPL::Web::CGIWrapper(); +use IMPL::declare { + require => { + Disposable => '-IMPL::Object::Disposable', + HttpResponse => 'IMPL::Web::HttpResponse' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Disposable' => undef + ], + props => [ + application => PROP_RW, + security => PROP_RW, + query => PROP_RO, + context => PROP_RW, + _jsonData => PROP_RW, + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->context({}); + $this->security($this->application->CreateSecurity()); +} + +sub cookie { + my ($this,$name,$rx) = @_; + + $this->_launder(scalar( $this->query->cookie($name) ), $rx ); +} + +sub header { + my ($this,$header) = @_; + + $this->query->https ? $this->query->https($header) : $this->query->http($header); +} + +sub isSecure { + shift->query->https ? 1 : 0; +} + +sub isJson { + return shift->contentType =~ m{^application/json} ? 1 : 0; +} + +sub param { + my ($this,$name,$rx) = @_; + + my $value; + + if ( + $this->requestMethod eq 'GET' + or + $this->contentType eq 'multipart/form-data' + or + $this->contentType eq 'application/x-www-form-urlencoded' + ) { + $value = scalar( $this->query->param($name) ); + } else { + $value = scalar( $this->query->url_param($name) ); + } + + $this->_launder($value, $rx ); +} + +sub urlParam { + my ($this,$name,$rx) = @_; + + $this->_launder(scalar( $this->query->url_param($name) ), $rx); +} + +sub urlParams { + shift->query->url_param(); +} + +sub rawData { + my ($this, $decode) = @_; + + local $IMPL::Web::CGIWrapper::NO_DECODE = $decode ? 0 : 1; + if ($this->requestMethod eq 'POST') { + return $this->query->param('POSTDATA'); + } elsif($this->requestMethod eq 'PUT') { + return $this->query->param('PUTDATA'); + } +} + +sub jsonData { + my ($this) = @_; + + if ($this->isJson ) { + my $data = $this->_jsonData; + unless($data) { + $data = JSON->new()->decode($this->rawData('decode encoding')); + $this->_jsonData($data); + } + + return $data; + } + + return; +} + +sub requestMethod { + my ($this) = @_; + return $this->query->request_method; +} + +sub contentType { + return shift->query->content_type(); +} + +sub pathInfo { + my ($this) = @_; + return $this->query->path_info; +} + +sub baseUrl { + my ($this) = @_; + + return $this->query->url(-base => 1); +} + +sub applicationUrl { + shift->application->baseUrl; +} + +sub applicationFullUrl { + my ($this) = @_; + + return URI->new_abs($this->application->baseUrl, $this->query->url(-base => 1)); +} + +# creates an url that contains server, schema and path parts +sub CreateFullUrl { + my ($this,$path) = @_; + + return $path ? URI->new_abs($path,$this->applicationFullUrl) : $this->applicationFullUrl; +} + +# creates an url that contains only a path part +sub CreateAbsoluteUrl { + my ($this,$path) = @_; + + return $path ? URI->new_abs($path,$this->applicationUrl) : $this->applicationUrl; +} + +sub Redirect { + my ($this,$path) = @_; + return HttpResponse->Redirect( + location => $this->CreateFullUrl($path) + ); +} + +sub _launder { + my ($this,$value,$rx) = @_; + + if ( $value ) { + if ($rx) { + if ( my @result = ($value =~ m/$rx/) ) { + return @result > 1 ? \@result : $result[0]; + } else { + return; + } + } else { + return $value; + } + } else { + return; + } +} + +sub Dispose { + my ($this) = @_; + + $this->security->Dispose() + if $this->security and $this->security->can('Dispose'); + + $_->Dispose() foreach grep is($_,Disposable), values %{$this->context}; + + $this->next::method(); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::Action> - Обертка вокруг C<CGI> запроса. + +=head1 DESCRIPTION + +C<[Infrastructure]> +Свзяывет CGI запрос, приложение, орабатывающее его и ответ, который будет отправлен клиенту. + +=head1 MEMBERS + +=head2 C<CTOR(%args)> + +Инициализирует новый экземпляр. Именованными параметрами передаются значения +свойств. + +=head2 C< [get]application> + +Экземпляр приложения создавшего текущий объект + +=item C< [get] query > + +Экземпляр C<CGI> запроса + +=back + + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Application/HttpResponseResource.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,32 @@ +package IMPL::Web::Application::HttpResponseResource; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + HttpResponse => 'IMPL::Web::HttpResponse' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Web::Application::ResourceInterface' => undef + ], + props => [ + response => PROP_RW + ] +}; + +sub CTOR { + my ($this,%args) = @_; + + $this->response($args{response} || HttpResponse->NoContent); +} + +sub FetchChildResource { + return shift; +} + +sub InvokeHttpVerb { + return shift->response; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Application/Resource.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,402 @@ +package IMPL::Web::Application::Resource; +use strict; + +use constant { + ResourceClass => __PACKAGE__ +}; +use Scalar::Util qw(blessed); + +use IMPL::lang qw(:hash :base); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + OpException => '-IMPL::InvalidOperationException', + NotFoundException => 'IMPL::Web::NotFoundException', + ResourceInterface => '-IMPL::Web::Application', + HttpResponse => 'IMPL::Web::HttpResponse', + HttpResponseResource => 'IMPL::Web::Application::HttpResponseResource', + Loader => 'IMPL::Code::Loader' + }, + base => [ + 'IMPL::Web::Application::ResourceBase' => '@_' + ], + props => [ + access => PROP_RW, + verbs => PROP_RW, + children => PROP_RW + ] +}; + +__PACKAGE__->static_accessor(verbNames => [qw(get post put delete options head)]); +__PACKAGE__->static_accessor(httpMethodPrefix => 'Http'); + +sub CTOR { + my ($this, %args) = @_; + + my %verbs; + my $httpPrefix = $this->httpMethodPrefix; + + foreach my $verb (@{$this->verbNames}) { + my $method = exists $args{$verb} ? $args{$verb} : $this->can($httpPrefix . ucfirst($verb)); + $verbs{$verb} = $method + if $method; + } + + hashApply(\%verbs,$args{verbs}) + if ref($args{verbs}) eq 'HASH' ; + + $this->children($args{children} || $this->GetChildResources()); + + $this->access($args{access}) + if $args{access}; + + $this->verbs(\%verbs); +} + +sub _isInvokable { + my ($this,$method) = @_; + + return + (blessed($method) and $method->can('Invoke')) || + ref($method) eq 'CODE' +} + +sub _invoke { + my ($this,$method,@args) = @_; + + if(blessed($method) and $method->can('Invoke')) { + return $method->Invoke($this,@args); + } elsif(ref($method) eq 'CODE' || (not(ref($method)) and $this->can($method))) { + return $this->$method(@args); + } else { + die OpException->new("Can't invoke the specified method: $method"); + } +} + +sub HttpGet { + shift->model; +} + +sub AccessCheck { + my ($this,$verb) = @_; + + $this->_invoke($this->access,$verb) + if $this->access; +} + +sub Fetch { + my ($this,$childId) = @_; + + my $children = $this->children + or die NotFoundException->new( $this->location->url, $childId ); + + if (ref($children) eq 'HASH') { + if(my $child = $children->{$childId}) { + return $this->_isInvokable($child) ? $this->_invoke($child, $childId) : $child; + } else { + die NotFoundException->new( $this->location->url, $childId ); + } + } elsif($this->_isInvokable($children)) { + return $this->_invoke($children,$childId); + } else { + die OpException->new("Invalid resource description", $childId, $children); + } +} + +sub FetchChildResource { + my ($this,$childId) = @_; + + my $info = $this->Fetch($childId); + + return $info + if (is($info,ResourceInterface)); + + $info = { + response => $info, + class => HttpResponseResource + } + if is($info,HttpResponse); + + return $this->CreateChildResource($info, $childId) + if ref($info) eq 'HASH'; + + die OpException->new("Invalid resource description", $childId, $info); +} + +sub CreateChildResource { + my ($this,$info, $childId) = @_; + + my $params = hashApply( + { + parent => $this, + id => $childId, + request => $this->request, + class => ResourceClass + }, + $info + ); + + $params->{model} = $this->_invoke($params->{model}) + if $this->_isInvokable($params->{model}); + + my $factory = Loader->default->Require($params->{class}); + + return $factory->new(%$params); +} + +sub GetChildResources { + return {}; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::Resource> - Ресурс C<REST> веб приложения + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + Resource => 'IMPL::Web::Application::Resource', + Security => 'IMPL::Security', + NotFoundException => 'IMPL::Web::NotFoundException', + ForbiddenException => 'IMPL::Web::ForbiddenException' +}; + +my $model = Resource->new( + get => sub { }, + verbs => { + # non-standart verbs placed here + myverb => sub { } + }, + #child resources can be a hash + children => { + user => { + # a resource class may be specified optionally + # class => Resource, + model => sub { + return Security->principal + }, + # the default get implementation is implied + # get => sub { shift->model }, + access => sub { + my ($this,$verb) = @_; + die ForbiddenException->new() + if Security->principal->isNobody + } + }, + catalog => { + get => sub { + my $ctx = shift->application->ConnectDb()->AutoPtr(); + + return $ctx->products->find_rs({ in_stock => 1 }); + }, + # chid resource may be created dynamically + children => sub { + # binds model against the parent reource and id + my ($this,$id) = @_; + + ($id) = ($id =~ /^(\w+)$/) + or die NotFoundException->new($id); + + my $ctx = shift->application->ConnectDb()->AutoPtr(); + + my $item = $ctx->products->fetch($id); + + die NotFoundException->new() + unless $item; + + # return parameters for the new resource + return { + model => $item, + get => sub { shift->model } + }; + } + }, + # dynamically binds whole child resource. The result of binding is + # the new resource or a hash with arguments to create one + posts => sub { + my ($this,$id) = @_; + + # this approach can be used to create a dynamic resource relaying + # on the type of the model + + return Resource->new( + id => $id, + parent => $this, + get => sub { shift->model } + ); + + # ditto + # parent and id will be mixed in automagically + # return { get => sub { shift->model} } + }, + post_only => { + get => undef, # remove GET verb implicitly + post => sub { + my ($this) = @_; + } + } + } +); + +=end code + +Альтернативный вариант для создания класса ресурса. + +=begin code + +package MyResource; + +use IMPL::declare { + require => { + ForbiddenException => 'IMPL::Web::ForbiddenException' + }, + base => [ + 'IMPL::Web::Application::Resource' => '@_' + ] +}; + +sub ds { + my ($this) = @_; + + $this->context->{ds} ||= $this->application->ConnectDb(); +} + +sub InvokeHttpVerb { + my $this = shift; + + $this->ds->Begin(); + + my $result = $this->next::method(@_); + + # in case of error the data context will be disposed and the transaction + # will be reverted + $this->ds->Commit(); + + return $result; +} + +# this method is inherited by default +# sub HttpGet { +# shift->model +# +# } + +sub HttpPost { + my ($this) = @_; + + my %data = map { + $_, + $this->request->param($_) + } qw(name description value); + + die ForbiddenException->new("The item with the scpecified name can't be created'") + if(not $data{name} or $this->ds->items->find({ name => $data{name})) + + $this->ds->items->insert(\%data); + + return $this->NoContent(); +} + +sub Fetch { + my ($this,$childId) = @_; + + my $item = $this->ds->items->find({name => $childId}) + or die NotFoundException->new(); + + # return parameters for the child resource + return { model => $item, role => "item food" }; +} + +=end code + +=head1 MEMBERS + +=head2 C<[get,set]verbs> + +Хеш с C<HTTP> методами. При попытке вызова C<HTTP> метода, которого нет в этом +хеше приводит к исключению C<IMPL::Web::NotAllowedException>. + +=head2 C<[get,set]access> + +Метод для проверки прав доступа. Если не задан, то доспуп возможен для всех. + +=head2 C<[get,set]children> + +Дочерние ресурсы. Дочерние ресурсы могут быть описаны либо в виде хеша, либо +в виде метода. + +=head3 C<HASH> + +Данный хещ содержит в себе таблицу идентификаторов дочерних ресурсов и их +описаний. + +Описание каждого ресурса представляет собой либо функцию, либо параметры для +создания ресурса C<CraeteChildResource>. Если описание в виде функции, то она +должна возвращать либо объект типа ресурс либо параметры для его создания. + +=head3 C<CODE> + +Если дочерние ресурсы описаны в виде функции (возможно использовать имя метода +класса текущего ресурса), то для получения дочернего ресурса будет вызвана +функция с параметрами C<($this,$childId)>, где C<$this> - текущий ресурс, +C<$childId> - идентификатор дочернего ресурса, который нужно вернуть. + +Данная функция должна возвратить либо объект типа ресурс, либо ссылку на хеш с +параметрами для создания оного при помощи метода +C<CreateChildResource($params,$childId)>. + +=head2 C<[virtual]Fetch($childId)> + +Метод для получения дочернего ресурса. + +Возвращает параметры для создания дочернего ресурса, либо уже созданный ресурс. +Создание дочернего ресурса происходит при помощи метода C<CreateChildResource()> +который добавляет недостающие параметры к возвращенным в данным методом и +создает новый ресурс + +=head2 C<CreateChildResource($params,$id)> + +Создает новый дочерний ресурс с указанным идентификатором и параметрами. +Автоматически заполняет параметры + +=over + +=item * C<parent> + +=item * C<id> + +=item * C<request> + +=back + +Тип создаваемого ресурса C<IMPL::Web::Application::Resource>, либо указывается +в параметре C<class>. + +=head2 C<[virtual]HttpGet()> + +Реализует C<HTTP> метод C<GET>. По-умолчанию возвращает модель. + +Данный метод нужен для того, чтобы ресурс по-умолчанию поддерживал метод C<GET>, +что является самым частым случаем, если нужно изменить данное поведение, нужно: + +=over + +=item * Передать в параметр конструктора C<get> значение undef + +=item * Переопределить метод C<HttpGet> + +=item * При проверке прав доступа выдать исключение + +=back + +=cut +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Application/ResourceBase.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,262 @@ +package IMPL::Web::Application::ResourceBase; +use strict; + +use URI; +use Carp qw(carp); +use IMPL::lang qw(:hash :base); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException', + OperationException => '-IMPL::InvalidOperationException', + NotAllowedException => 'IMPL::Web::NotAllowedException', + + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Web::Application::ResourceInterface' => undef + ], + props => [ + request => PROP_RO, + application => PROP_RO, + parent => PROP_RO, + model => PROP_RO, + id => PROP_RO, + location => PROP_RO, + role => PROP_RO | PROP_LIST + ] +}; + +sub CTOR { + my ( $this, %args ) = @_; + + die ArgumentException->new(request => 'A request object must be specified') + unless $args{request}; + + $this->request( $args{request} ); + $this->parent( $args{parent} ) if $args{parent}; + $this->model( $args{model} ) if $args{model}; + $this->id( $args{id} ) if $args{id}; + $this->application( $args{request}->application ); + +# если расположение явно не указано, то оно вычисляется автоматически, +# либо остается не заданным + $this->location( $args{location} + || eval { $this->parent->location->Child( $this->id ) } ); + + if (my $role = $args{role}) { + if (ref($role) eq 'ARRAY') { + $this->role($role); + } elsif (not ref($role)) { + $this->role(split(/\s+/, $role)); + } else { + die ArgumentException->new( role => 'A invalid value is provided, expected ARRAY or SCALAR'); + } + } +} + +sub InvokeHttpVerb { + my ( $this, $verb ) = @_; + + my $operation = $this->verbs->{ lc($verb) }; + + die NotAllowedException->new( + allow => join( ',', $this->GetAllowedMethods ) ) + unless $operation; + + $this->AccessCheck($verb); + my $request = $this->request; + +# в случае, когда один ресурс вызывает HTTP метод другого ресурса, нужно +# сохранить оригинальный resourceLocation + $request->context->{resourceLocation} ||= $this->location; + +# это свойство специфично только для REST приложений. +# сохранение текущего ресурса не повлечет за собой существенных расходов, +# т.к. они просто освободятся несколько позже. + if ( not $request->context->{resource} ) { + $request->context->{resource} = $this; + } + + return _InvokeDelegate( $operation, $this, $request ); +} + +sub security { + shift->request->security +} + +sub context { + shift->request->context +} + +sub verbs { + {} # возвращаем пстой список операций +} + +sub GetAllowedMethods { + map( uc, keys %{ shift->verbs } ); +} + +sub AccessCheck { + +} + +sub Seek { + my ($this, $role) = @_; + + my @roles; + + if (ref($role) eq 'ARRAY') { + @roles = @{$role}; + } elsif (not ref($role)) { + @roles = split(/\s+/, $role); + } else { + die ArgumentException->new( role => 'A invalid value is provided, expected ARRAY or SCALAR'); + } + + + for(my $r = $this; $r; $r = $r->parent) { + return $r if $r->HasRole(@roles); + } + return; +} + +sub HasRole { + my ($this, @roles) = @_; + my %cache = map { $_, 1 } @{$this->role}; + return scalar(grep not($cache{$_}), @roles) ? 0 : 1; +} + +sub _InvokeDelegate { + my $delegate = shift; + + return $delegate->(@_) if ref $delegate eq 'CODE'; + return $delegate->Invoke(@_) if eval { $delegate->can('Invoke') }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::Resource> - Web-ресурс. + +=head1 SYNOPSIS + +Класс для внутреннего использования. Объединяет в себе контракт и модель данных. +Основная задача - обработать поступающий от контроллера запрос на вызов C<HTTP> +метода. + +Экземпляры данного класса передаются в качестве параметров делегатам +осуществляющим привязку к модели в C<IMPL::Web::Application::ResourceContract> +и C<IMPL::Web::Application::OperationContract>. + +=head1 DESCRIPTION + +Весь функционал ресурса, поддерживаемые им C<HTTP> методы определяются +контрактом. Однако можно реализовывать ресурсы, которые не имеют контракта +или он отличается от того, что предоставляется стандартно +C<IMPL::Web::Application::ResourceContract>. + +Каждый ресурс является контейнером, тоесть позволяет получить дочерний ресурс +по идентифифкатору, если таковой имеется, тоесть ресурс, у которого нет дочерних +ресурсов на самом деле рассматривается как пустой контейнер. + +С ресурсом непосредственно взаимодействует котроллер запросов +C<IMPL::Web::Handler::RestController>, вызывая два метода. + +=over + +=item * C<FetchChildResource($childId)> + +Данный метод возвращает дочерний ресурс, соответствующий C<$childId>. +Текущая реализация использует метод C<FindChildResourceInfo> контракта текущего +ресурса, после чего создает дочерний ресурс. + +Если дочерний ресурс не найден, вызывается исключение +C<IMPL::Web::NotFoundException>. + +=item * C<InvokeHttpVerb($verb,$action)> + +Обрабатывает запрос к ресурсу. Для этого используется контракт ресурса, в +нем выбирается соответсвующий C<IMPL::Web::Application::OperationContract>. +Затем найденный контракт для указанной операции используется для обработки +запроса. + +=back + +Если объект реализует два вышеуказанных метода, он является веб-ресурсом, а +детали его реализации, котнракт и прочее уже не важно, поэтому можно реализовать +собственный класс ресурса, например унаследованный от +C<IMPL::Web::Application::CustomResource>. + +=head1 MEMBERS + +=head2 C<[get]request> + +Объект C<IMPL::Web::Application::Action> представляющий запрос к серверу. + +=head2 C<[get]application> + +Ссылка на приложение, к которому относится данный ресурс. Получается +автоматически из объекта запроса. + +=head2 C<[get]contract> + +Обязательное свойство для ресурса, ссылается, на контракт, соответствующий +данному ресурсу, используется для выполнения C<HTTP> методов и получения +дочерних ресурсов. + +=head2 C<[get]id> + +Обязательное свойство ресурса, идентифицирует его в родительском контейнере, +для корневого ресурса может иметь произвольное значение. + +=head2 C<[get]parent> + +Ссылка на родительский ресурс, для корневого ресурса не определена. + +=head2 C<[get]model> + +Ссылка на объект предметной области, представляемый данным ресурсом. Данное +свойство не является обязательным и может быть не задано. + +=head2 C<[get]location> + +Объект типа C<IMPL::Web::AutoLocator> или аналогичный описывающий адрес текущего +ресурса, может быть как явно передан при создании ресурса, так и вычислен +автоматически (только для ресурсов имеющих родителя). Следует заметить, что +адрес ресурса не содержит параметров запроса, а только путь. + +=head2 C<[get,list]role> + +Список ролей ресурса. Роль это условный маркер, который позволяет определить +функции выполняемые ресурсом, например контейнер, профиль пользователя и т.п. + +Используется при построении цепочек навигации, а также при поиске с использованием +метода C<seek>. + +=head2 C<seek($role)> + +Ищет ресурс в цепочке родителей (включая сам ресурс) с подходящими ролями. + +Роли могут быть переданы в виде массива или строки, где роли разделены пробелами + +=head2 C<[get]FetchChildResource($id)> + +Возвращает дочерний ресурс, по его идентификатору. + +Данная реализация использует контракт текущего ресурса для поиска информации о +дочернем ресурсе C<< $this->contract->FindChildResourceInfo($id) >>. + +Затем осуществляется привязка к моделе, тоесть, выполняется делегат, для +получения модели дочернего ресурса, а затем осуществляется привязка к контракту, +при этом в делегат, который должен вернуть контракт дочернего ресурса передаются +текущий ресурc и модель дочернего ресурса. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Application/ResourceInterface.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,89 @@ +package IMPL::Web::Application::ResourceInterface; +use strict; + +use IMPL::require { + Exception => 'IMPL::Exception', + NotImplException => '-IMPL::NotImplementedException' +}; + +sub InvokeHttpVerb { + die NotImplException->new(); +} + +sub FetchChildResource { + die NotImplException->new(); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::ResourceInterface> - Интерфейс для Web-ресурса. + +=head1 SYNOPSIS + +=begin code + +package MyApp::Web::Resource; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + NotAllowedException => 'IMPL::Web::NotAllowedException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Web::Application::ResourceInterface' => undef + ], + props => [ + model => PROP_ALL + ] +}; + +sub InvokeHttpVerb { + my ($this,$verb,$action) = @_; + + if($verb eq 'GET') { + return $this->model; + } else { + die NotAllowedException->new(allow => 'GET'); + } +} + +sub FetchChildResource { + # no child resources + return; +} + +=end code + +=head1 DESCRIPTION + +Данный модуль объявляет только интерфейс, тоесть в нем есть заглушки для функций +которые необходимо реализовать. + +Для создания класса, который может быть использоваться для создания Web-ресурсов +нужно унаследовать данный интерфейс и реализовать его методы. + +=head1 MEMBERS + +=head2 C<InvokeHttpVerb($verb,$action)> + +Выполняет операцию над ресурсом и возвращает результат ее выполнения. +Результатом может быть произвольный объект, который будет передан по цепочке +обработчиков приложения для формирования ответа вервера, либо +C<IMPL::Web::HttpResponse>, который описывает (не обязательно полностью) ответ. +В любом случае результат будет передан далее в цепочку обработчиков и может +быть изменен. + +=head2 C<FetchChildResource($childId)> + +Используется для получения дочернего ресурса (который содержится в данном +контейнере). Метод должен возвращать либо Web-ресурс +C<IMPL::Web::Application::ResourceInterface>, либо C<undef> если дочерний ресурс +не найден. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/AutoLocator.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,241 @@ +package IMPL::Web::AutoLocator; +use strict; + +use overload '""' => 'toString'; + +use IMPL::Const qw(:prop); +use IMPL::lang qw(:hash); +use IMPL::clone qw(clone); +use URI; +use URI::Escape; +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => '@_' + ], + props => [ + base => PROP_RO, + view => PROP_RW, + query => PROP_RW, + hash => PROP_RW + ] +}; + +sub Clone { + my $this = shift; + + return clone($this); +} + +sub Child { + my $this = shift; + my $child = shift or die ArgumentException->new("a child resource identifier is required"); + die ArgumentException->new("a child resource can't be a reference") if ref $child; + + # safe + #$child = uri_escape_utf8($child); + + my %args; + + $args{base} = $this->base =~ /\/$/ ? $this->base . $child : $this->base . '/' . $child; + $args{view} = $this->view if $this->view; + $args{hash} = $this->hash if $this->hash; + + if (@_) { + my $query = shift; + + $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; + } + + return $this->new(%args); +} + +sub Sibling { + my $this = shift; + my $child = shift or die ArgumentException->new("a child resource identifier is required"); + die ArgumentException->new("a child resource can't be a reference") if ref $child; + + # safe + #$child = uri_escape($child); + + my %args; + + if($this->base =~ /(.*?)(\/[^\/]*)?$/) { + $args{base} = join('/',$1,$child); + } else { + $args{base} = $child; + } + + $args{view} = $this->view if $this->view; + $args{hash} = $this->hash if $this->hash; + + if (@_) { + my $query = shift; + + $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; + } + + return $this->new(%args); + +} + +sub Query { + my ($this,$query) = @_; + + my %args; + + $args{base} = $this->base; + $args{view} = $this->view if $this->view; + $args{hash} = $this->hash if $this->hash; + $args{query} = ref $query eq 'HASH' ? hashMerge($this->query,$query) : $query; + + return $this->new(%args); +} + +sub SetView { + my ($this,$newView) = @_; + + $this->view($newView); + + return $this; +} + +sub url { + my ($this) = @_; + + my $url = URI->new($this->view ? $this->base . "." . $this->view : $this->base); + $url->query_form($this->query); + $url->fragment($this->hash); + + return $url; +} + +sub ToAbsolute { + my ($this,$baseUrl) = @_; + + return URI->new_abs( $this->url, $baseUrl ); +} + +sub toString { + shift->url->as_string(); +} + +sub AUTOLOAD { + our $AUTOLOAD; + + (my $method) = ($AUTOLOAD =~ m/(\w+)$/); + + return if $method eq 'DESTROY'; + + my $this = shift; + return $this->Child($method,@_); +} + + + +1; + +__END__ + +=head1 NAME + +C<IMPL::Web::AutoLocator> - Обертка вокруг адреса ресурса. + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + Locator => 'IMPL::Web::AutoLocator' +}; + +my $bugTracker = Locator->new(base => "http://myhost.org/bugzilla")->SetView("cgi"); + +my $bug = $bugTracker->show_bug({id = 1}); + +my $wikiPages = Locator->new(base => "http://myhost.org/wiki/bin/view"); + +my $page = $wiki->Main->HowTo; + +my $images = Locator->new(base => "http://static.myhost.org/images", view => "png"); + +my $editIco = $images->icons->small->edit; + +=end code + +=head1 DESCRIPTION + +Для удобстав навигации по ресурсам, полностью отражает классическую структуру +иерархически организованных ресурсов. позволяет гибко работать с параметрами +запроса и хешем. Для постоты чтения реализует метод C<AUTOLOAD> для доступа +к дочерним ресурсам. + +=head1 MEMBERS + +=head2 C<CTOR(%args)> + +Создает новый объект расположение. Позволяет задать путь, расширение, параметры +запроса и фрагмент ресурса. + +=over + +=item * C<base> + +Строка с базовым адресом для дочерних ресурсов. + +=item * C<view> + +Задает суфикс, обозначающий представление ресурса, аналогично расширению у +файлов. Данный суффикс может использоваться контроллером для выбора +представления ресурса. + +=item * C<query> + +Ссылка на хеш с параметрами запроса + +=item * C<hash> + +Часть C<uri> обозначающая фрагмент документа (все, что идет после символа C<#>). + +=back + +=head2 C<Child($child[,$query])> + +Получает расположение дочернего ресурса. При этом cоздается новый объект адреса ресурса. + +=head2 C<SetView($view)> + +Позволяет указать представление (расширение) у текущего адреса ресурса. Изменяет +представление и возвращает измененный адрес ресурса. + +=head2 C<[get]base> + +Базовый адрес, относительно которого будут получены дочерние ресурсы. + +=head2 C<[get,set]view> + +Представление для ресурсов, аналогично расширению у файлов. + +=head2 C<[get,set]query> + +Ссылка на хеш с параметрами для C<GET> запроса. + +=head2 C<[get,set]hash> + +Часть адреса ресурса, отвечающая за фрагмент. + +=head2 C<[get]url> + +Объект C<URI> для текущего адреса. + +=head2 C<AUTLOAD> + +Перенаправляет вызовы методов в метод C<Child> передавая первым параметром имя метода. + +=cut +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/BadRequestException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,30 @@ +package IMPL::Web::BadRequestException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + } +}; + +use IMPL::Resources::Strings { + message => "The request could not be understood due to malformed syntax" +}; + +sub status { + "400 Bad Request"; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::BadRequestException> - 400 Bad Request + +=head1 DESCRIPTION + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/CGIApplication.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,29 @@ +package IMPL::Web::CGIApplication; +use strict; + +use IMPL::declare { + require => { + CGIWrapper => 'IMPL::Web::CGIWrapper' + }, + base => [ + 'IMPL::Web::Application' => '@_' + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->output(\*STDOUT) unless $this->output; +} + +sub Run { + my ($this) = @_; + + my $query = CGIWrapper->new(); + + $query->charset('utf-8'); + + $this->ProcessRequest($query); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/CGIWrapper.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,75 @@ +package IMPL::Web::CGIWrapper; +use strict; + +use parent qw(CGI); +use Encode; + +our $NO_DECODE = 0; + +sub param { + my $this = shift; + + return $this->SUPER::param(@_) if $NO_DECODE; + + if (wantarray) { + my @result = $this->SUPER::param(@_); + + return map Encode::is_utf8($_) + ? $_ + : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result; + } + else { + my $result = $this->SUPER::param(@_); + + return Encode::is_utf8($result) + ? $result + : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC ); + } + +} + +sub upload { + my $this = shift; + + local $NO_DECODE = 1; + my $oldCharset = $this->charset(); + $this->charset('ISO-8859-1'); + + my $fh = $this->SUPER::upload(@_); + + $this->charset($oldCharset); + return $fh; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::CGIWrapper> - обетрка вокруг стандартного объекта C<CGI> + +=head1 DESCRIPTION + +Наследуется от C<CGI>, и переопределяет метод C<param> для декодирования +строковых параметров. В остальном функциональность аналогична стандартному +модулю C<CGI>. + +=head1 MEMBERS + +=head2 C<$NO_DECODE> + +Глобальная переменная для отключения декодирования параметров. + +=begin code + +{ + local $IMPL::Web::CGIWrapper::NO_DECODE = 1; + my $raw = $q->param('binary'); +} + +=end code + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/DOM/FileNode.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,193 @@ +package IMPL::Web::DOM::FileNode; +use parent qw(IMPL::DOM::Node); + +__PACKAGE__->PassThroughArgs; + +use IMPL::Class::Property; +use File::Temp qw(tempfile); + +BEGIN { + public property parameterName => { + get => sub { + my ($this) = @_; + $this->_parameterName() or + $this->_parameterName( + join '/', ( map { + (defined $_->nodeProperty('instanceId')) ? + $_->nodeName . '['.$_->nodeProperty('instanceId').']': + $_->nodeName + } $this->_selectParents, $this ) + ); + } + }; + private property _parameterName => prop_all; + public property fileName => { + get => sub { + my ($this) = @_; + return $this->document->query->param($this->parameterName); + } + }; + public property fileHandle => { + get => sub { + my ($this) = @_; + return $this->document->query->upload($this->parameterName); + } + }; +} + +sub invokeTempFile { + my ($this,$sub,$target) = @_; + + die new IMPL::InvalidArgumentException("A reference to a function should be specified") unless $sub && ref $sub eq 'CODE'; + + $target ||= $this; + + my $query = $this->document->nodeProperty('query') or die new IMPL::InvalidOperationException("Failed to get a CGI query from the document"); + my $hFile = $query->upload($this->parameterName) or die new IMPL::IOException("Failed to open the uploaded file",$query->cgi_error,$this->parameterName,$this->nodeProperty('instanceId')); + + my ($hTemp,$tempFileName) = tempfile(); + binmode($hTemp); + + print $hTemp $_ while <$hFile>; + + $hTemp->flush(); + seek $hTemp, 0,0; + { + local $_ = $tempFileName; + $sub->($this,$tempFileName,$hTemp); + } +} + +sub _selectParents { + my ($node) = @_; + + my @result; + + unshift @result, $node while $node = $node->parentNode; + + return @result; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::DOM::FileNode> - узел, использующийся для представления параметра запроса в котором передан файл. + +=head1 SINOPSYS + +=begin code xml + +<!-- input.schema.xml --> +<schema> + <SimpleType type="file" nativeType="IMPL::Web::DOM::FileNode"/> + <ComplexNode name="user"> + <Node type="file" name="avatar"/> + </ComplexNode> +</schema> + +=end code xml + +=begin code + +# handle.pl +use IMPL::DOM::Transform::PostToDOM (); +use IMPL::DOM::Schema; +use CGI; +use File::Copy qw(copy); + +my $t = new IMPL::DOM::Transform::PostToDOM( + undef, + IMPL::DOM::Schema->LoadSchema('input.schema.xml'), + 'user' +); + +my $doc = $t->Transform(CGI->new()); + +if ($t->Errors->Count) { + # handle errors +} + +$doc->selectSingleNode('avatar')->invokeTempFile( + sub { + my($node,$fname,$fhandle) = @_; + + # do smth with file + copy($_,'avatar.jpg'); + + # same thing + # copy($fname,'avatar.jpg'); + } +); + +=end code + +=head1 DESCRIPTION + +Данный класс используется для представлении параметров C<CGI> запросов при преобзаовании +запроса в ДОМ документ преобразованием C<IMPL::DOM::Transform::PostToDOM>. + +Узлы данного типа расширяют стандатрный C<IMPL::DOM::Node> несколькими свойствами и +методами для доступа к файлу, переданному в виде параметра запроса. + +=head1 MEMBERS + +=head2 PROPERTIES + +=over + +=item C<[get] parameterName> + +Имя параметра C<CGI> запроса соответствующего данному узлу. + +=item C<[get] fileName> + +Имя файла из параметра запроса + +=item C<[get] fileHandle> + +Указатель на файл из параметра запроса + +=back + +=head2 METHODS + +=over + +=item C<invokeTempFile($callback,$target)> + +Сохраняет файл, переданный в запросе во временный, вызывает C<$callback> для обработки временного файла. + +=over + +=item C<$callback> + +Ссылка на функцию которая будет вызвана для обработки временного файла. C<callback($target,$fname,$fhandle)> + +=over + +=item C<$fname> + +Имя временного файла + +=item C<$fhandle> + +Указатель на временный файл + +=back + +Также пременная C<$_> содержит имя временного файла. + +=item C<$target> + +Значение этого параметра будет передано первым параметром функции C<$callback>. + +=back + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Exception.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,60 @@ +package IMPL::Web::Exception; +use strict; +use warnings; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::AppException' => '@_' + ], + props => [ + headers => PROP_ALL + ] +}; + +sub status { + "500 Internal error"; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Exception> - Базовый класс для всех web-исключений, для ошибок вызванных +по вине клиента. + +=head1 SYNOPSIS + +Вызов исключения + +=begin code + +use IMPL::require { + WebException => 'IMPL::Web::Exception' +}; + +sub MyWebHandler { + # ... + + die WebException->new("something is wrong"); + + # ... +} + +=end code + +=head1 MEMBERS + +=head2 C<status()> + +Возвращает C<HTTP> код ошибки. Каждый класс иключений должен переопределить данный метод. + +=head2 C<[get,set]headers> + +Ссылка на хеш с параметрами заголовка. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/ForbiddenException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,28 @@ +package IMPL::Web::ForbiddenException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + } +}; + +use IMPL::Resources::Strings { + message => "You don't have access to this resource" +}; + +sub status { + "403 Forbidden" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::ForbiddenException> - операция не разрешается. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/ErrorHandler.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,127 @@ +package IMPL::Web::Handler::ErrorHandler; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::Exception(); +use IMPL::declare { + require => { + WebException => 'IMPL::Web::Exception', + ArgumentException => '-IMPL::InvalidArgumentException', + IOException => '-IMPL::IOException', + HttpResponse => 'IMPL::Web::HttpResponse', + Security => 'IMPL::Security' + }, + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + }, + props => [ + errors => PROP_RW, + view => PROP_RW, + fallback => PROP_RW, + contentType => PROP_RW + ] +}; + +sub CTOR { + my ($this) = @_; + + die ArgumentException->new("view") unless $this->view; + die ArgumentException->new("fallback") unless $this->fallback; + + $this->errors({}) unless $this->errors; + +} + +sub Invoke { + my ($this,$action,$next) = @_; + + undef $@; + my $result; + eval { + $result = $next ? $next->($action) : undef; + }; + + if (my $err = $@) { + + my $vars = { + error => $err, + result => $result, + request => sub { $action }, + app => $action->application, + location => $action->context->{resourceLocation}, + resource => $action->context->{resource}, + document => {}, + session => sub { Security->context }, + user => sub { Security->principal }, + security => sub { $action->security } + }; + + my $status = "500 Internal Server Error"; + + if (eval { $err->isa(WebException) }) { + $status = $err->status; + } + + my ($code) = ($status =~ m/^(\d+)/); + + my $text = $this->view->display( + $err, + $this->errors->{$code} || $this->fallback, + $vars + ); + + $result = HttpResponse->new( + status => $status, + type => $this->contentType, + charset => 'utf-8', + headers => eval{ $err->headers } || {}, + body => $text + ); + } + + return $result; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Handler::ErrorHandler> - обертка для обработки исключений. + +=head1 SYNOPSIS + +Используется в цеопчке обработчиков приложения. + +=begin code xml + + <handlers type="ARRAY"> + <item type="IMPL::Web::Handler::ErrorHandler"> + <contentType>text/html</contentType> + <loader refid="tt-loader"/> + <errors type="HASH"> + <error extname="500">errors/500</error> + <error extname="404">errors/404</error> + <error extname="403">errors/403</error> + </errors> + <fallback>errors/500</fallback> + </item> + </handlers> + +=end code xml + +=head1 DESCRIPTION + +Позволяет создать представление для ресурса в случае ошибки, для этого +используется соответствие представлений и кодов ошибок. + +В результате обработчик либо прозрачно передает результат вышестоящего +обработчика нижестоящему, либо создает C<IMPL::Web::HttpResponse> с +соответствующим статусом и содержанием. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/JSONView.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,70 @@ +package IMPL::Web::Handler::JSONView; +use strict; +use JSON; + +use IMPL::lang qw(is); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + HttpResponse => 'IMPL::Web::HttpResponse', + ViewResult => '-IMPL::Web::ViewResult', + Loader => 'IMPL::Code::Loader' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Serializable' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + transform => PROP_RW + ] +}; + +sub contentType { + 'application/json' +} + +sub Invoke { + my ($this,$action,$next) = @_; + + my $result = $next ? $next->($action) : undef; + + + my $model = ( ref $result and is($result,ViewResult) ) + ? $result->model + : $result; + + $model = [$model] unless ref $model; + + if (my $factory = $this->transform) { + Loader->safe->Require($factory) unless ref $factory; + my $t = $this->transform->new(); + $model = $t->Transform($model); + } + + my %params = ( + type => $this->contentType, + charset => 'utf-8', + body => JSON->new->utf8->pretty->encode($model) + ); + + if(is($result,ViewResult)) { + $params{status} = $result->status if $result->status; + $params{headers} = $result->headers if $result->headers; + $params{cookies} = $result->cookies if $result->cookies; + } + + return HttpResponse->new( + %params + ); +} + +1; + +__END__ + +=pod + +=head1 + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/LocaleHandler.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,96 @@ +package IMPL::Web::Handler::LocaleHandler; +use strict; + +use IMPL::Const qw(:prop); +use DateTime; +use IMPL::declare { + require => { + Resources => 'IMPL::Resources' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + props => [ + locales => PROP_RO | PROP_LIST, + default => PROP_RO, + cookie => PROP_RO + ] +}; + +sub Invoke { + my ($this,$action,$nextHandler) = @_; + + my $locale; + + if ($this->cookie and my $cookie = $action->cookie($this->cookie)) { + ($locale) = grep /^$cookie/i, $this->locales; + } + + unless($locale) { + my @matches; + + my $best = [$this->default,0]; + + if(my $header = $action->header('Accept-Language')) { + foreach my $part (split(/\s*,\s*/, $header)) { + my ($lang,$quality) = ($part =~ /([a-z]+(?:\-[a-z]+)*)(?:\s*;\s*q=(0\.[\d]+|1))?/i ); + + $quality ||=1; + + foreach my $tag ($this->locales) { + if ( $tag =~ m/^$lang/i ) { + push @matches, [$tag,$quality]; + } + } + } + + foreach my $match (@matches) { + if ($match->[1] > $best->[1]) { + $best = $match; + } + } + + } + + $locale = $best->[0]; + } + + if($locale) { + Resources->SetLocale($locale); + #$locale =~ tr/-/_/; + DateTime->DefaultLocale($locale); + } + + return $nextHandler->($action); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Handler::LocaleHandler> - handles locale for the request + +=head1 SYNOPSIS + +=begin code xml + + <handlers type="ARRAY"> + <item type="IMPL::Web::Handler::LocaleHandler"> + <locales type="ARRAY"> + <item>en-US</item> + <item>ru-RU</item> + </locales> + <default>en-US</default> + <cookie>lang</cookie> + </item> + </handlers> + +=end code xml + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/RestController.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,148 @@ +package IMPL::Web::Handler::RestController; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Locator => 'IMPL::Web::AutoLocator', + ResourceInterface => 'IMPL::Web::Application::ResourceInterface', + Exception => 'IMPL::Exception', + ArgumentExecption => '-IMPL::InvalidArgumentException', + NotFoundException => 'IMPL::Web::NotFoundException', + Loader => 'IMPL::Code::Loader' + }, + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + }, + props => [ + resourceFactory => PROP_RO, + trailingSlash => PROP_RO + ] +}; + +sub CTOR { + my ($this) = @_; + + die ArgumentException->new(resourceFactory => "A web-resource is required") + unless $this->resourceFactory; + #unless eval { $this->resourceFacotry->isa(ResourceInterface) }; + +} + +sub GetResourcePath { + my ($this,$action) = @_; + + my $pathInfo = $action->pathInfo; + my @segments; + + if (length $pathInfo) { + + @segments = split(/\//, $pathInfo, $this->trailingSlash ? -1 : 0); + + # remove first segment if it is empty + shift @segments if @segments && length($segments[0]) == 0; + } + + return @segments; +} + + +sub Invoke { + my ($this,$request) = @_; + + my $method = $request->requestMethod; + + my @segments = $this->GetResourcePath($request); + + my $factory = $this->resourceFactory; + + $factory = Loader->default->Require($factory) + unless ref($factory) || eval { $factory->can('new') }; + + my $res = $factory->new( + id => 'root', + request => $request, + location => Locator->new(base => $request->application->baseUrl), + ); + + while(@segments) { + my $id = shift @segments; + $res = $res->FetchChildResource($id); + } + + $res = $res->InvokeHttpVerb($method); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Handler::RestController> - Обрабатывает C<HTTP> запрос передавая +его соответствующему ресурсу. + +=head1 SYNOPSIS + +Используется в конфигурации приложения как элемент цепочки обработчиков. +Как правило располагается на самом верхнем уровне. + +=begin code xml + + <handlers type="ARRAY"> + <item type="IMPL::Web::Handler::RestController"> + <resourceFactory>My::App::Web::RootResource</resourceFactory> + </item> + <item type="IMPL::Web::Handler::JSONView" /> + <item type="IMPL::Web::Handler::SecureCookie" /> + <item type="IMPL::Web::Handler::ErrorHandler" /> + </handlers> + +=end code xml + + +=head1 DESCRIPTION + +Использует C<PATH_INFO> для определения нужного ресурса, затем предает +найденному ресурсу управление для обработки запроса. + +Если ресурс не найден, то возникает исключение C<IMPL::Web::NotFoundException>. + +Для определения нужного ресурса контроллер разбивает C<PATH_INFO> на фрагменты +и использует каждый фрагмент для получения дочернего ресурса начиная с корневого. +Для чего используется метод +C<< IMPL::Web::Application::ResourceInterface->FetchChildResource($childId) >>. + +Дерево ресурсов сущестувет независимо от обрабатываемого запроса, однако оно +может полностью или частично загружаться в начале обработки запроса и +освобождаться по окончании обработки запроса. Поэтому при получении дочерних +ресурсов не участвует C<HTTP> запрос, он адресуется только последнему ресурсу. + +=begin text + +/music/audio.mp3 -> ['music','audio.mp3'] + +=end text + +=head1 MEMEBERS + +=head2 C<[get]resourceFactory> + +Фабрика для создания корневого ресурса приложения, полученный ресурс должен +реализовывать интерфейс C<IMPL::Web::Application::ResourceInterface>. + +Фабрика может сохранять ссылку на корневой ресурс и каждый раз не создавать +его, а возвращать уже существующий. Это вполне оправдано, если хранение +дерева ресурсов требует меньше ресурсов, чем его создание и при этом приложение +остается в памяти между C<HTTP> запросами. + +=head2 C<[get]trailingSlash> + +Если данная переменная имеет значение C<true>, то слеш в конце пути к ресурсу +будет интерпретироваться, как дочерний ресурс с пустым идентификатором. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/SecureCookie.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,201 @@ +package IMPL::Web::Handler::SecureCookie; +use strict; + + +use Digest::MD5 qw(md5_hex); +use IMPL::Const qw(:prop); +use IMPL::Security::Auth qw(:Const GenSSID); +use IMPL::declare { + require => { + SecurityContext => 'IMPL::Security::Context', + User => 'IMPL::Security::Principal', + AuthSimple => 'IMPL::Security::Auth::Simple', + Exception => 'IMPL::Exception', + OperationException => '-IMPL::InvalidOperationException', + HttpResponse => '-IMPL::Web::HttpResponse' + }, + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + }, + props => [ + salt => PROP_RO, + _security => PROP_RW, + _cookies => PROP_RW + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->salt('DeadBeef') unless $this->salt; +} + +sub ValidateCookie { + my ($this,$sid,$cookie,$sign) = @_; + + return 1 if $sid and $cookie and $sign and $sign eq md5_hex($this->salt,$sid,$cookie,$this->salt); + + return 0; +} + +sub AuthCookie { + my ($this,$sid,$cookie,$sign, $context) = @_; + + if (eval { $context->auth->isa(AuthSimple) }) { + my ($result,$challenge) = $context->auth->DoAuth($cookie); + return $result; + } + + return AUTH_FAIL; +} + +sub Invoke { + my ($this,$action,$nextHandler) = @_; + + return unless $nextHandler; + + my $context; + $this->_security($action->security); + + + my $sid = $action->cookie('sid',qr/(\w+)/); + my $cookie = $action->cookie('sdata',qr/(\w+)/); + my $sign = $action->cookie('sign',qw/(\w+)/); + + if ( $this->ValidateCookie($sid,$cookie,$sign) ) { + # TODO: add a DeferredProxy to deffer a request to a data source + if ( $context = $this->_security->sessions->GetById($sid) ) { + if ( eval { $context->auth->isa(AuthSimple) } ) { + my ($result,$challenge) = $context->auth->DoAuth($cookie); + + $context->authority($this); + + if ($result == AUTH_FAIL) { + $context = undef; + } + } else { + undef $context; + } + } + + } + + $context ||= SecurityContext->new(principal => User->nobody, authority => $this); + + my $httpResponse = eval { $context->Impersonate($nextHandler,$action); }; + my $e = $@; + + die $e if $e; + + die OperationException->new("A HttpResponse instance is expected") + unless ref $httpResponse && eval { $httpResponse->isa(HttpResponse) }; + + return $this->_WriteResponse($httpResponse); +} + +sub InitSession { + my ($this,$user,$roles,$auth,$challenge) = @_; + + my ($status,$answer); + + if ($auth) { + ($status,$answer) = $auth->DoAuth($challenge); + } else { + $status = AUTH_SUCCESS; + } + + die OperationException->new("This provider doesn't support multiround auth") + if ($status == AUTH_INCOMPLETE || $answer); + + if ($status == AUTH_SUCCESS) { + my $sid = GenSSID(); + my $cookie = GenSSID(); + + $this->_cookies({ + sid => $sid, + sdata => $cookie + }); + + my $context = $this->_security->sessions->Create({ + sessionId => $sid, + principal => $user, + auth => AuthSimple->Create(password => $cookie), + authority => $this, + rolesAssigned => $roles + }); + + $context->Apply(); + + } + + return $status; +} + +sub CloseSession { + my ($this) = @_; + if(my $session = SecurityContext->current) { + $this->_cookies({ + sid => undef, + sdata => undef + }) + } +} + +sub _WriteResponse { + my ($this,$response) = @_; + + if (my $data = $this->_cookies) { + + my $sign = $data->{sid} && md5_hex( + $this->salt, + $data->{sid}, + $data->{sdata}, + $this->salt + ); + + $response->cookies->{sid} = $data->{sid}; + $response->cookies->{sdata} = $data->{sdata}; + $response->cookies->{sign} = $sign; + } + + return $response; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Handler::SecureCookie> + +=head1 DESCRIPTION + +Возобновляет сессию пользователя на основе информации переданной через Cookie. + +Использует механизм подписи информации для проверки верности входных данных перед +началом каких-либо действий. + +Данный обработчик возвращает результат выполнения следдующего обработчика. + + + +=head1 MEMBERS + +=head2 C<[get,set] salt> + +Скаляр, использующийся для подписи данных. + + +=head2 C<InitSession($user,$roles,$auth,$challenge)> + +Инициирует сессию, поскольку данный модуль отвечает за взаимодействие с клиентом +при проверки аутентификации, ему передаются данные аутентификации для +продолжения обмена данными с клиентом. Если создается новая сессия, по +инициативе веб-приложения, то C<$auth> должно быть пусто. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/View.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,323 @@ +package IMPL::Web::Handler::View; +use strict; + +use Carp qw(carp); +use List::Util qw(first); +use IMPL::lang; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Factory => 'IMPL::Web::View::ObjectFactory', + HttpResponse => 'IMPL::Web::HttpResponse', + Loader => 'IMPL::Code::Loader', + ViewResult => 'IMPL::Web::ViewResult', + Security => 'IMPL::Security' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + + props => [ + contentType => PROP_RO, + contentCharset => PROP_RO, + view => PROP_RO, + layout => PROP_RO, + selectors => PROP_RO, + defaultDocument => PROP_RW, + _selectorsCache => PROP_RW + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->_selectorsCache([ map $this->ParseRule($_), @{$this->selectors || []} ]); +} + +sub Invoke { + my ( $this, $action, $next ) = @_; + + my $result = $next ? $next->($action) : undef; + + my $model; + if( ref $result and eval { $result->isa(ViewResult) } ) { + $model = $result->model; + } else { + $model = $result; + $result = ViewResult->new(model => $model); + } + + my $vars = { + result => $result, + request => sub { $action }, + app => $action->application, + location => $action->context->{resourceLocation}, + resource => $action->context->{resource}, + layout => $this->layout, + document => {}, + session => sub { Security->context }, + user => sub { Security->principal }, + security => sub { $action->security } + }; + + my %responseParams = ( + type => $this->contentType, + charset => $this->contentCharset, + body => $this->view->display( + $model, + $this->SelectView( $action, ref $model ), + $vars + ) + ); + + $responseParams{status} = $result->status if $result->status; + $responseParams{cookies} = $result->cookies if ref $result->cookies eq 'HASH'; + $responseParams{headers} = $result->headers if ref $result->headers eq 'HASH'; + + return HttpResponse->new( + %responseParams + ); +} + +sub SelectView { + my ($this,$action) = @_; + + my @path; + + for(my $r = $action->context->{resource}; $r ; $r = $r->parent ) { + unshift @path, { + name => $r->id, + class => typeof($r->model) + }; + } + + @path = map { name => $_}, split /\/+/, $action->query->path_info() + unless (@path); + + return $this->MatchPath(\@path,$this->_selectorsCache) || $this->defaultDocument; +} + +sub ParseRule { + my ($this, $rule) = @_; + + my ($selector,$data) = split /\s+=>\s+/, $rule; + + my @parts; + my $first = 1; + my $weight = 0; + foreach my $part ( split /\//, $selector ) { + # если первым символом является / + # значит путь в селекторе абсолютный и не нужно + # добавлять "любой" элемент в начало + + if($part) { + $weight ++; + push @parts,{ any => 1 } if $first; + } else { + push @parts,{ any => 1 } unless $first; + next; + } + + my ($name,$class) = split /@/, $part; + + if ( my ( $varName, $rx ) = ( $name =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) { + #this is a regexp + + push @parts, { + rx => $rx, + var => $varName, + class => $class, + }; + } else { + push @parts, { + name => length($name) ? $name : undef, + class => $class, + }; + } + } continue { + $first = 0; + } + + return { selector => \@parts, data => $data, weight => $weight }; +} + +sub MatchPath { + my ($this,$path,$rules) = @_; + + $path ||= []; + $rules ||= []; + + my @next; + + foreach my $segment (@$path) { + foreach my $rule (@$rules) { + my @selector = @{$rule->{selector}}; + + my $part = shift @selector; + + # if this rule doesn't have a selector + next unless $part; + + if ($part->{any}) { + #keep the rule for the next try + push @next, $rule; + + $part = shift @selector while $part->{any}; + } + + my $newRule = { + selector => \@selector, + data => $rule->{data}, + weight => $rule->{weight}, + vars => { %{$rule->{vars} || {}} } + }; + + my $success = 1; + if (my $class = $part->{class}) { + $success = isclass($segment->{class},$class); + } + + if($success && (my $name = $part->{name})) { + $success = $segment->{name} eq $name; + } elsif ($success && (my $rx = $part->{rx})) { + if( my @captures = ($segment->{name} =~ m/($rx)/) ) { + $newRule->{vars}->{$part->{var}} = \@captures + if $part->{var}; + } else { + $success = 0; + } + } + + push @next, $newRule if $success; + + } + $rules = [@next]; + undef @next; + } + + my $result = ( + sort { + $b->{weight} <=> $a->{weight} + } + grep { + scalar(@{$_->{selector}}) == 0 + } + @$rules + )[0]; + + if($result) { + my $data = $result->{data}; + $data =~ s/{(\w+)(?:\:(\d+))?}/ + my ($name,$index) = ($1,$2 || 0); + + if ($result->{vars}{$name}) { + $result->{vars}{$name}[$index]; + } else { + ""; + } + /gex; + + return $data; + } else { + return; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Handler::TTView> - использует шаблоны для построения представления. + +=head1 SYNOPSIS + +=begin code xml + +<item id="html-view" type="IMPL::Web::Handler::View"> + <contentType>text/html</contentType> + <view id="tt-loader" type="IMPL::Web::View::TTView"> + <options type="HASH"> + <INCLUDE_PATH type="IMPL::Config::Reference"> + <target>IMPL::Config</target> + <AppBase>view</AppBase> + </INCLUDE_PATH> + <INTERPOLATE>1</INTERPOLATE> + <POST_CHOMP>1</POST_CHOMP> + <ENCODING>utf-8</ENCODING> + </options> + <ext>.tt</ext> + <initializer>global.tt</initializer> + <layoutBase>layouts</layoutBase> + </view> + <defaultDocument>default</defaultDocument> + <selectors type="ARRAY"> + <item>@HASH => dump</item> + <item>@My::Data::Product => product/info</item> + <item>{action:.*} @My::Data::Product => product/{action}</item> + </selectors> +</item> + +=end code xml + +=head1 DESCRIPTION + +Подбирает шаблон для представления результата, полученного при выполнении следующего обработчика. При +выборе используется принцип похожий на селекторы C<CSS>, основывающийся на именах ресурсов и их типах +данных. + +Данный обработчик понимает определенные свойства контекста: + +=over + +=item * C<resourceLocation> + +В данном свойстве может быть передана информация о текущем расположении ресурса, +для которого строится представление. Эта информация будет доступна в шаблоне +через свойство документа C<location>. + +=item * C<environment> + +В данном совойстве контекста передается дополнительная информация об окружении +ресурса, например, которую задали родительские ресурсы. Использование данного +свойства позволяет не загромождать ресурс реализацией функциональности по +поддержке окружения. Это свойство может быть ссылкой на функцию, что позволяет +формировать контекст только по необходимости, при этом указанная функция будет +выполнена только один раз, при первом обращении. + +=back + +=head1 SELECTORS + +=begin text + +syntax::= selector => template + +selector::= ([>]segment-template[@class-name]) + +segment-template::= {'{'name:regular-expr'}'|segment-name} + +name::= \w+ + +segment-name::= \S+ + +class-name::= name[(::name)] + +url-template@class => template + +shoes => product/list +/shop//{action:*.}@My::Data::Product => product/{action} + +stuff >list => product/list +details => product/details + +=end text + + +=cut +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Handler/ViewSelector.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,100 @@ +package IMPL::Web::Handler::ViewSelector; +use strict; + +use IMPL::Const qw(:prop); + +use IMPL::declare { + require => { + NotAcceptable => 'IMPL::Web::NotAcceptableException', + HttpResponse => 'IMPL::Web::HttpResponse' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + props => [ + views => PROP_RW | PROP_LIST, + fallback => PROP_RW, + types => PROP_RW + ] +}; + +sub Invoke { + my ( $this, $action, $next ) = @_; + + my $result = $next ? $next->($action) : undef; + + my $model; + + return $result if eval { $result->isa(HttpResponse) }; + + my $handler; + my $path = $action->pathInfo; + + if ( $this->types and $path =~ m/\.(\w+)$/ ) { + my $forced; + if ( $forced = $this->types->{$1} and $action->query->Accept($forced) ) + { + ($handler) = + grep eval { $_->can('contentType') } + && $_->contentType eq $forced, $this->views; + } + } + + if ( not $handler ) { + + my @handlers = + sort { $b->{preference} <=> $a->{preference} } map { + { + handler => $_, + preference => eval { $_->can('contentType') } + ? $action->query->Accept( $_->contentType ) + : 0 + } + } $this->views; + + my $info = shift @handlers; + $handler = $info ? $info->{handler} : undef; + + } + + die NotAcceptable->new( + map { + eval { $_->can('contentType') } ? $_->contentType : () + } $this->views + ) unless $handler; + + return $handler->Invoke( $action, sub { $result } ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Handler::ViewSelector> - Выбор нужного представления на основе заголовка C<Accept> + +=head1 DESCRIPTION + +Использует заголовок запроса C<Accept> для выбора подходящего представления, если задано свойство C<types>, +пытается в первую очередь по расширению определить, какое представление подходит. + +В случаях, когда не требуется строить представление для данных (например, при перенаправлении к другому +ресурсу или если нет данных), нужно, чтобы данному обработчику был возвращен +L<IMPL::Web::Application::ActionResult>, который будет просто передан далее. + +=head1 MEMBERS + +=head2 C<[get,set,list]views> + +Список представлений, которые могут быть возвращены. + +=head2 C<[get,set]types> + +Хеш с соотвествием между расширением и типом содержимого, для подсказки при выборе представления. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/HttpResponse.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,174 @@ +use strict; +package IMPL::Web::HttpResponse; + +use CGI(); +use IMPL::lang qw(:declare :hash); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + status => PROP_ALL, + type => PROP_ALL, + charset => PROP_ALL, + cookies => PROP_ALL, + headers => PROP_ALL, + body => PROP_ALL + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->headers({}) unless $this->headers(); + $this->cookies({}) unless $this->cookies(); +} + +sub PrintResponse { + my ($this,$out) = @_; + + my $q = CGI->new({}); + + my %headers = %{$this->headers}; + + if(my $cookies = $this->cookies) { + $headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies; + } + + $headers{'-status'} = $this->status || '200 OK'; + $headers{'-type'} = $this->type || 'text/html'; + + if(my $charset = $this->charset) { + $q->charset($charset); + binmode $out, ":encoding($charset)"; + } else { + $q->charset(''); + binmode $out; + } + + print $out $q->header(\%headers); + + if(my $body = $this->body) { + if(ref $body eq 'CODE') { + $body->($out); + } else { + print $out $body; + } + } +} + +#used to map a pair name valie to a valid cookie object +sub _createCookie { + return UNIVERSAL::isa($_[1], 'CGI::Cookie') + ? $_[1] + : ( defined $_[1] + ? CGI::Cookie->new(-name => $_[0], -value => $_[1] ) + : CGI::Cookie->new(-name => $_[0], -expires => '-1d', -value => '') + ); +} + +sub InternalError { + my ($self,%args) = @_; + + $args{status} ||= '500 Internal Server Error'; + + return $self->new(%args); +} + +sub Redirect { + my ($self,%args) = @_; + + return $self->new( + status => $args{status} || '303 See other', + headers => { + location => $args{location} + } + ); +} + +sub NoContent { + my ($self,%args) = @_; + + return $self->new( + status => $args{status} || '204 No Content' + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::HttpResponse> - Результат обработки C<HTTP> запроса. + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа, +например + +Данный объект используется для формирования и передачи данных C<HTTP> ответа +напрямую. Основными полями являются C<body> и C<status>. + +Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект +может содержать свойства относящиеся к процессу обработки запроса, например +механизму формирования представления. + +=head1 MEMBERS + +=head2 C<[get,set]status> + +Статус который будет отправлен сервером клиенту, например, C<200 OK> или +C<204 No response>. Если не указан, то будет C<200 OK>. + +=head2 C<[get,set]type> + +Тип содержимого, которое будет передано клиенту, если не указано, будет +C<text/html>. + +=head2 C<[get,set]charset> + +Кодировка в которой будут переданны данные. Следует задавать если и только, если +передается текстовая информация. Если указана кодировка, то она будет +автоматически применена к потоку, который будет передан методу C<PrintResponse>. + +=head2 C<[get,set]cookies> + +Опционально. Ссылка на хеш с печеньками. + +=head2 C<[get,set]headers> + +Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат +имен полей как у модуля C<CGI>. + +=begin code + +$response->header->{custom_header} = "my value"; + +#will produce the following header + +Custom-header: my value + +=end code + +=head2 C<[get,set]body> + +Тело ответа. Может быть как простой скаляр, который будет приведен к строке и +выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на +процедуру, в таком случае будет вызвана эта процедура и ей будет передан +первым параметром поток для вывода тела ответа. + +=head2 C<PrintResponse($outStream)> + +Формирует заголовок и выводит ответ сервера в указанный параметром поток. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/NotAcceptableException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,25 @@ +package IMPL::Web::NotAcceptableException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + } +}; + +sub status { + "406 Not acceptable" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::NotAcceptableException> Исключение в случае, если запрошенный ресурс не может +быть выдан в указанном виде. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/NotAllowedException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,30 @@ +package IMPL::Web::NotAllowedException; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Web::Exception' => '@_' + ] +}; + +use IMPL::Resources::Strings { + message => "The requested method isn't allowed" +}; + +sub CTOR { + my $this = shift; + my %args = @_; + + $this->headers({ + allow => $args{allow} + }); +} + +sub status { + "405 Method Not Allowed" +} + +1; + +__END__ \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/NotFoundException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,28 @@ +package IMPL::Web::NotFoundException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + }, +}; + +use IMPL::Resources::Strings { + message => 'The specified resource isn\'t found.' +}; + +sub status { + "404 Not found" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::NotFoundException> Исключение для несущесьвующего ресурса. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/OutOfRangeException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,51 @@ +package IMPL::Web::OutOfRangeException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + }, +}; + +sub CTOR { + my ($this,$range) = @_; + + #TODO: validate args + + $this->headers({ + content_range => { $range->{units} . ' */' . $range->{length} } + }); +} + +use IMPL::Resources::Strings { + message => 'The specified range is invalid' +}; + +sub status { + "416 Requested Range Not Satisfiable" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::OutOfRangeException> A server SHOULD return a response with this +status code if a request included a Range request-header field (section 14.35), +and none of the range-specifier values in this field overlap the current extent +of the selected resource, and the request did not include an If-Range +request-header field. (For byte-ranges, this means that the first- byte-pos of +all of the byte-range-spec values were greater than the current length of the +selected resource.) + +=head1 DESCRIPTION + +When this status code is returned for a byte-range request, the response SHOULD +include a Content-Range entity-header field specifying the current length of the +selected resource (see section 14.16). This response MUST NOT use the +multipart/byteranges content- type. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/PreconditionException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,33 @@ +package IMPL::Web::PreconditionException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + } +}; + +use IMPL::Resources::Strings { + message => "Precondition Failed" +}; + +sub status { + "412 Precondition Failed" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::PreconditionException> - The precondition given in one or more of +the request-header fields evaluated to false when it was tested on the server. + +This response code allows the client to place preconditions on the current +resource metainformation (header field data) and thus prevent the requested +method from being applied to a resource other than the one intended. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Security.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,196 @@ +package IMPL::Web::Security; +use strict; + +use IMPL::Security::Auth qw(:Const); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + NotImplementedException => '-IMPL::NotImplementedException', + ArgException => '-IMPL::InvalidArgumentException', + SecurityContext => 'IMPL::Security::AbstractContext' + }, +}; + +use constant { + ERR_NO_SUCH_USER => -1, + ERR_NO_SEC_DATA => -2, + ERR_NO_AUTHORITY => -3, + ERR_NO_SEC_CONTEXT => -4, + ERR_AUTH_FAIL => -5 +}; + +sub interactiveAuthPackage { + die NotImplementedException->new(); +} + +sub users { + die NotImplementedException->new(); +} + +sub roles { + die die NotImplementedException->new(); +} + +sub sessions { + die NotImplementedException->new(); +} + +sub AuthUser { + my ($this,$name,$challenge,$roles,$package) = @_; + + $package ||= $this->interactiveAuthPackage; + $roles ||= []; + + my $user = $this->users->GetById($name) + or return { + status => AUTH_FAIL, + code => ERR_NO_SUCH_USER + }; + + my $auth; + if ( my $secData = $user->GetSecData($package) ) { + $auth = $package->new($secData); + } else { + return { + status => AUTH_FAIL, + code => ERR_NO_SEC_DATA, + user => $user + }; + } + + return { + status => AUTH_FAIL, + code => ERR_NO_SEC_CONTEXT + } unless SecurityContext->current; + + return { + status => AUTH_FAIL, + code => ERR_NO_AUTHORITY + } unless SecurityContext->current->authority; + + my $status = SecurityContext->current->authority->InitSession( + $user, + $roles, + $auth, + $challenge + ); + + return { + status => $status, + code => ($status == AUTH_FAIL ? ERR_AUTH_FAIL : 0), + user => $user + }; +} + +sub Logout { + my ($this) = @_; + + my $session = SecurityContext->current; + if($session && $session->authority) { + $session->authority->CloseSession($session); + + $this->sessions->Delete($session); + } +} + +sub CreateSecData { + my ($this,$package,$params) = @_; + + die ArgException->new(params => 'A hash reference is required') + unless ref($params) eq 'HASH'; + + return $package->CreateSecData(%$params); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Security> Модуль для аутентификации и авторизации веб запроса. + +=head1 DESCRIPTION + +Текущий модуль обеспечивает функции верхнего уровня для работы с системой +безопасности. Поскольку модуль является абстрактым, конкретные функции +хранения и реализацию объектов модели безопасности должно обеспечить само +приложение. + +Сама система безопасности в веб приложении состоит из двух частей + +=over + +=item Модель системы безопасности + +Предоставляет такие объкты безопасности, как пользователь, сессия роль, +определяет правила проверки прав доступа субъекта к объекту. + +=item Модуль безопасности + +Контекст безопасности создается именно этим модулем. + +Как правило встраивается в транспортный уровеь в виде обработчика +C<IMPL::Web::Handler> и реализует непосредственно протокол аутентификации и +обмена с пользователем. + +Также модуль безопасности использует модель для хранения сессий и данных +аутентификции. + +=back + +=head1 MEMBERS + +=head2 C<AuthUser($name,$package,$challenge)> + +Инициирует создание новой сессии используя провайдера безопасности текущего +контекста безопасности. + +=over + +=item C<$name> + +Имя пользователя, которое будет использоваться при поиске его в БД. + +=item C<$package> + +Имя модуля аутентификации, например, C<IMPL::Security::Auth::Simple>. + +=item C<$challenge> + +Данные, полученные от клиента, которые будут переданы модулю аутентификации для +начала процесса аутентификации и создания сессии. + +=back + +Функция возвращает хеш с элементами + +=over + +=item C<status> + +Статус аутентификации - отражает общее состояние процесса ацтентификации, + +=over + +=item C<AUTH_FAIL> + +Аутентификация неудачная, сессия не создана. + +=item C<AUTH_INCOMPLETE> + +Аутентификация требует дополнительных шагов, сессия создана, но еще не доверена. + +=item C<AUTH_SUCCESS> + +Аутентификация успешно проведена, сессия создана. + +=back + +=item C<code> + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/Security/Session.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,63 @@ +package IMPL::Web::Security::Session; +use strict; +use parent qw(); + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Security::AbstractContext' => '@_' + ] +}; + +push @{__PACKAGE__->abstractProps}, sessionId => PROP_RW, security => PROP_RW; + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Security::Session> - Сессия пользователя. + +=head1 SINOPSYS + +=begin code + +# define a custom session for the application + +package App::Session; +use parent qw(IMPL::Web::Security::Session); + +use IMPL::Class::Property; + +BEGIN { + public property transactionId => prop_all; +} + +=end code + +=head1 DESCRIPTION + +C<use parent qw(IMPL::Security::Context)> + +Представляет собой контекст безопасности, имеет идентификатор. Является базовым классом +для расширения дополнительными атрибутами. + +=head1 MEMBERS + +=over + +=item C<[get] sessionId> + +Идентификатор сессии + +=item C<[get] security> + +Экземпляр C<IMPL::Web::Security> в рамках которого создана сессия (откуда взят +пользователь и роли). + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/UnauthorizedException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,24 @@ +package IMPL::Web::UnauthorizedException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + } +}; + +sub status { + "401 Unauthorized" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::UnauthorizedException> - запрос требует идентификации пользователя. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/UnsupportedMediaException.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,31 @@ +package IMPL::Web::UnsupportedMediaException; +use strict; + +use IMPL::declare { + base => { + 'IMPL::Web::Exception' => '@_' + } +}; + +sub status { + "415 Unsupported Media Type" +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::UnsupportedMediaException> - 415 Unsupported Media Type + +=head1 DESCRIPTION + +The request entity has a media type which the server or resource does not +support. For example, the client uploads an image as C<image/svg+xml>, but the +server requires that images use a different format. +L<http://en.wikipedia.org/wiki/List_of_HTTP_status_codes> + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/Metadata/BaseMeta.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,140 @@ +package IMPL::Web::View::Metadata::BaseMeta; +use strict; + +use IMPL::lang; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + NotImplException => '-IMPL::NotImplementedException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + model => PROP_RO, + modelType => PROP_RO, + name => PROP_RO, + label => PROP_RO, + container => PROP_RO, + template => PROP_RO, + + _childMap => PROP_RO, + _childNames => PROP_RO + ] +}; + +sub CTOR { + my ($this,$model,$type,$args) = @_; + + $this->model($model); + $this->modelType($type); + $this->_childMap({}); + + #mixin other args + if ($args) { + $this->$_($args->{$_}) foreach grep $args->{$_}, qw(name label container template); + } +} + +sub GetProperty { + my ($this,$name) = @_; + + $this->GetProperties() + unless $this->_childNames; + + return $this->_childMap->{$name}; +} + +sub GetProperties { + my ($this) = @_; + + if ($this->_childNames) { + return [ map $this->_childMap->{$_}, @{$this->_childNames} ]; + } else { + my @childNames; + my %childMap; + my @result; + + foreach my $child (@{$this->PopulateProperties()}) { + $childMap{$child->name} = $child; + push @childNames, $child->name; + push @result, $child; + } + + $this->_childMap(\%childMap); + $this->_childNames(\@childNames); + return \@result; + } +} + +sub PopulateProperties { + my ($this) = @_; + + die NotImplException->new(); +} + +sub GetItems { + my ($this) = @_; + + die NotImplException->new(); +} + +sub GetItem { + my ($this,$index) = @_; + + die NotImplException->new(); +} + +1; + +__END__ + +=pod + +=head1 NAME + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Метаданные описывают модель, ее свойства, используются для построения +представления. + +=over + +=item * type + +Опционально. Тип модели. В случаях, когда модель не определена, данное свойство +позволяет определить ее тип. + +=item * label + +Опционально. Имя модели для отображения. + +=item * template + +Шаблон, который следует использовать для отображения модели. + +=item * fields + +Коллекция с информацией по свойствам (полям) модели. Данный хеш используется +для определения представления при использовании C<display_for('field')>. + +=back + +Метаданные публикуются провайдером, кроме того они могут быть расширены +дополнительными свойствами. + +=head1 MEMBERS + +=head2 C<GetChild($name)> + +Возвращает метаданные для дочернего элемента, например свойства объекта + +=head2 C<GetChildren()> + +Возвращает ссылку на массив с метаданными для дочерних элементов + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/Metadata/FormMeta.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,319 @@ +package IMPL::Web::View::Metadata::FormMeta; +use strict; + +use IMPL::lang; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException', + SchemaNavigator => 'IMPL::DOM::Navigator::SchemaNavigator', + DOMNode => '-IMPL::DOM::Node' + }, + base => [ + 'IMPL::Web::View::Metadata::BaseMeta' => '@_' + ], + props => [ + nodes => PROP_RO, + decl => PROP_RO, + schema => PROP_RO, + errors => PROP_RO, + group => PROP_RO + ] +}; + +use constant { + Meta => __PACKAGE__ +}; + +sub CTOR { + my ($this,$model,$type,$args) = @_; + + if ($args) { + $this->$_($args->{$_}) foreach grep $args->{$_}, qw(decl schema nodes errors group); + } + + $this->$_() || die ArgException->new($_ => "The $_ is required") + foreach qw(schema); +} + +sub GetSchemaProperty { + my ($this,$name) = @_; + + return $this->decl ? $this->decl->nodeProperty($name) || $this->schema->nodeProperty($name) : $this->schema->nodeProperty($name); +} + +sub template { + shift->GetSchemaProperty('template'); +} + +sub label { + shift->GetSchemaProperty('label'); +} + +sub inputType { + shift->GetSchemaProperty('inputType'); +} + +sub inputValue { + my ($this) = @_; + + if($this->isMultiple) { + return [ + map { + $_ ? $_->nodeValue || $_->nodeProperty('rawValue') : undef + } + @{$this->model || []} + ] + } else { + return $this->model ? $this->model->nodeValue || $this->model->nodeProperty('rawValue') : undef; + } +} + +sub isMultiple { + my ($this) = @_; + $this->decl && $this->decl->isMultiple; +} + +sub isOptional { + my ($this) = @_; + not($this->decl) || $this->decl->isOptional; +} + +sub GetOwnErrors { + my ($this) = @_; + + my $nodes = $this->nodes; + + my $errors = [ + grep _IsOwnError($nodes,$this->decl,$_), @{$this->errors || []} + ]; + + return $errors; +} + +sub _IsOwnError { + my ($nodes,$source,$err) = @_; + + return 1 if ($err->node && grep($err->node == $_, @$nodes)) || (not(@$nodes) && $err->schemaNode && $err->schemaNode == $source ); + + return 0; +} + +sub _IsErrorRelates { + my ($nodes,$source,$err) = @_; + + # this is an own error + return 1 if _IsOwnError($nodes,$source,$err); + + # this error relates to the child control + + return 0 unless @$nodes; + + for (my $n = $err->parent; $n ; $n = $n->parentNode) { + return 1 if grep($n == $_, @$nodes); + } + + return 0; +} + +sub PopulateProperties { + my ($this) = @_; + + my @props; + + # return empty list of properties in case of multiple values + return \@props if $this->isMultiple; + + my $navi = SchemaNavigator->new($this->schema); + + foreach my $decl (@{$this->schema->content->childNodes}) { + + my $schema = $navi->NavigateName($decl->name); + $navi->SchemaBack(); + + my @nodes = $this->model && $this->model->selectNodes( sub { $_->schemaNode == $decl } ); + + my %args = ( + name => $decl->name, + decl => $decl, + schema => $schema, + nodes => [@nodes], + errors => [grep _IsErrorRelates(\@nodes,$decl,$_), @{$this->errors || []}] + ); + + my ($model,$type); + + if ($decl->isMultiple) { + $model = [@nodes]; + $type = 'ARRAY'; + $args{holdingType} = $schema->type; + } else { + $model = shift @nodes; + $type = $schema->type; + } + + push @props, Meta->new($model,$type,\%args); + } + + return \@props; +} + +sub GetItems { + my ($this) = @_; + + die OpException->new("The operation must be performed on the container") + unless $this->isMultiple; + + my $i = 0; + + return [ + map $this->_GetItemMeta($_,$i++), @{$this->nodes} + ]; +} + +sub GetItem { + my ($this,$index) = @_; + + die OpException->new("The operation must be performed on the container") + unless $this->isMultiple; + + my $node = $this->nodes->[$index]; + + return $this->_GetItemMeta($node,$index); +} + +sub _GetItemMeta { + my ($this,$node,$index) = @_; + + my @nodes; + push @nodes,$node if $node; + + return Meta->new( + $node, + $this->schema->type, + { + name => $index, + schema => $this->schema, + errors => [grep _IsErrorRelates([$node],$this->decl,$_), @{$this->errors ||[]} ], + group => $this, + nodes => \@nodes + } + ); +} + +sub GetMetadataForModel { + my ($self,$model,$args) = @_; + + $args ||= {}; + + my $modelType = delete $args->{modelType}; + + if($model) { + die ArgException->new(model => "A node is required") + unless is($model,DOMNode); + + $args->{decl} ||= $model->schemaNode; + $args->{schema} ||= $model->schemaType; + } + + return $self->new( + $model, + $modelType, + $args + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Расширенные метаданные модели для элементов формы, помимо стандартных свойств +сожержит в себе информацию о схеме. + +=head1 MEMBERS + +=head2 C<[get]errors> + +Ссылка на массив с ошибками при проверке схемы. Ошибки относятся ко всем +узлам в текущей модели, включая вложенные и т.п. + +=head2 C<[get]model> + +Ссылка на элемент документа, либо на массив с элементами для множественных +значений (C<isMultiple = true>). В том случае, когда документ был не +корректен и для не множественного элемента было передено несколько значений, +данное свойство будет содержать только первое. + +=head2 C<[get]nodes> + +Ссылка на массив с узлами документа. В теории количество узлов может быть +произвольным, поскольку документ может быть некорректным, т.е. их может +быть более одного в то время, как C<isMultiple = false> или, напротив, ни +одного при C<isOptional = false>. + +Как правило для построения формы данное свойство не требуется. + +=head2 C<[get]modelType> + +Название типа данных из схемы документа (C<< schema->name >>), если тип не имеет название, то это +C<ComplexNode> для сложных узлов и C<SimpleNode> для простых. + +Для моделей с множественными значениями это свойство не задано. Тип элементов +храниться в свойстве C<holdingType> + +=head2 C<[get]decl> + +Объявление элемента формы, объявление может совпадать со схемой в случае, +когда это был C<SimpleNode> или C<ComplexNode>, иначе это C<Node> ссылающийся +на заранее обпределенный тип. + +=head2 C<[get]schema> + +Схема текущего элемента, C<СomlexType>, C<SimpleType>, C<ComplexNode> или +C<SimpleNode>. + +=head2 C<[get]isOptional> + +Данный элемент может не иметь ни одного значения + +=head2 C<[get]isMultiple> + +Данный элемент может иметь более одного значения. Модель с множественными +значениями является сложным элементом, в котором дочерними моделями являются +не свойства а сами элементы, в данном случае они их именами будут индексы. + +=begin code + +for(my $i=0; $i< 10; $i++) { + display_for($i,'template'); +} + +sub display_for { + my ($index,$tmpl) = @_; + + if ($index =~ /^\d+$/) { + return render($tmpl, metadata => { $meta->GetItem($index) }); + } else { + return render($tmpl, metadata => { $meta->GetProperty($index) }); + } +} + +=end code + +=head2 C<GetOwnErrors()> + +Возвращает ошибки относящиеся к самому элементу C<model>, это принципиально +для контейнеров и в случаях, когда модель не корректна и в ней присутствуют +лишние значения. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/Metadata/ObjectMeta.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,133 @@ +package IMPL::Web::View::Metadata::ObjectMeta; +use strict; + +use IMPL::lang; +use IMPL::Const qw(:prop :access); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException', + PropertyInfo => 'IMPL::Class::PropertyInfo', + AbstractObject => '-IMPL::Object::Abstract' + }, + base => [ + 'IMPL::Web::View::Metadata::BaseMeta' => sub { + my ($model,$type,$args) = @_; + $type ||= typeof($model); + return ($model,$type,$args); + } + ], + props => [ + isMultiple => PROP_RO, + holdingType => PROP_RO + ] +}; + +use constant { + Meta => __PACKAGE__ +}; + +sub CTOR { + my ($this,$model,$type,$args) = @_; + + $type = $this->modelType; + + $args->{isMultiple} ||= $type && $type eq 'ARRAY'; + + if ($args) { + $this->$_($args->{$_}) foreach grep $args->{$_}, qw(isMultiple holdingType); + } +} + +sub PopulateProperties { + my ($this) = @_; + + my %seen; + my @props; + + my $modelType = $this->modelType; + + if ( isclass($modelType,AbstractObject) ) { + foreach my $pi ( + $this->modelType->GetMeta( + PropertyInfo, + sub { not($seen{$_}++) and $_->access == ACCESS_PUBLIC }, + 1 + ) + ) { + my $pv = $this->model && $pi->getter->($this->model); + my $pt; + + my %args = (name => $pi->name); + if ($pi->isList) { + $pt = 'ARRAY'; + $args{isMultiple} = 1; + $args{holdingType} = $pi->type; + } else { + $pt = $pi->type; + } + + push @props, Meta->new($pv, $pt, \%args); + } + } elsif ( $modelType && $modelType eq 'HASH' ) { + while ( my ($k,$v) = each %{$this->model || {}} ) { + push @props, Meta->new($v,undef,{name => $k}); + } + } + + return \@props; +} + +sub GetItems { + my ($this) = @_; + + die OpException->new("The operation must be performed on the container") + unless $this->isMultiple; + + my $i = 0; + + return [ + map $this->_GetItemMeta($_,$i++), @{$this->model || []} + ]; +} + +sub GetItem { + my ($this,$index) = @_; + + die OpException->new("The operation must be performed on the container") + unless $this->isMultiple; + + my $item = @{$this->model || []}[$index]; + + return $this->_GetItemMeta($item,$index); +} + +sub _GetItemMeta { + my ($this,$item,$index) = @_; + + return Meta->new( + $item, + $this->holdingType, + { + name => $index, + container => $this + } + ); +} + +sub GetMetadataForModel { + my ($self,$model,$args) = @_; + + $args ||= {}; + + return $self->new( + $model, + delete $args->{modelType}, + $args + ) +} + +1; + +__END__
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/ObjectFactory.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,33 @@ +package IMPL::Web::View::ObjectFactory; +use strict; + +our $AUTOLOAD; + +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + OpException => '-IMPL::InvalidOperationException' + }, + base =>[ + 'IMPL::Object::Factory' => '@_' + ] +}; + +use IMPL::Resources::Strings { + MsgNoMethod => 'Method "%method%" isn\'t found in "%target%"' +}; + +sub AUTOLOAD { + my $this = shift; + my ($method) = ($AUTOLOAD =~ m/(\w+)$/); + + return if $method eq 'DESTROY'; + my $target = $this->factory; + if ( $target->can($method) ) { + return $target->$method(@_); + } else { + die OpException->new( MsgNoMethod( method => $method, target => $target ) ); + } +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/TTContext.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,519 @@ +package IMPL::Web::View::TTContext; +use strict; +use Template::Base; +use Carp qw(carp); +use File::Spec(); +use IMPL::Resources::Format qw(FormatMessage); +use IMPL::Resources::Strings(); + +use IMPL::Exception(); +use IMPL::lang qw(is typeof hashApply hashMerge); +use IMPL::declare { + require => { + Document => '-Template::Document', + TypeKeyedCollection => 'IMPL::TypeKeyedCollection', + ArgException => '-IMPL::InvalidArgumentException', + Resources => 'IMPL::Resources', + Loader => 'IMPL::Code::Loader', + MetadataBase => '-IMPL::Web::View::Metadata::BaseMeta', + Metadata => 'IMPL::Web::View::Metadata::ObjectMeta', + StringMap => 'IMPL::Resources::StringLocaleMap' + }, + base => [ + 'Template::Context' => '@_' + ] +}; + +BEGIN { + no strict 'refs'; + # modules is a global (for the whole document) templates cache + # tt_cache is a local (for the current context only) templtes cache + foreach my $prop (qw( + root + base + tt_ext + tt_cache + parent + prefix + cache + includes + modules + aliases + id + metadata + model + templateInfo + )) { + my $t = $prop; + + *{__PACKAGE__ . '::' . $prop} = sub { + my $this = shift; + return @_ ? $this->stash->set($t, @_) : $this->stash->get($t); + } + } +} + +sub clone { + my $this = shift; + my $params = shift; + + $this->localise(); + + my $args = { %{$this} }; + + $this->delocalise(); + + my $class = ref($this); + + delete $args->{CONFIG}; + + my $clone = $class->new($args); + + $clone->stash->update($params) if $params; + + return $clone; +} + +sub get_next_id { + my ($this) = @_; + + my $id = $this->stash->get('document.nextId') || 0; + $this->stash->set('document.nextId', $id + 1); + return "w-$id"; +} + +sub find_template { + my ($this,$name, $nothrow) = @_; + + my $cache = $this->tt_cache; + + $this->tt_cache($cache = {}) unless $cache; + + if(my $tpl = $cache->{$name}) { + return $tpl; + } + + my @inc = ($this->base, @{$this->includes || []}); + #my @inc = @{$this->includes || []}; + + my $ext = $this->tt_ext || ""; + + #warn "find: $name"; + + my $file; + + foreach my $dir (@inc) { + $file = $dir ? "$dir/$name" : $name; + + my @parts = split(/\/+/,$file); + + my $templateName = pop @parts; + + my $base = join('/',@parts); + + $file = $ext ? "$file.$ext" : $file; + + #warn " file: $file"; + + if (exists($this->modules->{$file})) { + my $info = $this->modules->{$file}; + return $cache->{$name} = $info + if $info; + } else { + if( my $tt = eval { $this->template($file) } ) { + #warn " found: $file"; + my $class; + if ($class = $tt->class) { + $class = $this->aliases->{$class} || $class; + Loader->safe->Require($class); + } + my $info = { + base => $base, + name => $templateName, + template => $tt, + initialized => 0, + class => $class, + file => $file + }; + $this->modules->{$file} = $info; + return $cache->{$name} = $info; + } else { + my $err = $@; + + #warn " not found: $err"; + + for(my $t = $err; is($t,'Template::Exception'); $t = $t->info ) { + die $err unless $t->type eq Template::Constants::ERROR_FILE; + } + $this->modules->{$file} = undef; + } + } + } + + $this->throw(Template::Constants::ERROR_FILE, "$name: not found") + unless $nothrow; + return; +} + +sub display_for { + my $this = shift; + my $path = shift; + my ($template, $args); + + if (ref $_[0] eq 'HASH') { + $args = shift; + } else { + $template = shift; + $args = shift; + } + + my $prefix = $this->prefix; + + my $info; + my $meta = $this->resolve_model($path,$args) + or return "[not found '$path']"; + + $info->{prefix} = join('.', grep($_, $prefix, $path)); + $info->{model} = $meta->model; + $info->{metadata} = $meta; + + $template ||= $info->{template}; + $template = $template ? $this->find_template($template) : $this->find_template_for($info->{metadata}); + + return $this->render( + $template, + hashApply( + $info, + $args + ) + ); +} + +sub display_model { + my $this = shift; + my $model = shift; + my ($template, $args); + + if (ref $_[0] eq 'HASH') { + $args = shift; + } else { + $template = shift; + $args = shift; + } + + #copy + $args = { %{$args || {}} }; + + $args->{prefix} = join('.',grep($_,$this->prefix,$args->{path})) + unless defined $args->{prefix}; + + if (is($model,MetadataBase)) { + $args->{model} = $model->model; + $args->{metadata} = $model; + } else { + $args->{model} = $model; + $args->{metadata} = Metadata->GetMetadataForModel($model); + } + + $template = $template ? $this->find_template($template) : $this->find_template_for($args->{metadata}); + + return $this->render( + $template, + $args + ); +} + +# обеспечивает необходимый уровень изоляции между контекстами +# $code - код, который нужно выполнить в новом контексте +# $env - хеш с переменными, которые будут переданы в новый контекст +# в процессе будет создан клон корневого контекста, со всеми его свойствами +# затем новый контекст будет локализован и в него будут добавлены новые переменные из $env +# созданный контекст будет передан параметром в $code +sub invoke_environment { + my ($this,$code,$env) = @_; + + $env ||= {}; + + my $ctx = ($this->root || $this)->clone(); + + my @includes = @{$this->includes || []}; + + if ($this->base) { + unshift @includes, $this->base; + } + + my $out = eval { + $ctx->localise( + hashApply( + { + includes => \@includes, + aliases => $this->aliases || {}, + root => $this->root || $ctx, + modules => $this->modules || {}, + cache => TypeKeyedCollection->new(), + display_for => sub { + $ctx->display_for(@_); + }, + render => sub { + $ctx->render(@_); + }, + display_model => sub { + $ctx->display_model(@_); + }, + tt_cache => {}, + labels => sub { + $ctx->load_labels(@_); + } + }, + $env + ) + ); + + &$code($ctx); + }; + + my $e = $@; + $ctx->delocalise(); + + die $e if $e; + + return $out; +} + +# использует указанный шаблон для создания фрагмента документа +# шаблон может быть как именем, так и хешем, содержащим информацию +# о шаблоне. +# отдельно следует отметить, что данный метод создает новый контекст +# для выполнения шаблона в котором задает переменные base, parent, id +# а также создает переменные для строковых констант из labels +# хеш с переменными $args будет передан самому шаблону в момент выполнения +# если у шаблона указан класс элемента управления, то при выполнении шаблона +# будет создан экземпляр этого класса и процесс выполнения шаблона будет +# делегирован методу Render этого экземпляра. +sub render { + my ($this,$template,$args) = @_; + + $args ||= {}; + + my $info = ref $template ? $template : $this->find_template($template); + + if (ref($info) ne 'HASH') { + carp "got an invalid template object: $info (" . ref($info) . ")"; + $info = { + template => $info, + base => $this->base, + initialized => 1 + }; + } + + return $this->invoke_environment( + sub { + my $ctx = shift; + + unless($info->{initialized}) { + if(my $init = $info->{template}->blocks->{INIT}) { + $info->{initialized} = 1; + eval { + $ctx->visit($info->{template}->blocks); + $ctx->include($init); + }; + $ctx->leave(); + } + } + + if (my $class = $info->{class}) { + $class->new($ctx,$info->{template},$args)->Render({}); + } else { + return $ctx->include($info->{template},$args); + } + }, + { + base => $info->{base}, + parent => $this, + id => $this->get_next_id, + templateInfo => $info + } + ) +} + +sub resolve_model { + my ($this,$prefix) = @_; + + die ArgException->new(prefix => "the prefix must be specified") + unless defined $prefix; + + my $meta = $this->metadata; + unless($meta) { + $meta = Metadata->GetMetadataForModel($this->model); + $this->metadata($meta); + } + + foreach my $part (grep length($_), split(/\.|\[(\d+)\]/, $prefix)) { + last unless $meta; + if ($part =~ /^\d+$/) { + $meta = $meta->GetItem($part); + } else { + $meta = $meta->GetProperty($part); + } + } + + return $meta; +} + +sub find_template_for { + my ($this,$meta, $nothrow) = @_; + + die ArgException->new(meta => 'An invalid metadata is supplied') + unless is($meta,MetadataBase); + + return $this->find_template($meta->template) + if ($meta->template); + + my $type = $meta->modelType; + + return $this->find_template('templates/plain') unless $type; + + if (my $template = $this->cache->Get($type)) { + return $template; + } else { + + no strict 'refs'; + + my @isa = $type; + + while (@isa) { + my $sclass = shift @isa; + + (my $name = $sclass) =~ s/:+/_/g; + my ($shortName) = ($sclass =~ m/(\w+)$/); + + $template = $this->find_template("templates/$name",1) || $this->find_template("templates/$shortName",1); + + if ($template) { + $this->cache->Set($sclass,$template); + return $template; + } + + #todo $meta->GetISA to implement custom hierachy + push @isa, @{"${sclass}::ISA"}; + } + + } + $this->throw(Template::Constants::ERROR_FILE, "can't find a template for the model $type") + unless $nothrow; + + return; +} + +sub get_real_file { + my ($this,$fname) = @_; + + return unless length $fname; + + my @path = split(/\/+/,$fname); + + foreach my $provider (@{$this->load_templates || []}) { + foreach my $dir (@{$provider->paths || []}) { + my $realName = File::Spec->catfile($dir,@path); + return $realName if -f $realName; + } + } +} + +sub load_labels { + my ($this,$data) = @_; + + die ArgException->new("A hash reference is required") + unless ref($data) eq 'HASH'; + + my $stringMap = StringMap->new($data); + + $this->stash->update({ + map { + my $id = $_; + $id, + sub { + $stringMap->GetString($id,@_); + }; + } keys %$data + }); + + my $ti = $this->templateInfo || {}; + + if (my $fullName = $this->get_real_file($ti->{file})) { + my ($vol,$dir,$fname) = File::Spec->splitpath($fullName); + + my $name = $this->templateInfo->{name}; + + my $localePath = File::Spec->catpath($vol, File::Spec->catdir($dir,'locale'),''); + + $stringMap->name($name); + $stringMap->paths($localePath); + } + return; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::View::TTContext> - доработанная версия контекста + +=head1 DESCRIPTION + +Расширяет функции C<Template::Context> + +=begin plantuml + +@startuml + +object RootContext { + document + globals +} + +object DocumentContext { + base + extends +} + +object ControlContext { + base + extends +} + +RootContext o-- DocumentContext +RootContext o-- ControlContext + +Document -- DocumentContext +Control - ControlContext + +Loader . RootContext: <<creates>> +Loader . Document: <<creates>> +Loader -up- Registry + +@enduml + +=end plantuml + +=head1 MEMBERS + +=head2 C<[get,set]base> + +Префикс пути для поиска шаблонов + +=head2 C<template($name)> + +Сначала пытается загрузить шаблон используя префикс C<base>, затем без префикса. + +=head2 C<clone()> + +Создает копию контекста, при этом C<stash> локализуется, таким образом +клонированный контекст имеет собственное пространство имен, вложенное в +пространство родительского контекста. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/TTControl.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,122 @@ +package IMPL::Web::View::TTControl; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::lang qw(:hash :base); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + context => PROP_RO, + template => PROP_RO + ] +}; + +our $AUTOLOAD_REGEX = qr/^[a-z]/; + +sub CTOR { + my ($this,$context,$template,$args) = @_; + + $this->context($context) + or die ArgException->new(context => 'A context is required'); + $this->template($template) + or die ArgException->new(template => 'A template is required'); + + if (ref $args eq 'HASH') { + while(my ($key, $value) = each %$args) { + next if grep $_ eq $key, qw(context template); + $this->$key($value); + } + } +} + +sub _PopulateMethods { + my ($this,@methods) = @_; + + $this->_stash->update({ + map { + my $name = $_; + $name, + sub { + $this->$name(@_); + } + } @methods + }); +} + +sub _stash { + $_[0]->context->stash; +} + +sub Render { + my ($this,$args) = @_; + return $this->context->include($this->template,$args); +} + +our $AUTOLOAD; +sub AUTOLOAD { + my ($prop) = ($AUTOLOAD =~ m/(\w+)$/); + + die Exception->new("Method not found: $AUTOLOAD") unless $prop=~/$AUTOLOAD_REGEX/ and $_[0]; + + no strict 'refs'; + + my $method = sub { + my $that = shift; + if (@_ == 0) { + return $that->_stash->get($prop); + } elsif (@_ == 1) { + return $that->_stash->set($prop,shift); + } else { + return $that->_stash->get([$prop,[@_]]); + } + }; + + *{$AUTOLOAD} = $method; + + goto &$method; +} + + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::View::TTControl> расширяет функциональность шаблонов + +=head1 SYNPOSIS + +=begin code + +package My::View::Menu; +use IMPL::declare { + base => [ + 'IMPL::Web::View::TTControl' => '@_' + ] +}; + +sub Render { + my ($this,$args) = @_; + + $this->PrepareItems($args); + + return $this->next::method($args); +} + +sub PrepareItems + +=end code + +=head1 DESCRIPTION + + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/TTView.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,113 @@ +package IMPL::Web::View::TTView; +use strict; + +use JSON; +use IMPL::lang qw(hashMerge is); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Context => 'IMPL::Web::View::TTContext', + Loader => 'IMPL::Code::Loader', + Factory => 'IMPL::Web::View::ObjectFactory' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + props => [ + options => PROP_RW, + viewBase => PROP_RW, + layoutBase => PROP_RW, + layout => PROP_RW, + tt_ext => PROP_RW, + includes => PROP_RW | PROP_LIST, + globals => PROP_RW + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->tt_ext('tt') unless defined $this->tt_ext; +} + +sub display { + my ($this,$model,$template,$args) = @_; + + my $context = Context->new($this->options); + eval { + $context->process('globals' . '.' . $this->tt_ext, $args); + }; + my $layout = delete $args->{layout} || $this->layout; + + return $context->invoke_environment( + sub { + my $ctx = shift; + if ($layout) { + return $ctx->invoke_environment( + sub { + return shift->render( + $layout, + hashMerge( + { + content => sub { + $ctx->invoke_environment( + sub { + return shift->display_model($model,$template); + }, + { + base => $this->viewBase + } + ) + }, + model => $model + } + ) + ); # render + }, + { + base => $this->layoutBase, + } + ); + } else { + return $ctx->invoke_environment( + sub { + return shift->display_model($model,$template); + }, + { + base => $this->viewBase + } + ); + } + },hashMerge( + $this->globals, + hashMerge( + $args, + { + includes => scalar($this->includes), + tt_ext => $this->tt_ext, + debug => sub { + warn @_; + }, + is => sub { + my ($obj,$class) = @_; + if (is($class,Factory)) { + return is($obj,$class->factory); + } else { + return is($obj,$class); + } + }, + import => sub { + return Factory->new(Loader->safe->Require(shift)); + }, + toJSON => sub { + return JSON->new()->utf8->pretty->encode(shift); + } + } + ) + ) + ); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/View/TemplateView.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,20 @@ +package IMPL::Web::View::TemplateView; +use strict; + +use Carp qw(carp); + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Web::ViewResult' => '@_' + ], + props => [ + template => PROP_RW, + ] +}; + +sub CTOR { + carp "deprecated"; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Web/ViewResult.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,73 @@ +package IMPL::Web::ViewResult; +use strict; + +use IMPL::Const qw(:prop); +use Carp qw(carp); + +use IMPL::declare { + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + model => PROP_RW, + _location => PROP_RW, + cookies => PROP_RW, + headers => PROP_RW, + status => PROP_RW + ] +}; + +sub location { + carp "location property is absolute"; + return shift->_location(@_); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::ViewResult> - описание представления результата. + +=head1 SYNOPSIS + +=begin code + +sub HttpGet { + my ($this, $action) = @_; + + return IMPL::Web::ViewResult->new( + model => $model + ); +} + +=end code + +=head1 DESCRIPTION + +Сожержит в себе информацию для представления модели. Также включает поля для +заголовков ответа C<cookies>, C<headers>, C<status>. + +=head1 MEMBERS + +=head2 C<[get,set]model> + +Модель ресурса, как правило это результат выполнения C<Http> метода. + +=head2 C<[get,set]cookies> + +Хеш с печеньками, которые будут добавлены в C<HTTP> ответ. + +=head2 C<[get,set]headers> + +Заголовки которые нужно добавить в заголовки C<HTTP> ответа. + +=head2 C<[get,set]status> + +Код C<HTTP> ответа. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/XML/SaxParser.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,149 @@ +package IMPL::XML::SaxParser; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + XMLReader => 'XML::LibXML::Reader', + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ 'IMPL::Object' => undef ], + props => [ _reader => PROP_RW ] +}; + +BEGIN { + XMLReader->import; +} + +sub Parse { + my ( $this, $options ) = @_; + + my $reader = $this->_reader( XMLReader->new($options) ); + + if ( $reader->read() > 0) { + $this->ProcessRootNode($reader); + } +} + +sub ProcessRootNode { + my ( $this, $reader ) = @_; + warn "not implemented"; +} + +sub ReadChildren { + my ( $this, $handler ) = @_; + + my $reader = $this->_reader; + + # содержимое можеть быть только у не пустых элементов + if($reader->nodeType == XML_READER_TYPE_ELEMENT && !$reader->isEmptyElement) { + # нужно прочитать все, что ниже, для этого запоминаем текущий уровень + my $currentLevel = $reader->depth; + + # при чтении и проверке данного условия "съедается" закрывающий теэг текущего узла + while($reader->read && $reader->depth > $currentLevel) { + # при обходе дочерних узлов нужно пропустить закрывающие узлы + $this->$handler($reader) + if $handler and $reader->nodeType != XML_READER_TYPE_END_ELEMENT; + } + } +} + +sub ReadTextNode { + my ($this) = @_; + + my $text = ""; + + my $handler; + $handler = sub { + my ( $me, $reader ) = @_; + if ( $reader->nodeType == XML_READER_TYPE_TEXT ) { + $text .= $reader->value; + } else { + $this->ReadChildren($handler); + } + }; + + $this->ReadChildren($handler); + + return $text; +} + +sub ReadComplexContent { + goto &ReadComplexNode; +} + +sub ReadComplexNode { + my ( $this, $schema ) = @_; + + if ( ref $schema eq 'HASH' ) { + my %data; + + my ($handlers,$aliases); + while(my ($selector,$handler) = each %$schema) { + my ($alias,$node) = split /:/, $selector; + $node ||= $alias; + $handlers->{$node} = $handler; + $aliases->{$node} = $alias; + } + + $this->ReadChildren( + sub { + my ( $me, $node ) = @_; + + my $name = $node->localName; + my $alias = $aliases->{$name}; + if ( my $handler = $handlers->{$name} ) { + if (ref $handler eq 'ARRAY') { + push @{$data{$alias}}, $me->ReadComplexNode($$handler[0]); + } else { + $data{$alias} = $me->ReadComplexNode($handler); + } + } else { + $me->ReadChildren(); + } + } + ); + + return \%data; + } + elsif ( ref $schema eq 'CODE' or not ref $schema ) { + return $this->$schema($this->_reader); + } + else { + die ArgException->new( schema => 'An invalid schema is supplied' ); + } +} + +sub attribute { + shift->_reader->getAttribute(shift); +} + +1; + +__END__ + +=pod + +=head1 NAME + +=head1 DESCRIPTION + +=head1 MEMBERS + +=head2 ReadComplexNode($schema) + +=begin code + +{ + comments => sub { shift->ReadTextNode }, + data => [ { + location => sub { $_[1]->getAttribute('href')} , + timestamp => 'ReadTextNode' + } ] +} + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/_core/version.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,25 @@ +package IMPL::_core::version; + +our $VERSION = '0.04'; + +sub import { + *{scalar(caller).'::VERSION'} = \$VERSION; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::_core::version> - Модуль с версией библиотеки C<IMPL>. + +=head1 DESCRIPTION + +Модуль исключительно для внутреннего использования. + +Все модули подключившие данный модуль разделяют с ним версию. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/clone.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,57 @@ +package IMPL::clone; + +use Scalar::Util qw(blessed reftype refaddr); + +use base qw(Exporter); +our @EXPORT_OK = qw(&clone); + +{ + my %handlers = ( + HASH => sub { + my $class = blessed($_[0]); + + my $new = $_[1]->{ refaddr($_[0]) } = {}; + while (my ($key,$val) = each %{$_[0]}) { + $new->{$key} = clone($val,$_[1]); + } + $class ? bless $new, $class : $new; + }, + ARRAY => sub { + my $class = blessed($_[0]); + + my $new = $_[1]->{ refaddr($_[0]) } = []; + + push @$new, clone($_,$_[1]) foreach @{$_[0]}; + + $class ? bless( $new, $class ) : $new; + }, + SCALAR => sub { + my $class = blessed($_[0]); + + my $v = ${$_[0]}; + $class ? bless \$v, $class : \$v; + }, + REF => sub { + my $class = blessed($_[0]); + my $v; + my $new = $_[1]->{ refaddr($_[0]) } = \$v; + $v = clone ( ${$_[0]},$_[1] ); + $class ? bless \$v, $class : \$v; + + }, + REGEXP => sub { + $_[0]; + } + ); + + sub clone { + return unless @_; + + return $_[0] unless ref $_[0]; + + return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_); + } + +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/declare.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,216 @@ +package IMPL::declare; +use strict; + +use Carp qw(carp); +use IMPL::Class::PropertyInfo(); +use IMPL::Const qw(:access); +use IMPL::require(); + +BEGIN { + *_require = *IMPL::require::_require; + *_trace = *IMPL::require::_trace; +} + +sub import { + my ( $self, $args ) = @_; + + return unless $args; + + die "A hash reference is required" unless ref $args eq 'HASH'; + + no strict 'refs'; + no warnings 'once'; + + my $caller = caller; + + my $aliases = $args->{require} || {}; + + $IMPL::require::PENDING{$caller} = 1; + _trace("declare $caller"); + $IMPL::require::level++; + + *{"${caller}::SELF"} = sub () { + $caller; + }; + + while ( my ( $alias, $class ) = each %$aliases ) { + _trace("$alias => $class"); + $IMPL::require::level++; + my $c = _require($class); + + *{"${caller}::$alias"} = sub() { + $c; + }; + $IMPL::require::level--; + } + + my $base = $args->{base} || {}; + + my %ctor; + my @isa; + + if ( ref $base eq 'ARRAY' ) { + carp "Odd elements number in require" + unless scalar(@$base) % 2 == 0; + while ( my ( $class, $mapper ) = splice @$base, 0, 2 ) { + _trace("parent $class"); + $IMPL::require::level++; + $class = $aliases->{$class} || _require($class); + $IMPL::require::level--; + + push @isa, $class; + $ctor{$class} = $mapper; + } + } + elsif ( ref $base eq 'HASH' ) { + while ( my ( $class, $mapper ) = each %$base ) { + _trace("parent $class"); + $IMPL::require::level++; + $class = $aliases->{$class} || _require($class); + $IMPL::require::level--; + + push @isa, $class; + $ctor{$class} = $mapper; + } + } + + %{"${caller}::CTOR"} = %ctor; + push @{"${caller}::ISA"}, @isa; + + if ( ref( $args->{meta} ) eq 'ARRAY' ) { + $caller->SetMeta($_) foreach @{ $args->{meta} }; + } + + my $props = $args->{props} || []; + + if ( $props eq 'HASH' ) { + $props = [%$props]; + } + + die "A hash or an array reference is required in the properties list" + unless ref $props eq 'ARRAY'; + + carp "Odd elements number in properties declaration of $caller" + unless scalar(@$props) % 2 == 0; + + if (@$props) { + $self->_implementProps( $props, $caller ); + } + + if ( $args->{_implement} ) { + $self->_implementProps( $caller->abstractProps, $caller ); + $caller->abstractProps( [] ); + } + + $IMPL::require::level--; + delete $IMPL::require::PENDING{$caller}; +} + +sub _implementProps { + my ( $self, $props, $caller ) = @_; + + for ( my $i = 0 ; $i < @$props - 1 ; $i = $i + 2 ) { + my ( $prop, $spec ) = @{$props}[ $i, $i + 1 ]; + + $caller->ClassPropertyImplementor->Implement( + $spec, + { + name => $prop, + class => $caller, + access => $prop =~ /^_/ + ? ACCESS_PRIVATE + : ACCESS_PUBLIC + } + ); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::declare> - описывает класс + +=head1 SYNOPSIS + +=begin code + +package My::Bar; + +use IMPL::declare { + require => { + TFoo => 'My::Foo', + TBox => 'My::Box' + }, + base => { + TFoo => '@_', + 'IMPL::Object' => undef, + } +} + +sub CreateBox { + my ($this) = @_; + return TBox->new($this); +} + +=end code + +Специальная ситрока C<@_> означает передачу параметров конструктора текущего класса конструктору +базового класса без изменений. + +=head1 DESCRIPTION + +Описывает текущий пакет(модуль) как класс. В качестве параметра получает ссылку на хеш, +в которой храняться метаданные для объявления класса. + +=head1 METADATA + +=head2 C<require> + +Содержит ссылку на хеш с синонимами модулей, которые будут доступны в текушем модуле, +аналогично использованию C<IMPL::require>. Однако, если модуль не требует загрузки при +помощи C<require> нужно использовать префикс C<'-'> в его имени + +=begin code + +{ + require => { + TObject => 'IMPL::Object', # will be loaded with require + TFoo => '-My:App::Data::Foo' # will not use 'require' to load module + } +} + +=end code + +=head2 C<base> + +Обисывает базове классы для текущего класса. Если данный параметр - ссылка массив, то +этот массив будет превращен в массив C<@ISA>. Если данный параметр - ссылка на хеш, то +его ключи опичавют список базовых классов, а значения - преобразование параметров для +вызова базовых конструкторов. + +В качестве имен базовых классов могут быть как полные имена модулей, так и назначенные +ранее псевдонимы. Использование префикса C<'-'> перед B<полным именем модуля> означает, +что модуль не требуется загружать, в случае с псевдонимами, префикс C<'-'> уже был указан +при их объявлении. + +=begin code + +{ + require => { + TFoo => '-My:App::Data::Foo' # will not use 'require' to load module + }, + base => { + TFoo => '@_', # pass parameters unchanged + 'My::Base::Class' => sub { name => $_[0], data => $_[1] }, # remap parameters + '-My::Extentions' => undef, # do not pass any parameters + } +} + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/lang.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,251 @@ +package IMPL::lang; +use strict; +use warnings; + +use parent qw(Exporter); +use IMPL::_core::version; +use IMPL::clone qw(clone); +use Scalar::Util qw(blessed); +use Carp qw(carp); + +our @EXPORT = qw(&is &isclass &typeof); +our %EXPORT_TAGS = ( + base => [ + qw( + &is + &clone + &isclass + &typeof + ) + ], + + declare => [ + qw( + &public + &protected + &private + &property + &static + &property + &_direct + &ACCESS_PUBLIC + &ACCESS_PROTECTED + &ACCESS_PRIVATE + &PROP_GET + &PROP_SET + &PROP_OWNERSET + &PROP_LIST + &PROP_ALL + &PROP_RO + &PROP_RW + &PROP_DIRECT + ) + ], + compare => [ + qw( + &equals + &equals_s + &hashCompare + ) + ], + hash => [ + qw( + &hashApply + &hashMerge + &hashDiff + &hashCompare + &hashParse + &hashSave + ) + ] +); + +our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; + +use IMPL::Const qw(:all); + +sub is($$) { + carp "A typename can't be undefined" unless $_[1]; + blessed($_[0]) and $_[0]->isa( $_[1] ); +} + +sub isclass { + carp "A typename can't be undefined" unless $_[1]; + local $@; + eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; +} + +sub typeof(*) { + local $@; + eval { $_[0]->_typeof } || blessed($_[0]) || ref($_[0]); +} + +sub public($) { + my $info = shift; + $info->{access} = ACCESS_PUBLIC; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub private($) { + my $info = shift; + $info->{access} = ACCESS_PRIVATE; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub protected($) { + my $info = shift; + $info->{access} = ACCESS_PROTECTED; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub _direct ($) { + my $info = shift; + $info->{direct} = 1; + return $info; +} + +sub property($$) { + my ($propName,$attributes) = @_; + + $attributes = { + get => $attributes & PROP_GET, + set => $attributes & PROP_SET, + isList => $attributes & PROP_LIST + } unless ref $attributes; + + my $class = caller; + + return hashMerge ( + $attributes, + { + implementor => $class->ClassPropertyImplementor, + name => $propName, + class => scalar(caller), + } + ); +} + +sub static($$) { + my ( $name, $value ) = @_; + my $class = caller; + $class->static_accessor( $name, $value ); +} + +sub equals { + if (defined $_[0]) { + return 0 if (not defined $_[1]); + + return $_[0] == $_[1]; + } else { + return 0 if defined $_[1]; + + return 1; + } +} + +sub equals_s { + if (defined $_[0]) { + return 0 if (not defined $_[1]); + + return $_[0] eq $_[1]; + } else { + return 0 if defined $_[1]; + + return 1; + } +} + +sub hashDiff { + my ($src,$dst) = @_; + + $dst = $dst ? { %$dst } : {} ; + $src ||= {}; + + my %result; + + foreach my $key ( keys %$src ) { + if (exists $dst->{$key}) { + $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); + delete $dst->{$key}; + } else { + $result{"-$key"} = 1; + } + } + + $result{"+$_"} = $dst->{$_} foreach keys %$dst; + + return \%result; +} + +sub hashMerge { + return hashApply( { %{$_[0] || {}} }, $_[1] ); +} + +sub hashApply { + my ($target,$diff) = @_; + + return $target unless ref $diff eq 'HASH'; + + while ( my ($key,$value) = each %$diff) { + $key =~ /^(\+|-)?(.*)$/; + my $op = $1 || '+'; + $key = $2; + + if ($op eq '-') { + delete $target->{$key}; + } else { + $target->{$key} = $value; + } + } + + return $target; +} + +sub hashCompare { + my ($l,$r,$cmp) = @_; + + $cmp ||= \&equals_s; + + return 0 unless scalar keys %$l == scalar keys %$r; + &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; + + return 1; +} + +sub hashParse { + my ($s,$p,$d) = @_; + + $p = $p ? qr/$p/ : qr/\n+/; + $d = $d ? qr/$d/ : qr/\s*=\s*/; + + return { + map split($d,$_,2), split($p,$s) + }; +} + +sub hashSave { + my ($hash,$p,$d) = @_; + + return "" unless ref $hash eq 'HASH'; + + $p ||= "\n"; + $d ||= " = "; + + return + join( + $p, + map( + join( + $d, + $_, + $hash->{$_} + ), + keys %$hash + ) + ); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/require.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,99 @@ +package IMPL::require; +use strict; + +#require IMPL::Code::Loader; + +use Carp qw(carp); + +our %PENDING; +our $LOADER_LOG; + +our $level = 0; + +sub import { + my ( $self, $aliases ) = @_; + + return unless $aliases; + + die "A hash reference is required" unless ref $aliases eq 'HASH'; + + my $caller = caller; + + $PENDING{$caller} = 1; + + no strict 'refs'; + + while ( my ( $alias, $class ) = each %$aliases ) { + _trace("$alias => $class"); + $level++; + + $class = _require($class); + + *{"${caller}::$alias"} = sub () { + $class; + }; + + $level--; + } + + delete $PENDING{$caller}; +} + +sub _require { + my ($class) = @_; + + if ( not $class =~ s/^-// ) { + ( my $file = $class ) =~ s/::|'/\//g; + _trace("already pending") and return $class + if $PENDING{$class}; + $PENDING{$class} = 1; + _trace("loading $file.pm"); + $level++; + require "$file.pm"; + $level--; + _trace("loaded $file.pm"); + delete $PENDING{$class}; + } + $class; +} + +sub _trace { + my ($message) = @_; + + $LOADER_LOG->print( "\t" x $level, "$message\n" ) if $LOADER_LOG; + + return 1; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::require> загружает и назначет псевдонимы модулям. + +=head1 SYNOPSIS + +=begin code + +use IMPL::require { + TFoo => 'My::Nested::Package::Foo', + FS => 'File::Spec' +}; + +my $obj = My::Nested::Package::Foo->new('foo'); +$obj = TFoo->new('foo'); # ditto + +FS->catdir('one','two','three'); + +=end code + +=head1 DESCRIPTION + +Загружает модули с помощью C<require> и создает константы которые возвращаю полное имя модуля. + + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/template.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,155 @@ +package IMPL::template; +use strict; +use warnings; + +use IMPL::Class::Template(); + +sub import { + shift; + my %args = @_; + + my $class = caller; + + my @paramNames = grep m/\w+/, @{$args{parameters} || []}; + my $declare = $args{declare}; + my @isa = (@{$args{base} || []}, $class); + my %instances; + + no strict 'refs'; + + push @{"${class}::ISA"}, 'IMPL::Class::Template'; + + *{"${class}::$_"} = sub { die IMPL::InvalidOperationException("A template parameter isn't available here") } + foreach @paramNames; + + *{"${class}::spec"} = sub { + my ($self,@params) = @_; + + my $specClass = $self->makeName(@params); + + return $specClass if $instances{$specClass}; + + $instances{$specClass} = 1; + + for (my $i=0; $i < @paramNames; $i++) { + my $param = $params[$i]; + *{"${specClass}::$paramNames[$i]"} = sub { $param }; + } + + @{"${specClass}::ISA"} = @isa; + + &$declare($specClass) if $declare; + return $specClass; + }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::template> директива для объявления шаблона. + +=head1 SYNPOSIS + +=begin code + +package KeyValuePair; + +use IMPL::Class::Property; + +use IMPL::template ( + parameters => [qw(TKey TValue))], + base => [qw(IMPL::Object IMPL::Object::Autofill)], + declare => sub { + my ($class) = @_; + public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } ); + public $class->CreateProperty(value => prop_all, { type => $class->TValue} ); + + $class->PassThroughArgs; + } +); + +BEGIN { + public property id => prop_get | owner_set, { type => 'integer'}; +} + +__PACKAGE__->PassThroughArgs; + +package MyCollection; + +use IMPL::Class::Property; + +use IMPL::lang; +use IMPL::template( + parameters => [qw(TKey TValue)], + base => [qw(IMPL::Object)], + declare => sub { + my ($class) = @_; + my $item_t = spec KeyValuePair($class->TKey,$class->TValue); + + public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } ); + + $class->static_accessor( ItemType => $item_t ); + } +) + +sub Add { + my ($this,$key,$value) = @_; + + die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey; + die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue; + + $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) ); +} + +package main; + +use IMPL::require { + TFoo => 'Some::Package::Foo', + TBar => 'Some::Package::Bar' +}; + +my $TCol = spec MyCollection(TFoo, TBar); + +=end code + +=head1 DESCRIPTION + +Шаблоны используются для динамической генерации классов. Процесс создания класса +по шаблону называется специализацией, при этом создается новый класс: + +=over + +=item 1 + +Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона + +=item 2 + +Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона + +=item 3 + +Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров + +=item 4 + +Вызывается метод для конструирования специализиции + +=back + +=head1 MEMBERS + +=over + +=item C<spec(@params)> + +Метод, создающий специализацию шаблона. Может быть вызван как оператор. + +=back + +=cut