Mercurial > pub > Impl

changeset 381:ced5937ff21a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Custom getters/setters support method names in theirs definitions Initial support for localizable labels in DOM schemas
author cin
date Wed, 22 Jan 2014 16:56:10 +0400
parents 1eca08048ba9
children 99ac2e19c0cc
files Lib/IMPL/Code/BasePropertyImplementor.pm Lib/IMPL/DOM/Schema.pm Lib/IMPL/DOM/Schema/Label.pm Lib/IMPL/DOM/Schema/Node.pm Lib/IMPL/DOM/Schema/Property.pm Lib/IMPL/Resources/StringMap.pm Lib/IMPL/Web/View/TTContext.pm _test/Test/Object/Common.pm _test/temp.pl
diffstat 9 files changed, 177 insertions(+), 83 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/Code/BasePropertyImplementor.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/Lib/IMPL/Code/BasePropertyImplementor.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -2,12 +2,13 @@
 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 => 'unshift @_, $this and goto &$get;',
-    CodeCustomSetAccessor => 'unshift @_, $this and goto &$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;"
 };
@@ -56,7 +57,7 @@
 	join( '',
         map(
             ($_
-                ? (ref $_ eq 'CODE'
+                ? ( _isCustom($_)
                     ? 'x'
                     : 's')
                 : '_'),
@@ -69,12 +70,16 @@
     );
 }
 
+sub _isCustom {
+	ref($_[0]) eq 'CODE' || not(ref($_[0]) || looks_like_number($_[0]));
+}
+
 sub CreateFactory {
 	my ($self,$spec) = @_;
 	
 	return $self->CreateFactoryImpl(
         ($spec->{get}
-            ? (ref $spec->{get} eq 'CODE'
+            ? ( _isCustom($spec->{get})
                 ? $self->CodeCustomGetAccessor
                 : ($spec->{isList}
                     ? $self->CodeGetListAccessor
@@ -84,7 +89,7 @@
             : $self->CodeNoGetAccessor
         ),
         ($spec->{set}
-            ? (ref $spec->{set} eq 'CODE'
+            ? ( _isCustom($spec->{set})
                 ? $self->CodeCustomSetAccessor
                 : ($spec->{isList}
                     ? $self->CodeSetListAccessor
@@ -108,8 +113,7 @@
     
 sub {
     my ($strParams) = \@_;
-    my \$accessor;
-    \$accessor = sub {
+    return sub {
         my \$this = shift;
         $codeAccessCheck
         if (\@_) {
--- a/Lib/IMPL/DOM/Schema.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/Lib/IMPL/DOM/Schema.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -2,38 +2,44 @@
 use strict;
 use warnings;
 
-use IMPL::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
-    InflateFactory => 'IMPL::DOM::Schema::InflateFactory',
-    Loader => 'IMPL::Code::Loader'
+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
+	    InflateFactory => 'IMPL::DOM::Schema::InflateFactory',
+	    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_DIRECT,
+		stringMap => {
+			get => '_getStringMap',
+			direct => 1
+		}
+	]
 };
 
-use parent qw(IMPL::DOM::Document);
-use IMPL::Class::Property;
-use File::Spec;
-
-our %CTOR = (
-    'IMPL::DOM::Document' => sub { nodeName => 'schema' }
-);
-
-BEGIN {
-    private _direct property _TypesMap => prop_all;
-    public _direct property baseDir => prop_all;
-    public _direct property BaseSchemas => prop_get | owner_set;
-}
-
 my $validatorLoader = Loader->new(prefix => Validator, verifyNames => 1);
 
 #TODO rename and remove
@@ -71,6 +77,14 @@
     return $this->SUPER::Create($nodeName,$class,$refArgs);
 }
 
+sub _getStringMap {
+	my ($this) = @_;
+	
+	
+	
+	File::Spec->catdir($this->baseDir,'locale');
+}
+
 sub Process {
     my ($this) = @_;
     
@@ -108,9 +122,12 @@
     
     my $schema = $reader->Navigator->Document;
     
-    my ($vol,$dir) = File::Spec->splitpath($file);
+    my ($vol,$dir,$name) = File::Spec->splitpath($file);
+    
+    $name =~ s/\.xml$//;
     
     $schema->baseDir($dir);
+    $schema->schemaName($name);
     
     my @errors = $class->MetaSchema->Validate($schema);
     
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/DOM/Schema/Label.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -0,0 +1,48 @@
+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;
+}
+
+our $AUTOLOAD;
+sub AUTOLOAD {
+	my ($this) = @_;
+	
+	my ($method) = ($AUTOLOAD =~ /(\w+)$/);
+	return
+		if $method eq 'DESTROY';
+		
+	return $this->new($this->_map,$method);
+}
+
+sub ToString {
+	my ($this) = @_;
+	return $this->_map->GetString($this->_id);
+}
+
+1;
\ No newline at end of file
--- a/Lib/IMPL/DOM/Schema/Node.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/Lib/IMPL/DOM/Schema/Node.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -6,32 +6,35 @@
 use IMPL::Class::Property;
 use IMPL::DOM::Property qw(_dom);
 
-BEGIN {
-    public _dom _direct property minOccur => prop_all;
-    public _dom _direct property maxOccur => prop_all;
-    public _dom _direct property type => prop_all;
-    public _dom _direct property name => prop_all;
-    public _dom _direct property display => prop_all;
-    public _dom _direct property display_no => prop_all;
-    public _dom _direct property display_blame => prop_all;
-}
+use IMPL::Const qw(:prop);
+use IMPL::declare {
+	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 }
+	]
+};
 
-our %CTOR = (
-    'IMPL::DOM::Node' => sub {
-        my %args = @_;
-        delete @args{qw(
-            minOccur
-            maxOccur
-            type
-            name
-            display
-            display_no
-            display_blame
-        )} ;
-        $args{nodeName} ||= 'Node';
-        %args
-    }
-);
+sub _getLabel {
+	my ($this) = @_;
+	
+	
+}
 
 sub CTOR {
     my ($this,%args) = @_;
@@ -40,9 +43,6 @@
     $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');
-    $this->{$display} = $args{display} if $args{display};
-    $this->{$display_no} = $args{display_no} if $args{display};
-    $this->{$display_blame} = $args{display_blame} if $args{display};
 }
 
 sub Validate {
--- a/Lib/IMPL/DOM/Schema/Property.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/Lib/IMPL/DOM/Schema/Property.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -36,7 +36,6 @@
     my ($this,$node,$ctx) = @_;
     
     my $prop = $this->name;
-    
     # buld a pseudo node for the property value 
     my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => eval { $node->$prop() } || $node->nodeProperty($prop));
         
--- a/Lib/IMPL/Resources/StringMap.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/Lib/IMPL/Resources/StringMap.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -82,7 +82,7 @@
 sub Resolve {
 	my ($self,$obj,$prop) = @_;
     
-    return ( eval { $obj->can($prop) } ? $obj->$prop() : undef );
+    return eval { $obj->$prop() };
 }
 
 1;
--- a/Lib/IMPL/Web/View/TTContext.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/Lib/IMPL/Web/View/TTContext.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -387,7 +387,7 @@
             	return $template;
             } 
             
-            #todo $meta->GetISA
+            #todo $meta->GetISA to implement custom hierachy 
             push @isa, @{"${sclass}::ISA"};
         }
 		
--- a/_test/Test/Object/Common.pm	Fri Jan 17 15:58:57 2014 +0400
+++ b/_test/Test/Object/Common.pm	Wed Jan 22 16:56:10 2014 +0400
@@ -2,10 +2,12 @@
 use strict;
 use warnings;
 
-use parent qw( IMPL::Test::Unit );
-use IMPL::Test qw(test failed cmparray);
-
-__PACKAGE__->PassThroughArgs;
+use IMPL::Test qw(test failed cmparray assert);
+use IMPL::declare {
+	base => [
+		'IMPL::Test::Unit' => '@_' 
+	]
+};
 
 {
     package Foo;
@@ -103,4 +105,36 @@
     failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
 };
 
+test CustomGetterSetter => sub {
+	my $obj = Test::Object::Common::Bar->new();
+	
+	assert($obj->custom eq 'default');
+	$obj->custom('new_value');
+	assert($obj->custom eq 'new_value');
+};
+
+package Test::Object::Common::Bar;
+use IMPL::Const qw(:prop);
+use IMPL::declare {
+	base => [
+		'IMPL::Object' => undef
+	],
+	props => [
+		custom => {
+			get => '_getCustom',
+			set => '_setCustom',
+			direct => 1
+		}
+	]
+};
+
+sub _getCustom {
+	shift->{$custom} || 'default';
+}
+
+sub _setCustom {
+	my ($this,$value) = @_;
+	$this->{$custom} = $value;
+}
+
 1;
--- a/_test/temp.pl	Fri Jan 17 15:58:57 2014 +0400
+++ b/_test/temp.pl	Wed Jan 22 16:56:10 2014 +0400
@@ -1,13 +1,5 @@
 #!/usr/bin/perl
 use strict;
+use Scalar::Util qw(looks_like_number);
+print looks_like_number(0);
 
-{
-	local $@;
-	eval {
-		
-		die "oops";
-	};
-}
-
-print $@;
-