# HG changeset patch
# User cin
# Date 1441384823 -10800
# Node ID c6e90e02dd17e214210fcdf4ab996125abfe9cd6
# Parent f23fcb19d3c1b2684289a42539580b2a84e2998d
renamed Lib->lib
diff -r f23fcb19d3c1 -r c6e90e02dd17 .includepath
--- a/.includepath Mon Aug 31 20:22:16 2015 +0300
+++ b/.includepath Fri Sep 04 19:40:23 2015 +0300
@@ -1,5 +1,5 @@
-
+
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL.pm
--- a/Lib/IMPL.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
-package IMPL;
-use strict;
-
-use IMPL::_core qw(setDebug);
-use IMPL::_core::version;
-
-sub import {
- my ($opts) = @_;
-
- if (ref $opts eq 'HASH') {
- setDebug($$opts{Debug}) if exists $$opts{Debug};
- }
-}
-
-1;
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/AppException.pm
--- a/Lib/IMPL/AppException.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,144 +0,0 @@
-package IMPL::AppException;
-use strict;
-use mro 'c3';
-use overload
- '""' => 'ToString',
- 'bool' => sub { return 1; },
- 'fallback' => 1;
-
-use Carp qw(longmess shortmess);
-use Scalar::Util qw(refaddr);
-
-use IMPL::Const qw(:prop);
-use IMPL::Resources::Strings {
- message => "Application exception"
-};
-
-use IMPL::declare {
- base => [
- 'IMPL::Object' => undef
- ],
- props => [
- source => PROP_RO,
- callStack => PROP_RO,
- ]
-};
-
-sub new {
- my $self = shift;
-
- my $instance = $self->next::method(@_);
-
- $instance->source(shortmess);
- $instance->callStack(longmess);
-
- return $instance;
-}
-
-sub ToString {
- my ($this) = @_;
-
- return join("\n", $this->message, $this->callStack);
-}
-
-sub throw {
- my $self = shift;
-
- die $self->new(@_);
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-C - исключение приложения.
-
-=head1 SYNOPSIS
-
-=begin code
-
-package MyException;
-use strict;
-
-use IMPL::Const qw(:prop);
-use IMPL::declare {
- base => [
- 'IMPL::AppException' => undef
- ],
- props => [
- level => PROP_RO
- ]
-};
-
-use IMPL::Resources::Strings {
- message => "Something wrong at level %level%"
-};
-
-sub CTOR {
- my ($this,$level) = @_;
-
- $this->level($level);
-}
-
-=end code
-
-=head1 DESCRIPTION
-
-Для описания собственных исключений в качестве базового класса должен
-использоваться C поскольку он позволяет использовать
-C и объявлять свойства.
-
-C также является классом для исключений, однако поскольку
-он используется в базовых механизмах библиотеки, то в нем не реализованы
-механизмы для описания свойсвт.
-
-Исключение имеет свойство C которое возвращает текст с описанием
-проблемы, данное свойство можно реализовать с использованием
-C для реализации поддержки нескольких языков.
-
-Особенностью тсключений также является то, что при их создании автоматически
-фиксируется место, где оно было создано и свойства C и C
-заполняются автоматически.
-
-Для исключений переопределены операторы приведения к строке и к булевому
-значению.
-
-=head1 MEMBERS
-
-=head2 C<[op]new(@args)>
-
-Оператор создающий новый экземпляр исключения, сначала создает экземпляр
-исключения, затем заполняет свойства C, C.
-
-=head2 C<[op]throw(@args)>
-
-Создает объект исключения и бросает его.
-
-=begin code
-
-throw MyException(10);
-MyException->throw(10); # ditto
-
-=end code
-
-=head2 C<[get]source>
-
-Строка с описанием в каком файле и где произошло исключение. см. C
-
-=head2 C<[get]callStack>
-
-Строка со стеком вызовов в момент возникновения исключения. см. C
-
-=head2 C<[get]message>
-
-Возвращает описание исключения.
-
-=head2 C
-
-Возвращает текстовое представление, как правило это C и C.
-
-=cut
\ No newline at end of file
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/AccessorPropertyInfo.pm
--- a/Lib/IMPL/Class/AccessorPropertyInfo.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,13 +0,0 @@
-package IMPL::Class::AccessorPropertyInfo;
-use strict;
-
-BEGIN {
- our @ISA = qw(IMPL::Class::PropertyInfo);
-}
-require IMPL::Class::PropertyInfo;
-
-our %CTOR = ('IMPL::Class::PropertyInfo' => '@_');
-
-__PACKAGE__->mk_accessors(qw(fieldName));
-
-1;
\ No newline at end of file
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/DirectPropertyInfo.pm
--- a/Lib/IMPL/Class/DirectPropertyInfo.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,10 +0,0 @@
-package IMPL::Class::DirectPropertyInfo;
-use strict;
-
-use parent 'IMPL::Class::PropertyInfo';
-our %CTOR = ('IMPL::Class::PropertyInfo' => '@_');
-
-__PACKAGE__->mk_accessors(qw(fieldName directAccess));
-
-
-1;
\ No newline at end of file
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/Member.pm
--- a/Lib/IMPL/Class/Member.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-package IMPL::Class::Member;
-use strict;
-use parent qw(Exporter);
-our @EXPORT = qw(&public &private &protected &_direct);
-
-
-use IMPL::Const qw(:access);
-
-require IMPL::Class::MemberInfo;
-
-sub public($) {
- my $info = shift;
- $info->{access} = ACCESS_PUBLIC;
- my $implementor = delete $info->{implementor};
- $implementor->Implement($info);
-}
-
-sub private($) {
- my $info = shift;
- $info->{access} = ACCESS_PRIVATE;
- my $implementor = delete $info->{implementor};
- $implementor->Implement($info);
-}
-
-sub protected($) {
- my $info = shift;
- $info->{access} = ACCESS_PROTECTED;
- my $implementor = delete $info->{implementor};
- $implementor->Implement($info);
-}
-
-sub _direct($) {
- my $info = shift;
- $info->{direct} = 1;
- return $info;
-}
-
-1;
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/MemberInfo.pm
--- a/Lib/IMPL/Class/MemberInfo.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,84 +0,0 @@
-package IMPL::Class::MemberInfo;
-use strict;
-
-use IMPL::Const qw(:prop);
-BEGIN {
- our @ISA = qw(IMPL::Object::Accessor);
-}
-
-require IMPL::Object::Accessor;
-require IMPL::Exception;
-
-# использовать ClassPropertyImplementor не получится, поскольку он будет
-# создавать экземпляры PropertyInfo, который не доописан (в нем не определены
-# члены)
-__PACKAGE__->mk_accessors(
- qw(
- name
- access
- class
- attributes
- )
-);
-
-our %CTOR = (
- 'IMPL::Object::Accessor' => undef
-);
-
-sub CTOR {
- my $this = shift;
-
- die new IMPL::Exception('The name is required for the member') unless $this->name;
- die new IMPL::Exception('The class is required for the member') unless $this->class;
-
- $this->attributes({}) unless defined $this->attributes;
- $this->access(3) unless $this->access;
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-C - информация о члене класса.
-
-=head1 DESCRIPTION
-
-Данный класс является базовым для таких классов как C, C и
-предназначен для хренения метаданных.
-
-Данный класс наследуется от C и не содержит в себе метаданных о своих членах.
-
-=head1 MEMBERS
-
-=over
-
-=item C<[get,set] name>
-
-Имя члена.
-
-=item C<[get,set] access>
-
-Default public.
-
-Атрибут доступа ( public | private | protected )
-
-=item C<[get,set] class>
-
-Класс владелец
-
-=item C<[get,set] attributes>
-
-Дополнительные атрибуты
-
-=item C
-
-При реализации собственного субкласса, данный метод может быть переопределен для
-реализации дополнительной обработки (например, создание методов доступа для свойств).
-
-=back
-
-=cut
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/Meta.pm
--- a/Lib/IMPL/Class/Meta.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,344 +0,0 @@
-package IMPL::Class::Meta;
-use strict;
-
-use Carp qw(carp confess);
-use IMPL::clone qw(clone);
-
-my %class_meta;
-my %class_data;
-
-sub SetMeta {
- my ($class,$meta_data) = @_;
- $class = ref $class || $class;
-
- # тут нельзя использовать стандартное исключение, поскольку для него используется
- # класс IMPL::Object::Accessor, который наследуется от текущего класса
- confess "The meta_data parameter should be an object" if not ref $meta_data;
-
- push @{$class_meta{$class}{ref $meta_data}},$meta_data;
-}
-
-sub set_meta {
- goto &SetMeta;
-}
-
-sub GetMeta {
- my ($class,$meta_class,$predicate,$deep) = @_;
- $class = ref $class if ref $class;
- no strict 'refs';
- my @result;
-
- if ($predicate) {
- push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) );
- } else {
- push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
- }
-
- if ($deep) {
- push @result, map { $_->can('GetMeta') ? $_->GetMeta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'};
- }
-
- wantarray ? @result : \@result;
-}
-
-sub get_meta {
- goto &GetMeta;
-}
-
-sub class_data {
- my $class = shift;
- $class = ref $class || $class;
-
- carp 'The method is obsolete, use static_accessor($name,$value,\'clone\') instead';
-
- if (@_ > 1) {
- my ($name,$value) = @_;
- return $class_data{$class}{$name} = $value;
- } else {
- my ($name) = @_;
-
- if( exists $class_data{$class}{$name} ) {
- $class_data{$class}{$name};
- } else {
- if ( my $value = $class->_find_class_data($name) ) {
- $class_data{$class}{$name} = clone($value);
- } else {
- undef;
- }
- }
- }
-}
-
-sub static_accessor {
- my ($class,$name,$value,$inherit) = @_;
-
- $inherit ||= 'inherit';
-
- my $method = "static_accessor_$inherit";
-
- return $class->$method($name,$value);
-}
-
-sub static_accessor_clone {
- my ($class,$name,$value) = @_;
- $class = ref $class || $class;
-
- no strict 'refs';
-
- *{"${class}::${name}"} = sub {
- my $self = shift;
-
- $self = ref $self || $self;
-
- if (@_ > 0) {
- if ($class ne $self) {
- $self->static_accessor_clone( $name => $_[0] ); # define own class data
- } else {
- $value = $_[0];
- }
- } else {
- return $self ne $class
- ? $self->static_accessor_clone($name => clone($value))
- : $value;
- }
- };
- return $value;
-};
-
-sub static_accessor_inherit {
- my ($class,$name,$value) = @_;
-
- no strict 'refs';
-
- *{"${class}::$name"} = sub {
- my $self = shift;
-
- if (@_ > 0) {
- $self = ref $self || $self;
-
- if ($class ne $self) {
- $self->static_accessor_inherit( $name => $_[0] ); # define own class data
- } else {
- $value = $_[0];
- }
- } else {
- $value ;
- }
- };
- return $value;
-}
-
-sub static_accessor_own {
- my ($class,$name,$value) = @_;
-
- no strict 'refs';
-
- *{"${class}::$name"} = sub {
- my $self = shift;
- $self = ref $self || $self;
-
- if ($class ne $self) {
- if (@_ > 0) {
- $self->static_accessor_own( $name => $_[0] ); # define own class data
- } else {
- return;
- }
- } else {
- if ( @_ > 0 ) {
- $value = $_[0];
- } else {
- return $value;
- }
- }
- };
-
- return $value;
-}
-
-sub _find_class_data {
- my ($class,$name) = @_;
-
- no strict 'refs';
-
- exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"};
-
- my $val;
- $val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"};
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-C - информация хранимая на уровне класса.
-
-=head1 SYNOPSIS
-
-=begin code
-
-package InfoMeta;
-
-use parent qw(IMPL::Object IMPL::Object::Autofill);
-use IMPL::Class::Property;
-
-__PACKAGE__->PassThroughArgs;
-
-BEGIN {
- public property name => prop_get | owner_set;
-}
-
-package InfoExMeta;
-use parent qw(InfoMeta);
-
-__PACKAGE__->PassThroughArgs;
-
-BEGIN {
- public property description => prop_all;
-}
-
-package Foo;
-
-__PACKAGE__->set_meta(new InfoMeta(name => 'info'));
-__PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' ));
-
-package main;
-
-# get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta
-my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx';
-
-# get all InfoExMeta meta
-@info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx'
-
-# get filtered meta
-@info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info'
-
-=end code
-
-=head1 DESCRIPTION
-
-Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты,
-притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные.
-
-Существует возможность выборки метаданных с учетом унаследованных от базовых классов
-
-=head1 MEMBERS
-
-=head2 C
-
-Добавляет метаданные C<$meta_data> к классу.
-
-=head2 C
-
-Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
-метаданных базовых классов.
-
-=over
-
-=item C<$meta_class>
-
-Тип метаданных
-
-=item C<$predicate>
-
-Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата
-ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра
-объект с метаданными, возвращает C - включить метаданные в результа, C - пропустить
-метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными.
-
-=begin code
-
-my @info = Foo->get_meta(
- 'InfoMeta',
- sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta')
- 1 # deep search
-);
-
-my @info = Foo->get_meta(
- 'InfoMeta',
- sub {
- my $item = shift;
- ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta')
- },
- 1 # deep search
-);
-
-=end code
-
-=item C<$deep>
-
-Осуществлять поиск по базовым классам.
-
-=back
-
-=head2 C
-
-Создает статическое свойство с именем C<$name> и начальным значением C<$value>.
-
-Параметр C<$inherit> контролирует то, как наследуются значения.
-
-=over
-
-=item * C
-
-По умолчанию. Означает, что если для класса не определено значение, оно будет
-получено от родителя.
-
-=item * C
-
-Если для класса не определено значение, то оно будет клонировано из
-родительского значения при первом обращении. Полезно, когда родитель задает
-значение по-умолчанию, которое разделяется между несколькими потомками,
-которые модифицирю само значение (например значением является ссылка на хеш,
-а потомки добавляют или меняют значения в этом хеше).
-
-=item * C
-
-Каждый класс имеет свое собственное значение не зависящее от того, что было
-у предка. Начальное значение для этого статического свойства C.
-
-=back
-
-Данный метод является заглушкой, он передает управление
-C, C, C
-соответственно. Эти методы можно вызывать явно
-C.
-
-
-=begin code
-
-package Foo;
-use parent qw(IMPL::Class::Meta);
-
-__PACKAGE__->static_accessor( info => { version => 1 } );
-__PACKAGE__->static_accessor( mappings => { toString => \&ToString }, 'clone' );
-__PACKAGE__->static_accessor( _instance => undef, 'own' );
-
-sub ToString {
- "[object Foo]";
-}
-
-sub default {
- my ($self) = @_;
-
- $self = ref $self || $self;
- return $self->_instance ? $self->_instance : $self->_instance($self->new());
-}
-
-package Bar;
-use parent qw(Foo);
-
-__PACKAGE__->info({language => 'English', version => 2}); # will define own 'info' but will loose original data.
-__PACKAGE__->mappings->{sayHello} = \&SayHello; # will not affect Foo->mappings;
-
-package main;
-
-my $foo = Foo->default; # will be a Foo object
-my $bar = Bar->default; # will be a Bar object
-
-=end code
-
-=cut
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/MethodInfo.pm
--- a/Lib/IMPL/Class/MethodInfo.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,13 +0,0 @@
-use strict;
-package IMPL::Class::MethodInfo;
-
-use parent qw(IMPL::Class::MemberInfo);
-
-__PACKAGE__->PassThroughArgs;
-
-__PACKAGE__->mk_accessors(qw(
- returnType
- parameters
-));
-
-1;
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/Property.pm
--- a/Lib/IMPL/Class/Property.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,55 +0,0 @@
-package IMPL::Class::Property;
-use strict;
-use parent qw(Exporter);
-
-BEGIN {
- our @EXPORT = qw(property prop_get prop_set owner_set prop_none prop_all prop_list CreateProperty);
-}
-
-use IMPL::lang qw(:hash);
-use IMPL::Const qw(:prop);
-use Carp qw(carp);
-require IMPL::Class::Member;
-
-sub import {
- __PACKAGE__->export_to_level(1,@_);
- IMPL::Class::Member->export_to_level(1,@_);
-}
-
-sub prop_get { 1 };
-sub prop_set { 2 };
-sub owner_set { 10 };
-sub prop_none { 0 };
-sub prop_all { 3 };
-sub prop_list { 4 };
-
-sub property($$) {
- my ($propName,$attributes) = @_;
-
- my $class = caller;
-
- return hashMerge (
- $class->ClassPropertyImplementor->NormalizeSpecification($attributes),
- {
- implementor => $class->ClassPropertyImplementor,
- name => $propName,
- class => scalar(caller),
- }
- );
-}
-
-sub CreateProperty {
- my ($class,$propName,@attributes) = @_;
-
- $class
- ->ClassPropertyImplementor
- ->Implement(
- @attributes,
- {
- name => $propName,
- class => $class,
- }
- );
-};
-
-1;
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/PropertyInfo.pm
--- a/Lib/IMPL/Class/PropertyInfo.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-package IMPL::Class::PropertyInfo;
-use strict;
-
-BEGIN {
- our @ISA = qw(IMPL::Class::MemberInfo);
-}
-
-require IMPL::Class::MemberInfo;
-
-our %CTOR = ( 'IMPL::Class::MemberInfo' => '@_' );
-
-__PACKAGE__->mk_accessors(
- qw(
- type
- getter
- setter
- ownerSet
- isList
- )
-);
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-C - метаданные о свойствах объектов. Используются для отражения и
-проверки данных объектов.
-
-=head1 DESCRIPTION
-
-В зависимости от типа каждый объект предоставляет способ хранения данных, например хеши позволяют
-хранить состояние в виде ассоциативного массива и т.д. Информация о свойстве предоставляет определенный
-уровень абстракции.
-
-=cut
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Class/Template.pm
--- a/Lib/IMPL/Class/Template.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,113 +0,0 @@
-package IMPL::Class::Template;
-use strict;
-use IMPL::lang;
-use IMPL::_core::version;
-
-sub makeName {
- my ($class,@params) = @_;
-
- $_ =~ s/^.*::(\w+)$/$1/ foreach @params;
- return join('',$class,@params);
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-C базовый класс для шаблонов.
-
-=head1 SYNPOSIS
-
-=begin code
-
-package KeyValuePair;
-
-use IMPL::Class::Property;
-
-use IMPL::template (
- parameters => [qw(TKey TValue))],
- base => [qw(IMPL::Object IMPL::Object::Autofill)],
- declare => sub {
- my ($class) = @_;
- public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } );
- public $class->CreateProperty(value => prop_all, { type => $class->TValue} );
-
- $class->PassThroughArgs;
- }
-);
-
-BEGIN {
- public property id => prop_get | owner_set, { type => 'integer'};
-}
-
-__PACKAGE__->PassThroughArgs;
-
-package MyCollection;
-
-use IMPL::Class::Property;
-
-use IMPL::lang;
-use IMPL::template(
- parameters => [qw(TKey TValue)],
- base => [qw(IMPL::Object)],
- declare => sub {
- my ($class) = @_;
- my $item_t = spec KeyValuePair($class->TKey,$class->TValue);
-
- public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } )
-
- $class->static_accessor( ItemType => $item_t );
- }
-)
-
-sub Add {
- my ($this,$key,$value) = @_;
-
- die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey;
- die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue;
-
- $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) );
-}
-
-=end code
-
-=head1 DESCRIPTION
-
-Шаблоны используются для динамической генерации классов. Процесс создания класса
-по шаблону называется специализацией, при этом создается новый класс:
-
-=over
-
-=item 1
-
-Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона
-
-=item 2
-
-Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона
-
-=item 3
-
-Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров
-
-=item 4
-
-Вызывается метод для конструирования специализиции
-
-=back
-
-=head1 MEMBERS
-
-=over
-
-=item C
-
-Метод, создающий специализацию шаблона. Может быть вызван как оператор.
-
-=back
-
-=cut
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Code/AccessorPropertyImplementor.pm
--- a/Lib/IMPL/Code/AccessorPropertyImplementor.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,84 +0,0 @@
-package IMPL::Code::AccessorPropertyImplementor;
-use strict;
-
-use IMPL::lang qw(:hash);
-use IMPL::require {
- Exception => '-IMPL::Exception',
- ArgException => '-IMPL::InvalidArgumentException',
- AccessorPropertyInfo => '-IMPL::Class::AccessorPropertyInfo'
-};
-
-require IMPL::Class::AccessorPropertyInfo;
-require IMPL::Object::List;
-
-use parent qw(IMPL::Code::BasePropertyImplementor);
-
-use constant {
- CodeGetAccessor => 'return $this->get($field);',
- CodeSetAccessor => 'return $this->set($field,@_);',
- CodeSetListAccessor =>
- 'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] );
- $this->set($field,$val);
- return( wantarray ? @{ $val } : $val );',
- CodeGetListAccessor =>
- 'my $val = $this->get($field);
- $this->set($field,$val = IMPL::Object::List->new()) unless $val;
- return( wantarray ? @{ $val } : $val );'
-};
-
-sub factoryParams { qw($class $name $get $set $validator $field) };
-
-my %cache;
-
-sub Implement {
- my $self = shift;
-
- my $spec = {};
-
- map hashApply($spec,$self->NormalizeSpecification($_)), @_;
-
- my $name = $spec->{name}
- or ArgException->new(name => "The name of the property is required");
- my $class = $spec->{class}
- or ArgException->new(name => "The onwer class must be specified");
-
- my $id = $self->CreateFactoryId($spec);
- my $factory = $cache{$id};
- unless($factory) {
- $factory = $self->CreateFactory($spec);
- $cache{$id} = $factory;
- }
-
- my $field = $name;
-
- my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field);
-
- my $args = {
- getter => $spec->{get} ? $accessor : undef,
- setter => $spec->{set} ? $accessor : undef,
- ownetSet => $spec->{ownerSet} ? 1 : 0,
- isList => $spec->{isList} ? 1 : 0,
- name => $spec->{name},
- class => $spec->{class},
- type => $spec->{type},
- access => $spec->{access},
- fieldName => $field
- };
-
- delete @$spec{qw(get set ownerSet isList name class type access field direct)};
-
- $args->{attributes} = $spec;
-
- my $propInfo = AccessorPropertyInfo->new($args);
-
- {
- no strict 'refs';
- *{"${class}::$name"} = $accessor;
- }
-
- $class->SetMeta($propInfo);
-
- return $propInfo;
-}
-
-1;
\ No newline at end of file
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Code/BasePropertyImplementor.pm
--- a/Lib/IMPL/Code/BasePropertyImplementor.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,149 +0,0 @@
-package IMPL::Code::BasePropertyImplementor;
-use strict;
-
-use IMPL::Const qw(:prop :access);
-use Scalar::Util qw(looks_like_number);
-
-use constant {
- CodeNoGetAccessor => 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;',
- CodeNoSetAccessor => 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;',
- CodeCustomGetAccessor => '$this->$get(@_);',
- CodeCustomSetAccessor => '$this->$set(@_);',
- CodeValidator => '$this->$validator(@_);',
- CodeOwnerCheck => "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"
-};
-
-sub CodeSetAccessor {
- die new IMPL::Exception("Standard accessors not supported",'Set');
-}
-
-sub CodeGetAccessor {
- die new IMPL::Exception("Standard accessors not supported",'Get');
-}
-
-sub CodeGetListAccessor {
- die new IMPL::Exception("Standard accessors not supported",'GetList');
-}
-
-sub CodeSetListAccessor {
- die new IMPL::Exception("Standard accessors not supported",'SetList');
-}
-
-sub factoryParams { qw($class $name $set $get $validator) };
-
-our %ACCESS_CODE = (
- ACCESS_PUBLIC , "",
- ACCESS_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
- ACCESS_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"
-);
-
-sub NormalizeSpecification {
- my ($this,$spec) = @_;
-
- return $spec if ref($spec);
-
- if (looks_like_number($spec)) {
- return {
- get => $spec & PROP_GET,
- set => $spec & PROP_SET,
- isList => $spec & PROP_LIST,
- ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET),
- direct => $spec & PROP_DIRECT
- };
- } else {
- return {};
- }
-}
-
-sub CreateFactoryId {
- my ($self, $spec) = @_;
-
- join( '',
- map(
- ($_
- ? ( _isCustom($_)
- ? 'x'
- : 's')
- : '_'),
- @$spec{qw(get set)}
- ),
- $spec->{access} || ACCESS_PUBLIC,
- $spec->{validator} ? 'v' : '_',
- $spec->{isList} ? 'l' : '_',
- $spec->{ownerSet} ? 'o' : '_'
- );
-}
-
-sub _isCustom {
- ref($_[0]) eq 'CODE' || not(ref($_[0]) || looks_like_number($_[0]));
-}
-
-sub CreateFactory {
- my ($self,$spec) = @_;
-
- return $self->CreateFactoryImpl(
- ($spec->{get}
- ? ( _isCustom($spec->{get})
- ? $self->CodeCustomGetAccessor
- : ($spec->{isList}
- ? $self->CodeGetListAccessor
- : $self->CodeGetAccessor
- )
- )
- : $self->CodeNoGetAccessor
- ),
- ($spec->{set}
- ? ( _isCustom($spec->{set})
- ? $self->CodeCustomSetAccessor
- : ($spec->{isList}
- ? $self->CodeSetListAccessor
- : $self->CodeSetAccessor
- )
- )
- : $self->CodeNoSetAccessor
- ),
- $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '',
- $spec->{validator} ? $self->CodeValidator : '',
- $spec->{ownerSet} ? $self->CodeOwnerCheck : ''
- );
-}
-
-sub CreateFactoryImpl {
- my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_;
-
- my $strParams = join(',',$self->factoryParams);
-
- my $factory = < набор впомогательныйх статических методов
-для генерации свойств.
-
-=cut
\ No newline at end of file
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Code/DirectPropertyImplementor.pm
--- a/Lib/IMPL/Code/DirectPropertyImplementor.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,96 +0,0 @@
-package IMPL::Code::DirectPropertyImplementor;
-use strict;
-
-require IMPL::Object::List;
-
-use IMPL::lang qw(:hash);
-use IMPL::require {
- Exception => 'IMPL::Exception',
- ArgException => '-IMPL::InvalidArgumentException',
- DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo'
-};
-
-use parent qw(IMPL::Code::BasePropertyImplementor);
-
-use constant {
- CodeGetAccessor => 'return ($this->{$field});',
- CodeSetAccessor => 'return ($this->{$field} = $_[0])',
- CodeGetListAccessor => 'return(
- wantarray ?
- @{ $this->{$field} ?
- $this->{$field} :
- ( $this->{$field} = IMPL::Object::List->new() )
- } :
- ( $this->{$field} ?
- $this->{$field} :
- ( $this->{$field} = IMPL::Object::List->new() )
- )
- );',
- CodeSetListAccessor => 'return(
- wantarray ?
- @{ $this->{$field} = IMPL::Object::List->new(
- (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
- )} :
- ($this->{$field} = IMPL::Object::List->new(
- (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]
- ))
- );'
-};
-
-sub factoryParams { qw($class $name $get $set $validator $field) };
-
-my %cache;
-
-sub Implement {
- my $self = shift;
-
- my $spec = {};
-
- map hashApply($spec,$self->NormalizeSpecification($_)), @_;
-
- my $name = $spec->{name}
- or ArgException->new(name => "The name of the property is required");
- my $class = $spec->{class}
- or ArgException->new(name => "The onwer class must be specified");
-
- my $id = $self->CreateFactoryId($spec);
- my $factory = $cache{$id};
- unless($factory) {
- $factory = $self->CreateFactory($spec);
- $cache{$id} = $factory;
- }
-
- my $field = join( '_', split(/::/, $class), $name);
-
- my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field);
-
- my $args = {
- getter => $spec->{get} ? $accessor : undef,
- setter => $spec->{set} ? $accessor : undef,
- ownetSet => $spec->{ownerSet} ? 1 : 0,
- isList => $spec->{isList} ? 1 : 0,
- name => $spec->{name},
- class => $spec->{class},
- type => $spec->{type},
- access => $spec->{access},
- fieldName => $field,
- directAccess => $spec->{direct}
- };
-
- delete @$spec{qw(get set ownerSet isList name class type access field direct)};
-
- $args->{attributes} = $spec;
-
- my $propInfo = DirectPropertyInfo->new($args);
-
- {
- no strict 'refs';
- *{"${class}::$name"} = $accessor;
- *{"${class}::$name"} = \$field if $args->{directAccess};
- }
- $class->SetMeta($propInfo);
-
- return $propInfo;
-}
-
-1;
\ No newline at end of file
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Code/Loader.pm
--- a/Lib/IMPL/Code/Loader.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,79 +0,0 @@
-package IMPL::Code::Loader;
-use strict;
-use warnings;
-
-use IMPL::Const qw(:prop);
-use File::Spec;
-use IMPL::declare {
- require => {
- Exception => 'IMPL::Exception',
- ArgumentException => '-IMPL::InvalidArgumentException'
- },
- base => {
- 'IMPL::Object' => undef,
- 'IMPL::Object::Autofill' => '@_'
- },
- props => [
- verifyNames => PROP_RO,
- prefix => PROP_RO,
- _pending => PROP_RW
- ]
-};
-
-my $default;
-sub default {
- $default ||= new IMPL::Code::Loader;
-}
-
-my $safe;
-sub safe {
- $safe ||= new IMPL::Code::Loader(verifyNames => 1);
-}
-
-sub CTOR {
- my ($this) = @_;
-
- $this->_pending({});
-}
-
-sub Require {
- my ($this,$package) = @_;
-
- if ($this->verifyNames) {
- $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/
- or die ArgumentException->new(package => 'Invalid package name') ;
- $package = $1;
- }
-
- $package = $this->prefix . '::' . $package if $this->prefix;
-
- my $file = join('/', split(/::/,$package)) . ".pm";
-
- require $file;
-
- return $package;
-}
-
-sub ModuleExists {
- my ($this,$package) = @_;
-
- my $file = join('/', split(/::/,$this->GetFullName($package))) . ".pm";
-
- -f File::Spec->catfile($_,$file) and return 1 foreach @INC;
-
- return 0;
-}
-
-sub GetFullName {
- my ($this,$package) = @_;
-
- if ($this->verifyNames) {
- $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/
- or die ArgumentException->new(package => 'Invalid package name') ;
- }
-
- return $this->prefix . '::' . $package if $this->prefix;
-}
-
-1;
-
diff -r f23fcb19d3c1 -r c6e90e02dd17 Lib/IMPL/Config.pm
--- a/Lib/IMPL/Config.pm Mon Aug 31 20:22:16 2015 +0300
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,291 +0,0 @@
-package IMPL::Config;
-use strict;
-use warnings;
-use mro;
-
-use Carp qw(carp);
-
-use IMPL::lang qw(is);
-use IMPL::Exception;
-use IMPL::Const qw(:access);
-use IMPL::declare {
- require => {
- PropertyInfo => 'IMPL::Class::PropertyInfo',
- XmlFormatter => 'IMPL::Serialization::XmlFormatter',
- Serializer => '-IMPL::Serializer',
- Activator => '-IMPL::Config::Activator',
-
- Exception => 'IMPL::Exception',
- IOException => '-IMPL::IOException'
- },
- base => [
- 'IMPL::Object::Accessor' => undef,
- 'IMPL::Object::Serializable' => undef,
- 'IMPL::Object::Autofill' => '@_'
- ]
-};
-
-use File::Spec();
-
-
-our $ConfigBase ||= '';
-our $AppBase;
-
-sub LoadXMLFile {
- my ($self,$file) = @_;
-
- my $class = ref $self || $self;
-
- my $serializer = Serializer->new(
- formatter => XmlFormatter->new(
- IdentOutput => 1,
- SkipWhitespace => 1
- )
- );
-
- open my $hFile,'<',$file or die IOException->new("Failed to open file",$file,$!);
-
- my $obj;
- eval {
- $obj = $serializer->Deserialize($hFile);
- };
-
- if ($@) {
- my $e=$@;
- die Exception->new("Can't load the configuration file",$file,$e);
- }
- return $obj;
-}
-
-sub SaveXMLFile {
- my ($this,$file) = @_;
-
- my $serializer = Serializer->new(
- formatter => XmlFormatter->new(
- IdentOutput => 1,
- SkipWhitespace => 1
- )
- );
-
- open my $hFile,'>',$file or die IOException->new("Failed to open file",$file,$!);
-
- $serializer->Serialize($hFile, $this);
-}
-
-sub xml {
- my $this = shift;
- my $serializer = Serializer->new(
- formatter => XmlFormatter->new(
- IdentOutput => 1,
- SkipWhitespace => 1
- )
- );
- my $str = '';
- open my $hFile,'>',\$str or die IOException->new("Failed to open stream",$!);
-
- $serializer->Serialize($hFile, $this);
-
- undef $hFile;
-
- return $str;
-}
-
-sub save {
- my ($this,$ctx) = @_;
-
- my $val;
-
- $val = $this->rawGet($_) and $ctx->AddVar($_ => $val) foreach map $_->Name, $this->get_meta(
- PropertyInfo,
- sub {
- $_->access == ACCESS_PUBLIC and
- $_->setter;
- },
- 1);
-}
-
-sub spawn {
- my ($this,$file) = @_;
- unless ($file) {
- ($file = ref $this || $this) =~ s/:+/./g;
- $file .= ".xml";
- }
- return $this->LoadXMLFile( File::Spec->catfile($ConfigBase,$file) );
-}
-
-sub get {
- my $this = shift;
-
- if (@_ == 1) {
- my $obj = $this->SUPER::get(@_);
- return is($obj,Activator) ? $obj->activate : $obj;
- } else {
- my @objs = $this->SUPER::get(@_);
- return map is($_,Activator) ? $_->activate : $_, @objs ;
- }
-}
-
-sub rawGet {
- my $this = shift;
- return $this->SUPER::get(@_);
-}
-
-sub Exists {
- $_[0]->SUPER::get($_[1]) ? 1 : 0;
-}
-
-sub AppBase {
- carp "obsolete";
- shift;
- File::Spec->catdir($AppBase,@_);
-}
-
-sub AppDir {
- shift;
- File::Spec->catdir($AppBase,@_);
-}
-
-sub AppFile {
- shift;
- File::Spec->catfile($AppBase,@_);
-}
-
-sub ConfigBase {
- carp "obsolete";
- shift;
- File::Spec->catdir($ConfigBase,@_);
-}
-
-sub ConfigDir {
- shift;
- File::Spec->catdir($ConfigBase,@_);
-}
-
-sub ConfigFile {
- shift;
- File::Spec->catfile($ConfigBase,@_);
-}
-
-1;
-__END__
-
-=pod
-
-=head1 NAME
-
-C - базовый класс для настраиваемого приложения.
-
-=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