# HG changeset patch # User cin # Date 1526334661 -10800 # Node ID eed50c01e75829a19ae575c2cd4a5f49bb207180 # Parent 87af445663d7f6ba8d041121fee67a92d0e17fe5 Split off the core module, added Dist-Zilla config diff -r 87af445663d7 -r eed50c01e758 .hg_archival.txt --- a/.hg_archival.txt Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -repo: 03e58a454b208a22e4b4ca287c68fd43942a03d3 -node: de83ecba0fd753fbee216945ba2fe2e225e10a7c -branch: default -latesttag: null -latesttagdistance: 209 diff -r 87af445663d7 -r eed50c01e758 _test/temp.pl --- a/_test/temp.pl Tue Apr 03 10:54:09 2018 +0300 +++ b/_test/temp.pl Tue May 15 00:51:01 2018 +0300 @@ -44,7 +44,7 @@ my $t = [gettimeofday]; for(my $i=0; $i <1000000; $i++) { - my $v = new Bar2; + my $v = new Foo2; } say tv_interval($t); diff -r 87af445663d7 -r eed50c01e758 deps.txt --- a/deps.txt Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -Class::Accessor -Template -XML::Writer -JSON -DBIx::Class -DateTime::Format::Parser -DateTime::Format::MySQL -Sub::Name \ No newline at end of file diff -r 87af445663d7 -r eed50c01e758 dist.ini --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/dist.ini Tue May 15 00:51:01 2018 +0300 @@ -0,0 +1,12 @@ +name = Impl-Core +main_module = lib/IMPL.pm +abstract = IMPL module +author = Sergey Smirnov +license = BSD +copyright_holder = Sergey Smirnov +copyright_year = 2018 +version = 0.002 + +[@Basic] +[PkgVersion] +finder=:MainModule \ No newline at end of file diff -r 87af445663d7 -r eed50c01e758 impl.komodoproject --- a/impl.komodoproject Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ - - - - - - - - 1 - None - None - lib - 1 - - - - - Perl - TAP (*.t) - - - - diff -r 87af445663d7 -r eed50c01e758 impl.kpf --- a/impl.kpf Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1109 +0,0 @@ - - - - - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - 1 - Lib - - - - - Perl - TAP (*.t) - - - - - - - - - 9011 - - - Lib/IMPL/DOM/Navigator/Builder.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/DOM/Navigator/SimpleBuilder.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/DOM/Schema.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/DOM/Schema/ComplexNode.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/DOM/Schema/Item.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/DOM/Schema/Property.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/DOM/XMLReader.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/ORM/Entity.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/ORM/Object.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/Object.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - Lib/IMPL/Security/Auth/Simple.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/DOM.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/ORM.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/Resources.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/SQL.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/Test/DOM/Builder.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/Test/DOM/Node.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/Test/DOM/Schema.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/Test/ORM/Schema.pm - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/Web.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/any.pl - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/run_tests.pl - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/wmi.pl - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - - - - - - 9011 - - - _test/object.t - - Perl - - - - application/x-www-form-urlencoded - GET - 1 - 0 - 0 - - - enabled - - - default - - diff -r 87af445663d7 -r eed50c01e758 lib/IMPL.pm --- a/lib/IMPL.pm Tue Apr 03 10:54:09 2018 +0300 +++ b/lib/IMPL.pm Tue May 15 00:51:01 2018 +0300 @@ -1,15 +1,5 @@ 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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Config.pm --- a/lib/IMPL/Config.pm Tue Apr 03 10:54:09 2018 +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 - базовый класс для настраиваемого приложения. - -=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 содержащего настройки приложения - -=begin code xml - - - The application - - MyDataSourceClass - - localhost - dbuser - - - - -=end code xml - -=head1 DESCRIPTION - -C<[Serializable]> - -C<[Autofill]> - -C - -Базовый класс для приложений. Использует подход, что приложение -является объектом, состояние которого предтавляет собой конфигурацию, -а методы - логику. - -Данный класс реализует функционал десериализации (и сериализации) экземпляра -приложения из XML документа. Для этого используется механизм C. -При этом используются опции C C и -C для записи документа в легко читаемом виде. - -Поскольку в результате восстановления приложения восстанавливаются все элементы -из файла конфигурации, то это может потребовать значительных ресурсов для -создания частей, которые могут никогда не понадобиться. Например, не требуется инициализация -источника данных для передачи пользователю статических данных, сохраненных на диске. - -Для решения этой проблемы используются специальные объекты C. - -Если у приложения описано свойство, в котором хранится C, то -при первом обращении к такому свойству, будет создан объект вызовом метода -C<< IMPL::Config::Activator->activate() >> и возвращен как значение этого свойства. -Таким образом реализуется прозрачная отложенная активация объектов, что позволяет -экономить ресурсы. - -=head1 MEMBERS - -=over - -=item C<[static] LoadXMLFile($fileName) > - -Создает из XML файла C<$fileName> экземпляр приложения - -=item C - -Сохраняет приложение в файл C<$fileName> - -=item C<[get] xml > - -Сохраняет конфигурацию приложения в XML строку. - -=item C<[static,operator] spawn($file)> - -Синоним для C, предполагается использование как оператора. - -=item C - -Метод для получения значений свойств приложения. Данный метод позволяет избежать -использование активации объектов через C. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Document.pm --- a/lib/IMPL/DOM/Document.pm Tue Apr 03 10:54:09 2018 +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 DOM документ. - -=head1 DESCRIPTION - -Документ, позволяет создавать узлы определенных типов, что позволяет абстрагироваться -от механизмов реального создания объектов. Т.о. например C -может формировать произвольные документы. - -=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 который будет использован для записи -содержимого документа - -=back - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Navigator.pm --- a/lib/IMPL/DOM/Navigator.pm Tue Apr 03 10:54:09 2018 +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. - -=item C<<$obj->Back()>> - -Возвращается в предыдущий узел, если таковой есть. - -Возвращает либо узел в который перешли, либо C. - -=item C<<$obj->advanceNavigator()>> - -Переходит в следующую альтернативу, соответствующую текущему запросу. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Navigator/Builder.pm --- a/lib/IMPL/DOM/Navigator/Builder.pm Tue Apr 03 10:54:09 2018 +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. - -=head1 MEMBERS - -=head2 C< CTOR($classDocument,$schema, %opts) > - -Создает новый объект, принимает на вход класс документа (или фабрику, например -L) и схему. В процессе процедуры построения документа -будет создан объект документа. - -Необязательные именованные параметры - -=over - -=item C - -C не будет вызывать исключение, если запрашиваемый узел не -найден в схеме, но будет возвращать C. - -=back - -=head2 C< NavigateCreate($nodeName,%props) > - -Создает новый узел с указанным именем и переходит в него. В случае если в схеме -подходящий узел не найден, то вызывается исключение или будет возвращено -C см. C. - -При этом по имени узла ищется его схема, после чего определяется класс для -создания экземпляра узла и созданный узел доавляется в документ. При создании -нового узла используется метод документа C<< IMPL::DOM::Document->Create >> - -Свойства узла передаются при создании через параметр C<%props>, но имя -создаваемого узла НЕ может быть переопределено свойством C, оно будет -проигнорировано. - -Свойства узла будут преобразованы при помощи заданных в схеме заполнителей -C. - -=head2 C<[get]document > - -Свойство, которое содержит документ по окончании процедуры построения. - -=head2 C<[get]buildErrors> - -Ошибки, возникшие в процессе построения документа. - -=head2 C<[get]ignoreUndefined> - -Опция, заданная при создании построителя, отвечающая за обработку узлов -не найденных в схеме. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Navigator/SchemaNavigator.pm --- a/lib/IMPL/DOM/Navigator/SchemaNavigator.pm Tue Apr 03 10:54:09 2018 +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 - -Переходит на схему узла с указанным именем. Тоесть использует свойство C. - -=item C - -Возвращается на позицию до последней операции C. Данный метод нужен -посокольку операция навигации по элементам описываемым схемой может приводить к -нескольким операциям навигации по самой схеме. - -=item C - -Получает схему узла из которого было выполнено перенаправление, например, C. -В остальных случаях совпадает со свойством C. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Navigator/SimpleBuilder.pm --- a/lib/IMPL/DOM/Navigator/SimpleBuilder.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Node.pm --- a/lib/IMPL/DOM/Node.pm Tue Apr 03 10:54:09 2018 +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 Элемент DOM модели - -=head1 DESCRIPTION - -Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели. - -=head1 MEMBERS - -=head2 PROPERTIES - -=over - -=item C<[get] nodeName> - -Имя узла. Задается при создании. - -=item C<[get] document> - -Документ к которому принадлежит узел. Задается при поздании узла. - -=item C<[get] isComplex> - -Определяет является ли узел сложным (тоесть есть ли дети). - -C - есть, C - нет. - -=item C<[get,set] nodeValue> - -Значение узла, обычно простой скаляр, но ничто не мешает туда -устанавливать любое значение. - -=item C<[get,list] childNodes> - -Список детей, является списокм C. - -=item C<[get] parentNode> - -Ссылка на родительский элемент, если таковой имеется. - -=item C<[get] schemaType> - -Ссылка на узел из C, представляющий схему данных текущего узла. Может быть C. - -=item C<[get] schemaNode> - -Ссылка на узел из C, представляющий элемент схемы, объявляющий данный узел. Может быть C. - -Отличается от свойства C тем, что узел в случае ссылки на тип узла, данной свойство будет содержать -описание ссылки C, а свойство C например будет ссылаться на -C. - -=back - -=head2 METHODS - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Property.pm --- a/lib/IMPL/DOM/Property.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema.pm --- a/lib/IMPL/DOM/Schema.pm Tue Apr 03 10:54:09 2018 +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 - Схема документа. - -=head1 DESCRIPTION - -C - -DOM схема - это документ, состоящий из определенных узлов, описывающая структуру -других документов. - -=head1 METHODS - -=over - -=item C<< $obj->Process() >> - -Обновляет таблицу типов из содержимого. - -=item C<< $obj->ResolveType($typeName) >> - -Возвращает схему типа c именем C<$typeName>. - -=back - -=head1 META SCHEMA - -Схема для описания схемы, эта схема используется для постороения других схем, выглядит приблизительно так - -=begin code xml - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -=end code xml - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/AnyNode.pm --- a/lib/IMPL/DOM/Schema/AnyNode.pm Tue Apr 03 10:54:09 2018 +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 этот узел можно использовать только один раз -причем его использование исключает использование узла C. - -В контейнерах типа С данный узел может применяться несколько раз -для решения таких задач как последовательности разноименных узлов с одним типом. - - - - - - - - - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/ComplexNode.pm --- a/lib/IMPL/DOM/Schema/ComplexNode.pm Tue Apr 03 10:54:09 2018 +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 - -=head2 PROPERTIES - -=over - -=item C - -Содержимое узла, может быть либо C либо -C, в зависимости от того важен порядок или нет. -Это свойство ссылается на первый дочерний элемент узла. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/ComplexType.pm --- a/lib/IMPL/DOM/Schema/ComplexType.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/Label.pm --- a/lib/IMPL/DOM/Schema/Label.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/Node.pm --- a/lib/IMPL/DOM/Schema/Node.pm Tue Apr 03 10:54:09 2018 +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. - -Минимальное количество повторений узла. - -=item C<[get,set] maxOccur> - -C. - -Максимальное количество повторений узла - -=item C<[get,set] type> - -C - -Имя типа из схемы. - -=item C<[get,set] name> - -Имя узла. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/NodeList.pm --- a/lib/IMPL/DOM/Schema/NodeList.pm Tue Apr 03 10:54:09 2018 +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 и C. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/NodeSet.pm --- a/lib/IMPL/DOM/Schema/NodeSet.pm Tue Apr 03 10:54:09 2018 +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 и C. - -При проверке данного правила, проверяются имеющиеся элементы на соответсие схемы -и количества встречаемости, после чего проверяются количественные ограничения -для несуществующих элементов. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/Property.pm --- a/lib/IMPL/DOM/Schema/Property.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/SimpleNode.pm --- a/lib/IMPL/DOM/Schema/SimpleNode.pm Tue Apr 03 10:54:09 2018 +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 - узел с текстом. - -=head1 DESCRIPTION - -Узел имеющий простое значение. Данный узел может содержать ограничения -на простое значение. - -Производит валидацию содержимого, при постоении DOM модели не имеет специального -типа и будет создан в виде C. - -Также определяет как будет воссоздано значение узла в DOM модели. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/SimpleType.pm --- a/lib/IMPL/DOM/Schema/SimpleType.pm Tue Apr 03 10:54:09 2018 +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 - тип для простых узлов. - -=head1 DESCRIPTION - -Используется для описания простых узлов, которые можно отобразить в узлы -определенного типа при построении DOM документа. - -=head1 MEMBERS - -=over - -=item C - -Имя класса который будет представлять узел в DOM модели. - -=item C - -Формат сообщения которое будет выдано, если узел в дом модели не будет -соответствовать свойству C. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/SwitchNode.pm --- a/lib/IMPL/DOM/Schema/SwitchNode.pm Tue Apr 03 10:54:09 2018 +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. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/ValidationError.pm --- a/lib/IMPL/DOM/Schema/ValidationError.pm Tue Apr 03 10:54:09 2018 +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 - Описывает ошибку в документе. - -=head1 DESCRIPTION - -При проверке документа на ошибки формирования возвращается массив с объектами -C, каждая из которых описывает одну ошибку -в документе. - -С помощью данного объекта осущетсвляется привязка элемента схемы, элемента документа -и сообщения о причине возникновения ошибки. - -Часть ошибок, таких как проверка содержимого на регулярные выражения, привязаны -непосредственно к элементу. Но есть ошибки которые привязываются к родительскому -контейнеру, например отсутсвие обязательного элемента. В таком случае ошибка -содержит свойство C и по свойству C можно определить элемент -(например его имя), к которому относится ошибка. - -=head1 MEMBERS - -=over - -=item C<[get] node> - -Узел в документе который привел к ошибке. Как правило это либо простые узлы, либо -узлы, которые не могут присутствоать в данном месте по схеме. - -Данное свойство может быть C. - -=item C<[get] parent> - -Родительский узел в котором произошла ошибка. Используется в случаях, когда C -не указан, например, если по схеме должен существовать дочерний узел с определенным -именем, а в реальном документе его нет. - -Также это свойство может использоваться при формировании сообщения. - -=item C<[get] schema> - -Схема для C или узла который должен присутсвовать если C не задан. - -=item C<[get] source> - -Схема, проверка которой привела к возникновению ошибки. Поскольку схемы могут -использовать ссылки, то данное свойство нужно для получения схемы узла, а не -схемы его типа. - -Тоесть проверка схемы узла C приводит к проверке схемы -типа, например, C, а свойство C будет -указывать именно на C. - -=item C<[get] message> - -Возвращает форматированное сообщение об ошибке. - -=item C - -Преобразует ошибку к строке, возвращает значение свойства C - -=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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/Validator.pm --- a/lib/IMPL/DOM/Schema/Validator.pm Tue Apr 03 10:54:09 2018 +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 - Базовый класс для ограничений на простые значения. - -=head1 DESCRIPTION - -От основных элементов схемы его отличает то, что в конечном документе он не соответсвует -никаким узлам и поэтому у него отсутствуют свойства C. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/Validator/Compare.pm --- a/lib/IMPL/DOM/Schema/Validator/Compare.pm Tue Apr 03 10:54:09 2018 +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 - ограничение на содержимое текущего узла, -сравнивая его со значением другого узла. - -=head1 SYNOPSIS - -Пример типа описания поля с проверочным полем - -=begin code xml - - - - - - - - -=begin code xml - -=head1 DESCRIPTION - -Позволяет сравнивать значение текущего узла со значением другого узла. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Schema/Validator/RegExp.pm --- a/lib/IMPL/DOM/Schema/Validator/RegExp.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Transform.pm --- a/lib/IMPL/DOM/Transform.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Transform/ObjectToDOM.pm --- a/lib/IMPL/DOM/Transform/ObjectToDOM.pm Tue Apr 03 10:54:09 2018 +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 -преобразование объекта в 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. Определяет базовые преобразования для хешей и -объектов, поддерживающих метаданные. - -Результатом выполнения преобразования является DOM документ. При построении -документа используется навигатор C для -сопоставления схемы и свойств преобразуемого объекта. Элементы полученного -документа имеют ссылки на соответствующие им элементы схемы. - -После того, как документ построен и преобразование будет очищено, не останется -объектов, которые бы ссылались на документ со схемой, поскольку элементы схемы -имеют слабые ссылки на саму схему и не могут предотвратить ее удаление. -Для предотвращения очитски документа схемы, ссылка на него сохраняется в -атрибуте документа C, что обеспечит жизнь схемы на протяжении -жизни документа. - -Преобразование происходит рекурсивно, сначала используется метод -C для создания элемента соответсвующего свойству объекта, -затем вызывается метод C для преобразования значения свойства, при -этом C указывает на только что созданный элемент документа. - -Для изменения поведения преобразования можно добавлять новые обработчики, как -в случае со стандартным преобразованием, а также можно унаследовать текущий -класс для переопределения его некоторых методов. - -=head1 MEMBERS - -=head2 C - -Создает преобразование, при этом будет создан документ состоящий только из -корневого элемента с именем C<$docName> и будет найдена подходящий для него -элемент схемы C<$schema>. - -=over - -=item * C<$docName> - -Имя корневого узла документа, которое будет использовано для поиска -соответствующего элемента схемы C<$schema> - -=item * C<$schema> - -Схема, содержащая описание документа. Если в данной схеме нет описания корневого -элемента с именем C<$docName>, будет вызвано исключение. - -=back - -=head2 C<[get]documentSchema> - -Элемент схемы C соответствующий документу. Определяется в -конструкторе исходя из имени документа. - -=head2 C<[get]currentNode> - -Текущий элемент документа. После создания преобразования - это сам документ. -Данное свойство использется внутри преобразования для работы с текущим -элементом. - -=head2 C<[virtual]StoreObject($node,$data)> - -Метод, который вызывается преобразованием в случае если текущий узел документа -является простым, а значени которое ему соответсвует является объектом (ссылкой). - -По-умолчанию будет выполнено присваивание C<< $node->nodeValue($data) >>, однако -это можно заменить, например, на преобразование в строку. - -=cut \ No newline at end of file diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Transform/PostToDOM.pm --- a/lib/IMPL/DOM/Transform/PostToDOM.pm Tue Apr 03 10:54:09 2018 +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 - Преобразование объекта C в 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. - -Имена параметров интерпретируются следующим образом - -=over - -=item 1 Имя параметра составляется из имени узла, имен всех его родителей и указанием номера экземпляра. - -=item 2 Имена узлов могут содержать только буквы, цифры и символ _ - -=item 3 В случае когда узел может повторяться несколько раз, в квадратных скобках указывается -послеовательный номер экземпляра. - -=item 4 Имена параметров объединяются через символ '/' - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/Transform/QueryToDOM.pm --- a/lib/IMPL/DOM/Transform/QueryToDOM.pm Tue Apr 03 10:54:09 2018 +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 - преобразование 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. Добавляет метод -C который применятеся к объектам типа C (и производных). - -Запрос C сначала приводится к хешу, затем полученный хеш преобразуется -в DOM документ при помощи вызова метода C. - -Для этого выбираются параметры запроса, затем, имя каждого параметра -рассматривается в виде пути к свойству, создается структура из хешей и массивов -в которую по указанному пути кладется значение. - -Если параметр имеет несколько значений, значит свойство является массивом. - -Также изменено поведение некоторых методов преобразования. - -=over - -=item * C - -Преобразование для простого значения свойства. Посокльку в запросе передаются -строковые значения, а схема документа может предполпгать другие типы, при -преобразовании значения параметра из запроса к значению узла используется -метод C<< $this->inflateNodeValue($value) >>, также помимо значения -C<< $this->currentNode->nodeValue >> задается атрибут -C<< $this->currentNode->nodeProperty( rawValue => $value) >>, для того, чтобы -была возможность получить оригинальное значение параметра запроса (например, -в случае когда его формат был не верным и C будет C). - -=item * C - -Данный метод вызывается если текущий узел (переданный в параметре 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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/DOM/XMLReader.pm --- a/lib/IMPL/DOM/XMLReader.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,153 +0,0 @@ -package IMPL::DOM::XMLReader; -use strict; -use warnings; - -use XML::Parser; - -use IMPL::declare { - require => { - Schema => 'IMPL::DOM::Schema', # IMPL::DOM::Schema references IMPL::DOM::XML::Reader - Builder => 'IMPL::DOM::Navigator::Builder', - SimpleBuilder => 'IMPL::DOM::Navigator::SimpleBuilder' - }, - base => [ - 'IMPL::Object' => undef - ], - props => [ - Navigator => '*r', - SkipWhitespace => '*r', - _current => '*rw', - _text => '*rw', - _textHistory => '*rw' - ] -}; - -use IMPL::require { - -}; - -sub CTOR { - my ($this, %params) = @_; - - $this->{$Navigator} = $params{Navigator} if $params{Navigator}; - $this->{$SkipWhitespace} = $params{SkipWhitespace} if $params{SkipWhitespace}; -} - -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 и C - -=head1 METHODS - -=over - -=item C $builder)> - -Создает новый экземпляр парсера, с указанным навигатором для построения документа - -=item C<$obj->Parse($in)> - -Строит документ. На вход получает либо xml строку, либо HANDLE. - -=item C<$obj->ParseFile($fileName)> - -Строит документ из файла с именем C<$fileName>. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Mailer.pm --- a/lib/IMPL/Mailer.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM.pm --- a/lib/IMPL/ORM.pm Tue Apr 03 10:54:09 2018 +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 - 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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Adapter/Generic.pm --- a/lib/IMPL/ORM/Adapter/Generic.pm Tue Apr 03 10:54:09 2018 +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 Адаптер для работы с данными объекта произвольного класса. - -=head1 DESCRIPTION - -Позволяет получать данные, изменения данных из объекта, а также записать данные в -объект и создать новый объект. - -=head1 MEMBERS - -=over - -=item C - -Создает новый адаптер к объекту C<$object> - -=item C<[get]object> - -Объект для которого создан данный адаптер, C если объект удален. - -=item C<[get]isChanged> - -Были ли обновления в объекте. - -=item C<[get]isDeleted> - -Является ли объект удаленным. - -=item C<[get]isNew> - -Является ли объект новым для БД. - -=item C<[get]initialState> - -Начальное состояние объекта, C если объект был создан. - -=item C<[get]currentState> - -Текущие состояние. C если объект удален. - -=item C<[get,list]history> - -История изменений. C - -=item C - -Сохраняет изменения из объекта в текущее состояние, при этом изменения записываются в историю. - -B информацию об изменениях в объекте. - -=item C - -Возвращает объект в определенную версию. - -=item C - -Удаляет объект, точнее помечает его для удаления до вызова C. - -=item C - -Сбрасывает историю изменений, и устанавливает соответсвующие свойства. - -=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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Entity.pm --- a/lib/IMPL/ORM/Entity.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Helpers.pm --- a/lib/IMPL/ORM/Helpers.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Object.pm --- a/lib/IMPL/ORM/Object.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/PropertyImplementor.pm --- a/lib/IMPL/ORM/PropertyImplementor.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -package IMPL::ORM::PropertyImplementor; -use strict; -use warnings; - - - -1; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema.pm --- a/lib/IMPL/ORM/Schema.pm Tue Apr 03 10:54:09 2018 +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 Схема отображения классов в реляционную структуру. - -=head1 DESCRIPTION - -Схема данных, представляет собой DOM документ, элементами которой -являются сущности. - -Каждый узел - это описание сущности. - -=begin code xml - - - - - - - - - - - - - - - -=end code xml - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/Entity.pm --- a/lib/IMPL/ORM/Schema/Entity.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/Field.pm --- a/lib/IMPL/ORM/Schema/Field.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/GenericClass.pm --- a/lib/IMPL/ORM/Schema/GenericClass.pm Tue Apr 03 10:54:09 2018 +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 Построение схемы из произвольного класса. - -=head1 DESCRIPTION - -Читает метаданные класса и строит на их основании элементы схемы данных. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/Relation.pm --- a/lib/IMPL/ORM/Schema/Relation.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/Relation/HasMany.pm --- a/lib/IMPL/ORM/Schema/Relation/HasMany.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/Relation/HasOne.pm --- a/lib/IMPL/ORM/Schema/Relation/HasOne.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/Relation/Subclass.pm --- a/lib/IMPL/ORM/Schema/Relation/Subclass.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/TransformToSQL.pm --- a/lib/IMPL/ORM/Schema/TransformToSQL.pm Tue Apr 03 10:54:09 2018 +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 - diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Schema/ValueType.pm --- a/lib/IMPL/ORM/Schema/ValueType.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Store/DBIC.pm --- a/lib/IMPL/ORM/Store/DBIC.pm Tue Apr 03 10:54:09 2018 +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 - Хранилище данных на основе C. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Store/SQL.pm --- a/lib/IMPL/ORM/Store/SQL.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/ORM/Unit.pm --- a/lib/IMPL/ORM/Unit.pm Tue Apr 03 10:54:09 2018 +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 Единица действий. - -=head1 DESCRIPTION - -C<[Infrastructure]> - -Позволяет записывать последовательность изменений. Используется C для реализации логических -транзакций. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema.pm --- a/lib/IMPL/SQL/Schema.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,190 +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::Clonable' => undef, - ], - props => [ - version => PROP_RO | PROP_DIRECT, - name => PROP_RO | PROP_DIRECT, - _tables => PROP_RO | PROP_DIRECT - ] -}; - -sub CTOR { - my ($this,%args) = @_; - - $this->$_($args{$_}) foreach grep exists $args{$_}, qw(name version); -} - -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 - -Конструктор заполняет объект свойствами из C. - -=item C<[get]name> - -Имя схемы. - -=item C<[get]version> - -Версия схемы. - -=item C - -Доавляет таблицу в схему. C<$table> может быть либо таблице, либо хешем с набором -свойств для создания новой таблицы. Если таблица с таким именем уже существует в сехеме, -то вызывается исключение. - -=item C - -Возвращает таблицу с именем C<$name> или C. - -=item C - -Возвращает список таблиц. В скалярном контексте - ссылку на массив с таблицами. - -=item C - -Если параметр C<$table> - таблица, то возвращается C<$table>, если C<$table> строка, то -ищется таблица с таким именем, если таблица не найдена, возвращается C. - -=item C - -Происходит переименование таблицы. Если C<$oldName> не существует, либо если C<$newName> -существует, вызывается исключение. - -=item C - -Удаляется таблица C<$table> с удалением всех связей и ограничений. Если такой таблицы нет, -то вызывается исключение. C<$table> может быть либо именем таблицы, либо объектом. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Column.pm --- a/lib/IMPL/SQL/Schema/Column.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,78 +0,0 @@ -use strict; - -package IMPL::SQL::Schema::Column; - -use IMPL::lang qw( :base :compare :hash ); -use IMPL::Exception(); -use IMPL::Const qw(:prop); -use IMPL::declare { - require => { - SchemaType => '-IMPL::SQL::Schema::Type' - }, - base => [ - 'IMPL::Object' => undef, - ], - 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, %args ) = @_; - - $this->$_( $args{$_} ) - foreach grep exists $args{$_}, qw( name type isNullable defaultValue tag); - - $this->{$name} or - die new IMPL::InvalidArgumentException('A column name is required'); - - $this->{$isNullable} ||= 0; # if not exists $this->{$isNullable}; - - is( $this->{$type}, SchemaType ) - or die new IMPL::InvalidArgumentException( - 'a type is required for the column', - $this->{$name} ); -} - -sub SameValue { - my ( $this, $other ) = @_; - - return ( $this->{$name} eq $other->{$name} - and $this->{$isNullable} == $other->{$isNullable} - and equals_s( $this->{$defaultValue}, $other->{$defaultValue} ) - and $this->{$type}->SameValue( $other->{$type} ) ); -} - -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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Constraint.pm --- a/lib/IMPL/SQL/Schema/Constraint.pm Tue Apr 03 10:54:09 2018 +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}, '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, 'IMPL::SQL::Schema::Constraint') ? $alias : $aliases{$alias}; -} - -sub RegisterAlias { - my ($self,$alias) = @_; - - $aliases{$alias} = ref $self ? typeof($self) : $self; -} - -1; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm --- a/lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Constraint/Index.pm --- a/lib/IMPL/SQL/Schema/Constraint/Index.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm --- a/lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Constraint/Unique.pm --- a/lib/IMPL/SQL/Schema/Constraint/Unique.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Diff.pm --- a/lib/IMPL/SQL/Schema/Diff.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/MySQL/CharType.pm --- a/lib/IMPL/SQL/Schema/MySQL/CharType.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/MySQL/EnumType.pm --- a/lib/IMPL/SQL/Schema/MySQL/EnumType.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/MySQL/Formatter.pm --- a/lib/IMPL/SQL/Schema/MySQL/Formatter.pm Tue Apr 03 10:54:09 2018 +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 - преобразует операции над схемой в C -выражения. - -=head1 DESCRIPTION - -Используется для форматирования операций изменения схемы БД. Осуществляет -правильное экранирование имен, форматирование значений, имен типов данных. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/MySQL/Processor.pm --- a/lib/IMPL/SQL/Schema/MySQL/Processor.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Processor.pm --- a/lib/IMPL/SQL/Schema/Processor.pm Tue Apr 03 10:54:09 2018 +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 к -схеме. - -=cut \ No newline at end of file diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Table.pm --- a/lib/IMPL/SQL/Schema/Table.pm Tue Apr 03 10:54:09 2018 +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; - - diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Traits.pm --- a/lib/IMPL/SQL/Schema/Traits.pm Tue Apr 03 10:54:09 2018 +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 - Операции над объектками SQL схемы. - -=head1 DESCRIPTION - -Изменения схемы могу быть представлены в виде последовательности примитивных операций. -Правила выполнения последовательности примитывных действий могут варьироваться -в зависимости от процессора, который их выполняет. Например C. - -Данные, которые содержаться в примитивных операциях не могут существовать независимо от схемы. - -=head1 OPERATIONS - -=head2 General - -Методы обще для всех примитивных операций. - -=head3 C - -Определяет возможность применения операции к указанной схеме. - -Возвращаемое значение: - -=over - -=item C - -Операция приминима к схеме. - -=item C - -Операция не может быть применена к схеме. - -=back - -=head3 C - -Применяет операцию к указанной схеме. - -=head2 Primitive operations - -=head3 C - -Создает таблицу - -=head4 C - -=head4 C<[get]table> - -C - описание создаваемой таблицы - -=head3 C - -Удалает таблицу по имени - -=head4 C - -=head4 C<[get]tableName> - -Имя удаляемой таблицы - -=head3 C - -=head4 C - -=head4 C<[get]tableName> - -Имя таблицы, которую требуется переименовать - -=head4 C<[get]tableNewName> - -Новое имя таблицы - -=head3 C - -Добавляет столбец в таблицу - -=head4 C - -=head4 C<[get]tableName> - -Имя таблицы в которую нужно добавить столбец - -=head4 C<[get]column> - -C - описание столбца который нужно добавить - -=head4 C<[get]position> - -Позиция на которую нужно вставить столбец - -=head3 C - -Удаляет столбец из таблицы - -=head4 C - -=head4 C<[get]tableName> - -Имя таблицы в которой нужно удалить столбец - -=head4 C<[get]columnName> - -Имя столбца для удаления - -=head3 C - -Меняет описание столбца - -=head4 C - -C<%args> - хеш, ключами которого являются оставшиеся свойства создаваемого объекта. - -=head4 C<[get]tableName> - -Имя таблицы в которой находится столбец. - -=head4 C<[get]columnName> - -Имя столбца для изменения - -=head4 C<[get]columnType> - -Новый тип столбца. Не задан, если тип не меняется - -=head4 C<[get]defaultValue> - -Значение по умолчанию. Не задано, если не меняется - -=head4 C<[get]isNullable> - -Может ли столбец содержать C. Не задано, если не меняется. - -=head4 C<[get]options> - -Хеш опций, не задан, если опции не меняются. Данный хеш содержит разничу между -старыми и новыми значениями свойства C столбца. - - -=head3 C - -Базовый класс для операций по добавлению ограничений - -=head4 C - -=head4 C<[get]tableName> - -Имя таблицы в которую добавляется ограничение. - -=head4 C<[get]constraint> - -C - описние ограничения, которое нужно добавить. - -=head3 C - -Удаляет ограничение на таблицу - -=head4 C - -=head4 C<[get]tableName> - -Имя таблицы в которой требуется удалить ограничение. - -=head4 C<[get]constraintName> - -Имя ограничения для удаления. - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Traits/Diff.pm --- a/lib/IMPL/SQL/Schema/Traits/Diff.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Traits/mysql.pm --- a/lib/IMPL/SQL/Schema/Traits/mysql.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Schema/Type.pm --- a/lib/IMPL/SQL/Schema/Type.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,103 +0,0 @@ -package IMPL::SQL::Schema::Type; -use strict; -use warnings; - -use IMPL::lang qw( :compare ); -use IMPL::Const qw(:prop :access); -use IMPL::declare{ - base => [ - 'IMPL::Object' => undef, - ], - 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; - - my $fields = ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; - - while(my ($k,$v) = each %$fields) { - $this->$k($v); - } - - $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 Описывает 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 - -Конструктор, заполняет объект значениями которые были переданы в конструкторе. - -=item C<[get]name> - -Имя типа. Обязательно. - -=item C<[get]maxLength> - -Максимальная длина, используется только для типов, имеющих длину (либо переменную, -либо постоянную). - -=item C<[get]scale> - -Точность, количество знаков после запятой. Используется вместе с C. - -=item C<[get]unsigned> - -Используется с числовыми данными, обозначает беззнаковые типы. - -=item C<[get]zerofill> - -Нестандартный атрибут дополняющий числа лидирующими нулями до C. - -=item C<[get]tag> - -Хеш с дополнительными опциями. - -=back - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/SQL/Types.pm --- a/lib/IMPL/SQL/Types.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Serialization.pm --- a/lib/IMPL/Serialization.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Serialization/XmlFormatter.pm --- a/lib/IMPL/Serialization/XmlFormatter.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/TargetException.pm --- a/lib/IMPL/TargetException.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test.pm --- a/lib/IMPL/Test.pm Tue Apr 03 10:54:09 2018 +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($_) ? $_ : '', @$a), - join(', ', map defined($_) ? $_ : '', @$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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/BadUnit.pm --- a/lib/IMPL/Test/BadUnit.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/FailException.pm --- a/lib/IMPL/Test/FailException.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/HarnessRunner.pm --- a/lib/IMPL/Test/HarnessRunner.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -package IMPL::Test::HarnessRunner; -use strict; -use warnings; - -use TAP::Parser; -use Test::Harness; - -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => undef - ] -}; - -sub RunTests { - my ($this,@files) = @_; - - return runtests(@files); -} - -sub ExecuteTests { - my ($this,%args) = @_; - - return Test::Harness::execute_tests(%args); -} - -1; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/Plan.pm --- a/lib/IMPL/Test/Plan.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/Result.pm --- a/lib/IMPL/Test/Result.pm Tue Apr 03 10:54:09 2018 +0300 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package IMPL::Test::Result; -use strict; -use warnings; - -use IMPL::Const qw(:prop); -use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Serializable' => '@_' - ], - props => [ - name => PROP_RW, - state => PROP_RW, - exception => PROP_RW, - timeExclusive => PROP_RW, - timeInclusive => PROP_RW - ] -}; - -__PACKAGE__->PassThroughArgs; - -use constant { - SUCCESS => 0, - FAIL => 1, - ERROR => 2 -}; - -sub CTOR { - my $this = shift; - - my $fields = @_ == 1 ? $_[0] : {@_}; - - $fields->{timeExclusive} ||= 0; - $fields->{timeInclusive} ||= 0; - - while (my ($k,$v) = each %$fields) { - $this->$k($v); - } -} - - -1; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/SkipException.pm --- a/lib/IMPL/Test/SkipException.pm Tue Apr 03 10:54:09 2018 +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; - diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/Straps/ShellExecutor.pm --- a/lib/IMPL/Test/Straps/ShellExecutor.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/TAPListener.pm --- a/lib/IMPL/Test/TAPListener.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Test/Unit.pm --- a/lib/IMPL/Test/Unit.pm Tue Apr 03 10:54:09 2018 +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; diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Transform.pm --- a/lib/IMPL/Transform.pm Tue Apr 03 10:54:09 2018 +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 - преобразование объектной структуры - -=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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Application.pm --- a/lib/IMPL/Web/Application.pm Tue Apr 03 10:54:09 2018 +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 Базовай класс для веб-приложения - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Application/Action.pm --- a/lib/IMPL/Web/Application/Action.pm Tue Apr 03 10:54:09 2018 +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 - Обертка вокруг C запроса. - -=head1 DESCRIPTION - -C<[Infrastructure]> -Свзяывет CGI запрос, приложение, орабатывающее его и ответ, который будет отправлен клиенту. - -=head1 MEMBERS - -=head2 C - -Инициализирует новый экземпляр. Именованными параметрами передаются значения -свойств. - -=head2 C< [get]application> - -Экземпляр приложения создавшего текущий объект - -=item C< [get] query > - -Экземпляр C запроса - -=back - - -=cut diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Application/HttpResponseResource.pm --- a/lib/IMPL/Web/Application/HttpResponseResource.pm Tue Apr 03 10:54:09 2018 +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 diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Application/Resource.pm --- a/lib/IMPL/Web/Application/Resource.pm Tue Apr 03 10:54:09 2018 +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 - Ресурс C веб приложения - -=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 методами. При попытке вызова C метода, которого нет в этом -хеше приводит к исключению C. - -=head2 C<[get,set]access> - -Метод для проверки прав доступа. Если не задан, то доспуп возможен для всех. - -=head2 C<[get,set]children> - -Дочерние ресурсы. Дочерние ресурсы могут быть описаны либо в виде хеша, либо -в виде метода. - -=head3 C - -Данный хещ содержит в себе таблицу идентификаторов дочерних ресурсов и их -описаний. - -Описание каждого ресурса представляет собой либо функцию, либо параметры для -создания ресурса C. Если описание в виде функции, то она -должна возвращать либо объект типа ресурс либо параметры для его создания. - -=head3 C


