# HG changeset patch # User cin # Date 1338220736 -14400 # Node ID a8db61d0ed3380d50717aa78dbdf3d2dfeca62a1 # Parent 3d433a977e3baa55d86a12db1889fc9cfc696a23 IMPL::Class::Meta refactoring diff -r 3d433a977e3b -r a8db61d0ed33 Lib/IMPL/Class/Meta.pm --- a/Lib/IMPL/Class/Meta.pm Fri May 18 18:43:00 2012 +0400 +++ b/Lib/IMPL/Class/Meta.pm Mon May 28 19:58:56 2012 +0400 @@ -1,12 +1,13 @@ package IMPL::Class::Meta; use strict; +use Carp qw(carp); use IMPL::clone qw(clone); my %class_meta; my %class_data; -sub set_meta { +sub SetMeta { my ($class,$meta_data) = @_; $class = ref $class if ref $class; @@ -17,7 +18,11 @@ push @{$class_meta{$class}{ref $meta_data}},$meta_data; } -sub get_meta { +sub set_meta { + goto &SetMeta; +} + +sub GetMeta { my ($class,$meta_class,$predicate,$deep) = @_; $class = ref $class if ref $class; no strict 'refs'; @@ -35,10 +40,16 @@ 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; @@ -58,23 +69,26 @@ } sub static_accessor { - my ($class,$name,$value) = @_; + my ($class,$name,$value,$clone) = @_; $class = ref $class || $class; no strict 'refs'; *{"${class}::${name}"} = sub { - if (@_ > 1) { - my $self = shift; - $self = ref $self || $self; + my $self = shift; + + if (@_ > 0) { + $self = ref $self || $self; if ($class ne $self) { - $self->static_accessor( $name => $_[0]); # define own class data + $self->static_accessor( $name => $_[0] ); # define own class data } else { $value = $_[0]; } } else { - $value; + ($clone and $class ne $self) + ? $self->static_accessor($name => clone($value),$clone) + : $value and $value ; } }; $value @@ -152,13 +166,11 @@ =head1 MEMBERS -=over - -=item C +=head2 C Добавляет метаданные C<$meta_data> к классу. -=item C +=head2 C Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения метаданных базовых классов. @@ -201,50 +213,13 @@ =back -=item C - -В отличии от метаданных, C не накапливает информацию, -а хранит только один экземпляр для одного ключа C<$name>. - -Если новое значение не задано, то осуществляется выборка сохраненного, -если текущий класс не имеет сохраненного значения, то оно ищется в базовых -классах, затем копия найденного значения сохраняется в текущем классе и -возвращается наружу. Это позволяет базовым классам задавать значение по-умолчанию, -которые могут быть изменены или заменены субклассами. - -=begin code - -package Foo; -use parent qw(IMPL::Class::Meta); - -__PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses - -sub say_version { - my ($self) = @_; - - print $self->class_data('info')->{version}; -} - -package Bar; -use parent qw(Foo); - -__PACKAGE__->class_data('info')->{ language } = 'English'; - -package main; - -Foo->class_data('info')->{version} = 2; -Bar->say_version; # will print '1'; -Foo->say_version; # will print '2'; - -=end code - -=item C +=head2 C Создает статическое свойство с именем C<$name> и начальным значением C<$value>. -Использование данного свойство аналогично использованию C, за исключением -того, что C гарантирует, что наследник обладает собственной копией данных, -изменение которых не коснется ни базового класса, ни соседей. +Параметр C<$clone> контролирует то, как наследуются значения, если требуется каждому классу обеспечить +свое уникальное значение, то при первом обращении оно будет клонировано, по умолчанию клонирование не +происходит. =begin code @@ -260,8 +235,5 @@ __PACKAGE__->info({language => 'English'}); # will define own 'info' but will loose original data. =end code - - -=back =cut diff -r 3d433a977e3b -r a8db61d0ed33 Lib/IMPL/Class/PropertyInfo.pm --- a/Lib/IMPL/Class/PropertyInfo.pm Fri May 18 18:43:00 2012 +0400 +++ b/Lib/IMPL/Class/PropertyInfo.pm Mon May 28 19:58:56 2012 +0400 @@ -2,10 +2,13 @@ use strict; use IMPL::_core::version; -use parent qw(IMPL::Class::MemberInfo); +use IMPL::declare { + base =>{ + 'IMPL::Class::MemberInfo' => '@_' + } +}; __PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet ownerSet)); -__PACKAGE__->PassThroughArgs; my %LoadedModules; @@ -49,4 +52,15 @@ =pod +=head1 NAME + +C - метаданные о свойствах объектов. Используются для отражения и +проверки данных объектов. + +=head1 DESCRIPTION + +В зависимости от типа каждый объект предоставляет способ хранения данных, например хеши позволяют +хранить состояние в виде ассоциативного массива и т.д. Информация о свойстве предоставляет определенный +уровень абстракции. + =cut diff -r 3d433a977e3b -r a8db61d0ed33 Lib/IMPL/Code/Loader.pm --- a/Lib/IMPL/Code/Loader.pm Fri May 18 18:43:00 2012 +0400 +++ b/Lib/IMPL/Code/Loader.pm Mon May 28 19:58:56 2012 +0400 @@ -2,32 +2,47 @@ use strict; use warnings; -my %packages; +use IMPL::lang qw(:declare :constants); + +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException' + }, + base => { + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + } +}; -sub Provide { - my ($self,$package) = @_; - - my ($declaringPackage,$file) = caller(); - $packages{$package} = { declaringPackage => $declaringPackage, file => $file, evidence => 'provide' }; +my $default; +sub default { + $default ||= new IMPL::Code::Loader; } +my $safe; +sub safe { + $safe ||= new IMPL::Code::Loader(verifyNames => 1); +} + +BEGIN { + public property verifyNames => PROP_GET | PROP_OWNERSET; + public property prefix => PROP_GET | PROP_OWNERSET; +} + + sub Require { - my ($self,$package) = @_; + my ($this,$package) = @_; - return 1 if $packages{$package}; + if ($this->verifyNames) { + $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/ or die ArgumentException->new("package") ; + } - if (my $file = $INC{$package}) { - $packages{$package} = { file => $file, evidence => 'inc' }; - return 1; - } + $package = $this->prefix . $package if $this->prefix; - undef $@; + my $file = join('/', split(/::/,$package)) . ".pm"; - if ( eval "require $package; 1;" and not $packages{$package}) { - $packages{$package} = { file => $INC{$package}, evidence => 'inc' }; - }; - - die $@ if $@ and not $!; + require $file; } 1; diff -r 3d433a977e3b -r a8db61d0ed33 Lib/IMPL/DOM/Node.pm --- a/Lib/IMPL/DOM/Node.pm Fri May 18 18:43:00 2012 +0400 +++ b/Lib/IMPL/DOM/Node.pm Mon May 28 19:58:56 2012 +0400 @@ -22,7 +22,6 @@ public _direct property schemaSource => prop_get | owner_set; private _direct property _propertyMap => prop_all ; - __PACKAGE__->class_data(property_bind => {}); } our %Axes = ( diff -r 3d433a977e3b -r a8db61d0ed33 Lib/IMPL/declare.pm --- a/Lib/IMPL/declare.pm Fri May 18 18:43:00 2012 +0400 +++ b/Lib/IMPL/declare.pm Mon May 28 19:58:56 2012 +0400 @@ -2,6 +2,7 @@ use strict; use Scalar::Util qw(set_prototype); +use Carp qw(carp); sub import { my ($self,$args) = @_; @@ -30,6 +31,7 @@ my @isa; if (ref $base eq 'ARRAY') { + carp("will be changed in next version"); @isa = map _require($_), @$base if @$base; } elsif (ref $base eq 'HASH' ) { while ( my ($class,$mapper) = each %$base ) { diff -r 3d433a977e3b -r a8db61d0ed33 _test/Test/Class/Meta.pm --- a/_test/Test/Class/Meta.pm Fri May 18 18:43:00 2012 +0400 +++ b/_test/Test/Class/Meta.pm Mon May 28 19:58:56 2012 +0400 @@ -5,42 +5,43 @@ __PACKAGE__->PassThroughArgs; -use IMPL::Test qw(test failed); +use IMPL::Test qw(test failed assert); test defineFooClassData => sub { - Foo->class_data(info => {}); + Foo->static_accessor(info => {},'clone'); }; test updateFooClassData => sub { - Foo->class_data('info')->{data} = 'Foo' ; + Foo->info->{data} = 'Foo' ; }; test getFooClassData => sub { - failed "Wrong class data", "Expected: Foo", "Got: ".Foo->class_data('info')->{data} unless Foo->class_data('info')->{data} eq 'Foo'; + assert( Foo->info->{data} eq 'Foo' ); }; test getBazClassData => sub { - failed "Wrong class data", "Expected: Foo", "Got: ".Baz->class_data('info')->{data} unless Baz->class_data('info')->{data} eq 'Foo'; + assert( Baz->info->{data} eq 'Foo' ); + assert( Bar->info->{data} eq 'Foo' ); }; test updateBarClassData => sub { - Bar->class_data('info')->{data} = 'Bar'; + Bar->info->{data} = 'Bar'; }; test getBarClassData => sub { - failed "Wrong class data", "Expected: Bar", "Got: ".Bar->class_data('info')->{data} unless Bar->class_data('info')->{data} eq 'Bar'; + assert( Bar->info->{data} eq 'Bar'); }; test validatetFooClassData => sub { - failed "Wrong class data", "Expected: Foo", "Got: ".Foo->class_data('info')->{data} unless Foo->class_data('info')->{data} eq 'Foo'; + assert( Foo->info->{data} eq 'Foo'); }; test validateBazClassData => sub { - failed "Wrong class data", "Expected: Foo", "Got: ".Baz->class_data('info')->{data} unless Baz->class_data('info')->{data} eq 'Foo'; + assert( Baz->info->{data} eq 'Foo'); }; test getwrongBazClassData => sub { - failed "Wrong class data", "Expected: undef", "Got: ".Foo->class_data( 'info2' ) if Foo->class_data( 'info2' ); + assert( not eval { Foo->info2; 1; } ); }; diff -r 3d433a977e3b -r a8db61d0ed33 _test/temp.pl --- a/_test/temp.pl Fri May 18 18:43:00 2012 +0400 +++ b/_test/temp.pl Mon May 28 19:58:56 2012 +0400 @@ -1,135 +1,1 @@ -#!/usr/bin/perl -use strict; - -use Data::Dumper(); - -=pod - -{ - bar => { - next => { - foo => { - data => 'teo' - }, - baz => { - data => 'ioh' - } - }, - data => 'duo' - }, - wee => { - data => 'iwy' - } -} - -=cut - -my $tree = {}; - -foreach my $selector( - { path => [qw( foo bar )], data => 'teo' }, - { path => [qw( {x:.*} zoo bar )], data => 'view/{x}'}, - { path => [qw( foo >zoo >bar )], data => 'ilo' }, - { path => [qw( bar )], data => 'duo' }, - { path => [qw( wee )], data => 'iwy'}, - { path => [qw( foo wee )], data => 'fwy'}, - { path => [qw( {x:\w+} )], data => 'x:{x}'}, - { path => [qw( boo {x:\w+} )], data => 'boo/{x}'}, -) { - my $t = $tree; - my @path = reverse @{$selector->{path}}; - my $last = pop @path; - my $level = 1; - foreach my $prim (@path ) { - $t = ($t->{$prim}->{next} ||= {}); - $level ++; - } - $t->{$last}->{level} = $level; - $t->{$last}->{data} = $selector->{data}; -} - -my @target = qw( foo zoo bar ); -my @results; -my $alternatives = [ { selector => $tree, immediate => 1 } ]; - -$alternatives = MatchAlternatives($_,$alternatives,\@results) foreach reverse @target; - - -sub MatchAlternatives { - my ($segment,$alternatives,$results) = @_; - - warn "alternatives: ", scalar @$alternatives,", segment: $segment"; - - my @next; - - foreach my $alt (@$alternatives) { - while (my ($selector,$match) = each %{$alt->{selector}} ) { - warn $selector; - - warn "\timmediate" if $alt->{immediate}; - warn "\thas children" if $match->{next}; - - my $context = { - vars => \%{ $alt->{vars} || {} }, - selector => $match->{next} - }; - - if ($selector =~ s/^>//) { - $context->{immediate} = 1; - } - - if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) { - #this is a regexp - warn "\tregexp: [$name] $rx"; - - if ( my @captures = ($segment =~ m/($rx)/) ) { - $context->{success} = 1; - - warn "\t",join(',',@captures); - - if ($name) { - $context->{vars}->{$name} = \@captures; - } - } - } else { - #this is a segment name - if ($segment eq $selector) { - $context->{success} = 1; - } - } - - # test if there were a match - if (delete $context->{success}) { - warn "\tmatch"; - if (my $data = $match->{data}) { - # interpolate data - $data =~ s/{(\w+)(?:\:(\d+))?}/ - my ($name,$index) = ($1,$2 || 0); - - if ($context->{vars}{$name}) { - $context->{vars}{$name}[$index]; - } else { - ""; - } - /gex; - - push @$results, { level => $match->{level}, result => $data }; - } - warn "\tnext" if $context->{selector}; - push @next, $context if $context->{selector}; - } else { - #repeat current alternative if it's not required to be immediate - push @next, { - selector => { $selector, $match }, - vars => $alt->{vars} - } unless $alt->{immediate}; - } - } - } - - warn "end, next trip: ",scalar @next, " alternatives"; - - return \@next; -} - -print Data::Dumper->Dump([$tree,\@results],[qw(tree results)]); \ No newline at end of file +print "asd::asd" =~ /^[a-zA-Z]+(?:::[a-zA-Z]+)*$/; \ No newline at end of file