Mercurial > pub > Impl

changeset 209:a8db61d0ed33

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
IMPL::Class::Meta refactoring
author cin
date Mon, 28 May 2012 19:58:56 +0400
parents 3d433a977e3b
children 6adaeb86945d
files Lib/IMPL/Class/Meta.pm Lib/IMPL/Class/PropertyInfo.pm Lib/IMPL/Code/Loader.pm Lib/IMPL/DOM/Node.pm Lib/IMPL/declare.pm _test/Test/Class/Meta.pm _test/temp.pl
diffstat 7 files changed, 91 insertions(+), 222 deletions(-) [+]
line wrap: on
line diff
--- 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<set_meta($meta_data)>
+=head2 C<set_meta($meta_data)>
 
 Добавляет метаданные C<$meta_data> к классу.
 
-=item C<get_meta($meta_class,$predicate,$deep)>
+=head2 C<get_meta($meta_class,$predicate,$deep)>
 
 Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
 метаданных базовых классов.
@@ -201,50 +213,13 @@
 
 =back  
 
-=item C<class_data($name,$new_value)>
-
-В отличии от метаданных, C<class_data> не накапливает информацию,
-а хранит только один экземпляр для одного ключа 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<static_accessor($name[,$value])>
+=head2 C<static_accessor($name[,$value[,$clone]])>
 
 Создает статическое свойство с именем C<$name> и начальным значением C<$value>.
 
-Использование данного свойство аналогично использованию C<class_data>, за исключением
-того, что C<class_data> гарантирует, что наследник обладает собственной копией данных,
-изменение которых не коснется ни базового класса, ни соседей.
+Параметр 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
--- 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<IMPL::Class::PropertyInfo> - метаданные о свойствах объектов. Используются для отражения и
+проверки данных объектов.
+
+=head1 DESCRIPTION
+
+В зависимости от типа каждый объект предоставляет способ хранения данных, например хеши позволяют
+хранить состояние в виде ассоциативного массива и т.д. Информация о свойстве предоставляет определенный
+уровень абстракции. 
+
 =cut
--- 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;
--- 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 = (
--- 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 ) {
--- 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; } );
 };
 
 
--- 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