-
-Если дочерние ресурсы описаны в виде функции (возможно использовать имя метода
-класса текущего ресурса), то для получения дочернего ресурса будет вызвана
-функция с параметрами C<($this,$childId)>, где C<$this> - текущий ресурс,
-C<$childId> - идентификатор дочернего ресурса, который нужно вернуть.
-
-Данная функция должна возвратить либо объект типа ресурс, либо ссылку на хеш с
-параметрами для создания оного при помощи метода
-C.
-
-=head2 C<[virtual]Fetch($childId)>
-
-Метод для получения дочернего ресурса.
-
-Возвращает параметры для создания дочернего ресурса, либо уже созданный ресурс.
-Создание дочернего ресурса происходит при помощи метода C
-который добавляет недостающие параметры к возвращенным в данным методом и
-создает новый ресурс
-
-=head2 C
-
-Создает новый дочерний ресурс с указанным идентификатором и параметрами.
-Автоматически заполняет параметры
-
-=over
-
-=item * C
-
-=item * C
-
-=item * C
-
-=back
-
-Тип создаваемого ресурса C, либо указывается
-в параметре C.
-
-=head2 C<[virtual]HttpGet()>
-
-Реализует C метод C. По-умолчанию возвращает модель.
-
-Данный метод нужен для того, чтобы ресурс по-умолчанию поддерживал метод C,
-что является самым частым случаем, если нужно изменить данное поведение, нужно:
-
-=over
-
-=item * Передать в параметр конструктора C значение undef
-
-=item * Переопределить метод C
-
-=item * При проверке прав доступа выдать исключение 
-
-=back
-
-=cut
-
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Application/ResourceBase.pm
--- a/lib/IMPL/Web/Application/ResourceBase.pm	Tue Apr 03 10:54:09 2018 +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 - Web-ресурс.
-
-=head1 SYNOPSIS
-
-Класс для внутреннего использования. Объединяет в себе контракт и модель данных.
-Основная задача - обработать поступающий от контроллера запрос на вызов C
-метода.
-
-Экземпляры данного класса передаются в качестве параметров делегатам
-осуществляющим привязку к модели в C
-и C.
-
-=head1 DESCRIPTION
-
-Весь функционал ресурса, поддерживаемые им C методы определяются
-контрактом. Однако можно реализовывать ресурсы, которые не имеют контракта
-или он отличается от того, что предоставляется стандартно
-C.
-
-Каждый ресурс является контейнером, тоесть позволяет получить дочерний ресурс
-по идентифифкатору, если таковой имеется, тоесть ресурс, у которого нет дочерних
-ресурсов на самом деле рассматривается как пустой контейнер.
-
-С ресурсом непосредственно взаимодействует котроллер запросов
-C, вызывая два метода.
-
-=over
-
-=item * C
-
-Данный метод возвращает дочерний ресурс, соответствующий C<$childId>.
-Текущая реализация использует метод C контракта текущего
-ресурса, после чего создает дочерний ресурс.
-
-Если дочерний ресурс не найден, вызывается исключение
-C.
-
-=item * C
-
-Обрабатывает запрос к ресурсу. Для этого используется контракт ресурса, в
-нем выбирается соответсвующий C.
-Затем найденный контракт для указанной операции используется для обработки
-запроса.
-
-=back
-
-Если объект реализует два вышеуказанных метода, он является веб-ресурсом, а
-детали его реализации, котнракт и прочее уже не важно, поэтому можно реализовать
-собственный класс ресурса, например унаследованный от 
-C.
-
-=head1 MEMBERS
-
-=head2 C<[get]request>
-
-Объект C представляющий запрос к серверу.
-
-=head2 C<[get]application>
-
-Ссылка на приложение, к которому относится данный ресурс. Получается
-автоматически из объекта запроса.
-
-=head2 C<[get]contract>
-
-Обязательное свойство для ресурса, ссылается, на контракт, соответствующий
-данному ресурсу, используется для выполнения C методов и получения
-дочерних ресурсов.
-
-=head2 C<[get]id>
-
-Обязательное свойство ресурса, идентифицирует его в родительском контейнере,
-для корневого ресурса может иметь произвольное значение.
-
-=head2 C<[get]parent>
-
-Ссылка на родительский ресурс, для корневого ресурса не определена.
-
-=head2 C<[get]model>
-
-Ссылка на объект предметной области, представляемый данным ресурсом. Данное 
-свойство не является обязательным и может быть не задано.
-
-=head2 C<[get]location>
-
-Объект типа C или аналогичный описывающий адрес текущего
-ресурса, может быть как явно передан при создании ресурса, так и вычислен
-автоматически (только для ресурсов имеющих родителя). Следует заметить, что
-адрес ресурса не содержит параметров запроса, а только путь.
-
-=head2 C<[get,list]role>
-
-Список ролей ресурса. Роль это условный маркер, который позволяет определить
-функции выполняемые ресурсом, например контейнер, профиль пользователя и т.п.
-
-Используется при построении цепочек навигации, а также при поиске с использованием
-метода C.
-
-=head2 C
-
-Ищет ресурс в цепочке родителей (включая сам ресурс) с подходящими ролями.
-
-Роли могут быть переданы в виде массива или строки, где роли разделены пробелами 
-
-=head2 C<[get]FetchChildResource($id)>
-
-Возвращает дочерний ресурс, по его идентификатору.
-
-Данная реализация использует контракт текущего ресурса для поиска информации о
-дочернем ресурсе C<< $this->contract->FindChildResourceInfo($id) >>.
-
-Затем осуществляется привязка к моделе, тоесть, выполняется делегат, для
-получения модели дочернего ресурса, а затем осуществляется привязка к контракту,
-при этом в делегат, который должен вернуть контракт дочернего ресурса передаются
-текущий ресурc и модель дочернего ресурса.
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Application/ResourceInterface.pm
--- a/lib/IMPL/Web/Application/ResourceInterface.pm	Tue Apr 03 10:54:09 2018 +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 - Интерфейс для 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
-
-Выполняет операцию над ресурсом и возвращает результат ее выполнения.
-Результатом может быть произвольный объект, который будет передан по цепочке
-обработчиков приложения для формирования ответа вервера, либо
-C, который описывает (не обязательно полностью) ответ.
-В любом случае результат будет передан далее в цепочку обработчиков и может
-быть изменен.  
-
-=head2 C
-
-Используется для получения дочернего ресурса (который содержится в данном
-контейнере). Метод должен возвращать либо Web-ресурс
-C, либо C если дочерний ресурс
-не найден.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/AutoLocator.pm
--- a/lib/IMPL/Web/AutoLocator.pm	Tue Apr 03 10:54:09 2018 +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 - Обертка вокруг адреса ресурса.
-
-=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 для доступа
-к дочерним ресурсам.
-
-=head1 MEMBERS
-
-=head2 C
-
-Создает новый объект расположение. Позволяет задать путь, расширение, параметры
-запроса и фрагмент ресурса.
-
-=over
-
-=item * C
-
-Строка с базовым адресом для дочерних ресурсов.
-
-=item * C
-
-Задает суфикс, обозначающий представление ресурса, аналогично расширению у
-файлов. Данный суффикс может использоваться контроллером для выбора
-представления ресурса.
-
-=item * C
-
-Ссылка на хеш с параметрами запроса
-
-=item * C
-
-Часть C обозначающая фрагмент документа (все, что идет после символа C<#>).
-
-=back
-
-=head2 C
-
-Получает расположение дочернего ресурса. При этом cоздается новый объект адреса ресурса.
-
-=head2 C
-
-Позволяет указать представление (расширение) у текущего адреса ресурса. Изменяет
-представление и возвращает измененный адрес ресурса.
-
-=head2 C<[get]base>
-
-Базовый адрес, относительно которого будут получены дочерние ресурсы.
-
-=head2 C<[get,set]view>
-
-Представление для ресурсов, аналогично расширению у файлов.
-
-=head2 C<[get,set]query>
-
-Ссылка на хеш с параметрами для C запроса.
-
-=head2 C<[get,set]hash>
-
-Часть адреса ресурса, отвечающая за фрагмент. 
-
-=head2 C<[get]url>
-
-Объект C для текущего адреса.
-
-=head2 C
-
-Перенаправляет вызовы методов в метод C передавая первым параметром имя метода.
-
-=cut
-
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/BadRequestException.pm
--- a/lib/IMPL/Web/BadRequestException.pm	Tue Apr 03 10:54:09 2018 +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 - 400 Bad Request
-
-=head1 DESCRIPTION
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/CGIApplication.pm
--- a/lib/IMPL/Web/CGIApplication.pm	Tue Apr 03 10:54:09 2018 +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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/CGIWrapper.pm
--- a/lib/IMPL/Web/CGIWrapper.pm	Tue Apr 03 10:54:09 2018 +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 - обетрка вокруг стандартного объекта C
-
-=head1 DESCRIPTION
-
-Наследуется от C, и переопределяет метод C для декодирования
-строковых параметров. В остальном функциональность аналогична стандартному
-модулю C.
-
-=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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/DOM/FileNode.pm
--- a/lib/IMPL/Web/DOM/FileNode.pm	Tue Apr 03 10:54:09 2018 +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 - узел, использующийся для представления параметра запроса в котором передан файл.
-
-=head1 SINOPSYS
-
-=begin code xml
-
-
-
-    
-    
-        
-    
-
-
-=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 запросов при преобзаовании
-запроса в ДОМ документ преобразованием C.
-
-Узлы данного типа расширяют стандатрный C несколькими свойствами и
-методами для доступа к файлу, переданному в виде параметра запроса.
-
-=head1 MEMBERS
-
-=head2 PROPERTIES
-
-=over
-
-=item C<[get] parameterName>
-
-Имя параметра C запроса соответствующего данному узлу.
-
-=item C<[get] fileName>
-
-Имя файла из параметра запроса
-
-=item C<[get] fileHandle>
-
-Указатель на файл из параметра запроса
-
-=back
-
-=head2 METHODS
-
-=over
-
-=item C
-
-Сохраняет файл, переданный в запросе во временный, вызывает C<$callback> для обработки временного файла.
-
-=over
-
-=item C<$callback>
-
-Ссылка на функцию которая будет вызвана для обработки временного файла. C
-
-=over
-
-=item C<$fname>
-
-Имя временного файла
-
-=item C<$fhandle>
-
-Указатель на временный файл
-
-=back
-    
-Также пременная C<$_> содержит имя временного файла.
-
-=item C<$target>
-
-Значение этого параметра будет передано первым параметром функции C<$callback>.
-
-=back
-
-=back
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Exception.pm
--- a/lib/IMPL/Web/Exception.pm	Tue Apr 03 10:54:09 2018 +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 - Базовый класс для всех 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
-
-Возвращает C код ошибки. Каждый класс иключений должен переопределить данный метод.
-
-=head2 C<[get,set]headers>
-
-Ссылка на хеш с параметрами заголовка.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/ForbiddenException.pm
--- a/lib/IMPL/Web/ForbiddenException.pm	Tue Apr 03 10:54:09 2018 +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 - операция не разрешается.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/ErrorHandler.pm
--- a/lib/IMPL/Web/Handler/ErrorHandler.pm	Tue Apr 03 10:54:09 2018 +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 - обертка для обработки исключений.
-
-=head1 SYNOPSIS
-
-Используется в цеопчке обработчиков приложения.
-
-=begin code xml
-
-    
-        
-            text/html
-            
-            
-                errors/500
-                errors/404
-                errors/403
-            
-            errors/500
-        
-    
-
-=end code xml
-
-=head1 DESCRIPTION
-
-Позволяет создать представление для ресурса в случае ошибки, для этого
-используется соответствие представлений и кодов ошибок.
-
-В результате обработчик либо прозрачно передает результат вышестоящего
-обработчика нижестоящему, либо создает C с
-соответствующим статусом и содержанием. 
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/JSONView.pm
--- a/lib/IMPL/Web/Handler/JSONView.pm	Tue Apr 03 10:54:09 2018 +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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/LocaleHandler.pm
--- a/lib/IMPL/Web/Handler/LocaleHandler.pm	Tue Apr 03 10:54:09 2018 +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 - handles locale for the request
-
-=head1 SYNOPSIS
-
-=begin code xml
-
-	
-		
-			
-				en-US
-				ru-RU
-			
-			en-US
-			lang
-		
-	
-
-=end code xml
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/RestController.pm
--- a/lib/IMPL/Web/Handler/RestController.pm	Tue Apr 03 10:54:09 2018 +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 - Обрабатывает C запрос передавая
-его соответствующему ресурсу.
-
-=head1 SYNOPSIS
-
-Используется в конфигурации приложения как элемент цепочки обработчиков.
-Как правило располагается на самом верхнем уровне.
-
-=begin code xml
-
-    
-        
-            My::App::Web::RootResource
-        
-        
-        
-        
-    
-
-=end code xml
-
-
-=head1 DESCRIPTION
-
-Использует C для определения нужного ресурса, затем предает
-найденному ресурсу управление для обработки запроса.
-
-Если ресурс не найден, то возникает исключение C.
-
-Для определения нужного ресурса контроллер разбивает C на фрагменты
-и использует каждый фрагмент для получения дочернего ресурса начиная с корневого.
-Для чего используется метод
-C<< IMPL::Web::Application::ResourceInterface->FetchChildResource($childId) >>.
-
-Дерево ресурсов сущестувет независимо от обрабатываемого запроса, однако оно
-может полностью или частично загружаться в начале обработки запроса и
-освобождаться по окончании обработки запроса. Поэтому при получении дочерних
-ресурсов не участвует C запрос, он адресуется только последнему ресурсу.
-
-=begin text
-
-/music/audio.mp3 -> ['music','audio.mp3']
-
-=end text
-
-=head1 MEMEBERS
-
-=head2 C<[get]resourceFactory>
-
-Фабрика для создания корневого ресурса приложения, полученный ресурс должен
-реализовывать интерфейс C.
-
-Фабрика может сохранять ссылку на корневой ресурс и каждый раз не создавать
-его, а возвращать уже существующий. Это вполне оправдано, если хранение
-дерева ресурсов требует меньше ресурсов, чем его создание и при этом приложение
-остается в памяти между C запросами.
-
-=head2 C<[get]trailingSlash>
-
-Если данная переменная имеет значение C, то слеш в конце пути к ресурсу
-будет интерпретироваться, как дочерний ресурс с пустым идентификатором.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/SecureCookie.pm
--- a/lib/IMPL/Web/Handler/SecureCookie.pm	Tue Apr 03 10:54:09 2018 +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
-
-=head1 DESCRIPTION
-
-Возобновляет сессию пользователя на основе информации переданной через Cookie.
-
-Использует механизм подписи информации для проверки верности входных данных перед
-началом каких-либо действий.
-
-Данный обработчик возвращает результат выполнения следдующего обработчика.
-
-
-
-=head1 MEMBERS
-
-=head2 C<[get,set] salt>
-
-Скаляр, использующийся для подписи данных.
-
-
-=head2 C
-
-Инициирует сессию, поскольку данный модуль отвечает за взаимодействие с клиентом
-при проверки аутентификации, ему передаются данные аутентификации для
-продолжения обмена данными с клиентом. Если создается новая сессия, по
-инициативе веб-приложения, то C<$auth> должно быть пусто. 
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/View.pm
--- a/lib/IMPL/Web/Handler/View.pm	Tue Apr 03 10:54:09 2018 +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 - использует шаблоны для построения представления.
-
-=head1 SYNOPSIS
-
-=begin code xml
-
-
-    text/html
-    
-	    
-	        
-	            IMPL::Config
-	            view
-	        
-	        1
-	        1
-	        utf-8
-	    
-	    .tt
-	    global.tt
-	    layouts
-    
-    default
-    
-        @HASH => dump
-        @My::Data::Product => product/info
-        {action:.*} @My::Data::Product => product/{action}
-                        
-
-
-=end code xml
-
-=head1 DESCRIPTION
-
-Подбирает шаблон для представления результата, полученного при выполнении следующего обработчика. При
-выборе используется принцип похожий на селекторы C, основывающийся на именах ресурсов и их типах
-данных.
-
-Данный обработчик понимает определенные свойства контекста:
-
-=over
-
-=item * C
-
-В данном свойстве может быть передана информация о текущем расположении ресурса,
-для которого строится представление. Эта информация будет доступна в шаблоне
-через свойство документа C.
-
-=item * C
-
-В данном совойстве контекста передается дополнительная информация об окружении
-ресурса, например, которую задали родительские ресурсы. Использование данного
-свойства позволяет не загромождать ресурс реализацией функциональности по
-поддержке окружения. Это свойство может быть ссылкой на функцию, что позволяет
-формировать контекст только по необходимости, при этом указанная функция будет
-выполнена только один раз, при первом обращении.
-
-=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
-
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Handler/ViewSelector.pm
--- a/lib/IMPL/Web/Handler/ViewSelector.pm	Tue Apr 03 10:54:09 2018 +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 - Выбор нужного представления на основе заголовка C
-
-=head1 DESCRIPTION
-
-Использует заголовок запроса C для выбора подходящего представления, если задано свойство C,
-пытается в первую очередь по расширению определить, какое представление подходит.
-
-В случаях, когда не требуется строить представление для данных (например, при перенаправлении к другому
-ресурсу или если нет данных), нужно, чтобы данному обработчику был возвращен
-L, который будет просто передан далее.
-
-=head1 MEMBERS
-
-=head2 C<[get,set,list]views>
-
-Список представлений, которые могут быть возвращены.
-
-=head2 C<[get,set]types>
-
-Хеш с соотвествием между расширением и типом содержимого, для подсказки при выборе представления.
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/HttpResponse.pm
--- a/lib/IMPL/Web/HttpResponse.pm	Tue Apr 03 10:54:09 2018 +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 - Результат обработки C запроса.
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-Базовый класс для ответов приложения на C запрос. Каждый вид ответа,
-например 
-
-Данный объект используется для формирования и передачи данных C ответа
-напрямую. Основными полями являются C и C.
-
-Кроме свойств относящихся непосредственно к самому C ответу, данный объект
-может содержать свойства относящиеся к процессу обработки запроса, например
-механизму формирования представления.
-
-=head1 MEMBERS
-
-=head2 C<[get,set]status>
-
-Статус который будет отправлен сервером клиенту, например, C<200 OK> или
-C<204 No response>. Если не указан, то будет C<200 OK>.
-
-=head2 C<[get,set]type>
-
-Тип содержимого, которое будет передано клиенту, если не указано, будет
-C.
-
-=head2 C<[get,set]charset>
-
-Кодировка в которой будут переданны данные. Следует задавать если и только, если
-передается текстовая информация. Если указана кодировка, то она будет
-автоматически применена к потоку, который будет передан методу C. 
-
-=head2 C<[get,set]cookies>
-
-Опционально. Ссылка на хеш с печеньками.
-
-=head2 C<[get,set]headers>
-
-Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат
-имен полей как у модуля C.
-
-=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. Также может быть ссылкой на
-процедуру, в таком случае будет вызвана эта процедура и ей будет передан
-первым параметром поток для вывода тела ответа.
-
-=head2 C
-
-Формирует заголовок и выводит ответ сервера в указанный параметром поток. 
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/NotAcceptableException.pm
--- a/lib/IMPL/Web/NotAcceptableException.pm	Tue Apr 03 10:54:09 2018 +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 Исключение в случае, если запрошенный ресурс не может
-быть выдан в указанном виде.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/NotAllowedException.pm
--- a/lib/IMPL/Web/NotAllowedException.pm	Tue Apr 03 10:54:09 2018 +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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/NotFoundException.pm
--- a/lib/IMPL/Web/NotFoundException.pm	Tue Apr 03 10:54:09 2018 +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 Исключение для несущесьвующего ресурса.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/OutOfRangeException.pm
--- a/lib/IMPL/Web/OutOfRangeException.pm	Tue Apr 03 10:54:09 2018 +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  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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/PreconditionException.pm
--- a/lib/IMPL/Web/PreconditionException.pm	Tue Apr 03 10:54:09 2018 +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 - 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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Security.pm
--- a/lib/IMPL/Web/Security.pm	Tue Apr 03 10:54:09 2018 +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 Модуль для аутентификации и авторизации веб запроса.
-
-=head1 DESCRIPTION
-
-Текущий модуль обеспечивает функции верхнего уровня для работы с системой
-безопасности. Поскольку модуль является абстрактым, конкретные функции
-хранения и реализацию объектов модели безопасности должно обеспечить само
-приложение.
-
-Сама система безопасности в веб приложении состоит из двух частей
-
-=over
-
-=item Модель системы безопасности
-
-Предоставляет такие объкты безопасности, как пользователь, сессия роль,
-определяет правила проверки прав доступа субъекта к объекту.
-
-=item Модуль безопасности
-
-Контекст безопасности создается именно этим модулем.
-
-Как правило встраивается в транспортный уровеь в виде обработчика
-C и реализует непосредственно протокол аутентификации и
-обмена с пользователем.
-
-Также модуль безопасности использует модель для хранения сессий и данных
-аутентификции. 
-
-=back
-
-=head1 MEMBERS
-
-=head2 C
-
-Инициирует создание новой сессии используя провайдера безопасности текущего
-контекста безопасности.
-
-=over
-
-=item C<$name>
-
-Имя пользователя, которое будет использоваться при поиске его в БД. 
-
-=item C<$package>
-
-Имя модуля аутентификации, например, C.
-
-=item C<$challenge>
-
-Данные, полученные от клиента, которые будут переданы модулю аутентификации для
-начала процесса аутентификации и создания сессии.
-
-=back
-
-Функция возвращает хеш с элементами
-
-=over
-
-=item C
-
-Статус аутентификации - отражает общее состояние процесса ацтентификации,
-
-=over
-
-=item C
-
-Аутентификация неудачная, сессия не создана.
-
-=item C
-
-Аутентификация требует дополнительных шагов, сессия создана, но еще не доверена.
-
-=item C
-
-Аутентификация успешно проведена, сессия создана.
-
-=back
-
-=item C
-
-=back
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/Security/Session.pm
--- a/lib/IMPL/Web/Security/Session.pm	Tue Apr 03 10:54:09 2018 +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 - Сессия пользователя.
-
-=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
-
-Представляет собой контекст безопасности, имеет идентификатор. Является базовым классом
-для расширения дополнительными атрибутами.
-
-=head1 MEMBERS
-
-=over
-
-=item C<[get] sessionId>
-
-Идентификатор сессии
-
-=item C<[get] security>
-
-Экземпляр C в рамках которого создана сессия (откуда взят
-пользователь и роли).
-
-=back
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/UnauthorizedException.pm
--- a/lib/IMPL/Web/UnauthorizedException.pm	Tue Apr 03 10:54:09 2018 +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 - запрос требует идентификации пользователя.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/UnsupportedMediaException.pm
--- a/lib/IMPL/Web/UnsupportedMediaException.pm	Tue Apr 03 10:54:09 2018 +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 - 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, but the
-server requires that images use a different format.
-L
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/Metadata/BaseMeta.pm
--- a/lib/IMPL/Web/View/Metadata/BaseMeta.pm	Tue Apr 03 10:54:09 2018 +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.
-
-=back
-
-Метаданные публикуются провайдером, кроме того они могут быть расширены
-дополнительными свойствами.
-
-=head1 MEMBERS
-
-=head2 C
-
-Возвращает метаданные для дочернего элемента, например свойства объекта
-
-=head2 C
-
-Возвращает ссылку на массив с метаданными для дочерних элементов
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/Metadata/FormMeta.pm
--- a/lib/IMPL/Web/View/Metadata/FormMeta.pm	Tue Apr 03 10:54:09 2018 +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). В том случае, когда документ был не
-корректен и для не множественного элемента было передено несколько значений,
-данное свойство будет содержать только первое.
-
-=head2 C<[get]nodes>
-
-Ссылка на массив с узлами документа. В теории количество узлов может быть
-произвольным, поскольку документ может быть некорректным, т.е. их может
-быть более одного в то время, как C или, напротив, ни
-одного при C.
-
-Как правило для построения формы данное свойство не требуется.
-
-=head2 C<[get]modelType>
-
-Название типа данных из схемы документа (C<< schema->name >>), если тип не имеет название, то это
-C для сложных узлов и C для простых.
-
-Для моделей с множественными значениями это свойство не задано. Тип элементов
-храниться в свойстве C
-
-=head2 C<[get]decl>
-
-Объявление элемента формы, объявление может совпадать со схемой в случае,
-когда это был C или C, иначе это C ссылающийся
-на заранее обпределенный тип.
-
-=head2 C<[get]schema>
-
-Схема текущего элемента, C<СomlexType>, C, C или
-C.
-
-=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
-
-Возвращает ошибки относящиеся к самому элементу C, это принципиально
-для контейнеров и в случаях, когда модель не корректна и в ней присутствуют
-лишние значения.  
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/Metadata/ObjectMeta.pm
--- a/lib/IMPL/Web/View/Metadata/ObjectMeta.pm	Tue Apr 03 10:54:09 2018 +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__
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/ObjectFactory.pm
--- a/lib/IMPL/Web/View/ObjectFactory.pm	Tue Apr 03 10:54:09 2018 +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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/TTContext.pm
--- a/lib/IMPL/Web/View/TTContext.pm	Tue Apr 03 10:54:09 2018 +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 - доработанная версия контекста
-
-=head1 DESCRIPTION
-
-Расширяет функции C
-
-=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: <>
-Loader . Document: <>
-Loader -up- Registry
-
-@enduml
-
-=end plantuml
-
-=head1 MEMBERS
-
-=head2 C<[get,set]base>
-
-Префикс пути для поиска шаблонов
-
-=head2 C
-
-Сначала пытается загрузить шаблон используя префикс C, затем без префикса.
-
-=head2 C
-
-Создает копию контекста, при этом C локализуется, таким образом
-клонированный контекст имеет собственное пространство имен, вложенное в
-пространство родительского контекста.
-
-=cut
\ No newline at end of file
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/TTControl.pm
--- a/lib/IMPL/Web/View/TTControl.pm	Tue Apr 03 10:54:09 2018 +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 расширяет функциональность шаблонов
-
-=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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/TTView.pm
--- a/lib/IMPL/Web/View/TTView.pm	Tue Apr 03 10:54:09 2018 +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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/View/TemplateView.pm
--- a/lib/IMPL/Web/View/TemplateView.pm	Tue Apr 03 10:54:09 2018 +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
diff -r 87af445663d7 -r eed50c01e758 lib/IMPL/Web/ViewResult.pm
--- a/lib/IMPL/Web/ViewResult.pm	Tue Apr 03 10:54:09 2018 +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 - описание представления результата.
-
-=head1 SYNOPSIS
-
-=begin code
-
-sub HttpGet {
-    my ($this, $action) = @_;
-    
-    return IMPL::Web::ViewResult->new(
-        model => $model
-    );
-}
-
-=end code
-
-=head1 DESCRIPTION
-
-Сожержит в себе информацию для представления модели. Также включает поля для
-заголовков ответа C, C, C.
-
-=head1 MEMBERS
-
-=head2 C<[get,set]model>
-
-Модель ресурса, как правило это результат выполнения C метода.
-
-=head2 C<[get,set]cookies>
-
-Хеш с печеньками, которые будут добавлены в C ответ.
-
-=head2 C<[get,set]headers>
-
-Заголовки которые нужно добавить в заголовки C ответа.
-
-=head2 C<[get,set]status>
-
-Код C ответа. 
-
-=cut
diff -r 87af445663d7 -r eed50c01e758 nohup.out
--- a/nohup.out	Tue Apr 03 10:54:09 2018 +0300
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,6 +0,0 @@
-Oracle VM VirtualBox Headless Interface 4.2.6
-(C) 2008-2012 Oracle Corporation
-All rights reserved.
-
-VRDE server is listening on port 5002.
-VRDE server is inactive.