Mercurial > pub > Impl
changeset 194:4d0e1962161c
Replaced tabs with spaces
IMPL::Web::View - fixed document model, new features (control classes, document constructor parameters)
line wrap: on
line diff
--- a/Lib/IMPL.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,11 +5,11 @@ use IMPL::_core::version; sub import { - my ($opts) = @_; - - if (ref $opts eq 'HASH') { - setDebug($$opts{Debug}) if exists $$opts{Debug}; - } + my ($opts) = @_; + + if (ref $opts eq 'HASH') { + setDebug($$opts{Debug}) if exists $$opts{Debug}; + } } 1;
--- a/Lib/IMPL/Class/Meta.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Class/Meta.pm Tue Apr 10 20:08:29 2012 +0400 @@ -36,59 +36,59 @@ } sub class_data { - my $class = shift; - $class = ref $class || $class; - - 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; - } - } - } + my $class = shift; + $class = ref $class || $class; + + 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) = @_; - $class = ref $class || $class; - - no strict 'refs'; - - *{"${class}::${name}"} = sub { - if (@_ > 1) { - my $self = shift; - $self = ref $self || $self; - - if ($class ne $self) { - $self->static_accessor( $name => $_[0]); # define own class data - } else { - $value = $_[0]; - } - } else { - $value; - } - }; - $value + my ($class,$name,$value) = @_; + $class = ref $class || $class; + + no strict 'refs'; + + *{"${class}::${name}"} = sub { + if (@_ > 1) { + my $self = shift; + $self = ref $self || $self; + + if ($class ne $self) { + $self->static_accessor( $name => $_[0]); # define own class data + } else { + $value = $_[0]; + } + } else { + $value; + } + }; + $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"}; + 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; @@ -113,7 +113,7 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property name => prop_get | owner_set; + public property name => prop_get | owner_set; } package InfoExMeta; @@ -122,7 +122,7 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property description => prop_all; + public property description => prop_all; } package Foo; @@ -179,18 +179,18 @@ =begin code my @info = Foo->get_meta( - 'InfoMeta', - sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta') - 1 # deep search + '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 + 'InfoMeta', + sub { + my $item = shift; + ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta') + }, + 1 # deep search ); =end code @@ -220,9 +220,9 @@ __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses sub say_version { - my ($self) = @_; - - print $self->class_data('info')->{version}; + my ($self) = @_; + + print $self->class_data('info')->{version}; } package Bar;
--- a/Lib/IMPL/Class/MethodInfo.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Class/MethodInfo.pm Tue Apr 10 20:08:29 2012 +0400 @@ -6,8 +6,8 @@ __PACKAGE__->PassThroughArgs; __PACKAGE__->mk_accessors(qw( - ReturnType - Parameters + ReturnType + Parameters )); 1;
--- a/Lib/IMPL/Class/Property/Accessor.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Class/Property/Accessor.pm Tue Apr 10 20:08:29 2012 +0400 @@ -3,33 +3,33 @@ use parent qw(IMPL::Class::Property::Base); sub factoryParams { - $_[0]->SUPER::factoryParams, qw($field); + $_[0]->SUPER::factoryParams, qw($field); } sub RemapFactoryParams { - my ($self,$propInfo) = @_; - - return $self->SUPER::RemapFactoryParams($propInfo),$propInfo->Name; + my ($self,$propInfo) = @_; + + return $self->SUPER::RemapFactoryParams($propInfo),$propInfo->Name; } sub GenerateGet { - 'return $this->get($field);'; + 'return $this->get($field);'; } sub GenerateSet { - 'return $this->set($field,@_);'; + 'return $this->set($field,@_);'; } sub GenerateSetList { - 'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] ); - $this->set($field,$val); - return( wantarray ? @{ $val } : $val );'; + 'my $val = IMPL::Object::List->new( (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_] ); + $this->set($field,$val); + return( wantarray ? @{ $val } : $val );'; } sub GenerateGetList { - 'my $val = $this->get($field); - $this->set($field,$val = IMPL::Object::List->new()) unless $val; - return( wantarray ? @{ $val } : $val );'; + 'my $val = $this->get($field); + $this->set($field,$val = IMPL::Object::List->new()) unless $val; + return( wantarray ? @{ $val } : $val );'; } 1;
--- a/Lib/IMPL/Class/Property/Base.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Class/Property/Base.pm Tue Apr 10 20:08:29 2012 +0400 @@ -18,142 +18,142 @@ my $validator_code = '$this->$validator(@_);'; my %access_code = ( - IMPL::Class::Member::MOD_PUBLIC , "", - IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", - IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" + IMPL::Class::Member::MOD_PUBLIC , "", + IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", + IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" ); my $virtual_call = q( - my $method = $this->can($name); + my $method = $this->can($name); return $this->$method(@_) unless $method == $accessor or caller->isa($class); ); my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"; sub GenerateAccessors { - my ($self,$param,@params) = @_; - - my %accessors; - - if (not ref $param) { - if ($param & prop_list) { - $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef; - $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef; - } else { - $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef; - $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef; - } - $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : ""; - } elsif (UNIVERSAL::isa($param,'HASH')) { - $accessors{get} = $param->{get} ? $custom_accessor_get : undef; - $accessors{set} = $param->{set} ? $custom_accessor_set : undef; - $accessors{owner} = ""; - } else { - die new IMPL::Exception('The unsupported accessor/mutators supplied',$param); - } - - return \%accessors; + my ($self,$param,@params) = @_; + + my %accessors; + + if (not ref $param) { + if ($param & prop_list) { + $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef; + $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef; + } else { + $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef; + $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef; + } + $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : ""; + } elsif (UNIVERSAL::isa($param,'HASH')) { + $accessors{get} = $param->{get} ? $custom_accessor_get : undef; + $accessors{set} = $param->{set} ? $custom_accessor_set : undef; + $accessors{owner} = ""; + } else { + die new IMPL::Exception('The unsupported accessor/mutators supplied',$param); + } + + return \%accessors; } sub GenerateSet { - die new IMPL::Exception("Standard accessors not supported",'Set'); + die new IMPL::Exception("Standard accessors not supported",'Set'); } - + sub GenerateGet { - die new IMPL::Exception("Standard accessors not supported",'Get'); + die new IMPL::Exception("Standard accessors not supported",'Get'); } sub GenerateGetList { - die new IMPL::Exception("Standard accessors not supported",'GetList'); + die new IMPL::Exception("Standard accessors not supported",'GetList'); } sub GenerateSetList { - my ($self) = @_; - die new IMPL::Exception("Standard accessors not supported",'SetList'); + my ($self) = @_; + die new IMPL::Exception("Standard accessors not supported",'SetList'); } sub Make { - my ($self,$propInfo) = @_; - - my $key = $self->MakeFactoryKey($propInfo); - - my $factoryInfo = $factoryCache{$key}; - - unless ($factoryInfo) { - my $mutators = $self->GenerateAccessors($propInfo->Mutators); - $factoryInfo = { - factory => $self->CreateFactory( - $access_code{ $propInfo->Access }, - $propInfo->Attributes->{validator} ? $validator_code : "", - $mutators->{owner}, - $mutators->{get} || $accessor_get_no, - $mutators->{set} || $accessor_set_no - ), - mutators => $mutators - }; - $factoryCache{$key} = $factoryInfo; - } - - { - no strict 'refs'; - *{ $propInfo->Class.'::'.$propInfo->Name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo)); - } - - my $mutators = $factoryInfo->{mutators}; - - $propInfo->canGet( $mutators->{get} ? 1 : 0 ); - $propInfo->canSet( $mutators->{set} ? 1 : 0 ); - $propInfo->ownerSet( $mutators->{owner} ); - - 1; + my ($self,$propInfo) = @_; + + my $key = $self->MakeFactoryKey($propInfo); + + my $factoryInfo = $factoryCache{$key}; + + unless ($factoryInfo) { + my $mutators = $self->GenerateAccessors($propInfo->Mutators); + $factoryInfo = { + factory => $self->CreateFactory( + $access_code{ $propInfo->Access }, + $propInfo->Attributes->{validator} ? $validator_code : "", + $mutators->{owner}, + $mutators->{get} || $accessor_get_no, + $mutators->{set} || $accessor_set_no + ), + mutators => $mutators + }; + $factoryCache{$key} = $factoryInfo; + } + + { + no strict 'refs'; + *{ $propInfo->Class.'::'.$propInfo->Name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo)); + } + + my $mutators = $factoryInfo->{mutators}; + + $propInfo->canGet( $mutators->{get} ? 1 : 0 ); + $propInfo->canSet( $mutators->{set} ? 1 : 0 ); + $propInfo->ownerSet( $mutators->{owner} ); + + 1; } # extract from property info: class, name, get_accessor, set_accessor, validator sub RemapFactoryParams { - my ($self,$propInfo) = @_; - - my $mutators = $propInfo->Mutators; - my $class = $propInfo->Class; - my $validator = $propInfo->Attributes->{validator}; - - die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); + my ($self,$propInfo) = @_; + + my $mutators = $propInfo->Mutators; + my $class = $propInfo->Class; + my $validator = $propInfo->Attributes->{validator}; + + die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); - return ( - $propInfo->get(qw(Class Name)), - (ref $mutators? - ($mutators->{set},$mutators->{get}) - : - (undef,undef) - ), - $validator - ); + return ( + $propInfo->get(qw(Class Name)), + (ref $mutators? + ($mutators->{set},$mutators->{get}) + : + (undef,undef) + ), + $validator + ); } sub MakeFactoryKey { - my ($self,$propInfo) = @_; - - my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator}); - - my $implementor = ref $self || $self; - - return join ('', - $implementor, - $access, - $validator ? 'v' : 'n', - ref $mutators ? - ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0) - : - ('s',$mutators) - ); + my ($self,$propInfo) = @_; + + my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator}); + + my $implementor = ref $self || $self; + + return join ('', + $implementor, + $access, + $validator ? 'v' : 'n', + ref $mutators ? + ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0) + : + ('s',$mutators) + ); } sub CreateFactory { - my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_; - - my $strParams = join(',',$self->factoryParams); - - my $factory = <<FACTORY; - + my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_; + + my $strParams = join(',',$self->factoryParams); + + my $factory = <<FACTORY; + sub { my ($strParams) = \@_; my \$accessor; @@ -161,17 +161,17 @@ my \$this = shift; $codeAccessCheck if (\@_) { - $codeOwnerCheck - $codeValidator - $codeSet + $codeOwnerCheck + $codeValidator + $codeSet } else { - $codeGet + $codeGet } } } FACTORY - return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") ); + return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") ); } 1;
--- a/Lib/IMPL/Class/Property/Direct.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Class/Property/Direct.pm Tue Apr 10 20:08:29 2012 +0400 @@ -11,7 +11,7 @@ __PACKAGE__->mk_accessors( qw(ExportField) ); sub factoryParams { - $_[0]->SUPER::factoryParams, qw($field); + $_[0]->SUPER::factoryParams, qw($field); } my $default = __PACKAGE__->new({ExportField => 1}); @@ -24,57 +24,57 @@ sub GenerateGet { - 'return ($this->{$field});'; + 'return ($this->{$field});'; } sub GenerateSet { - 'return ($this->{$field} = $_[0])'; + 'return ($this->{$field} = $_[0])'; } sub GenerateSetList { - '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] : [@_] - )) - );'; + '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 GenerateGetList { - 'return( - wantarray ? - @{ $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - } : - ( $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - ) - );'; + 'return( + wantarray ? + @{ $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + } : + ( $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + ) + );'; } sub RemapFactoryParams { - my ($self,$propInfo) = @_; - - return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo); + my ($self,$propInfo) = @_; + + return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo); } sub Make { - my ($self,$propInfo) = @_; - - $self->SUPER::Make($propInfo); - - { - no strict 'refs'; - if (ref $self and $self->ExportField) { - my $field = $self->FieldName($propInfo); - *{$propInfo->Class.'::'.$propInfo->Name} = \$field; - } - } + my ($self,$propInfo) = @_; + + $self->SUPER::Make($propInfo); + + { + no strict 'refs'; + if (ref $self and $self->ExportField) { + my $field = $self->FieldName($propInfo); + *{$propInfo->Class.'::'.$propInfo->Name} = \$field; + } + } } sub FieldName {
--- a/Lib/IMPL/Class/Template.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Class/Template.pm Tue Apr 10 20:08:29 2012 +0400 @@ -4,10 +4,10 @@ use IMPL::_core::version; sub makeName { - my ($class,@params) = @_; - - $_ =~ s/^.*::(\w+)$/$1/ foreach @params; - return join('',$class,@params); + my ($class,@params) = @_; + + $_ =~ s/^.*::(\w+)$/$1/ foreach @params; + return join('',$class,@params); } 1; @@ -29,19 +29,19 @@ 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; - } + 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'}; + public property id => prop_get | owner_set, { type => 'integer'}; } __PACKAGE__->PassThroughArgs; @@ -52,25 +52,25 @@ 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 ); - } + 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 ) ); + 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
--- a/Lib/IMPL/Code/Loader.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Code/Loader.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,29 +5,29 @@ my %packages; sub Provide { - my ($self,$package) = @_; - - my ($declaringPackage,$file) = caller(); - $packages{$package} = { declaringPackage => $declaringPackage, file => $file, evidence => 'provide' }; + my ($self,$package) = @_; + + my ($declaringPackage,$file) = caller(); + $packages{$package} = { declaringPackage => $declaringPackage, file => $file, evidence => 'provide' }; } sub Require { - my ($self,$package) = @_; - - return 1 if $packages{$package}; - - if (my $file = $INC{$package}) { - $packages{$package} = { file => $file, evidence => 'inc' }; - return 1; - } - - undef $@; - - if ( eval "require $package; 1;" and not $packages{$package}) { - $packages{$package} = { file => $INC{$package}, evidence => 'inc' }; - }; - - die $@ if $@ and not $!; + my ($self,$package) = @_; + + return 1 if $packages{$package}; + + if (my $file = $INC{$package}) { + $packages{$package} = { file => $file, evidence => 'inc' }; + return 1; + } + + undef $@; + + if ( eval "require $package; 1;" and not $packages{$package}) { + $packages{$package} = { file => $INC{$package}, evidence => 'inc' }; + }; + + die $@ if $@ and not $!; } 1;
--- a/Lib/IMPL/Config.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Config.pm Tue Apr 10 20:08:29 2012 +0400 @@ -82,42 +82,42 @@ my $val; $val = $this->rawGet($_) and $ctx->AddVar($_ => $val) foreach map $_->Name, $this->get_meta( - 'IMPL::Class::PropertyInfo', - sub { - $_->Access == IMPL::Class::Member::MOD_PUBLIC and - $_->canGet; - }, - 1); + 'IMPL::Class::PropertyInfo', + sub { + $_->Access == IMPL::Class::Member::MOD_PUBLIC and + $_->canGet; + }, + 1); } sub spawn { - my ($this,$file) = @_; - unless ($file) { - ($file = ref $this || $this) =~ s/:+/./g; - $file .= ".xml"; - } - return $this->LoadXMLFile( File::Spec->catfile($ConfigBase,$file) ); + 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 UNIVERSAL::isa($obj,'IMPL::Config::Activator') ? $obj->activate : $obj; - } else { - my @objs = $this->SUPER::get(@_); - return map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @objs ; - } + my $this = shift; + + if (@_ == 1) { + my $obj = $this->SUPER::get(@_); + return UNIVERSAL::isa($obj,'IMPL::Config::Activator') ? $obj->activate : $obj; + } else { + my @objs = $this->SUPER::get(@_); + return map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @objs ; + } } sub rawGet { - my $this = shift; - return $this->SUPER::get(@_); + my $this = shift; + return $this->SUPER::get(@_); } sub Exists { - $_[0]->SUPER::get($_[1]) ? 1 : 0; + $_[0]->SUPER::get($_[1]) ? 1 : 0; } 1; @@ -150,13 +150,13 @@ my $this = shift; $this->DataSource( - new IMPL::Config::Activator( - factory => 'MyDataSource', - parameters=>{ - host => 'localhost', - user => 'dbuser' - } - ) + new IMPL::Config::Activator( + factory => 'MyDataSource', + parameters=>{ + host => 'localhost', + user => 'dbuser' + } + ) ) unless $this->Exists('DataSource'); } @@ -173,14 +173,14 @@ =begin code xml <app type='MyApp'> - <SimpleString>The application</SimpleString> - <DataSource type='IMPL::Config::Activator'> - <factory>MyDataSourceClass</factory> - <parameters type='HASH'> - <host>localhost</host> - <user>dbuser</user> - </parameters> - </DataSource> + <SimpleString>The application</SimpleString> + <DataSource type='IMPL::Config::Activator'> + <factory>MyDataSourceClass</factory> + <parameters type='HASH'> + <host>localhost</host> + <user>dbuser</user> + </parameters> + </DataSource> </app> =end code xml
--- a/Lib/IMPL/Config/Activator.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Config/Activator.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,9 +5,9 @@ use IMPL::Class::Property; BEGIN { - public property factory => prop_all; - public property parameters => prop_all; - public property object => prop_get | owner_set; + public property factory => prop_all; + public property parameters => prop_all; + public property object => prop_get | owner_set; } __PACKAGE__->PassThroughArgs; @@ -32,13 +32,13 @@ my $params = $this->parameters; if (UNIVERSAL::isa($params,'HASH')) { - while ( my ($key,$value) = each %$params ) { - push @args,$key, UNIVERSAL::isa($value,'IMPL::Config::Activator') ? $value->activate : $value; - } + while ( my ($key,$value) = each %$params ) { + push @args,$key, UNIVERSAL::isa($value,'IMPL::Config::Activator') ? $value->activate : $value; + } } elsif (UNIVERSAL::isa($params,'ARRAY')) { - push @args, map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @$params; + push @args, map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @$params; } else { - push @args, UNIVERSAL::isa($params,'IMPL::Config::Activator') ? $params->activate : $params; + push @args, UNIVERSAL::isa($params,'IMPL::Config::Activator') ? $params->activate : $params; } push @args, map UNIVERSAL::isa($_,'IMPL::Config::Activator') ? $_->activate : $_, @_ if @_; @@ -48,7 +48,7 @@ return $this->object($factory->new(@args)); } else { - return $this->object; + return $this->object; } }
--- a/Lib/IMPL/Config/Resolve.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Config/Resolve.pm Tue Apr 10 20:08:29 2012 +0400 @@ -6,71 +6,71 @@ use IMPL::Exception; BEGIN { - public property path => prop_all|prop_list; + public property path => prop_all|prop_list; } __PACKAGE__->PassThroughArgs; sub CTOR { - my $this = shift; - - my $list = $this->path; - - while(my $name = shift ) { - my $args = shift; - $list->Append({ method => $name, (defined $args ? (args => $args) : ()) }); - } - - die new IMPL::InvalidArgumentException("The argument is mandatory","path") unless $this->path->Count; + my $this = shift; + + my $list = $this->path; + + while(my $name = shift ) { + my $args = shift; + $list->Append({ method => $name, (defined $args ? (args => $args) : ()) }); + } + + die new IMPL::InvalidArgumentException("The argument is mandatory","path") unless $this->path->Count; } sub Invoke { - my ($this,$target,$default) = @_; - - my $result = $target; - $result = $this->_InvokeMember($result,$_) || return $default foreach $this->path; - - return $result; + my ($this,$target,$default) = @_; + + my $result = $target; + $result = $this->_InvokeMember($result,$_) || return $default foreach $this->path; + + return $result; } sub _InvokeMember { - my ($self,$object,$member) = @_; - - my $method = $member->{method}; - - local $@; - return eval { - ref $object eq 'HASH' ? - $object->{$method} - : - $object->$method( - exists $member->{args} ? - _as_list($member->{args}) - : - () - ) - }; + my ($self,$object,$member) = @_; + + my $method = $member->{method}; + + local $@; + return eval { + ref $object eq 'HASH' ? + $object->{$method} + : + $object->$method( + exists $member->{args} ? + _as_list($member->{args}) + : + () + ) + }; } sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar($_->{method},$_->{args}) foreach $this->path; + my ($this,$ctx) = @_; + + $ctx->AddVar($_->{method},$_->{args}) foreach $this->path; } sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); + ref $_[0] ? + (ref $_[0] eq 'HASH' ? + %{$_[0]} + : + (ref $_[0] eq 'ARRAY'? + @{$_[0]} + : + $_[0] + ) + ) + : + ($_[0]); } 1;
--- a/Lib/IMPL/DOM/Document.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Document.pm Tue Apr 10 20:08:29 2012 +0400 @@ -14,8 +14,8 @@ my ($this,$nodeName,$class,$refProps) = @_; if ( ref $class eq 'HASH' ) { - $refProps = $class; - $class = undef; + $refProps = $class; + $class = undef; } $class ||= typeof IMPL::DOM::Node; @@ -32,11 +32,11 @@ } sub save { - my ($this,$writer) = @_; - - $writer->xmlDecl(undef,'yes'); - $this->SUPER::save($writer); - $writer->end(); + my ($this,$writer) = @_; + + $writer->xmlDecl(undef,'yes'); + $this->SUPER::save($writer); + $writer->end(); } { @@ -69,15 +69,15 @@ 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(@_); - } + 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 @@ -93,13 +93,13 @@ =begin code sub Create { - my ($this,$nodeName,$class,$hashProps) = @_; - - return $class->new ( - nodeName => $nodeName, - document => $this, - %$hashProps - ); + my ($this,$nodeName,$class,$hashProps) = @_; + + return $class->new ( + nodeName => $nodeName, + document => $this, + %$hashProps + ); } =end code
--- a/Lib/IMPL/DOM/Navigator.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Navigator.pm Tue Apr 10 20:08:29 2012 +0400 @@ -155,18 +155,18 @@ } sub pathLength { - my ($this) = @_; - $this->{$_path} ? scalar @{$this->{$_path}} : 0; + 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 undef; - } + my ($this,$index) = @_; + + if (my $state = $this->{$_path} ? $this->{$_path}->[$index] : undef ) { + return $state->{alternatives}[$state->{current}] + } else { + return undef; + } } sub clone {
--- a/Lib/IMPL/DOM/Navigator/Builder.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Navigator/Builder.pm Tue Apr 10 20:08:29 2012 +0400 @@ -51,17 +51,17 @@ } if (@errors) { - $this->BuildErrors->Append( - map { - IMPL::DOM::Schema::ValidationError->new( - Node => $node, - Source => $schemaSource, - Schema => $schemaNode, - Message => $schemaNode->messageInflateError, - Error => $_ - ) - } @errors - ); + $this->BuildErrors->Append( + map { + IMPL::DOM::Schema::ValidationError->new( + Node => $node, + Source => $schemaSource, + Schema => $schemaNode, + Message => $schemaNode->messageInflateError, + Error => $_ + ) + } @errors + ); } return $node; @@ -71,40 +71,40 @@ } sub inflateProperties { - my ($this,$schemaNode,$refProps) = @_; - my @errors; - foreach my $schemaProp ( $schemaNode->selectNodes('Property') ) { - next if not exists $refProps->{$schemaProp->name}; - my $result = eval {$schemaProp->inflateValue($refProps->{$schemaProp->name}) }; - if (my $e = $@) { - push @errors, $e; - } else { - $refProps->{$schemaProp->name} = $result; - } - } - return @errors; + my ($this,$schemaNode,$refProps) = @_; + my @errors; + foreach my $schemaProp ( $schemaNode->selectNodes('Property') ) { + next if not exists $refProps->{$schemaProp->name}; + my $result = eval {$schemaProp->inflateValue($refProps->{$schemaProp->name}) }; + if (my $e = $@) { + push @errors, $e; + } else { + $refProps->{$schemaProp->name} = $result; + } + } + return @errors; } sub inflateValue { - my ($this,$value,$node) = @_; - - $node ||= $this->Current; - - my $nodeSchema = $this->{$_schemaNavi}->Current; - - my $result = eval { $nodeSchema->inflateValue($value) }; - if (my $e=$@) { - $this->BuildErrors->Append(new IMPL::DOM::Schema::ValidationError( - Schema => $nodeSchema, - Node => $node, - Error => $e, - Message => $nodeSchema->messageInflateError, - Source => $this->{$_schemaNavi}->SourceSchemaNode - )); - return $value; - } else { - return $result; - } + my ($this,$value,$node) = @_; + + $node ||= $this->Current; + + my $nodeSchema = $this->{$_schemaNavi}->Current; + + my $result = eval { $nodeSchema->inflateValue($value) }; + if (my $e=$@) { + $this->BuildErrors->Append(new IMPL::DOM::Schema::ValidationError( + Schema => $nodeSchema, + Node => $node, + Error => $e, + Message => $nodeSchema->messageInflateError, + Source => $this->{$_schemaNavi}->SourceSchemaNode + )); + return $value; + } else { + return $result; + } } sub Back { @@ -115,17 +115,17 @@ } sub saveState { - my ($this) = @_; - - $this->{$_schemaNavi}->saveState; - $this->SUPER::saveState; + my ($this) = @_; + + $this->{$_schemaNavi}->saveState; + $this->SUPER::saveState; } sub restoreState { - my ($this) = @_; - - $this->{$_schemaNavi}->restoreState; - $this->SUPER::restoreState; + my ($this) = @_; + + $this->{$_schemaNavi}->restoreState; + $this->SUPER::restoreState; } 1;
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Tue Apr 10 20:08:29 2012 +0400 @@ -59,7 +59,7 @@ ) }) ) { - $steps ++; + $steps ++; if ($node->nodeName eq 'AnyNode') { # if we navigate to the anynode # assume it to be ComplexType by default @@ -98,16 +98,16 @@ } sub SourceSchemaNode { - my ($this) = @_; - - if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or - $this->Current->isa('IMPL::DOM::Schema::ComplexType') - ) { - # we a redirected - return $this->GetNodeFromHistory(-1); - } else { - return $this->Current; - } + my ($this) = @_; + + if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or + $this->Current->isa('IMPL::DOM::Schema::ComplexType') + ) { + # we a redirected + return $this->GetNodeFromHistory(-1); + } else { + return $this->Current; + } } 1;
--- a/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Tue Apr 10 20:08:29 2012 +0400 @@ -35,7 +35,7 @@ } sub inflateValue { - $_[1]; + $_[1]; } 1;
--- a/Lib/IMPL/DOM/Node.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Node.pm Tue Apr 10 20:08:29 2012 +0400 @@ -26,12 +26,12 @@ } our %Axes = ( - parent => \&selectParent, - siblings => \&selectSiblings, - child => \&childNodes, - document => \&selectDocument, - ancestor => \&selectAncestors, - descendant => \&selectDescendant + parent => \&selectParent, + siblings => \&selectSiblings, + child => \&childNodes, + document => \&selectDocument, + ancestor => \&selectAncestors, + descendant => \&selectDescendant ); sub CTOR { @@ -45,7 +45,7 @@ } while ( my ($key,$value) = each %args ) { - $this->nodeProperty($key,$value); + $this->nodeProperty($key,$value); } } @@ -105,8 +105,8 @@ } sub childNodesRef { - my ($this) = @_; - return scalar $this->_getChildNodes; + my ($this) = @_; + return scalar $this->_getChildNodes; } sub removeNode { @@ -191,52 +191,52 @@ } sub resolveAxis { - my ($this,$axis) = @_; - return $Axes{$axis}->($this) + 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; + 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]; + my $this = shift; + my @result = $this->selectNodes(@_); + return $result[0]; } sub selectNodesRef { - my $this = shift; - - my @result = $this->selectNodes(@_); - return \@result; + 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]; + my ($this,$path) = @_; + + # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare + return [$path]; } sub selectNodesAxis { - my ($this,$query,$axis) = @_; + my ($this,$query,$axis) = @_; $axis ||= 'child'; @@ -252,9 +252,9 @@ 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); - } + while( my ($axis,$filter) = each %$query ) { + push @result, $this->selectNodesAxis($filter,$axis); + } } elsif (defined $query) { @result = grep $_->nodeName eq $query, @{$nodes}; } else { @@ -265,39 +265,39 @@ } sub selectParent { - my ($this) = @_; - - if ($this->parentNode) { - return wantarray ? $this->parentNode : [$this->parentNode]; - } else { - return wantarray ? () : []; - } + 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 ? () : []; - } + 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 ? () : []; - } + 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] + wantarray ? + map $_->selectAll(), $_[0]->childNodes : + [map $_->selectAll(), $_[0]->childNodes] } sub selectAll { @@ -305,11 +305,11 @@ } sub selectAncestors { - my $parent = $_[0]->parentNode; - - wantarray ? - ($parent ? ($parent->selectAncestors,$parent) : ()) : - [$parent ? ($parent->selectAncestors,$parent) : ()] + my $parent = $_[0]->parentNode; + + wantarray ? + ($parent ? ($parent->selectAncestors,$parent) : ()) : + [$parent ? ($parent->selectAncestors,$parent) : ()] } sub firstChild { @@ -373,52 +373,52 @@ return unless defined $name; if (my $method = $this->can($name)) { - unshift @_,$this; - # use goto to preserve calling context - goto &$method; + unshift @_,$this; + # use goto to preserve calling context + goto &$method; } # dynamic property if (@_) { - # set - return $this->{$_propertyMap}{$name} = shift; - } else { - return $this->{$_propertyMap}{$name}; + # set + return $this->{$_propertyMap}{$name} = shift; + } else { + return $this->{$_propertyMap}{$name}; } } sub listProperties { - my ($this) = @_; - - my %props = map {$_->Name, 1} $this->get_meta(typeof IMPL::Class::PropertyInfo, sub { $_->Attributes->{domProperty}},1); - - return (keys %props,keys %{$this->{$_propertyMap}}); + my ($this) = @_; + + my %props = map {$_->Name, 1} $this->get_meta(typeof IMPL::Class::PropertyInfo, sub { $_->Attributes->{domProperty}},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}); - } + 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 {
--- a/Lib/IMPL/DOM/Schema.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema.pm Tue Apr 10 20:08:29 2012 +0400 @@ -37,9 +37,9 @@ } sub CTOR { - my ($this,%args) = @_; - - $this->{$baseDir} = ($args{baseDir} || '.'); + my ($this,%args) = @_; + + $this->{$baseDir} = ($args{baseDir} || '.'); } sub Create { @@ -48,12 +48,12 @@ die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Node'); if ($class->isa('IMPL::DOM::Schema::Validator')) { - $class = "IMPL::DOM::Schema::Validator::$nodeName"; - unless (eval {$class->can('new')}) { - eval "require $class; 1;"; - my $e = $@; - die new IMPL::Exception("Invalid validator",$class,$e) if $e; - } + $class = "IMPL::DOM::Schema::Validator::$nodeName"; + unless (eval {$class->can('new')}) { + eval "require $class; 1;"; + my $e = $@; + die new IMPL::Exception("Invalid validator",$class,$e) if $e; + } } return $this->SUPER::Create($nodeName,$class,$refArgs); @@ -70,43 +70,43 @@ } sub Include { - my ($this,$file) = @_; - - my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file)); - - $this->appendRange( $schema->childNodes ); + my ($this,$file) = @_; + + my $schema = $this->LoadSchema(File::Spec->catfile($this->baseDir, $file)); + + $this->appendRange( $schema->childNodes ); } sub LoadSchema { - my ($this,$file) = @_; - - $file = File::Spec->rel2abs($file); - - my $class = ref $this || $this; - - my $reader = new IMPL::DOM::XMLReader( - Navigator => new IMPL::DOM::Navigator::Builder( - $class, - $class->MetaSchema - ), - SkipWhitespace => 1 - ); - - $reader->ParseFile($file); - - my $schema = $reader->Navigator->Document; - - my ($vol,$dir) = File::Spec->splitpath($file); - - $schema->baseDir($dir); - - my @errors = $class->MetaSchema->Validate($schema); - - die new IMPL::Exception("Schema is invalid",$file,map( $_->Message, @errors ) ) if @errors; - - $schema->Process; - - return $schema; + my ($this,$file) = @_; + + $file = File::Spec->rel2abs($file); + + my $class = ref $this || $this; + + my $reader = new IMPL::DOM::XMLReader( + Navigator => new IMPL::DOM::Navigator::Builder( + $class, + $class->MetaSchema + ), + SkipWhitespace => 1 + ); + + $reader->ParseFile($file); + + my $schema = $reader->Navigator->Document; + + my ($vol,$dir) = File::Spec->splitpath($file); + + $schema->baseDir($dir); + + 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 { @@ -191,7 +191,7 @@ ), IMPL::DOM::Schema::ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange( IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), + IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') ), new IMPL::DOM::Schema::Property(name => 'type'), @@ -199,7 +199,7 @@ ), IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), + IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') ), new IMPL::DOM::Schema::Property(name => 'name'), @@ -211,15 +211,15 @@ ) ), IMPL::DOM::Schema::ComplexType->new(type => 'Property', nativeType => 'IMPL::DOM::Schema::Property' )->appendRange( - IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) - ), - IMPL::DOM::Schema::Property->new(name => 'name'), - new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory') + IMPL::DOM::Schema::NodeList->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) + ), + IMPL::DOM::Schema::Property->new(name => 'name'), + new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory') ), IMPL::DOM::Schema::SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange( - IMPL::DOM::Schema::Property->new(name => 'name'), - IMPL::DOM::Schema::Property->new(name => 'type') + IMPL::DOM::Schema::Property->new(name => 'name'), + IMPL::DOM::Schema::Property->new(name => 'type') ), IMPL::DOM::Schema::SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode') );
--- a/Lib/IMPL/DOM/Schema/ComplexType.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/ComplexType.pm Tue Apr 10 20:08:29 2012 +0400 @@ -32,21 +32,21 @@ } sub Validate { - my ($this, $node,$ctx) = @_; - - if ($this->{$nativeType}) { - return new IMPL::DOM::Schema::ValidationError( - Node => $node, - Source => $ctx->{Source} || $this, - Schema => $this, - Message => $this->messageWrongType - ) unless $node->isa($this->{$nativeType}); - } - return $this->SUPER::Validate($node,$ctx); + my ($this, $node,$ctx) = @_; + + if ($this->{$nativeType}) { + return new IMPL::DOM::Schema::ValidationError( + Node => $node, + Source => $ctx->{Source} || $this, + Schema => $this, + Message => $this->messageWrongType + ) unless $node->isa($this->{$nativeType}); + } + return $this->SUPER::Validate($node,$ctx); } sub qname { - $_[0]->nodeName.'[type='.$_[0]->type.']'; + $_[0]->nodeName.'[type='.$_[0]->type.']'; }
--- a/Lib/IMPL/DOM/Schema/InflateFactory.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/InflateFactory.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,13 +5,13 @@ require IMPL::Object::Factory; sub new { - my ($self,$value) = @_; - - if ($value =~ /^(\w+(?:::\w+)*)(?:\.(\w+))?$/) { - return IMPL::Object::Factory->new($1,undef,$2); - } else { - die new IMPL::InvalidArgumentException("Expected value in the format PACKAGE::NAME.method_name",$value); - } + my ($self,$value) = @_; + + if ($value =~ /^(\w+(?:::\w+)*)(?:\.(\w+))?$/) { + return IMPL::Object::Factory->new($1,undef,$2); + } else { + die new IMPL::InvalidArgumentException("Expected value in the format PACKAGE::NAME.method_name",$value); + } } 1;
--- a/Lib/IMPL/DOM/Schema/Node.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/Node.pm Tue Apr 10 20:08:29 2012 +0400 @@ -19,18 +19,18 @@ our %CTOR = ( 'IMPL::DOM::Node' => sub { - my %args = @_; - delete @args{qw( - minOccur - maxOccur - type - name - display - display_no - display_blame - )} ; - $args{nodeName} ||= 'Node'; - %args + my %args = @_; + delete @args{qw( + minOccur + maxOccur + type + name + display + display_no + display_blame + )} ; + $args{nodeName} ||= 'Node'; + %args } ); @@ -58,7 +58,7 @@ } sub inflateValue { - $_[1]; + $_[1]; } sub inflator { undef }
--- a/Lib/IMPL/DOM/Schema/Property.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/Property.pm Tue Apr 10 20:08:29 2012 +0400 @@ -42,10 +42,10 @@ my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => eval { $node->$prop() } || $node->nodeProperty($prop)); if ($nodeProp->nodeValue) { - # we have a value so validate it - return $this->SUPER::Validate($nodeProp,$ctx); + # we have a value so validate it + return $this->SUPER::Validate($nodeProp,$ctx); } elsif($this->minOccur) { - # we don't have a value but it's a mandatory property + # we don't have a value but it's a mandatory property return new IMPL::DOM::Schema::ValidationError( Message => $this->messageRequired, Node => $node,
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,26 +8,26 @@ use IMPL::DOM::Property qw(_dom); BEGIN { - public _dom _direct property inflator => prop_get; - public _dom _direct property messageInflateError => prop_get; + public _dom _direct property inflator => prop_get; + public _dom _direct property messageInflateError => prop_get; } our %CTOR = ( 'IMPL::DOM::Schema::Node' => sub { - my %args = @_; - $args{nodeName} ||= 'SimpleNode'; - delete @args{qw(inflator messageInflateError)}; - %args + my %args = @_; + $args{nodeName} ||= 'SimpleNode'; + delete @args{qw(inflator messageInflateError)}; + %args } ); sub CTOR { - my ($this,%args) = @_; - - if ( $args{inflator} ) { - $this->{$inflator} = $args{inflator} ; - $this->{$messageInflateError} = exists $args{messageInflateError} ? $args{messageInflateError} : 'Failed to inflate nodeValue %Node.path%: %Error%'; - } + my ($this,%args) = @_; + + if ( $args{inflator} ) { + $this->{$inflator} = $args{inflator} ; + $this->{$messageInflateError} = exists $args{messageInflateError} ? $args{messageInflateError} : 'Failed to inflate nodeValue %Node.path%: %Error%'; + } } sub Validate { @@ -41,13 +41,13 @@ } sub inflateValue { - my ($this,$value) = @_; - - if ( my $inflator = $this->inflator ) { - return $inflator->new($value); - } else { - return $value; - } + my ($this,$value) = @_; + + if ( my $inflator = $this->inflator ) { + return $inflator->new($value); + } else { + return $value; + } } 1;
--- a/Lib/IMPL/DOM/Schema/SimpleType.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleType.pm Tue Apr 10 20:08:29 2012 +0400 @@ -32,21 +32,21 @@ } sub Validate { - my ($this, $node, $ctx) = @_; - - if ($this->{$nativeType}) { - return new IMPL::DOM::Schema::ValidationError( - Node => $node, - Source => $ctx && $ctx->{Source} || $this, - Schema => $this, - Message => $this->messageWrongType - ) unless $node->isa($this->{$nativeType}); - } - return $this->SUPER::Validate($node,$ctx); + my ($this, $node, $ctx) = @_; + + if ($this->{$nativeType}) { + return new IMPL::DOM::Schema::ValidationError( + Node => $node, + Source => $ctx && $ctx->{Source} || $this, + Schema => $this, + Message => $this->messageWrongType + ) unless $node->isa($this->{$nativeType}); + } + return $this->SUPER::Validate($node,$ctx); } sub qname { - $_[0]->nodeName.'[type='.$_[0]->type.']'; + $_[0]->nodeName.'[type='.$_[0]->type.']'; } 1;
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Tue Apr 10 20:08:29 2012 +0400 @@ -26,18 +26,18 @@ $this->{$Schema} = $args{Schema} if $args{Schema}; $this->{$Source} = $args{Source} if $args{Source}; if ($args{Parent}) { - $this->{$Parent} = $args{Parent}; + $this->{$Parent} = $args{Parent}; } elsif ($args{Node}) { - $this->{$Parent} = $args{Node}->parentNode; + $this->{$Parent} = $args{Node}->parentNode; } else { - die new IMPL::InvalidArgumentException("A 'Parent' or a 'Node' parameter is required"); + die new IMPL::InvalidArgumentException("A 'Parent' or a 'Node' parameter is required"); } $this->{$Message} = FormatMessage(delete $args{Message}, \%args) if $args{Message}; } sub toString { - (my $this) = @_; - return $this->Message; + (my $this) = @_; + return $this->Message; } 1;
--- a/Lib/IMPL/DOM/Schema/Validator.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/Validator.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,9 +7,9 @@ __PACKAGE__->PassThroughArgs; sub Validate { - my ($this,$node) = @_; - - die new IMPL::NotImplementedException(); + my ($this,$node) = @_; + + die new IMPL::NotImplementedException(); } 1;
--- a/Lib/IMPL/DOM/Schema/Validator/Compare.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/Validator/Compare.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,202 +7,202 @@ use IMPL::Class::Property; BEGIN { - public property targetProperty => prop_all; - public property op => prop_all; - public property nodePath => prop_all; - public property optional => prop_all; - private property _pathTranslated => prop_all; - private property _targetNode => prop_all; - public property message => prop_all; + public property targetProperty => prop_all; + public property op => prop_all; + public property nodePath => prop_all; + public property optional => prop_all; + private property _pathTranslated => prop_all; + private property _targetNode => prop_all; + public property message => prop_all; } our %CTOR = ( - 'IMPL::DOM::Schema::Validator' => sub { - my %args = @_; - $args{nodeName} ||= 'Compare'; - delete @args{qw(targetProperty op nodePath optional message)}; - %args; - } + 'IMPL::DOM::Schema::Validator' => sub { + my %args = @_; + $args{nodeName} ||= 'Compare'; + delete @args{qw(targetProperty op nodePath optional message)}; + %args; + } ); our %Ops = ( - '=' => \&_equals, - 'eq' => \&_equalsString, - '!=' => \&_notEquals, - 'ne' => \&_notEqualsString, - '=~' => \&_matchRx, - '!~' => \&_notMatchRx, - '<' => \&_less, - '>' => \&_greater, - 'lt' => \&_lessString, - 'gt' => \&_greaterString + '=' => \&_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% %Source.op% %Value% (%Source.nodePath%)' ); - $this->optional($args{optional}) if $args{optional}; + 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% %Source.op% %Value% (%Source.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*(=|!=|=~|!~)\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 - },\&_resovleProperty) - ) or return 0 foreach @parsedFilters; - - }; - } else { - die new IMPL::Exception("Invalid query syntax",$path,$chunk); - } - - push @selectQuery, $axis ? { $axis => $query } : $query; - - $i++; - } - - return \@selectQuery; + 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*(=|!=|=~|!~)\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 + },\&_resovleProperty) + ) or return 0 foreach @parsedFilters; + + }; + } 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; - - $this->_targetNode($node); - - my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath)); - - my ($foreignNode) = $node->selectNodes(@$query); - - my $Source = $ctx && $ctx->{Source} || $this->parentNode; - - 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, new IMPL::DOM::Schema::ValidationError( - Node => $node, - ForeignNode => $foreignNode, - Value => $value, - Source => $Source, - Schema => $this->parentNode, - Message => $this->message - ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value); - } elsif (not $this->optional) { - push @result, new IMPL::DOM::Schema::ValidationError( - Node => $node, - Value => '', - Source => $Source, - Schema => $this->parentNode, - Message => $this->message - ); - } - - $this->_targetNode(undef); - - return @result; + my ($this,$node,$ctx) = @_; + + my @result; + + $this->_targetNode($node); + + my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath)); + + my ($foreignNode) = $node->selectNodes(@$query); + + my $Source = $ctx && $ctx->{Source} || $this->parentNode; + + 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, new IMPL::DOM::Schema::ValidationError( + Node => $node, + ForeignNode => $foreignNode, + Value => $value, + Source => $Source, + Schema => $this->parentNode, + Message => $this->message + ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value); + } elsif (not $this->optional) { + push @result, new IMPL::DOM::Schema::ValidationError( + Node => $node, + Value => '', + Source => $Source, + Schema => $this->parentNode, + Message => $this->message + ); + } + + $this->_targetNode(undef); + + return @result; } sub _resovleProperty { - my ($node,$prop) = @_; - - return $node->can($prop) ? $node->$prop() : $node->nodeProperty($prop); + my ($node,$prop) = @_; + + return $node->can($prop) ? $node->$prop() : $node->nodeProperty($prop); } sub _matchRx { - $_[0] =~ $_[1]; + $_[0] =~ $_[1]; } sub _notMatchRx { - $_[0] !~ $_[1]; + $_[0] !~ $_[1]; } sub _equals { - $_[0] == $_[1]; + $_[0] == $_[1]; } sub _notEquals { - $_[0] != $_[0]; + $_[0] != $_[0]; } sub _equalsString { - $_[0] eq $_[1]; + $_[0] eq $_[1]; } sub _notEqualsString { - $_[0] ne $_[1]; + $_[0] ne $_[1]; } sub _less { - $_[0] < $_[1]; + $_[0] < $_[1]; } sub _greater { - $_[0] > $_[1]; + $_[0] > $_[1]; } sub _lessString { - $_[0] lt $_[1]; + $_[0] lt $_[1]; } sub _greaterString { - $_[0] gt $_[1]; + $_[0] gt $_[1]; } sub _lessEq { - $_[0] <= $_[1]; + $_[0] <= $_[1]; } sub _greaterEq { - $_[0] >= $_[1]; + $_[0] >= $_[1]; } 1; @@ -223,10 +223,10 @@ =begin code xml <schema> - <SimpleType type="retype_field"> - <Property name="linkedNode" message="Для узла %Node.nodeName% необходимо задать свойство %Source.name%"/> - <Compare op="eq" nodePath="sibling:*[nodeName eq '%Node.linkedNode%']"/> - </SimpleType> + <SimpleType type="retype_field"> + <Property name="linkedNode" message="Для узла %Node.nodeName% необходимо задать свойство %Source.name%"/> + <Compare op="eq" nodePath="sibling:*[nodeName eq '%Node.linkedNode%']"/> + </SimpleType> </schema> =begin code xml
--- a/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Tue Apr 10 20:08:29 2012 +0400 @@ -3,42 +3,42 @@ use parent qw(IMPL::DOM::Schema::Validator); our %CTOR = ( - 'IMPL::DOM::Schema::Validator' => sub { - my %args = @_; - $args{nodeName} ||= 'RegExp'; - %args; - } + 'IMPL::DOM::Schema::Validator' => sub { + my %args = @_; + $args{nodeName} ||= 'RegExp'; + %args; + } ); use IMPL::Class::Property; BEGIN { - public property message => prop_all; - public property launder => prop_all; - private property _rx => prop_all; + public property message => prop_all; + public property launder => prop_all; + private property _rx => prop_all; } sub CTOR { - my ($this,%args) = @_; - - $this->message($args{message} || "A %Node.nodeName% doesn't match to the format %Schema.display%"); + my ($this,%args) = @_; + + $this->message($args{message} || "A %Node.nodeName% doesn't match to the format %Schema.display%"); } sub Validate { - my ($this,$node,$ctx) = @_; - - my $rx = $this->_rx() || $this->_rx( map qr{$_}, $this->nodeValue ); - - return new IMPL::DOM::Schema::ValidationError( - Node => $node, - Source => $ctx && $ctx->{Source} || $this->parentNode, - Schema => $this->parentNode, - Message => $this->message - ) unless (not $node->isComplex) and $node->nodeValue =~ /($rx)/; - - $node->nodeValue($1) if $this->launder; - - return (); + my ($this,$node,$ctx) = @_; + + my $rx = $this->_rx() || $this->_rx( map qr{$_}, $this->nodeValue ); + + return new IMPL::DOM::Schema::ValidationError( + Node => $node, + Source => $ctx && $ctx->{Source} || $this->parentNode, + Schema => $this->parentNode, + Message => $this->message + ) unless (not $node->isComplex) and $node->nodeValue =~ /($rx)/; + + $node->nodeValue($1) if $this->launder; + + return (); } 1;
--- a/Lib/IMPL/DOM/Transform/PostToDOM.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/Transform/PostToDOM.pm Tue Apr 10 20:08:29 2012 +0400 @@ -18,7 +18,7 @@ our %CTOR = ( 'IMPL::Transform' => sub { - -plain => \&TransformPlain, + -plain => \&TransformPlain, HASH => \&TransformContainer, CGI => \&TransformCGI, CGIWrapper => \&TransformCGI @@ -26,17 +26,17 @@ ); 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; + 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 { @@ -45,59 +45,59 @@ my $navi = $this->_navi; foreach my $key ( - sort { $a->[1] cmp $b->[1] || $a->[2] <=> $b->[2]} - map [$_,/(\w+)(?:\[(\d+)\])?/], keys %$data + 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(); + 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) ); + my ($this,$data) = @_; + + $this->_navi->Current->nodeValue( $this->_navi->inflateValue($data) ); } sub TransformCGI { - my ($this,$query) = @_; + my ($this,$query) = @_; - my $data={}; - - my $prefix = $this->prefix; - - 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; + my $data={}; + + my $prefix = $this->prefix; + + 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; @@ -114,26 +114,26 @@ =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 - }) - ); + 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 @@ -152,7 +152,7 @@ =item 3 В случае когда узел может повторяться несколько раз, в квадратных скобках указывается послеовательный номер экземпляра. - + =item 4 Имена параметров объединяются через символ '/' =back
--- a/Lib/IMPL/DOM/XMLReader.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/DOM/XMLReader.pm Tue Apr 10 20:08:29 2012 +0400 @@ -69,31 +69,31 @@ } 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; - if ($schema) { - my @errors = $parser->Navigator->BuildErrors; - push @errors, $schema->Validate($doc); - die new IMPL::Exception("Loaded document doesn't match the schema", @errors) if @errors; - } - return $doc; + 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; + if ($schema) { + my @errors = $parser->Navigator->BuildErrors; + push @errors, $schema->Validate($doc); + die new IMPL::Exception("Loaded document doesn't match the schema", @errors) if @errors; + } + return $doc; } 1;
--- a/Lib/IMPL/Exception.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Exception.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,7 +7,7 @@ use Scalar::Util qw(refaddr); BEGIN { - require Error; + require Error; } use parent qw(IMPL::Object::Accessor Error); @@ -101,7 +101,7 @@ __PACKAGE__->PassThroughArgs; our %CTOR = ( - 'IMPL::Exception' => sub { "A specified element isn't found", $_[0] } + 'IMPL::Exception' => sub { "A specified element isn't found", $_[0] } ); package IMPL::NotImplementedException;
--- a/Lib/IMPL/ORM.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/ORM.pm Tue Apr 10 20:08:29 2012 +0400 @@ -50,15 +50,15 @@ my $foo = $ds->Insert( - My::Data::Foo->new( - 'foo class' - ) + My::Data::Foo->new( + 'foo class' + ) ); my $bar = $ds->Insert( - My::Data::Bar->new( - 'bar class' - ) + My::Data::Bar->new( + 'bar class' + ) ) $bar->fooObject($foo); @@ -66,13 +66,13 @@ $ds->Save($bar); my $fooOther = $ds->Retrieve( - 'My::Data::Bar', - { - name => 'bar class', - fooObject => { - name => 'some foo' - } - } + 'My::Data::Bar', + { + name => 'bar class', + fooObject => { + name => 'some foo' + } + } ) =end code
--- a/Lib/IMPL/ORM/Adapter/Generic.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/ORM/Adapter/Generic.pm Tue Apr 10 20:08:29 2012 +0400 @@ -76,16 +76,16 @@ =begin code { - version => 1, # object version - op => STORAGE_UPDATE, - data => { - entity1 => { - field1 => 'value 1' - }, - entity2 => { - field2 => 'value 2' - } - } + version => 1, # object version + op => STORAGE_UPDATE, + data => { + entity1 => { + field1 => 'value 1' + }, + entity2 => { + field2 => 'value 2' + } + } } =end code @@ -95,7 +95,7 @@ =begin code { - prop_name => [ entity => 'field' ] + prop_name => [ entity => 'field' ] } =end code
--- a/Lib/IMPL/Object/Abstract.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/Abstract.pm Tue Apr 10 20:08:29 2012 +0400 @@ -19,25 +19,25 @@ my $refCTORS = *{"${class}::CTOR"}{HASH}; foreach my $super ( @{"${class}::ISA"} ) { - my $superSequence = $cacheCTOR{$super} || cache_ctor($super); - - my $mapper = $refCTORS ? $refCTORS->{$super} : undef; - if (ref $mapper eq 'CODE') { - if ($mapper == *_pass_through_mapper{CODE}) { - push @sequence,@$superSequence; - } else { - push @sequence, sub { - my $this = shift; - $this->$_($mapper->(@_)) foreach @$superSequence; - } if @$superSequence; - } - } else { - warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; - push @sequence, sub { - my $this = shift; - $this->$_() foreach @$superSequence; - } if @$superSequence; - } + my $superSequence = $cacheCTOR{$super} || cache_ctor($super); + + my $mapper = $refCTORS ? $refCTORS->{$super} : undef; + if (ref $mapper eq 'CODE') { + if ($mapper == *_pass_through_mapper{CODE}) { + push @sequence,@$superSequence; + } else { + push @sequence, sub { + my $this = shift; + $this->$_($mapper->(@_)) foreach @$superSequence; + } if @$superSequence; + } + } else { + warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; + push @sequence, sub { + my $this = shift; + $this->$_() foreach @$superSequence; + } if @$superSequence; + } } push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; @@ -47,11 +47,11 @@ } sub dump_ctor { - my ($self) = @_; - $self = ref $self || $self; - - warn "dumping $self .ctor"; - warn "$_" foreach @{$cacheCTOR{$self}||[]}; + my ($self) = @_; + $self = ref $self || $self; + + warn "dumping $self .ctor"; + warn "$_" foreach @{$cacheCTOR{$self}||[]}; } sub callCTOR { @@ -68,7 +68,7 @@ } sub typeof { - ref $_[0] || $_[0]; + ref $_[0] || $_[0]; } sub isDisposed {
--- a/Lib/IMPL/Object/Accessor.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/Accessor.pm Tue Apr 10 20:08:29 2012 +0400 @@ -16,6 +16,6 @@ __PACKAGE__->static_accessor( propertyInfoClass => 'IMPL::Class::AccessorPropertyInfo' ); sub _PropertyImplementor { - 'IMPL::Class::Property::Accessor' + 'IMPL::Class::Property::Accessor' } 1;
--- a/Lib/IMPL/Object/Clonable.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/Clonable.pm Tue Apr 10 20:08:29 2012 +0400 @@ -4,7 +4,7 @@ use IMPL::lang qw(clone); sub Clone { - clone($_[0]); + clone($_[0]); } 1;
--- a/Lib/IMPL/Object/Factory.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/Factory.pm Tue Apr 10 20:08:29 2012 +0400 @@ -6,70 +6,70 @@ use IMPL::lang qw(:declare :constants); BEGIN { - public property factory => PROP_GET | PROP_OWNERSET; - public property parameters => PROP_GET | PROP_OWNERSET; - public property method => PROP_GET | PROP_OWNERSET; + public property factory => PROP_GET | PROP_OWNERSET; + public property parameters => PROP_GET | PROP_OWNERSET; + public property method => PROP_GET | PROP_OWNERSET; } # custom factory, overrides default sub new { - my $self = shift; - - return ref $self ? $self->CreateObject(@_) : $self->IMPL::Object::new(@_); + my $self = shift; + + return ref $self ? $self->CreateObject(@_) : $self->IMPL::Object::new(@_); } sub CTOR { - my ($this,$factory,$parameters,$method) = @_; - - $this->factory($factory) or die new IMPL::InvalidArgumentException("The argument 'factory' is mandatory"); - $this->parameters($parameters) if $parameters; - $this->method($method) if $method; + my ($this,$factory,$parameters,$method) = @_; + + $this->factory($factory) or die new IMPL::InvalidArgumentException("The argument 'factory' is mandatory"); + $this->parameters($parameters) if $parameters; + $this->method($method) if $method; } # override default restore method sub restore { - my ($class,$data,$surrogate) = @_; - - my %args = @$data; - - if ($surrogate) { - $surrogate->self::CTOR($args{factory},$args{parameters},$args{method}); - return $surrogate; - } else { - return $class->new($args{factory},$args{parameters},$args{method}); - } + my ($class,$data,$surrogate) = @_; + + my %args = @$data; + + if ($surrogate) { + $surrogate->self::CTOR($args{factory},$args{parameters},$args{method}); + return $surrogate; + } else { + return $class->new($args{factory},$args{parameters},$args{method}); + } } sub CreateObject { - my $this = shift; - - if (my $method = $this->method) { - $this->factory->$method($this->MergeParameters(@_)); - } else { - $this->factory->new($this->MergeParameters(@_)); - } + my $this = shift; + + if (my $method = $this->method) { + $this->factory->$method($this->MergeParameters(@_)); + } else { + $this->factory->new($this->MergeParameters(@_)); + } } sub MergeParameters { - my $this = shift; - - $this->parameters ? (_as_list($this->parameters),@_) : @_; + my $this = shift; + + $this->parameters ? (_as_list($this->parameters),@_) : @_; } sub _as_list { - ref $_[0] ? - (ref $_[0] eq 'HASH' ? - %{$_[0]} - : - (ref $_[0] eq 'ARRAY'? - @{$_[0]} - : - $_[0] - ) - ) - : - ($_[0]); + ref $_[0] ? + (ref $_[0] eq 'HASH' ? + %{$_[0]} + : + (ref $_[0] eq 'ARRAY'? + @{$_[0]} + : + $_[0] + ) + ) + : + ($_[0]); } @@ -84,10 +84,10 @@ =begin code my $factory = new IMPL::Object::Factory( - 'MyApp::User', - { - isAdmin => 1 - } + 'MyApp::User', + { + isAdmin => 1 + } ); my $class = 'MyApp::User'; @@ -96,7 +96,7 @@ $user = $class->new(name => 'nobody'); # will create object MyApp::User # and pass parameters (name=>'nobody') - + $user = $factory->new(name => 'root'); # will create object MyApp::User # and pass paremeters (isAdmin => 1, name => 'root') @@ -107,10 +107,10 @@ =begin code xml <factory type="IMPL::Object::Factory"> - <factory>MyApp::User</factory>, - <parameters type="HASH"> - <isAdmin>1</isAdmin> - </parameters> + <factory>MyApp::User</factory>, + <parameters type="HASH"> + <isAdmin>1</isAdmin> + </parameters> </factory> =end code xml @@ -191,11 +191,11 @@ =begin code sub new { - my ($this,@params) = @_; - - my $method = $this->method || 'new'; - - return $this->factory->$method(_as_list($this->parameters), @params); + my ($this,@params) = @_; + + my $method = $this->method || 'new'; + + return $this->factory->$method(_as_list($this->parameters), @params); } =end code
--- a/Lib/IMPL/Object/Fields.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/Fields.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,22 +5,22 @@ use parent qw(IMPL::Object::Abstract); sub new { - my $class = shift; - - $class = ref $class || $class; - - my $this = fields::new($class); - $this->callCTOR(@_); - - return $this; + my $class = shift; + + $class = ref $class || $class; + + my $this = fields::new($class); + $this->callCTOR(@_); + + return $this; } sub surrogate { - my $class = shift; - - $class = ref $class || $class; - - return fields::new($class); + my $class = shift; + + $class = ref $class || $class; + + return fields::new($class); } 1;
--- a/Lib/IMPL/Object/List.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/List.pm Tue Apr 10 20:08:29 2012 +0400 @@ -43,7 +43,7 @@ } sub Item { - return $_[0]->[$_[1]]; + return $_[0]->[$_[1]]; } sub InsertAt { @@ -77,41 +77,41 @@ } sub FindItem { - my ($this,$item) = @_; - - for (my $i = 0; $i < @$this; $i++ ) { - return $i if $this->[$i] == $item - } - return undef; + my ($this,$item) = @_; + + for (my $i = 0; $i < @$this; $i++ ) { + return $i if $this->[$i] == $item + } + return undef; } sub FindItemStr { - my ($this,$item) = @_; - - for (my $i = 0; $i < @$this; $i++ ) { - return $i if $this->[$i] eq $item - } - return undef; + my ($this,$item) = @_; + + for (my $i = 0; $i < @$this; $i++ ) { + return $i if $this->[$i] eq $item + } + return undef; } sub save { - my ($this,$ctx) = @_; - - $ctx->AddVar( item => $_ ) foreach @$this; + my ($this,$ctx) = @_; + + $ctx->AddVar( item => $_ ) foreach @$this; } sub restore { - my ($class,$data,$surrogate) = @_; - - my $i = 0; - - if ($surrogate) { - @$surrogate = grep { ($i++)%2 } @$data; - } else { - $surrogate = $class->new([grep { ($i++)%2 } @$data]); - } - - return $surrogate; + my ($class,$data,$surrogate) = @_; + + my $i = 0; + + if ($surrogate) { + @$surrogate = grep { ($i++)%2 } @$data; + } else { + $surrogate = $class->new([grep { ($i++)%2 } @$data]); + } + + return $surrogate; } 1;
--- a/Lib/IMPL/Object/PublicSerializable.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/PublicSerializable.pm Tue Apr 10 20:08:29 2012 +0400 @@ -15,23 +15,23 @@ } sub save { - my ($this,$ctx) = @_; - - my %seen; - - my $val; - - defined($val = $this->$_()) and $ctx->AddVar($_,$val) foreach - map $_->Name,$this->get_meta( - 'IMPL::Class::PropertyInfo', - sub { - $_->Access == IMPL::Class::Member::MOD_PUBLIC and - $_->canGet and - not $_->ownerSet and - not $seen{$_->Name} ++ - }, - 1 - ); + my ($this,$ctx) = @_; + + my %seen; + + my $val; + + defined($val = $this->$_()) and $ctx->AddVar($_,$val) foreach + map $_->Name,$this->get_meta( + 'IMPL::Class::PropertyInfo', + sub { + $_->Access == IMPL::Class::Member::MOD_PUBLIC and + $_->canGet and + not $_->ownerSet and + not $seen{$_->Name} ++ + }, + 1 + ); } 1;
--- a/Lib/IMPL/Object/Singleton.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Object/Singleton.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,8 +5,8 @@ my %instances; sub CTOR { - die new IMPL::InvalidOperationException("Only one instance of the singleton can be created",ref $_[0], $instances{ref $_[0]}) if $instances{ref $_[0]}; - $instances{ref $_[0]} = $_[0]; + die new IMPL::InvalidOperationException("Only one instance of the singleton can be created",ref $_[0], $instances{ref $_[0]}) if $instances{ref $_[0]}; + $instances{ref $_[0]} = $_[0]; } sub instance {
--- a/Lib/IMPL/Profiler.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Profiler.pm Tue Apr 10 20:08:29 2012 +0400 @@ -19,45 +19,45 @@ warn "profiler enabled"; unshift @INC, sub { - my ($self,$filename) = @_; - - (my $module = $filename) =~ s/\//::/g; - $module =~ s/\.\w+$//; - - return unless $module =~ $Filter; - - foreach my $dir (@INC) { - my $fullName = "$dir/$filename"; - if (-f $fullName) { - open my $hmod, $fullName or die "$fullName: $!" if $!; + my ($self,$filename) = @_; + + (my $module = $filename) =~ s/\//::/g; + $module =~ s/\.\w+$//; + + return unless $module =~ $Filter; + + foreach my $dir (@INC) { + my $fullName = "$dir/$filename"; + if (-f $fullName) { + open my $hmod, $fullName or die "$fullName: $!" if $!; - + - my @source; - local $/ = "\n"; - while (my $line = <$hmod>) { - last if $line =~ /^\s*__END__/; - push @source, $line; - } - - undef $hmod; - - push @source, - "IMPL::Profiler::trap_all(__PACKAGE__);\n", - "1;\n"; - - - return (sub { - if (@source) { - $_ = shift @source; - return 1; - } else { - return 0; - } - }, undef ); - } - } - }; + my @source; + local $/ = "\n"; + while (my $line = <$hmod>) { + last if $line =~ /^\s*__END__/; + push @source, $line; + } + + undef $hmod; + + push @source, + "IMPL::Profiler::trap_all(__PACKAGE__);\n", + "1;\n"; + + + return (sub { + if (@source) { + $_ = shift @source; + return 1; + } else { + return 0; + } + }, undef ); + } + } + }; no warnings 'once'; *CORE::GLOBAL::caller = sub { @@ -113,43 +113,43 @@ return; } { - package IMPL::Profiler::Proxy; - no warnings 'redefine'; - my $sub = sub { - my $t0 = [Time::HiRes::gettimeofday]; - my @arr; - my $scalar; - my $entry = $prevCode; - my ($timeOwn,$timeTotal); - my $context = wantarray; - { - local $InvokeTime = 0; - #warn "\t"x$level,"enter ${class}::$method"; - $level ++; - if ($context) { - @arr = &$entry(@_); - } else { - if (defined $context) { - $scalar = &$entry(@_); - } else { - &$entry(@_); - } - } - $timeTotal = Time::HiRes::tv_interval($t0); - $timeOwn = $timeTotal - $InvokeTime; - } - $InvokeInfo{"${class}::${method}"}{Count} ++; - $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; - $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; - $InvokeTime += $timeTotal; - $level --; - #warn "\t"x$level,"leave ${class}::$method"; - return $context ? @arr : $scalar; - }; - if ($proto) { - Scalar::Util::set_prototype($sub => $proto); - } - *{"${class}::${method}"} = $sub; + package IMPL::Profiler::Proxy; + no warnings 'redefine'; + my $sub = sub { + my $t0 = [Time::HiRes::gettimeofday]; + my @arr; + my $scalar; + my $entry = $prevCode; + my ($timeOwn,$timeTotal); + my $context = wantarray; + { + local $InvokeTime = 0; + #warn "\t"x$level,"enter ${class}::$method"; + $level ++; + if ($context) { + @arr = &$entry(@_); + } else { + if (defined $context) { + $scalar = &$entry(@_); + } else { + &$entry(@_); + } + } + $timeTotal = Time::HiRes::tv_interval($t0); + $timeOwn = $timeTotal - $InvokeTime; + } + $InvokeInfo{"${class}::${method}"}{Count} ++; + $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; + $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; + $InvokeTime += $timeTotal; + $level --; + #warn "\t"x$level,"leave ${class}::$method"; + return $context ? @arr : $scalar; + }; + if ($proto) { + Scalar::Util::set_prototype($sub => $proto); + } + *{"${class}::${method}"} = $sub; } }
--- a/Lib/IMPL/Profiler/Memory.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Profiler/Memory.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,47 +8,47 @@ my $trapped; BEGIN { - $trapped = 0; + $trapped = 0; } sub import { - if (not $trapped) { - *CORE::GLOBAL::bless = sub { - $_[1] |= caller unless $_[1]; - my $ref = CORE::bless $_[0],$_[1]; - - $_->track($ref) foreach values %listeners; - - return $ref; - }; - $trapped = 1; - } + if (not $trapped) { + *CORE::GLOBAL::bless = sub { + $_[1] |= caller unless $_[1]; + my $ref = CORE::bless $_[0],$_[1]; + + $_->track($ref) foreach values %listeners; + + return $ref; + }; + $trapped = 1; + } } sub _ConnectListener { - my ($self,$listener) = @_; - - die "Invalid listener" unless ref $listener; - - $listeners{refaddr($listener)} = $listener; + my ($self,$listener) = @_; + + die "Invalid listener" unless ref $listener; + + $listeners{refaddr($listener)} = $listener; } sub _RemoveListener { - my ($self,$listener) = @_; - - die "Invalid listener" unless ref $listener; - - delete $listeners{refaddr($listener)}; + my ($self,$listener) = @_; + + die "Invalid listener" unless ref $listener; + + delete $listeners{refaddr($listener)}; } sub Monitor { - my ($self,$code) = @_; - - my $data = IMPL::Profiler::Memory::Data->new(); - - $data->Monitor($code); - - return $data; + my ($self,$code) = @_; + + my $data = IMPL::Profiler::Memory::Data->new(); + + $data->Monitor($code); + + return $data; } package IMPL::Profiler::Memory::Data; @@ -60,50 +60,50 @@ use fields qw( objects counter); sub CTOR { - my $this = shift; - $this->{objects} = []; - $this->{counter} = 0; + my $this = shift; + $this->{objects} = []; + $this->{counter} = 0; } sub track { - my $i = scalar @{$_[0]->{objects}}; - $_[0]->{objects}[$i] = $_[1]; - weaken($_[0]->{objects}[$i]); - $_[0]->{counter} ++; + my $i = scalar @{$_[0]->{objects}}; + $_[0]->{objects}[$i] = $_[1]; + weaken($_[0]->{objects}[$i]); + $_[0]->{counter} ++; } sub Purge { - my $this = shift; - - return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; + my $this = shift; + + return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; } sub Dump { - my $this = shift; - return Data::Dumper->Dump([$this->{objects}]); + my $this = shift; + return Data::Dumper->Dump([$this->{objects}]); } sub isLeak { - my ($this) = @_; - $this->Purge(); - return ( scalar(@{$this->{objects}}) > 0); + my ($this) = @_; + $this->Purge(); + return ( scalar(@{$this->{objects}}) > 0); } sub Monitor { - my ($this,$code) = @_; - - die "A reference to a subroutine is required" unless ref $code; - - IMPL::Profiler::Memory->_ConnectListener($this); - eval { - $code->(); - }; - my $err = $@; - IMPL::Profiler::Memory->_RemoveListener($this); - - die $err if $err; - - return; + my ($this,$code) = @_; + + die "A reference to a subroutine is required" unless ref $code; + + IMPL::Profiler::Memory->_ConnectListener($this); + eval { + $code->(); + }; + my $err = $@; + IMPL::Profiler::Memory->_RemoveListener($this); + + die $err if $err; + + return; }
--- a/Lib/IMPL/Resources/Format.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Resources/Format.pm Tue Apr 10 20:08:29 2012 +0400 @@ -21,7 +21,7 @@ my ($obj,$path,$default,$resolver) = @_; foreach my $chunk (split /\./,$path) { - return $default unless $obj; + return $default unless $obj; if (ref $obj eq 'HASH') { $obj = $obj->{$chunk}; } else { @@ -32,9 +32,9 @@ } sub _defaultResolver { - my ($obj,$prop) = @_; - - return ( eval { $obj->can($prop) } ? $obj->$prop() : undef ); + my ($obj,$prop) = @_; + + return ( eval { $obj->can($prop) } ? $obj->$prop() : undef ); } 1;
--- a/Lib/IMPL/SQL/Schema.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema.pm Tue Apr 10 20:08:29 2012 +0400 @@ -6,10 +6,10 @@ use IMPL::lang qw(is :declare :constants); use parent qw( - IMPL::Object - IMPL::Object::Disposable - IMPL::Object::Autofill - IMPL::Object::Clonable + IMPL::Object + IMPL::Object::Disposable + IMPL::Object::Autofill + IMPL::Object::Clonable ); use IMPL::Class::Property::Direct; @@ -33,9 +33,9 @@ not exists $this->{$tables}->{$table->name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); } elsif (UNIVERSAL::isa($table,'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 }; + + 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 = new IMPL::SQL::Schema::Table(%{$table}); } else { @@ -62,31 +62,31 @@ } sub ResolveTable { - my ($this,$table) = @_; - - UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table : $this->{$tables}{$table}; + my ($this,$table) = @_; + + UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table : $this->{$tables}{$table}; } sub GetTable { - my ($this,$tableName) = @_; - return $this->{$tables}{$tableName}; + my ($this,$tableName) = @_; + return $this->{$tables}{$tableName}; } sub GetTables { - my ($this) = @_; - - return wantarray ? values %{$this->{$tables}} : [values %{$this->{$tables}}]; + 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; + 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 {
--- a/Lib/IMPL/SQL/Schema/Column.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Column.pm Tue Apr 10 20:08:29 2012 +0400 @@ -20,51 +20,51 @@ my $this = shift; $this->{$name} or - die new IMPL::InvalidArgumentException('A column name is required'); + die new IMPL::InvalidArgumentException('A column name is required'); $this->{$isNullable} = 0 if not exists $this->{$isNullable}; is( $this->{$type}, typeof IMPL::SQL::Schema::Type) or - die new IMPL::InvalidArgumentException('a type is required for the column',$this->{$name}); + 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}) + $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; + my ($this,$newType) = @_; + + $this->{$type} = $newType; } sub SetDefaultValue { - my ($this,$value) = @_; - - $this->{$defaultValue} = $value; + my ($this,$value) = @_; + + $this->{$defaultValue} = $value; } sub SetNullable { - my ($this, $value) = @_; - - $this->{$isNullable} = $value; + 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); + my ($this,$diff) = @_; + + return unless ref $diff eq 'HASH'; + + $this->tag({}) unless $this->tag; + + hashApply($this->tag,$diff); } 1;
--- a/Lib/IMPL/SQL/Schema/Constraint.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint.pm Tue Apr 10 20:08:29 2012 +0400 @@ -20,7 +20,7 @@ sub CTOR { my ($this,%args) = @_; is( $args{table}, typeof IMPL::SQL::Schema::Table ) or - die new IMPL::InvalidArgumentException("table argument must be a table object"); + 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'}}] ); @@ -60,27 +60,27 @@ } 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; + 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 is($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; + my ($self,$alias) = @_; + + return is($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; } sub RegisterAlias { - my ($self,$alias) = @_; - - $aliases{$alias} = $self->typeof; + my ($self,$alias) = @_; + + $aliases{$alias} = $self->typeof; } 1;
--- a/Lib/IMPL/SQL/Schema/Table.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Table.pm Tue Apr 10 20:08:29 2012 +0400 @@ -4,8 +4,8 @@ use IMPL::lang qw(:declare :constants is); use parent qw( - IMPL::Object - IMPL::Object::Disposable + IMPL::Object + IMPL::Object::Disposable ); require IMPL::SQL::Schema::Column; @@ -32,15 +32,15 @@ $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}}; + 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}}; } if ($args{constraints}) { - die new IMPL::InvalidOperationException('A constraints property should be a reference to an array') unless ref $args{constraints} eq 'ARRAY'; - - $this->AddConstraint($_) foreach @{$args{constraints}}; + die new IMPL::InvalidOperationException('A constraints property should be a reference to an array') unless ref $args{constraints} eq 'ARRAY'; + + $this->AddConstraint($_) foreach @{$args{constraints}}; } } @@ -110,47 +110,47 @@ my ($this,$index) = @_; die new IMPL::InvalidArgumentException("The index is out of range") - if $index < 0 || $index >= ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0); + if $index < 0 || $index >= ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0); return $this->{$columns}[$index]; } sub ColumnsCount { - my ($this) = @_; - - return scalar(@{$this->{$columns}}); + my ($this) = @_; + + return scalar(@{$this->{$columns}}); } sub AddConstraint { - my $this = shift; + my $this = shift; if (@_ == 1) { - my ($Constraint) = @_; - - die new IMPL::InvalidArgumentException('The invalid parameter') if not is($Constraint,typeof 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; - } + my ($Constraint) = @_; + + die new IMPL::InvalidArgumentException('The invalid parameter') if not is($Constraint,typeof 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->{table} = $this; - - $this->AddConstraint($type->new(%$params)); + my ($type,$params) = @_; + + $type = IMPL::SQL::Schema::Constraint->ResolveAlias($type) or + die new IMPL::Exception("Can't resolve a constraint alias",$_[0]); + + $params->{table} = $this; + + $this->AddConstraint($type->new(%$params)); } else { - die new IMPL::Exception("Wrong arguments number",scalar(@_)); + die new IMPL::Exception("Wrong arguments number",scalar(@_)); } } @@ -171,15 +171,15 @@ } sub GetConstraint { - my ($this,$name) = @_; - - return $this->{$constraints}{$name}; + my ($this,$name) = @_; + + return $this->{$constraints}{$name}; } sub GetConstraints { - my ($this) = @_; - - return wantarray ? values %{$this->{$constraints}} : [values %{$this->{$constraints}}]; + my ($this) = @_; + + return wantarray ? values %{$this->{$constraints}} : [values %{$this->{$constraints}}]; } sub GetColumnConstraints { @@ -214,28 +214,28 @@ } 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; + 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;
--- a/Lib/IMPL/SQL/Schema/Traits.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits.pm Tue Apr 10 20:08:29 2012 +0400 @@ -4,7 +4,6 @@ use IMPL::Exception(); use parent qw(IMPL::Object); -use IMPL::Code::Loader(); # required for use with typeof operator use IMPL::SQL::Schema::Constraint::PrimaryKey(); @@ -18,19 +17,19 @@ use base qw(IMPL::Object::Fields); use fields qw( - name - columns - constraints - options + 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; + 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; } ################################################### @@ -39,21 +38,21 @@ use base qw(IMPL::Object::Fields); use fields qw( - name - type - isNullable - defaultValue - tag + 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}; + 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}; } ################################################## @@ -62,19 +61,19 @@ use base qw(IMPL::Object::Fields); use fields qw( - name - columns + name + columns ); sub CTOR { - my ($this, $name, $columns) = @_; - - $this->{name} = $name; - $this->{columns} = $columns; # list of columnNames + my ($this, $name, $columns) = @_; + + $this->{name} = $name; + $this->{columns} = $columns; # list of columnNames } sub constraintClass { - die new IMPL::NotImplementedException(); + die new IMPL::NotImplementedException(); } ################################################## @@ -113,21 +112,21 @@ use base qw(IMPL::SQL::Schema::Traits::Constraint); use fields qw( - foreignTable - foreignColumns + foreignTable + foreignColumns ); use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::ForeignKey }; our %CTOR = ( - 'IMPL::SQL::Schema::Traits::Constraint' => sub { @_[0..1] } + 'IMPL::SQL::Schema::Traits::Constraint' => sub { @_[0..1] } ); sub CTOR { - my ($this,$foreignTable,$foreignColumns) = @_[0,3,4]; - - $this->{foreignTable} = $foreignTable; - $this->{foreignColunms} = $foreignColumns; + my ($this,$foreignTable,$foreignColumns) = @_[0,3,4]; + + $this->{foreignTable} = $foreignTable; + $this->{foreignColunms} = $foreignColumns; } @@ -140,25 +139,25 @@ use IMPL::lang; BEGIN { - public property table => prop_get | owner_set; + public property table => prop_get | owner_set; } sub CTOR { - my ($this,$table) = @_; - - die new IMPL::InvalidArgumentException("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") - unless is $table, typeof IMPL::SQL::Schema::Traits::Table; - - $this->table($table); + my ($this,$table) = @_; + + die new IMPL::InvalidArgumentException("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") + unless is $table, typeof IMPL::SQL::Schema::Traits::Table; + + $this->table($table); } sub apply { - my ($this,$schema) = @_; - - return 0 if ( $schema->GetTable( $this->table->{name} ) ); - - $schema->AddTable($this->table); - return 1; + my ($this,$schema) = @_; + + return 0 if ( $schema->GetTable( $this->table->{name} ) ); + + $schema->AddTable($this->table); + return 1; } ################################################## @@ -168,23 +167,23 @@ use IMPL::Class::Property; BEGIN { - public property tableName => prop_get | owner_set; + public property tableName => prop_get | owner_set; } sub CTOR { - my ($this,$tableName) = @_; - - $this->tableName($tableName) or die new IMPL::InvalidArgumentException("tableName is required"); + my ($this,$tableName) = @_; + + $this->tableName($tableName) or die new IMPL::InvalidArgumentException("tableName is required"); } sub apply { - my ($this,$schema) = @_; - - return 0 if $schema->GetTable( $this->tableName ); - - $schema->RemoveTable($this->tableName); - - return 1; + my ($this,$schema) = @_; + + return 0 if $schema->GetTable( $this->tableName ); + + $schema->RemoveTable($this->tableName); + + return 1; } ################################################## @@ -194,25 +193,25 @@ use IMPL::Class::Property; BEGIN { - public property tableName => prop_get | owner_set; - public property tableNewName => prop_get | owner_set; + public property tableName => prop_get | owner_set; + public property tableNewName => prop_get | owner_set; } sub CTOR { - my ($this, $oldName, $newName) = @_; - - $this->tableName($oldName) or die new IMPL::InvalidArgumentException("A table name is required"); - $this->tableNewName($newName) or die new IMPL::InvalidArgumentException("A new table name is required"); + my ($this, $oldName, $newName) = @_; + + $this->tableName($oldName) or die new IMPL::InvalidArgumentException("A table name is required"); + $this->tableNewName($newName) or die new IMPL::InvalidArgumentException("A new table name is required"); } sub apply { - my ($this,$schema) = @_; - - return 0 if not $schema->GetTable($this->tableName) or $schema->GetTable($this->tableNewName); - - $this->RenameTable($this->tableName, $this->tableNewName); - - return 1; + my ($this,$schema) = @_; + + return 0 if not $schema->GetTable($this->tableName) or $schema->GetTable($this->tableNewName); + + $this->RenameTable($this->tableName, $this->tableNewName); + + return 1; } ################################################# @@ -223,31 +222,31 @@ use IMPL::lang; BEGIN { - public property tableName => prop_get | owner_set; - public property column => prop_get | owner_set; + public property tableName => prop_get | owner_set; + public property column => prop_get | owner_set; } sub CTOR { - my ($this,$tableName,$column) = @_; - - $this->tableName($tableName) or die new IMPL::InvalidArgumentException("A table name is required"); - - die new IMPL::InvalidArgumentException("A column should be a IMPL::SQL::Schema::Traits::Column object") - unless is $column, typeof IMPL::SQL::Schema::Traits::Column; - - $this->column($column); + my ($this,$tableName,$column) = @_; + + $this->tableName($tableName) or die new IMPL::InvalidArgumentException("A table name is required"); + + die new IMPL::InvalidArgumentException("A column should be a IMPL::SQL::Schema::Traits::Column object") + unless is $column, typeof IMPL::SQL::Schema::Traits::Column; + + $this->column($column); } sub apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) or return 0; - - return 0 if $table->GetColumn( $this->column->{name} ); - - $table->AddColumn($this->column); - - return 1; + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) or return 0; + + return 0 if $table->GetColumn( $this->column->{name} ); + + $table->AddColumn($this->column); + + return 1; } ################################################# @@ -257,26 +256,26 @@ use IMPL::Class::Property; BEGIN { - public property tableName => prop_get | owner_set; - public property columnName => prop_get | owner_set; + public property tableName => prop_get | owner_set; + public property columnName => prop_get | owner_set; } sub CTOR { - my ($this,$table,$column) = @_; - - $this->tableName($table) or die new IMPL::InvalidArgumentException(tableName => "A table name should be specified"); - $this->columnName($column) or die new IMPL::InvalidArgumentException(columnName => "A column name should be specified"); + my ($this,$table,$column) = @_; + + $this->tableName($table) or die new IMPL::InvalidArgumentException(tableName => "A table name should be specified"); + $this->columnName($column) or die new IMPL::InvalidArgumentException(columnName => "A column name should be specified"); } sub apply { - my ($this,$schema) = @_; - - local $@; - - return eval { - $schema->GetTable($this->tableName)->RemoveColumn($this->columnName); - return 1; - } || 0; + my ($this,$schema) = @_; + + local $@; + + return eval { + $schema->GetTable($this->tableName)->RemoveColumn($this->columnName); + return 1; + } || 0; } ################################################# @@ -286,38 +285,38 @@ use IMPL::Class::Property; BEGIN { - public property tableName => prop_get | owner_set; - public property columnName => prop_get | owner_set; - public property columnType => prop_all; - public property defaultValue => prop_all; - public property isNullable => prop_all; - public property options => prop_all; # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) + public property tableName => prop_get | owner_set; + public property columnName => prop_get | owner_set; + public property columnType => prop_all; + public property defaultValue => prop_all; + public property isNullable => prop_all; + public property options => prop_all; # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) } sub CTOR { - my ($this, $table,$column,%args) = @_; - - $this->tableName($table) or die new IMPL::InvalidArgumentException(tableName => "A table name is required"); - $this->columnName($column) or die new IMPL::InvalidArgumentException(columnName => "A column name is required"); - - $this->$_($args{$_}) - for (grep exists $args{$_}, qw(columnType defaultValue isNullable options)); + my ($this, $table,$column,%args) = @_; + + $this->tableName($table) or die new IMPL::InvalidArgumentException(tableName => "A table name is required"); + $this->columnName($column) or die new IMPL::InvalidArgumentException(columnName => "A column name is required"); + + $this->$_($args{$_}) + for (grep exists $args{$_}, qw(columnType defaultValue isNullable options)); } sub apply { - my ($this,$schema) = @_; - - local $@; - - return eval { - my $column = $schema->GetTable($this->tableName)->GetColumn($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; - - return 1; - } || 0; + my ($this,$schema) = @_; + + local $@; + + return eval { + my $column = $schema->GetTable($this->tableName)->GetColumn($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; + + return 1; + } || 0; } ################################################# @@ -328,31 +327,31 @@ use IMPL::lang; BEGIN { - public property tableName => prop_get | owner_set; - public property constraint => prop_get | owner_set; + public property tableName => prop_get | owner_set; + public property constraint => prop_get | owner_set; } sub CTOR { - my ($this,$table,$constraint) = @_; - - $this->tableName($table) or die new IMPL::InvalidArgumentException( tableName => "A table name is required"); - - die new IMPL::InvalidArgumentException(constaraint => "A valid IMPL::SQL::Schema::Traits::Constarint is required") - unless is $constraint, typeof IMPL::SQL::Schema::Traits::Constraint; - - $this->constraint($constraint); + my ($this,$table,$constraint) = @_; + + $this->tableName($table) or die new IMPL::InvalidArgumentException( tableName => "A table name is required"); + + die new IMPL::InvalidArgumentException(constaraint => "A valid IMPL::SQL::Schema::Traits::Constarint is required") + unless is $constraint, typeof IMPL::SQL::Schema::Traits::Constraint; + + $this->constraint($constraint); } sub apply { - my ($this,$schema) = @_; - - local $@; - - return eval { - $schema->GetTable($this->tableName)->AddConstraint($this->constraint->constraintClass, $this->constraint); - return 1; - } || 0; - + my ($this,$schema) = @_; + + local $@; + + return eval { + $schema->GetTable($this->tableName)->AddConstraint($this->constraint->constraintClass, $this->constraint); + return 1; + } || 0; + } ################################################# @@ -362,29 +361,29 @@ use IMPL::Class::Property; BEGIN { - public property tableName => prop_get | owner_set; - public property constraintName => prop_get | owner_set; + public property tableName => prop_get | owner_set; + public property constraintName => prop_get | owner_set; } 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); + 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 apply { - my ($this,$schema) = @_; - - my $table = $schema->GetTable($this->tableName) or return 0; - - return 0 unless $table->GetConstraint($this->constraintName); - - $table->RemoveConstraint($this->constraintName); - return 1; + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) or return 0; + + return 0 unless $table->GetConstraint($this->constraintName); + + $table->RemoveConstraint($this->constraintName); + return 1; }
--- a/Lib/IMPL/SQL/Schema/Traits/Diff.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits/Diff.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,159 +7,159 @@ use IMPL::SQL::Schema::Traits(); use constant { - schema_t => typeof IMPL::SQL::Schema # defining a constant is a good style to enable compile checks + schema_t => typeof IMPL::SQL::Schema # defining a constant is a good style to enable compile checks }; 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; + 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); + 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; + $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 - ); + 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 = { - typeof IMPL::SQL::Schema::Constraint::ForeignKey , typeof IMPL::SQL::Schema::Traits::ForeignKey, - typeof IMPL::SQL::Schema::Constraint::PrimaryKey , typeof IMPL::SQL::Schema::Traits::PrimaryKey, - typeof IMPL::SQL::Schema::Constraint::Unique , typeof IMPL::SQL::Schema::Traits::Unique, - typeof IMPL::SQL::Schema::Constraint::Index , typeof IMPL::SQL::Schema::Traits::Index - }; - - my $class = $map->{$constraint->typeof} or die new IMPL::Exception("Can't map the constraint",$constraint->typeof); - - return $class->new( - $constraint->name, - [ map $_->name, $constraint->columns ] - ) + my ($constraint) = @_; + + my $map = { + typeof IMPL::SQL::Schema::Constraint::ForeignKey , typeof IMPL::SQL::Schema::Traits::ForeignKey, + typeof IMPL::SQL::Schema::Constraint::PrimaryKey , typeof IMPL::SQL::Schema::Traits::PrimaryKey, + typeof IMPL::SQL::Schema::Constraint::Unique , typeof IMPL::SQL::Schema::Traits::Unique, + typeof IMPL::SQL::Schema::Constraint::Index , typeof IMPL::SQL::Schema::Traits::Index + }; + + my $class = $map->{$constraint->typeof} or die new IMPL::Exception("Can't map the constraint",$constraint->typeof); + + return $class->new( + $constraint->name, + [ map $_->name, $constraint->columns ] + ) } 1;
--- a/Lib/IMPL/SQL/Schema/Traits/Formatter.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits/Formatter.pm Tue Apr 10 20:08:29 2012 +0400 @@ -2,7 +2,7 @@ use parent qw(IMPL::Object); sub ToSQL { - my ($this,$sequence) = @_; + my ($this,$sequence) = @_; }
--- a/Lib/IMPL/SQL/Schema/Type.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/SQL/Schema/Type.pm Tue Apr 10 20:08:29 2012 +0400 @@ -29,9 +29,9 @@ my ($this,$other) = @_; return ( - $this->{$name} eq $other->name - and equals($this->{$maxLength},$other->{$maxLength}) - and equals($this->{$scale},$other->{$scale}) + $this->{$name} eq $other->name + and equals($this->{$maxLength},$other->{$maxLength}) + and equals($this->{$scale},$other->{$scale}) ); }
--- a/Lib/IMPL/Security.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Security.pm Tue Apr 10 20:08:29 2012 +0400 @@ -3,43 +3,43 @@ require IMPL::Security::Rule::RoleCheck; our @rules = ( - \&IMPL::Security::Rule::RoleCheck::SatisfyAll + \&IMPL::Security::Rule::RoleCheck::SatisfyAll ); our $authority = undef; sub AccessCheck { - my ($self, $object, $desiredAccess, $context) = @_; - - $context ||= IMPL::Security::Context->contextCurrent; - - $_->() or return 0 foreach @{$self->Rules}; - - return 1; + my ($self, $object, $desiredAccess, $context) = @_; + + $context ||= IMPL::Security::Context->contextCurrent; + + $_->() or return 0 foreach @{$self->Rules}; + + return 1; } sub Take { - my ($self,$principal,$refRoles) = @_; - - die new IMPL::NotImplementedException(); + my ($self,$principal,$refRoles) = @_; + + die new IMPL::NotImplementedException(); } sub MakeContext { - my ($this,$principal,$refRoles,$auth) = @_; - - return new IMPL::Security::Context( - principal => $principal, - rolesAssigned => $refRoles, - auth => $auth - ); + my ($this,$principal,$refRoles,$auth) = @_; + + return new IMPL::Security::Context( + principal => $principal, + rolesAssigned => $refRoles, + auth => $auth + ); } sub Rules { - return \@rules; + return \@rules; } sub authority { - return $authority; + return $authority; } 1; @@ -59,48 +59,48 @@ use IMPL::Security; my Method { - my $this = shift; - - # access check in the current context, using standard configuration - IMPL::Security->AccessCheck($this,'Method') or die new IMPL::AccessDeniedException("Access is denied"); - - #some more results + my $this = shift; + + # access check in the current context, using standard configuration + IMPL::Security->AccessCheck($this,'Method') or die new IMPL::AccessDeniedException("Access is denied"); + + #some more results } my DelegationMethod { - - my $this = shift; - - #forced delegation - my $delegatedContext = IMPL::Security::Context->new( - principal => IMPL::Security::Principal->new( - name => 'suser' - ), - rolesAssigned => ['administrator'] - ) - - my $result; - - $delegatedContext->Impersonate(sub{ - $result = $this->Method(); - }); - - return $result; + + my $this = shift; + + #forced delegation + my $delegatedContext = IMPL::Security::Context->new( + principal => IMPL::Security::Principal->new( + name => 'suser' + ), + rolesAssigned => ['administrator'] + ) + + my $result; + + $delegatedContext->Impersonate(sub{ + $result = $this->Method(); + }); + + return $result; } my SafeDelegationMethod { - - my $this = shift; - - my $delegatedContext = IMPL::Security->Take( suser => 'administrator' ); - - my $result; - - $delegatedContext->Impersonate(sub{ - $result = $this->Method(); - }); - - return $result; + + my $this = shift; + + my $delegatedContext = IMPL::Security->Take( suser => 'administrator' ); + + my $result; + + $delegatedContext->Impersonate(sub{ + $result = $this->Method(); + }); + + return $result; } =end code @@ -199,11 +199,11 @@ use parent qw(IMPL::Security); sub Rules { - return [ - \&Rule1, - \&Rule2, - #... - ] + return [ + \&Rule1, + \&Rule2, + #... + ] } =end code
--- a/Lib/IMPL/Security/Auth.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Security/Auth.pm Tue Apr 10 20:08:29 2012 +0400 @@ -3,9 +3,9 @@ use Digest::MD5 qw(md5_hex); use constant { - AUTH_SUCCESS => 1, - AUTH_INCOMPLETE => 2, - AUTH_FAIL => 3 + AUTH_SUCCESS => 1, + AUTH_INCOMPLETE => 2, + AUTH_FAIL => 3 }; use parent qw(Exporter); @@ -21,21 +21,21 @@ } sub DoAuth { - die new IMPL::NotImplementedException; + die new IMPL::NotImplementedException; } sub ValidateSession { - die new IMPL::NotImplementedException; + die new IMPL::NotImplementedException; } sub isTrusted { - 0; + 0; } sub Create { - my ($self,%args) = @_; - - return $self->new($self->CreateSecData(%args)); + my ($self,%args) = @_; + + return $self->new($self->CreateSecData(%args)); } 1;
--- a/Lib/IMPL/Security/Auth/Simple.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Security/Auth/Simple.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,68 +7,68 @@ use IMPL::Class::Property; use IMPL::Security::Auth qw(:Const); -BEGIN { - private property _passwordImage => prop_all; - private property _sessionCookie => prop_all; +BEGIN { + private property _passwordImage => prop_all; + private property _sessionCookie => prop_all; } sub CTOR { - my ($this,$secData) = @_; - - my ($passImg,$cookie) = split /\|/,$secData; - - $this->_passwordImage($passImg); - $this->_sessionCookie($cookie); + my ($this,$secData) = @_; + + my ($passImg,$cookie) = split /\|/,$secData; + + $this->_passwordImage($passImg); + $this->_sessionCookie($cookie); } sub secData { - my ($this) = @_; - - if ($this->_sessionCookie) { - return join ('|',$this->_passwordImage, $this->_sessionCookie ); - } else { - return $this->_passwordImage; - } + my ($this) = @_; + + if ($this->_sessionCookie) { + return join ('|',$this->_passwordImage, $this->_sessionCookie ); + } else { + return $this->_passwordImage; + } } sub isTrusted { - my ($this) = @_; - - $this->_sessionCookie ? 1 : 0; + my ($this) = @_; + + $this->_sessionCookie ? 1 : 0; } sub DoAuth { - my ($this,$challenge) = @_; + my ($this,$challenge) = @_; - if (Digest::MD5::md5_hex($challenge) eq $this->_passwordImage) { - return (AUTH_SUCCESS,$this->_sessionCookie($this->GenSSID)); - } elsee { - return (AUTH_FAIL,$this->_sessionCookie(undef)); - } + if (Digest::MD5::md5_hex($challenge) eq $this->_passwordImage) { + return (AUTH_SUCCESS,$this->_sessionCookie($this->GenSSID)); + } elsee { + return (AUTH_FAIL,$this->_sessionCookie(undef)); + } } sub ValidateSession { - my ($this,$cookie) = @_; - - die new IMPL::InvalidOperationException("The context is untrusted") unless $this->_sessionCookie; - - if ($cookie eq $this->_sessionCookie) { - return (AUTH_SUCCESS,undef); - } else { - return (AUTH_FAIL,undef); - } + my ($this,$cookie) = @_; + + die new IMPL::InvalidOperationException("The context is untrusted") unless $this->_sessionCookie; + + if ($cookie eq $this->_sessionCookie) { + return (AUTH_SUCCESS,undef); + } else { + return (AUTH_FAIL,undef); + } } sub CreateSecData { - my ($self,%args) = @_; - - die new IMPL::InvalidArgumentException("The parameter is required",'password') unless $args{password}; - - return Digest::MD5::md5_hex($args{password}); + my ($self,%args) = @_; + + die new IMPL::InvalidArgumentException("The parameter is required",'password') unless $args{password}; + + return Digest::MD5::md5_hex($args{password}); } sub SecDataArgs { - password => 'SCALAR' + password => 'SCALAR' } 1;
--- a/Lib/IMPL/Security/Context.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Security/Context.pm Tue Apr 10 20:08:29 2012 +0400 @@ -21,9 +21,9 @@ } sub CTOR { - my ($this) = @_; - - die new IMPL::InvalidArgumentException("The parameter is required", 'principal') unless $this->principal; + my ($this) = @_; + + die new IMPL::InvalidArgumentException("The parameter is required", 'principal') unless $this->principal; } sub Impersonate { @@ -35,11 +35,11 @@ my $e; { - local $@; - eval { - $result = $code->(); - }; - $e = $@; + local $@; + eval { + $result = $code->(); + }; + $e = $@; } $current = $old; if($e) { @@ -50,19 +50,19 @@ } sub Apply { - my ($this) = @_; - - $current = $this; + my ($this) = @_; + + $current = $this; } sub isTrusted { - my ($this) = @_; - - if (my $auth = $this->auth) { - return $auth->isTrusted; - } else { - return 0; - } + my ($this) = @_; + + if (my $auth = $this->auth) { + return $auth->isTrusted; + } else { + return 0; + } } sub nobody { @@ -72,18 +72,18 @@ } sub current { - my ($self) = @_; - - $current = __PACKAGE__->nobody unless $current; - $current; + my ($self) = @_; + + $current = __PACKAGE__->nobody unless $current; + $current; } sub Satisfy { - my ($this,@roles) = @_; - - my $roleEffective = new IMPL::Security::Role ( _effective => scalar $this->rolesAssigned ); - - return $roleEffective->Satisfy(@roles); + my ($this,@roles) = @_; + + my $roleEffective = new IMPL::Security::Role ( _effective => scalar $this->rolesAssigned ); + + return $roleEffective->Satisfy(@roles); } 1; @@ -103,9 +103,9 @@ my $context = IMPL::Security::Context->nobody; my $result = $context->Impersonate( - sub { - # do some untrusted code - } + sub { + # do some untrusted code + } ); =end code
--- a/Lib/IMPL/Security/Role.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Security/Role.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,32 +5,32 @@ use IMPL::Class::Property; BEGIN { - public property roleName => prop_get | owner_set; - public property parentRoles => prop_get | owner_set | prop_list; + public property roleName => prop_get | owner_set; + public property parentRoles => prop_get | owner_set | prop_list; } sub CTOR { - my ($this,$name,$parentRoles) = @_; - - $this->roleName($name) if $name; - $this->parentRoles($parentRoles) if $parentRoles; + my ($this,$name,$parentRoles) = @_; + + $this->roleName($name) if $name; + $this->parentRoles($parentRoles) if $parentRoles; } sub Satisfy { - my ($this,@roles) = @_; - - return 1 unless $this->_FilterRoles( @roles ); - return 0; + my ($this,@roles) = @_; + + return 1 unless $this->_FilterRoles( @roles ); + return 0; } sub _FilterRoles { - my ($this,@roles) = @_; - - @roles = grep not (ref $_ ? $this == $_ : $this->roleName eq $_), @roles; - - @roles = $_->_FilterRoles(@roles) or return foreach $this->parentRoles ; - - return @roles; + my ($this,@roles) = @_; + + @roles = grep not (ref $_ ? $this == $_ : $this->roleName eq $_), @roles; + + @roles = $_->_FilterRoles(@roles) or return foreach $this->parentRoles ; + + return @roles; }
--- a/Lib/IMPL/Security/Rule/RoleCheck.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Security/Rule/RoleCheck.pm Tue Apr 10 20:08:29 2012 +0400 @@ -3,14 +3,14 @@ require IMPL::Security::Role; sub SatisfyAll { - my ($secPackage,$object,$desiredAccess,$context) = @_; - - my $roleEffective = new IMPL::Security::Role ( _effective => $context->rolesAssigned ); - - return $roleEffective->Satisfy(ExtractRoles($object)); + my ($secPackage,$object,$desiredAccess,$context) = @_; + + my $roleEffective = new IMPL::Security::Role ( _effective => $context->rolesAssigned ); + + return $roleEffective->Satisfy(ExtractRoles($object)); } sub _ExtractRoles { - return (); + return (); }
--- a/Lib/IMPL/Serialization.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Serialization.pm Tue Apr 10 20:08:29 2012 +0400 @@ -223,10 +223,10 @@ 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->{$SurrogateHelper} ? $this->{$SurrogateHelper}->($rhProps->{'type'}) : DefaultSurrogateHelper($rhProps->{'type'}); - } + 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->{$SurrogateHelper} ? $this->{$SurrogateHelper}->($rhProps->{'type'}) : DefaultSurrogateHelper($rhProps->{'type'}); + } } return 1;
--- a/Lib/IMPL/Test.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Test.pm Tue Apr 10 20:08:29 2012 +0400 @@ -39,13 +39,13 @@ } sub assert { - my ($condition,@params) = @_; - - die new IMPL::Test::FailException(@params ? @params : ("Assertion failed" , _GetSourceLine( (caller)[1,2] )) ) unless $condition; + 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(@_); + die new IMPL::Test::SkipException(@_); } sub cmparray { @@ -61,29 +61,29 @@ } 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"; + 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] ) + 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; + my (@units) = @_; + + my $plan = new IMPL::Test::Plan(@units); + + $plan->Prepare; + $plan->AddListener(new IMPL::Test::TAPListener); + $plan->Run; } 1;
--- a/Lib/IMPL/Test/Plan.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Test/Plan.pm Tue Apr 10 20:08:29 2012 +0400 @@ -75,14 +75,14 @@ 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 - ); + 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}}; @@ -119,20 +119,20 @@ 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 + 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); @@ -141,15 +141,15 @@ } } else { my $e = $@; - my $badTest = new IMPL::Test::BadUnit( - $info->{Unit}->can('UnitName') ? - $info->{Unit}->UnitName : - $info->{Unit}, - "Failed to initialize the unit", - $@ - ); + 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,
--- a/Lib/IMPL/Test/Unit.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Test/Unit.pm Tue Apr 10 20:08:29 2012 +0400 @@ -111,17 +111,17 @@ } sub GetResourceFile { - my ($this,@path) = @_; - - my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); - return File::Spec->catfile($cwd,@path); + 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); + my ($this,@path) = @_; + + my ($cwd) = map m/(.*)/, File::Spec->rel2abs(File::Spec->curdir()); + return File::Spec->catdir($cwd,@path); } package IMPL::Test::Unit::TestInfo;
--- a/Lib/IMPL/Web/Application.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/Application.pm Tue Apr 10 20:08:29 2012 +0400 @@ -22,12 +22,12 @@ sub CTOR { - my ($this) = @_; - - $this->actionFactory(typeof IMPL::Web::Application::Action) unless $this->actionFactory; - $this->responseCharset('utf-8') unless $this->responseCharset; - $this->fetchRequestMethod(\&defaultFetchRequest) unless $this->fetchRequestMethod; - $this->handlerError(\&defaultHandlerError) unless $this->handlerError; + my ($this) = @_; + + $this->actionFactory(typeof IMPL::Web::Application::Action) unless $this->actionFactory; + $this->responseCharset('utf-8') unless $this->responseCharset; + $this->fetchRequestMethod(\&defaultFetchRequest) unless $this->fetchRequestMethod; + $this->handlerError(\&defaultHandlerError) unless $this->handlerError; } sub Run { @@ -36,61 +36,61 @@ while (my $query = $this->FetchRequest()) { my $action = $this->actionFactory->new( - query => $query, - application => $this, + query => $query, + application => $this, ); eval { - $action->response->charset($this->responseCharset); - - $action->ChainHandler($_) foreach $this->handlersQuery; - - $action->Invoke(); - - $action->response->Complete; + $action->response->charset($this->responseCharset); + + $action->ChainHandler($_) foreach $this->handlersQuery; + + $action->Invoke(); + + $action->response->Complete; }; if ($@) { - my $e = $@; - # we are expecting this method to be safe otherwise we can trust nothing in this wolrd - $this->handlerError()->($this,$action,$e); + my $e = $@; + # we are expecting this method to be safe otherwise we can trust nothing in this wolrd + $this->handlerError()->($this,$action,$e); } } } sub FetchRequest { - my ($this) = @_; - - if( ref $this->fetchRequestMethod eq 'CODE' ) { - return $this->fetchRequestMethod->($this); - } else { - die new IMPL::Exception("Unknown fetchRequestMethod type",ref $this->fetchRequestMethod); - } + my ($this) = @_; + + if( ref $this->fetchRequestMethod eq 'CODE' ) { + return $this->fetchRequestMethod->($this); + } else { + die new IMPL::Exception("Unknown fetchRequestMethod type",ref $this->fetchRequestMethod); + } } { - my $hasFetched = 0; + my $hasFetched = 0; - sub defaultFetchRequest { - my ($this) = @_; - return undef if $hasFetched; - $hasFetched = 1; - my $query = CGIWrapper->new(); - $query->charset($this->responseCharset); - return $query; - } + sub defaultFetchRequest { + my ($this) = @_; + return undef if $hasFetched; + $hasFetched = 1; + my $query = CGIWrapper->new(); + $query->charset($this->responseCharset); + return $query; + } } sub defaultHandlerError { - my ($this,$action,$e) = @_; - warn $e; - if ( eval { $action->ReinitResponse(); 1; } ) { - $action->response->contentType('text/plain'); - $action->response->charset($this->responseCharset); - $action->response->status(500); - my $hout = $action->response->streamBody; - print $hout $e; - $action->response->Complete(); - } + my ($this,$action,$e) = @_; + warn $e; + if ( eval { $action->ReinitResponse(); 1; } ) { + $action->response->contentType('text/plain'); + $action->response->charset($this->responseCharset); + $action->response->status(500); + my $hout = $action->response->streamBody; + print $hout $e; + $action->response->Complete(); + } } package CGIWrapper; @@ -101,33 +101,33 @@ 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); - } + 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; + 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; @@ -190,60 +190,60 @@ <?xml version="1.0" encoding="UTF-8"?> <Application id='app' type="Test::Web::Application::Instance"> - - <!-- Begin custom properties --> - <name>Sample application</name> - <dataSource type='IMPL::Config::Activator' id='ds'> - <factory>IMPL::Object</factory> - <parameters type='HASH'> - <db>data</db> - <user>nobody</user> - </parameters> - </dataSource> - <securityMod type='IMPL::Config::Activator'> - <factory>IMPL::Object</factory> - <parameters type='HASH'> - <ds refid='ds'/> - </parameters> - </securityMod> - <!-- End custom properties --> - - <!-- direct access to the activators --> - <options type="HASH"> - <dataSource refid='ds'/> - </options> - - <!-- Set default output encoding, can be changed due query handling --> - <responseCharset>utf-8</responseCharset> - - <!-- Actions creation configuration --> - <actionFactory type="IMPL::Object::Factory"> - - <!-- Construct actions --> - <factory>IMPL::Web::Application::Action</factory> - <parameters type='HASH'> - - <!-- with special responseFactory --> - <responseFactory type='IMPL::Object::Factory'> - - <!-- Where resopnses have a special streamOut --> - <factory>IMPL::Web::Application::Response</factory> - <parameters type='HASH'> - - <!-- in memory dummy output instead of STDOUT --> - <streamOut>memory</streamOut> - - </parameters> - </responseFactory> - </parameters> - </actionFactory> - - <!-- Query processing chain --> - <handlersQuery type="IMPL::Object::List"> - <item type="IMPL::Web::QueryHandler::PageFormat"> - <templatesCharset>cp1251</templatesCharset> - </item> - </handlersQuery> + + <!-- Begin custom properties --> + <name>Sample application</name> + <dataSource type='IMPL::Config::Activator' id='ds'> + <factory>IMPL::Object</factory> + <parameters type='HASH'> + <db>data</db> + <user>nobody</user> + </parameters> + </dataSource> + <securityMod type='IMPL::Config::Activator'> + <factory>IMPL::Object</factory> + <parameters type='HASH'> + <ds refid='ds'/> + </parameters> + </securityMod> + <!-- End custom properties --> + + <!-- direct access to the activators --> + <options type="HASH"> + <dataSource refid='ds'/> + </options> + + <!-- Set default output encoding, can be changed due query handling --> + <responseCharset>utf-8</responseCharset> + + <!-- Actions creation configuration --> + <actionFactory type="IMPL::Object::Factory"> + + <!-- Construct actions --> + <factory>IMPL::Web::Application::Action</factory> + <parameters type='HASH'> + + <!-- with special responseFactory --> + <responseFactory type='IMPL::Object::Factory'> + + <!-- Where resopnses have a special streamOut --> + <factory>IMPL::Web::Application::Response</factory> + <parameters type='HASH'> + + <!-- in memory dummy output instead of STDOUT --> + <streamOut>memory</streamOut> + + </parameters> + </responseFactory> + </parameters> + </actionFactory> + + <!-- Query processing chain --> + <handlersQuery type="IMPL::Object::List"> + <item type="IMPL::Web::QueryHandler::PageFormat"> + <templatesCharset>cp1251</templatesCharset> + </item> + </handlersQuery> </Application> =end code xml
--- a/Lib/IMPL/Web/Application/Action.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/Application/Action.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,108 +8,108 @@ use IMPL::Class::Property; BEGIN { - public property application => prop_get | owner_set; - public property query => prop_get | owner_set; - public property response => prop_get | owner_set; - public property responseFactory => prop_get | owner_set; - public property context => prop_get | owner_set; - private property _entryPoint => prop_all; + public property application => prop_get | owner_set; + public property query => prop_get | owner_set; + public property response => prop_get | owner_set; + public property responseFactory => prop_get | owner_set; + public property context => prop_get | owner_set; + private property _entryPoint => prop_all; } sub CTOR { - my ($this) = @_; - - $this->responseFactory('IMPL::Web::Application::Response') unless $this->responseFactory; - $this->response( $this->responseFactory->new(query => $this->query) ); - $this->context({}); + my ($this) = @_; + + $this->responseFactory('IMPL::Web::Application::Response') unless $this->responseFactory; + $this->response( $this->responseFactory->new(query => $this->query) ); + $this->context({}); } sub Invoke { - my ($this) = @_; - - if ($this->_entryPoint) { - $this->_entryPoint->(); - } else { - die new IMPL::InvalidOperationException("At least one handler is required"); - } + my ($this) = @_; + + if ($this->_entryPoint) { + $this->_entryPoint->(); + } else { + die new IMPL::InvalidOperationException("At least one handler is required"); + } } sub ReinitResponse { - my ($this) = @_; - - die new IMPL::InvalidOperationException("Response already sent") if $this->response->isHeaderPrinted; - - $this->response->Discard; - $this->response($this->responseFactory->new(query => $this->query)); + my ($this) = @_; + + die new IMPL::InvalidOperationException("Response already sent") if $this->response->isHeaderPrinted; + + $this->response->Discard; + $this->response($this->responseFactory->new(query => $this->query)); } sub ChainHandler { - my ($this,$handler) = @_; - - my $delegateNext = $this->_entryPoint(); - - if (ref $handler eq 'CODE') { - $this->_entryPoint( sub { - $handler->($this,$delegateNext); - } ); - } elsif (ref $handler and UNIVERSAL::isa($handler,'IMPL::Web::QueryHandler')) { - $this->_entryPoint( sub { - $handler->Invoke($this,$delegateNext); - } ); - } elsif ($handler and not ref $handler) { - - if (my $method = $this->can($handler) ) { - $this->_entryPoint( sub { - $method->($this,$delegateNext); - } ); - } else { - { - no strict 'refs'; - eval "require $handler; 1;" or die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler,"Failed to load module") unless keys %{"${handler}::"}; - } - - if (UNIVERSAL::isa($handler,'IMPL::Web::QueryHandler')) { - $this->_entryPoint( sub { - $handler->Invoke($this,$delegateNext); - } ); - } else { - die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); - } - } - } else { - die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); - } - + my ($this,$handler) = @_; + + my $delegateNext = $this->_entryPoint(); + + if (ref $handler eq 'CODE') { + $this->_entryPoint( sub { + $handler->($this,$delegateNext); + } ); + } elsif (ref $handler and UNIVERSAL::isa($handler,'IMPL::Web::QueryHandler')) { + $this->_entryPoint( sub { + $handler->Invoke($this,$delegateNext); + } ); + } elsif ($handler and not ref $handler) { + + if (my $method = $this->can($handler) ) { + $this->_entryPoint( sub { + $method->($this,$delegateNext); + } ); + } else { + { + no strict 'refs'; + eval "require $handler; 1;" or die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler,"Failed to load module") unless keys %{"${handler}::"}; + } + + if (UNIVERSAL::isa($handler,'IMPL::Web::QueryHandler')) { + $this->_entryPoint( sub { + $handler->Invoke($this,$delegateNext); + } ); + } else { + die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); + } + } + } else { + die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); + } + } sub cookie { - my ($this,$name,$rx) = @_; - - $this->_launder(scalar( $this->query->cookie($name) ), $rx ); + my ($this,$name,$rx) = @_; + + $this->_launder(scalar( $this->query->cookie($name) ), $rx ); } sub param { - my ($this,$name,$rx) = @_; - - $this->_launder(scalar( $this->query->param($name) ), $rx ); + my ($this,$name,$rx) = @_; + + $this->_launder(scalar( $this->query->param($name) ), $rx ); } sub _launder { - my ($this,$value,$rx) = @_; - - if ( $value ) { - if ($rx) { - if ( my @result = ($value =~ m/$rx/) ) { - return @result > 1 ? \@result : $result[0]; - } else { - return undef; - } - } else { - return $value; - } - } else { - return undef; - } + my ($this,$value,$rx) = @_; + + if ( $value ) { + if ($rx) { + if ( my @result = ($value =~ m/$rx/) ) { + return @result > 1 ? \@result : $result[0]; + } else { + return undef; + } + } else { + return $value; + } + } else { + return undef; + } } 1; @@ -147,62 +147,62 @@ # the application creates a new Action object my $action = $application->actionFactory->new( - action => $application, # the application passes self - query => $query # current CGI query + action => $application, # the application passes self + query => $query # current CGI query ); # forms query handlers stack $action->ChainHandler($_) foreach qw ( - IMPL::Web::QueryHandler::SecCallToMethod - IMPL::Web::QueryHandler::AuthenticateCookie - IMPL::Web::QueryHandler::PageFormat + IMPL::Web::QueryHandler::SecCallToMethod + IMPL::Web::QueryHandler::AuthenticateCookie + IMPL::Web::QueryHandler::PageFormat ); # and finally invokes the action $action->Invoke() { - - # some internals - - IMPL::Web::QueryHandler::PageFormat->Invoke($action,$nextHandlerIsAuthHandler) { - - #some internals - - my $result = $nextHandlerIsAuthHandler() { - - # some internals + + # some internals + + IMPL::Web::QueryHandler::PageFormat->Invoke($action,$nextHandlerIsAuthHandler) { + + #some internals + + my $result = $nextHandlerIsAuthHandler() { + + # some internals - IMPL::Web::QueryHandler::AuthenticateCookie->Invoke($action,$nextHandlerIsSecCall) { - - # some internals - # do auth and generate security $context - - # impersonate $context and call the next handler - return $context->Impersonate($nextHandlerIsSecCall) { - - # some internals - - IMPL::Web::QueryHandler::SecCallToMethod->Invoke($action,undef) { - - # next handler isn't present as it is the last hanler - - # some internals - # calculate the $method and the $target from CGI request - - IMPL::Security->AccessCheck($target,$method); - return $target->$method(); - - } - - } - - } - } - - # some intenals - # formatted output to $action->response->streamBody - } + IMPL::Web::QueryHandler::AuthenticateCookie->Invoke($action,$nextHandlerIsSecCall) { + + # some internals + # do auth and generate security $context + + # impersonate $context and call the next handler + return $context->Impersonate($nextHandlerIsSecCall) { + + # some internals + + IMPL::Web::QueryHandler::SecCallToMethod->Invoke($action,undef) { + + # next handler isn't present as it is the last hanler + + # some internals + # calculate the $method and the $target from CGI request + + IMPL::Security->AccessCheck($target,$method); + return $target->$method(); + + } + + } + + } + } + + # some intenals + # formatted output to $action->response->streamBody + } } =end code
--- a/Lib/IMPL/Web/Application/ControllerUnit.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/Application/ControllerUnit.pm Tue Apr 10 20:08:29 2012 +0400 @@ -10,22 +10,22 @@ use Sub::Name; use constant { - CONTROLLER_METHODS => 'controller_methods', - STATE_CORRECT => 'correct', - STATE_NEW => 'new', - STATE_INVALID => 'invalid', - TTYPE_FORM => 'form', - TTYPE_TRANS => 'tran' + CONTROLLER_METHODS => 'controller_methods', + STATE_CORRECT => 'correct', + STATE_NEW => 'new', + STATE_INVALID => 'invalid', + TTYPE_FORM => 'form', + TTYPE_TRANS => 'tran' }; BEGIN { - public property action => prop_get | owner_set; - public property application => prop_get | owner_set; - public property query => prop_get | owner_set; - public property response => prop_get | owner_set; - public property formData => prop_get | owner_set; - public property formSchema => prop_get | owner_set; - public property formErrors => prop_get | owner_set; + public property action => prop_get | owner_set; + public property application => prop_get | owner_set; + public property query => prop_get | owner_set; + public property response => prop_get | owner_set; + public property formData => prop_get | owner_set; + public property formSchema => prop_get | owner_set; + public property formErrors => prop_get | owner_set; } my %publicProps = map {$_->Name , 1} __PACKAGE__->get_meta(typeof IMPL::Class::PropertyInfo); @@ -35,228 +35,228 @@ our @schemaInc; sub CTOR { - my ($this,$action,$args) = @_; - - $this->action($action); - $this->application($action->application); - $this->query($action->query); - $this->response($action->response); - - $this->$_($args->{$_}) foreach qw(formData formSchema formErrors); + my ($this,$action,$args) = @_; + + $this->action($action); + $this->application($action->application); + $this->query($action->query); + $this->response($action->response); + + $this->$_($args->{$_}) foreach qw(formData formSchema formErrors); } sub unitNamespace() { - "" + "" } sub transactions { - my ($self,%methods) = @_; - - while (my ($method,$info) = each %methods) { - if ($info and ref $info ne 'HASH') { - warn "Bad transaction $method description"; - $info = {}; - } - - $info->{wrapper} = 'TransactionWrapper'; - $info->{method} ||= $method; - $info->{context}{transactionType} = TTYPE_TRANS; - $self->class_data(CONTROLLER_METHODS)->{$method} = $info; - } + my ($self,%methods) = @_; + + while (my ($method,$info) = each %methods) { + if ($info and ref $info ne 'HASH') { + warn "Bad transaction $method description"; + $info = {}; + } + + $info->{wrapper} = 'TransactionWrapper'; + $info->{method} ||= $method; + $info->{context}{transactionType} = TTYPE_TRANS; + $self->class_data(CONTROLLER_METHODS)->{$method} = $info; + } } sub forms { - my ($self,%forms) = @_; - - while ( my ($method,$info) = each %forms ) { - die new IMPL::Exception("A method doesn't exists in the controller",$self,$method) unless $self->can($method); - if ( not ref $info ) { - $self->class_data(CONTROLLER_METHODS)->{$method} = { - wrapper => 'FormWrapper', - schema => $info, - method => $method, - context => { transactionType => TTYPE_FORM } - }; - } elsif (ref $info eq 'HASH') { - $info->{wrapper} = 'FormWrapper'; - $info->{method} ||= $method; - $info->{context}{transactionType} = TTYPE_FORM; - - $self->class_data(CONTROLLER_METHODS)->{$method} = $info; - } else { - die new IMPL::Exception("Unsupported method information",$self,$method); - } - } + my ($self,%forms) = @_; + + while ( my ($method,$info) = each %forms ) { + die new IMPL::Exception("A method doesn't exists in the controller",$self,$method) unless $self->can($method); + if ( not ref $info ) { + $self->class_data(CONTROLLER_METHODS)->{$method} = { + wrapper => 'FormWrapper', + schema => $info, + method => $method, + context => { transactionType => TTYPE_FORM } + }; + } elsif (ref $info eq 'HASH') { + $info->{wrapper} = 'FormWrapper'; + $info->{method} ||= $method; + $info->{context}{transactionType} = TTYPE_FORM; + + $self->class_data(CONTROLLER_METHODS)->{$method} = $info; + } else { + die new IMPL::Exception("Unsupported method information",$self,$method); + } + } } sub InvokeAction { - my ($self,$method,$action) = @_; - - if (my $methodInfo = $self->class_data(CONTROLLER_METHODS)->{$method}) { - if (my $ctx = $methodInfo->{context}) { - $action->context->{$_} = $ctx->{$_} foreach keys %$ctx; - } - if (my $wrapper = $methodInfo->{wrapper}) { - return $self->$wrapper($method,$action,$methodInfo); - } else { - return $self->TransactionWrapper($method,$action,$methodInfo); - } - } else { - die new IMPL::InvalidOperationException("Invalid method call",$self,$method); - } + my ($self,$method,$action) = @_; + + if (my $methodInfo = $self->class_data(CONTROLLER_METHODS)->{$method}) { + if (my $ctx = $methodInfo->{context}) { + $action->context->{$_} = $ctx->{$_} foreach keys %$ctx; + } + if (my $wrapper = $methodInfo->{wrapper}) { + return $self->$wrapper($method,$action,$methodInfo); + } else { + return $self->TransactionWrapper($method,$action,$methodInfo); + } + } else { + die new IMPL::InvalidOperationException("Invalid method call",$self,$method); + } } sub MakeParams { - my ($this,$methodInfo) = @_; - - my $params; - if ($params = $methodInfo->{parameters} and ref $params eq 'ARRAY') { - return map $this->ResolveParam($_,$methodInfo->{inflate}{$_}), @$params; - } - return(); + my ($this,$methodInfo) = @_; + + my $params; + if ($params = $methodInfo->{parameters} and ref $params eq 'ARRAY') { + return map $this->ResolveParam($_,$methodInfo->{inflate}{$_}), @$params; + } + return(); } sub ResolveParam { - my ($this,$param,$inflate) = @_; - - if ( $param =~ /^::(\w+)$/ and $publicProps{$1}) { - return $this->$1(); - } else { - my $value; - if ( my $rx = $inflate->{rx} ) { - $value = $this->action->param($param,$rx); - } else { - $value = $this->query->param($param); - } - - if (my $method = $inflate->{method}) { - $value = $this->$method($value); - } - return $value; - } + my ($this,$param,$inflate) = @_; + + if ( $param =~ /^::(\w+)$/ and $publicProps{$1}) { + return $this->$1(); + } else { + my $value; + if ( my $rx = $inflate->{rx} ) { + $value = $this->action->param($param,$rx); + } else { + $value = $this->query->param($param); + } + + if (my $method = $inflate->{method}) { + $value = $this->$method($value); + } + return $value; + } } sub TransactionWrapper { - my ($self,$method,$action,$methodInfo) = @_; - - my $unit = $self->new($action); - my $handler = $methodInfo->{method}; - return $unit->$handler($unit->MakeParams($methodInfo)); + my ($self,$method,$action,$methodInfo) = @_; + + my $unit = $self->new($action); + my $handler = $methodInfo->{method}; + return $unit->$handler($unit->MakeParams($methodInfo)); } sub FormWrapper { - my ($self,$method,$action,$methodInfo) = @_; - - my $schema = $methodInfo->{schema} ? $self->loadSchema($methodInfo->{schema}) : $self->unitSchema; - - my $process = $action->query->param('process') || 0; - my $form = $methodInfo->{form} - || $action->query->param('form') - || $method; - - my %result; - - my $transform = IMPL::DOM::Transform::PostToDOM->new( - undef, - $schema, - $form - ); - - my $handler = $methodInfo->{method}; - - $result{formName} = $form; - $result{formSchema} = $schema; - - if ($process) { - $result{formData} = $transform->Transform($action->query); - $result{formErrors} = $transform->Errors->as_list; - if ($transform->Errors->Count) { - $result{state} = STATE_INVALID; - } else { - $result{state} = STATE_CORRECT; - my $unit = $self->new($action,\%result); - - eval { - $result{result} = $unit->$handler($unit->MakeParams($methodInfo)); - }; - if (my $err = $@) { - $result{state} = STATE_INVALID; - if (eval { $err->isa(typeof IMPL::WrongDataException) } ) { - $result{formErrors} = $err->Args; - } else { - die $err; - } - } - } - } else { - if (my $initMethod = $methodInfo->{init}) { - my $unit = $self->new($action,\%result); - $result{formData} = $transform->Transform( $unit->$initMethod($unit->MakeParams($methodInfo)) ); - } else { - $result{formData} = $transform->Transform($action->query); - } - - # ignore errors for new forms - #$result{formErrors} = $transform->Errors->as_list; - $result{state} = STATE_NEW; - } - - return \%result; + my ($self,$method,$action,$methodInfo) = @_; + + my $schema = $methodInfo->{schema} ? $self->loadSchema($methodInfo->{schema}) : $self->unitSchema; + + my $process = $action->query->param('process') || 0; + my $form = $methodInfo->{form} + || $action->query->param('form') + || $method; + + my %result; + + my $transform = IMPL::DOM::Transform::PostToDOM->new( + undef, + $schema, + $form + ); + + my $handler = $methodInfo->{method}; + + $result{formName} = $form; + $result{formSchema} = $schema; + + if ($process) { + $result{formData} = $transform->Transform($action->query); + $result{formErrors} = $transform->Errors->as_list; + if ($transform->Errors->Count) { + $result{state} = STATE_INVALID; + } else { + $result{state} = STATE_CORRECT; + my $unit = $self->new($action,\%result); + + eval { + $result{result} = $unit->$handler($unit->MakeParams($methodInfo)); + }; + if (my $err = $@) { + $result{state} = STATE_INVALID; + if (eval { $err->isa(typeof IMPL::WrongDataException) } ) { + $result{formErrors} = $err->Args; + } else { + die $err; + } + } + } + } else { + if (my $initMethod = $methodInfo->{init}) { + my $unit = $self->new($action,\%result); + $result{formData} = $transform->Transform( $unit->$initMethod($unit->MakeParams($methodInfo)) ); + } else { + $result{formData} = $transform->Transform($action->query); + } + + # ignore errors for new forms + #$result{formErrors} = $transform->Errors->as_list; + $result{state} = STATE_NEW; + } + + return \%result; } sub loadSchema { - my ($self,$name) = @_; - - foreach my $path (map File::Spec->catfile($_,$name) ,@schemaInc) { - return IMPL::DOM::Schema->LoadSchema($path) if -f $path; - } + my ($self,$name) = @_; + + foreach my $path (map File::Spec->catfile($_,$name) ,@schemaInc) { + return IMPL::DOM::Schema->LoadSchema($path) if -f $path; + } - die new IMPL::Exception("A schema isn't found", $name); + die new IMPL::Exception("A schema isn't found", $name); } sub unitSchema { - my ($self) = @_; - - my $class = ref $self || $self; - - my @parts = split(/:+/, $class); - - my $file = pop @parts; - $file = "${file}.schema.xml"; - - foreach my $inc ( @schemaInc ) { - my $path = File::Spec->catfile($inc,@parts,$file); - - return IMPL::DOM::Schema->LoadSchema($path) if -f $path; - } - - return undef; + my ($self) = @_; + + my $class = ref $self || $self; + + my @parts = split(/:+/, $class); + + my $file = pop @parts; + $file = "${file}.schema.xml"; + + foreach my $inc ( @schemaInc ) { + my $path = File::Spec->catfile($inc,@parts,$file); + + return IMPL::DOM::Schema->LoadSchema($path) if -f $path; + } + + return undef; } sub discover { - my ($this) = @_; - - my $methods = $this->class_data(CONTROLLER_METHODS); - - my $namespace = $this->unitNamespace; - (my $module = typeof $this) =~ s/^$namespace//; - - my %smd = ( - module => [grep $_, split /::/, $module ], - ); - - while (my ($method,$info) = each %$methods) { - my %methodInfo = ( - name => $method - ); - $methodInfo{parameters} = [ grep /^[^\:]/, @{ $info->{parameters} } ] if ref $info->{parameters} eq 'ARRAY'; - push @{$smd{methods}},\%methodInfo; - } - return \%smd; + my ($this) = @_; + + my $methods = $this->class_data(CONTROLLER_METHODS); + + my $namespace = $this->unitNamespace; + (my $module = typeof $this) =~ s/^$namespace//; + + my %smd = ( + module => [grep $_, split /::/, $module ], + ); + + while (my ($method,$info) = each %$methods) { + my %methodInfo = ( + name => $method + ); + $methodInfo{parameters} = [ grep /^[^\:]/, @{ $info->{parameters} } ] if ref $info->{parameters} eq 'ARRAY'; + push @{$smd{methods}},\%methodInfo; + } + return \%smd; } __PACKAGE__->transactions( - discover => undef + discover => undef ); 1; @@ -299,11 +299,11 @@ =begin code { - state => '{ new | correct | invalid }', - result => $transactionResult, - formData => $formDOM, - formSchema => $formSchema, - formErrors => @errors + state => '{ new | correct | invalid }', + result => $transactionResult, + formData => $formDOM, + formSchema => $formSchema, + formErrors => @errors } =end code @@ -403,13 +403,13 @@ # SMD structure { - module => ['Foo','Bar'], - methods => [ - { - name => 'search', - parameters => ['text','limit'] #optional - } - ] + module => ['Foo','Bar'], + methods => [ + { + name => 'search', + parameters => ['text','limit'] #optional + } + ] } =end code @@ -429,37 +429,37 @@ sub unitDataClass { 'My::Books' } __PACKAGE__->transactions( - find => { - parameters => [qw(author)] - }, - info => { - parameters => [qw(id)] - } + find => { + parameters => [qw(author)] + }, + info => { + parameters => [qw(id)] + } ); __PACKAGE__->forms( - create => 'books.create.xml' + create => 'books.create.xml' ); sub find { - my ($this,$author) = @_; - - return $this->ds->find({author => $author}); + my ($this,$author) = @_; + + return $this->ds->find({author => $author}); } sub info { - my ($this,$id) = @_; - - return $this->ds->find({id => $id}); + my ($this,$id) = @_; + + return $this->ds->find({id => $id}); } sub create { - my ($this) = @_; - - my %book = map { - $_->nodeName, $_->nodeValue - } $this->formData->selectNodes([qw(author_id title year ISBN)]); - - return $this->ds->create(\%book); + my ($this) = @_; + + my %book = map { + $_->nodeName, $_->nodeValue + } $this->formData->selectNodes([qw(author_id title year ISBN)]); + + return $this->ds->create(\%book); } =end code
--- a/Lib/IMPL/Web/Application/Response.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/Application/Response.pm Tue Apr 10 20:08:29 2012 +0400 @@ -14,174 +14,174 @@ #todo: add binary method to set a binary encoding, set it automatic when type isn't a text BEGIN { - # автозаполнение буде происходить в порядке объявления - public property query => prop_get | owner_set; # cgi query - public property status => prop_all, { validator => \&_checkHeaderPrinted }; - public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String - public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; - public property expires => prop_all, { validator => \&_checkHeaderPrinted }; - public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash - - public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean - public property streamOut => prop_get | owner_set; # stream - public property streamBody => {get => \&getStreamBody }; # stream - public property isHeaderPrinted => prop_get | owner_set; # Boolean - - private property _bufferBody => prop_all; - private property _streamBody => prop_all; + # автозаполнение буде происходить в порядке объявления + public property query => prop_get | owner_set; # cgi query + public property status => prop_all, { validator => \&_checkHeaderPrinted }; + public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String + public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; + public property expires => prop_all, { validator => \&_checkHeaderPrinted }; + public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash + + public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean + public property streamOut => prop_get | owner_set; # stream + public property streamBody => {get => \&getStreamBody }; # stream + public property isHeaderPrinted => prop_get | owner_set; # Boolean + + private property _bufferBody => prop_all; + private property _streamBody => prop_all; } __PACKAGE__->PassThroughArgs; our %CTOR = ( - 'IMPL::Object::Autofill' => sub { - my %args = @_; - - $args{query} = CGI->new($args{query} || {}); - - %args; - } + 'IMPL::Object::Autofill' => sub { + my %args = @_; + + $args{query} = CGI->new($args{query} || {}); + + %args; + } ); sub CTOR { - my ($this,%args) = @_; - - if (lc $this->streamOut eq 'memory') { - my $dummy = ''; - open my $hout, '>:encoding(utf8)', \$dummy or die new IMPL::Exception("Failed to create memory stream",$!); - $this->streamOut($hout); - } elsif (not $this->streamOut) { - $this->streamOut(*STDOUT); - } else { - die new IMPL::InvalidArgumentException("Invalid parameter value",$this->streamOut); - } - - $this->buffered(1) unless defined $this->buffered; - binmode $this->streamOut, ":encoding(".$this->charset.")"; + my ($this,%args) = @_; + + if (lc $this->streamOut eq 'memory') { + my $dummy = ''; + open my $hout, '>:encoding(utf8)', \$dummy or die new IMPL::Exception("Failed to create memory stream",$!); + $this->streamOut($hout); + } elsif (not $this->streamOut) { + $this->streamOut(*STDOUT); + } else { + die new IMPL::InvalidArgumentException("Invalid parameter value",$this->streamOut); + } + + $this->buffered(1) unless defined $this->buffered; + binmode $this->streamOut, ":encoding(".$this->charset.")"; } sub _checkHeaderPrinted { - my ($this,$value) = @_; - - die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; + my ($this,$value) = @_; + + die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; } sub _canChangeBuffer { - my ($this,$value) = @_; - - die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; + my ($this,$value) = @_; + + die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; } sub _charset { - my $this = shift; - - if (@_) { - my $charset = $this->query->charset(@_); - - my $hout = $this->streamOut; - - binmode $hout; - binmode $hout, ":encoding($charset)"; - - return $charset; - } else { - return $this->query->charset; - } + my $this = shift; + + if (@_) { + my $charset = $this->query->charset(@_); + + my $hout = $this->streamOut; + + binmode $hout; + binmode $hout, ":encoding($charset)"; + + return $charset; + } else { + return $this->query->charset; + } } sub _PrintHeader { - my ($this) = @_; - - unless ($this->isHeaderPrinted) { - $this->isHeaderPrinted(1); - - my %opt; - - $opt{-type} = $this->contentType if $this->contentType; - $opt{-status} = $this->status if $this->status; - $opt{-expires} = $this->expires if $this->expires; - - my $refCookies = $this->cookies; - $opt{-cookie} = [map _createCookie($_,$refCookies->{$_}), keys %$refCookies] if $refCookies; - - my $hOut = $this->streamOut; - - print $hOut $this->query->header( - %opt - ); - } + my ($this) = @_; + + unless ($this->isHeaderPrinted) { + $this->isHeaderPrinted(1); + + my %opt; + + $opt{-type} = $this->contentType if $this->contentType; + $opt{-status} = $this->status if $this->status; + $opt{-expires} = $this->expires if $this->expires; + + my $refCookies = $this->cookies; + $opt{-cookie} = [map _createCookie($_,$refCookies->{$_}), keys %$refCookies] if $refCookies; + + my $hOut = $this->streamOut; + + print $hOut $this->query->header( + %opt + ); + } } sub _createCookie { - return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); + return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); } sub setCookie { - my ($this,$name,$value) = @_; - - unless ($this->cookies) { - $this->cookies({$name,$value}); - } else { - $this->_checkHeaderPrinted(); - $this->cookies->{$name} = $value; - } - return $value; + my ($this,$name,$value) = @_; + + unless ($this->cookies) { + $this->cookies({$name,$value}); + } else { + $this->_checkHeaderPrinted(); + $this->cookies->{$name} = $value; + } + return $value; } sub getStreamBody { - my ($this) = @_; - - return undef unless $this->streamOut; - - unless ($this->_streamBody) { - if ($this->buffered) { - my $buffer = ""; - - $this->_bufferBody(\$buffer); - - open my $hBody, ">:encoding(utf-8)", \$buffer or die new IMPL::Exception("Failed to create buffer",$!); - - Encode::_utf8_on($buffer); - - $this->_streamBody($hBody); - } else { - $this->_PrintHeader(); - $this->_streamBody($this->streamOut); - } - } - - return $this->_streamBody; + my ($this) = @_; + + return undef unless $this->streamOut; + + unless ($this->_streamBody) { + if ($this->buffered) { + my $buffer = ""; + + $this->_bufferBody(\$buffer); + + open my $hBody, ">:encoding(utf-8)", \$buffer or die new IMPL::Exception("Failed to create buffer",$!); + + Encode::_utf8_on($buffer); + + $this->_streamBody($hBody); + } else { + $this->_PrintHeader(); + $this->_streamBody($this->streamOut); + } + } + + return $this->_streamBody; } sub Complete { - my ($this) = @_; - - return 0 unless $this->streamOut; - - my $hOut = $this->streamOut; - - $this->_PrintHeader(); + my ($this) = @_; + + return 0 unless $this->streamOut; + + my $hOut = $this->streamOut; + + $this->_PrintHeader(); - close $this->_streamBody(); - - if ($this->buffered) { - print $hOut ${$this->_bufferBody}; - } - - $this->_bufferBody(undef); - $this->streamOut(undef); - - return 1; + close $this->_streamBody(); + + if ($this->buffered) { + print $hOut ${$this->_bufferBody}; + } + + $this->_bufferBody(undef); + $this->streamOut(undef); + + return 1; } sub Discard { - my ($this) = @_; - - carp "Discarding sent response" if $this->isHeaderPrinted; - - $this->_streamBody(undef); - $this->_bufferBody(undef); - $this->streamOut(undef); + my ($this) = @_; + + carp "Discarding sent response" if $this->isHeaderPrinted; + + $this->_streamBody(undef); + $this->_bufferBody(undef); + $this->streamOut(undef); } 1;
--- a/Lib/IMPL/Web/DOM/FileNode.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/DOM/FileNode.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,65 +7,65 @@ 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); - } - }; + 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); - } + 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; + my ($node) = @_; + + my @result; + + unshift @result, $node while $node = $node->parentNode; + + return @result; } 1; @@ -84,10 +84,10 @@ <!-- input.schema.xml --> <schema> - <SimpleType type="file" nativeType="IMPL::Web::DOM::FileNode"/> - <ComplexNode name="user"> - <Node type="file" name="avatar"/> - </ComplexNode> + <SimpleType type="file" nativeType="IMPL::Web::DOM::FileNode"/> + <ComplexNode name="user"> + <Node type="file" name="avatar"/> + </ComplexNode> </schema> =end code xml @@ -101,27 +101,27 @@ use File::Copy qw(copy); my $t = new IMPL::DOM::Transform::PostToDOM( - undef, - IMPL::DOM::Schema->LoadSchema('input.schema.xml'), - 'user' + undef, + IMPL::DOM::Schema->LoadSchema('input.schema.xml'), + 'user' ); my $doc = $t->Transform(CGI->new()); if ($t->Errors->Count) { - # handle errors + # handle errors } $doc->selectSingleNode('avatar')->invokeTempFile( - sub { - my($node,$fname,$fhandle) = @_; - - # do smth with file - copy($_,'avatar.jpg'); - - # same thing - # copy($fname,'avatar.jpg'); - } + sub { + my($node,$fname,$fhandle) = @_; + + # do smth with file + copy($_,'avatar.jpg'); + + # same thing + # copy($fname,'avatar.jpg'); + } ); =end code @@ -179,7 +179,7 @@ Указатель на временный файл =back - + Также пременная C<$_> содержит имя временного файла. =item C<$target>
--- a/Lib/IMPL/Web/QueryHandler.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/QueryHandler.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,17 +8,17 @@ use IMPL::Exception; sub Invoke { - my ($self,$action,$nextHandler) = @_; - - if (not ref $self) { - return $self->new( action => $action )->Invoke($action,$nextHandler); - } else { - return $self->Process($action,$nextHandler); - } + my ($self,$action,$nextHandler) = @_; + + if (not ref $self) { + return $self->new( action => $action )->Invoke($action,$nextHandler); + } else { + return $self->Process($action,$nextHandler); + } } sub Process { - die new IMPL::NotImplementedException("The method isn't implemented", __PACKAGE__, 'Process'); + die new IMPL::NotImplementedException("The method isn't implemented", __PACKAGE__, 'Process'); } 1; @@ -42,13 +42,13 @@ use parent qw(IMPL::Web::QueryHandler); sub CTOR { - my ($this,%args) = @_; - + my ($this,%args) = @_; + } sub Process { - my ($this,$action,$nextHandler) = @_; - + my ($this,$action,$nextHandler) = @_; + } =end code
--- a/Lib/IMPL/Web/QueryHandler/JsonFormat.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/QueryHandler/JsonFormat.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,31 +7,31 @@ use JSON; sub Process { - my ($this,$action,$nextHandler) = @_; - - my $result; - - try { - $result = $nextHandler->(); - $result = [$result] unless ref $result; - } otherwise { - my $err = shift; - $result = { error => $err }; - }; - - my $t = new IMPL::Transform::Json($action->context->{json}); - - if ($action->context->{transactionType} and $action->context->{transactionType} eq 'form') { - delete @$result{qw(formData formSchema)}; - my $errors = @$result{formErrors}; - - $result->{formErrors} = [ map $_->Message, @$errors ] if $errors; - } - - $action->response->contentType('text/javascript'); - - my $hout = $action->response->streamBody; - print $hout to_json( $t->Transform($result), {pretty => 1} ); + my ($this,$action,$nextHandler) = @_; + + my $result; + + try { + $result = $nextHandler->(); + $result = [$result] unless ref $result; + } otherwise { + my $err = shift; + $result = { error => $err }; + }; + + my $t = new IMPL::Transform::Json($action->context->{json}); + + if ($action->context->{transactionType} and $action->context->{transactionType} eq 'form') { + delete @$result{qw(formData formSchema)}; + my $errors = @$result{formErrors}; + + $result->{formErrors} = [ map $_->Message, @$errors ] if $errors; + } + + $action->response->contentType('text/javascript'); + + my $hout = $action->response->streamBody; + print $hout to_json( $t->Transform($result), {pretty => 1} ); } package IMPL::Transform::Json; @@ -42,85 +42,85 @@ use Scalar::Util qw(refaddr); BEGIN { - private _direct property _visited => prop_none; + private _direct property _visited => prop_none; } my %propListCache; our %CTOR = ( - 'IMPL::Transform' => sub { - my $options = shift; - ( - $options ? %{$options} : () - ), - ARRAY => sub { - my ($this,$object) = @_; - - return [ - map { $this->Transform($_) } @$object - ]; - }, - HASH => sub { - my ($this,$object) = @_; - - return { - map { $_, $this->Transform($object->{$_}) } keys %$object - }; - }, - 'IMPL::Object::List' => sub { - my ($this,$object) = @_; - - return [ - map { $this->Transform($_) } @$object - ]; - }, - -plain => sub { - $_[1]; - }, - -default => sub { - my ($this,$object) = @_; - - return "$object" unless $object->isa('IMPL::Object::Abstract'); - - if ( $object->isa(typeof IMPL::Exception) ) { - return { - type => $object->typeof, - message => $object->Message, - arguments => $this->Transform(scalar $object->Args) - }; - } - - my $propList = $propListCache{ref $object}; - unless ( $propList ) { - my %props = map { - $_->Name, (ref $_->Mutators ? 0 : ($_->Mutators & prop_list)) - } $object->get_meta('IMPL::Class::PropertyInfo',sub { $_->Access == IMPL::Class::Member::MOD_PUBLIC and $_->Name !~ /^_/}, 1 ); - - $propListCache{ref $object} = $propList = \%props; - } - - return { - map { - $_, $propList->{$_} ? $this->Transform([$object->$_()]) : $this->Transform(scalar $object->$_()); - } keys %$propList - }; - } - } + 'IMPL::Transform' => sub { + my $options = shift; + ( + $options ? %{$options} : () + ), + ARRAY => sub { + my ($this,$object) = @_; + + return [ + map { $this->Transform($_) } @$object + ]; + }, + HASH => sub { + my ($this,$object) = @_; + + return { + map { $_, $this->Transform($object->{$_}) } keys %$object + }; + }, + 'IMPL::Object::List' => sub { + my ($this,$object) = @_; + + return [ + map { $this->Transform($_) } @$object + ]; + }, + -plain => sub { + $_[1]; + }, + -default => sub { + my ($this,$object) = @_; + + return "$object" unless $object->isa('IMPL::Object::Abstract'); + + if ( $object->isa(typeof IMPL::Exception) ) { + return { + type => $object->typeof, + message => $object->Message, + arguments => $this->Transform(scalar $object->Args) + }; + } + + my $propList = $propListCache{ref $object}; + unless ( $propList ) { + my %props = map { + $_->Name, (ref $_->Mutators ? 0 : ($_->Mutators & prop_list)) + } $object->get_meta('IMPL::Class::PropertyInfo',sub { $_->Access == IMPL::Class::Member::MOD_PUBLIC and $_->Name !~ /^_/}, 1 ); + + $propListCache{ref $object} = $propList = \%props; + } + + return { + map { + $_, $propList->{$_} ? $this->Transform([$object->$_()]) : $this->Transform(scalar $object->$_()); + } keys %$propList + }; + } + } ); sub Transform { - my ($this,$object) = @_; - - # small hack to prevent cycling - - return $this->SUPER::Transform($object) unless ref $object; - - if (exists $this->{$_visited}{refaddr $object}) { - return $this->{$_visited}{refaddr $object}; - } else { - $this->{$_visited}{refaddr $object} = undef; - return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object); - } + my ($this,$object) = @_; + + # small hack to prevent cycling + + return $this->SUPER::Transform($object) unless ref $object; + + if (exists $this->{$_visited}{refaddr $object}) { + return $this->{$_visited}{refaddr $object}; + } else { + $this->{$_visited}{refaddr $object} = undef; + return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object); + } } 1;
--- a/Lib/IMPL/Web/QueryHandler/PageFormat.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/QueryHandler/PageFormat.pm Tue Apr 10 20:08:29 2012 +0400 @@ -18,117 +18,117 @@ $Template::Plugin::URL::JOINT = '&'; BEGIN { - public property templatesCharset => prop_all; - public property templatesBase => prop_all; - public property includes => prop_all | prop_list; - public property pathinfoPrefix => prop_all; - public property cache => prop_all; - public property preprocess => prop_all; - public property formatOutput => prop_all; - public property template => prop_all; + public property templatesCharset => prop_all; + public property templatesBase => prop_all; + public property includes => prop_all | prop_list; + public property pathinfoPrefix => prop_all; + public property cache => prop_all; + public property preprocess => prop_all; + public property formatOutput => prop_all; + public property template => prop_all; } sub CTOR { - my ($this) = @_; - - $this->templatesCharset('utf-8') unless $this->templatesCharset; - $this->cache(File::Spec->rel2abs($this->cache)) if $this->cache; - $this->templatesBase(File::Spec->rel2abs($this->templatesBase)) if $this->templatesBase; + my ($this) = @_; + + $this->templatesCharset('utf-8') unless $this->templatesCharset; + $this->cache(File::Spec->rel2abs($this->cache)) if $this->cache; + $this->templatesBase(File::Spec->rel2abs($this->templatesBase)) if $this->templatesBase; } sub Process { - my ($this,$action,$nextHandler) = @_; - - my $doc = new IMPL::Web::TT::Document(cache => $this->cache, preprocess => $this->preprocess); - - try { + my ($this,$action,$nextHandler) = @_; + + my $doc = new IMPL::Web::TT::Document(cache => $this->cache, preprocess => $this->preprocess); + + try { - $this->templatesBase($ENV{DOCUMENT_ROOT}) unless $this->templatesBase; - - my ($requestUri) = split( /\?/, $ENV{REQUEST_URI} ); - - my $pathInfo; - my @root = (''); - my @base; - - if ( $requestUri eq $ENV{SCRIPT_NAME}.$ENV{PATH_INFO} ) { - # CGI with path info, for example - # /base/cgi-bin/myscript.cgi/path/info - # PATH_INFO will be /path/info - $pathInfo = $ENV{PATH_INFO}; - } else { - # usual url, for exmaple - # /base/script.cgi will have PATH_INFO /base/script.cgi - # /base/ will have PATH_INFO /base/index.cgi (if index.cgi is a DirectoryIndex) - $pathInfo = $ENV{PATH_INFO}; - - if (my $rx = $this->pathinfoPrefix) { - $requestUri =~ s/^($rx)//; - $pathInfo =~ s/^($rx)//; - push @root, grep $_, split /\//, $1 if $1; - } - } - - @base = grep $_, split /\//, ($pathInfo ? substr $requestUri,0, -length($pathInfo) : $requestUri); - - local $ENV{PATH_INFO} = $pathInfo; - - my @path = grep $_, split /\//, ($ENV{PATH_INFO} || '') or die new IMPL::Exception("PATH_INFO is empty and no defaultTarget specified" ); - - my @pathContainer = @path; - pop @pathContainer; - - $doc->LoadFile ( - ($this->template || File::Spec->catfile($this->templatesBase,@path)), - $this->templatesCharset, - [$this->templatesBase, $this->includes], - { - result => scalar($nextHandler->()), - action => $action, - app => $action->application, - - absoluteUrl => sub { new URI(join ('/', @root, $_[0]) ) }, - baseUrl => sub { new URI (join ('/', @root, @base, $_[0]) ) }, - relativeUrl => sub { new URI(join ('/', @root, @base, @pathContainer,$_[0]) ) }, - - user => IMPL::Security::Context->current->principal, - session => IMPL::Security::Context->current, - - to_json => \&to_json, - escape_string => sub { $_[0] =~ s/"/"/g; $_[0] }, - } - ); - - $action->response->contentType('text/html'); - my $hOut = $action->response->streamBody; - if ($this->formatOutput == 1) { - my $tree = new HTML::TreeBuilder(); - try { - $tree->parse_content($doc->Render()); - print $hOut $tree->as_HTML('<>&'," ",{}); - } finally { - $tree->delete; - }; - } elsif ($this->formatOutput() == 2 ) { - (my $data = $doc->Render()) =~ s/\s+/ /g; - print $hOut $data; - } else { - print $hOut $doc->Render(); - } - } finally { - $doc->Dispose; - }; + $this->templatesBase($ENV{DOCUMENT_ROOT}) unless $this->templatesBase; + + my ($requestUri) = split( /\?/, $ENV{REQUEST_URI} ); + + my $pathInfo; + my @root = (''); + my @base; + + if ( $requestUri eq $ENV{SCRIPT_NAME}.$ENV{PATH_INFO} ) { + # CGI with path info, for example + # /base/cgi-bin/myscript.cgi/path/info + # PATH_INFO will be /path/info + $pathInfo = $ENV{PATH_INFO}; + } else { + # usual url, for exmaple + # /base/script.cgi will have PATH_INFO /base/script.cgi + # /base/ will have PATH_INFO /base/index.cgi (if index.cgi is a DirectoryIndex) + $pathInfo = $ENV{PATH_INFO}; + + if (my $rx = $this->pathinfoPrefix) { + $requestUri =~ s/^($rx)//; + $pathInfo =~ s/^($rx)//; + push @root, grep $_, split /\//, $1 if $1; + } + } + + @base = grep $_, split /\//, ($pathInfo ? substr $requestUri,0, -length($pathInfo) : $requestUri); + + local $ENV{PATH_INFO} = $pathInfo; + + my @path = grep $_, split /\//, ($ENV{PATH_INFO} || '') or die new IMPL::Exception("PATH_INFO is empty and no defaultTarget specified" ); + + my @pathContainer = @path; + pop @pathContainer; + + $doc->LoadFile ( + ($this->template || File::Spec->catfile($this->templatesBase,@path)), + $this->templatesCharset, + [$this->templatesBase, $this->includes], + { + result => scalar($nextHandler->()), + action => $action, + app => $action->application, + + absoluteUrl => sub { new URI(join ('/', @root, $_[0]) ) }, + baseUrl => sub { new URI (join ('/', @root, @base, $_[0]) ) }, + relativeUrl => sub { new URI(join ('/', @root, @base, @pathContainer,$_[0]) ) }, + + user => IMPL::Security::Context->current->principal, + session => IMPL::Security::Context->current, + + to_json => \&to_json, + escape_string => sub { $_[0] =~ s/"/"/g; $_[0] }, + } + ); + + $action->response->contentType('text/html'); + my $hOut = $action->response->streamBody; + if ($this->formatOutput == 1) { + my $tree = new HTML::TreeBuilder(); + try { + $tree->parse_content($doc->Render()); + print $hOut $tree->as_HTML('<>&'," ",{}); + } finally { + $tree->delete; + }; + } elsif ($this->formatOutput() == 2 ) { + (my $data = $doc->Render()) =~ s/\s+/ /g; + print $hOut $data; + } else { + print $hOut $doc->Render(); + } + } finally { + $doc->Dispose; + }; } sub URI::_query::new_params { - my ($this,$params) = @_; - - my $clone = $this->clone; - if (ref $params eq 'HASH' ) { - my %newParams = ($clone->query_form , %$params); - $clone->query_form(map { $_, ( Encode::is_utf8( $newParams{$_} ) ? Encode::encode('utf-8', $newParams{$_}) : $newParams{$_} ) } sort keys %newParams ); - } - return $clone; + my ($this,$params) = @_; + + my $clone = $this->clone; + if (ref $params eq 'HASH' ) { + my %newParams = ($clone->query_form , %$params); + $clone->query_form(map { $_, ( Encode::is_utf8( $newParams{$_} ) ? Encode::encode('utf-8', $newParams{$_}) : $newParams{$_} ) } sort keys %newParams ); + } + return $clone; } 1; @@ -148,9 +148,9 @@ =begin code xml <handlersQuery type="IMPL::Object::List"> - <item type="IMPL::Web::QueryHandler::PageFormat"> - <charsetTemplates>utf-8</charsetTemplates> - </item> + <item type="IMPL::Web::QueryHandler::PageFormat"> + <charsetTemplates>utf-8</charsetTemplates> + </item> </handlersQuery> =end code xml @@ -161,7 +161,7 @@ my $app = new IMPL::Web::Application(); $app->handlersQuery->Add( - new IMPL::Web::QueryHandler::PageFormat( charsetTemplates=> 'utf-8' ); + new IMPL::Web::QueryHandler::PageFormat( charsetTemplates=> 'utf-8' ); ); =end
--- a/Lib/IMPL/Web/QueryHandler/PathInfoRewrite.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/QueryHandler/PathInfoRewrite.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,20 +7,20 @@ use IMPL::Class::Property; BEGIN { - public property pathinfoPrefix => prop_all; + public property pathinfoPrefix => prop_all; } sub Process { - my ($this,$query,$nextHandler) = @_; - - my $pathInfo = $ENV{PATH_INFO}; - if (my $rx = $this->pathinfoPrefix) { - $pathInfo =~ s/^($rx)//; - } - - local $ENV{PATH_INFO} = $pathInfo; - - scalar $nextHandler->(); + my ($this,$query,$nextHandler) = @_; + + my $pathInfo = $ENV{PATH_INFO}; + if (my $rx = $this->pathinfoPrefix) { + $pathInfo =~ s/^($rx)//; + } + + local $ENV{PATH_INFO} = $pathInfo; + + scalar $nextHandler->(); } 1;
--- a/Lib/IMPL/Web/QueryHandler/SecureCookie.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/QueryHandler/SecureCookie.pm Tue Apr 10 20:08:29 2012 +0400 @@ -9,76 +9,76 @@ use IMPL::Security; BEGIN { - public property salt => prop_all; + public property salt => prop_all; } sub CTOR { - my ($this) = @_; - - $this->salt('DeadBeef') unless $this->salt; + my ($this) = @_; + + $this->salt('DeadBeef') unless $this->salt; } sub Process { - my ($this,$action,$nextHandler) = @_; - - return undef unless $nextHandler; - - local $IMPL::Security::authority = $this; - - my $method = $action->query->cookie('method') || 'simple'; - - if ($method eq 'simple') { - - my $sid = $action->query->cookie('sid'); - my $cookie = $action->query->cookie('sdata'); - my $sign = $action->query->cookie('sign'); - - if ( - $sid and - $cookie and - $sign and - $sign eq md5_hex( - $this->salt, - $sid, - $cookie, - $this->salt - ) - ) { - # TODO: add a DefferedProxy to deffer a request to a data source - my $context = $action->application->security->sourceSession->find( - { id => $sid } - ) or return $nextHandler->(); - - my ($result,$challenge) = $context->auth->ValidateSession($cookie); - - if ($result == AUTH_SUCCESS) { - $context->authority($this); - return $context->Impersonate($nextHandler); - } else { - return $nextHandler->(); - } - } else { - return $nextHandler->(); - } - } else { - return $nextHandler->(); - } + my ($this,$action,$nextHandler) = @_; + + return undef unless $nextHandler; + + local $IMPL::Security::authority = $this; + + my $method = $action->query->cookie('method') || 'simple'; + + if ($method eq 'simple') { + + my $sid = $action->query->cookie('sid'); + my $cookie = $action->query->cookie('sdata'); + my $sign = $action->query->cookie('sign'); + + if ( + $sid and + $cookie and + $sign and + $sign eq md5_hex( + $this->salt, + $sid, + $cookie, + $this->salt + ) + ) { + # TODO: add a DefferedProxy to deffer a request to a data source + my $context = $action->application->security->sourceSession->find( + { id => $sid } + ) or return $nextHandler->(); + + my ($result,$challenge) = $context->auth->ValidateSession($cookie); + + if ($result == AUTH_SUCCESS) { + $context->authority($this); + return $context->Impersonate($nextHandler); + } else { + return $nextHandler->(); + } + } else { + return $nextHandler->(); + } + } else { + return $nextHandler->(); + } } sub WriteResponse { - my ($this,$response,$sid,$cookie,$method) = @_; + my ($this,$response,$sid,$cookie,$method) = @_; - my $sign = md5_hex( - $this->salt, - $sid, - $cookie, - $this->salt - ); - - $response->setCookie(sid => $sid); - $response->setCookie(sdata => $cookie); - $response->setCookie(sign => $sign); - $response->setCookie(method => $method) if $method; + my $sign = md5_hex( + $this->salt, + $sid, + $cookie, + $this->salt + ); + + $response->setCookie(sid => $sid); + $response->setCookie(sdata => $cookie); + $response->setCookie(sign => $sign); + $response->setCookie(method => $method) if $method; } 1;
--- a/Lib/IMPL/Web/QueryHandler/UrlController.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/QueryHandler/UrlController.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,41 +8,41 @@ use Scalar::Util qw(tainted); BEGIN { - public property namespace => prop_all; + public property namespace => prop_all; } __PACKAGE__->PassThroughArgs; sub Process { - my ($this,$action,$nextHandler) = @_; - - my $namespace = $this->namespace || $action->application->typeof; - - my @target = grep $_, split /\//, ($ENV{PATH_INFO} || '') or die new IMPL::Exception("No target specified"); - - my $method = pop @target; - if ( $method =~ /^(\w+)/ ) { - $method = $1; - } else { - die new IMPL::Exception("Invalid method name",$method); - } - - (/^(\w+)$/ or die new IMPL::Exception("Invalid module name part", $_)) and $_=$1 foreach @target; - - my $module = join '::',$namespace,@target; - - die new IMPL::Exception("A module name is untrusted", $module) if tainted($module); - - eval "require $module; 1;" unless eval{ $module->can('InvokeAction'); }; - if (my $err = $@ ) { - die new IMPL::Exception("Failed to load module",$module,$err); - } - - if(UNIVERSAL::can($module,'InvokeAction')) { - $module->InvokeAction($method,$action); - } else { - die new IMPL::InvalidOperationException("Failed to invoke action",$ENV{PATH_INFO},$module,$method); - } + my ($this,$action,$nextHandler) = @_; + + my $namespace = $this->namespace || $action->application->typeof; + + my @target = grep $_, split /\//, ($ENV{PATH_INFO} || '') or die new IMPL::Exception("No target specified"); + + my $method = pop @target; + if ( $method =~ /^(\w+)/ ) { + $method = $1; + } else { + die new IMPL::Exception("Invalid method name",$method); + } + + (/^(\w+)$/ or die new IMPL::Exception("Invalid module name part", $_)) and $_=$1 foreach @target; + + my $module = join '::',$namespace,@target; + + die new IMPL::Exception("A module name is untrusted", $module) if tainted($module); + + eval "require $module; 1;" unless eval{ $module->can('InvokeAction'); }; + if (my $err = $@ ) { + die new IMPL::Exception("Failed to load module",$module,$err); + } + + if(UNIVERSAL::can($module,'InvokeAction')) { + $module->InvokeAction($method,$action); + } else { + die new IMPL::InvalidOperationException("Failed to invoke action",$ENV{PATH_INFO},$module,$method); + } } 1;
--- a/Lib/IMPL/Web/Security.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/Security.pm Tue Apr 10 20:08:29 2012 +0400 @@ -10,48 +10,48 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property sourceUser => prop_all; - public property sourceSession => prop_all; + public property sourceUser => prop_all; + public property sourceSession => prop_all; } sub CTOR { - my ($this) = @_; - - die new IMPL::InvalidArgumentException("An argument is required",'sourceUser') unless $this->sourceUser; - die new IMPL::InvalidArgumentException("An argument is required",'sourceSession') unless $this->sourceSession; + my ($this) = @_; + + die new IMPL::InvalidArgumentException("An argument is required",'sourceUser') unless $this->sourceUser; + die new IMPL::InvalidArgumentException("An argument is required",'sourceSession') unless $this->sourceSession; } sub AuthUser { - my ($this,$name,$package,$challenge) = @_; - - my $user = $this->sourceUser->find({name => $name}) or return { status => AUTH_FAIL, answer => "Can't find a user '$name'" }; - - my $auth; - if ( my $secData = $user->secData($package) ) { - $auth = $package->new($secData); - } else { - die new IMPL::SecurityException("Authentication failed","A sec data for the $package isn't found"); - } - - my ($status,$answer) = $auth->DoAuth($challenge); - - return { - status => $status, - answer => $answer, - context => $this->MakeContext( $user, [$user->roles], $auth ) - } + my ($this,$name,$package,$challenge) = @_; + + my $user = $this->sourceUser->find({name => $name}) or return { status => AUTH_FAIL, answer => "Can't find a user '$name'" }; + + my $auth; + if ( my $secData = $user->secData($package) ) { + $auth = $package->new($secData); + } else { + die new IMPL::SecurityException("Authentication failed","A sec data for the $package isn't found"); + } + + my ($status,$answer) = $auth->DoAuth($challenge); + + return { + status => $status, + answer => $answer, + context => $this->MakeContext( $user, [$user->roles], $auth ) + } } sub MakeContext { - my ($this,$principal,$roles,$auth) = @_; - - return $this->sourceSession->create( - { - principal => $principal, - rolesAssigned => $roles, - auth => $auth - } - ); + my ($this,$principal,$roles,$auth) = @_; + + return $this->sourceSession->create( + { + principal => $principal, + rolesAssigned => $roles, + auth => $auth + } + ); } 1; @@ -69,13 +69,13 @@ =begin code xml <security type='IMPL::Config::Activator'> - <factory>IMPL::Web::Security</factory> - <parameters type='HASH'> - <sessionFactory type='IMPL::Object::Factory'> - <factory type='IMPL::Object::Factory'>App::Data::Session</factory> - <method>insert</method> - </sessionFactory> - </parameters> + <factory>IMPL::Web::Security</factory> + <parameters type='HASH'> + <sessionFactory type='IMPL::Object::Factory'> + <factory type='IMPL::Object::Factory'>App::Data::Session</factory> + <method>insert</method> + </sessionFactory> + </parameters> </security> =end code xml
--- a/Lib/IMPL/Web/Security/Session.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/Security/Session.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,7 +7,7 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property id => prop_all | owner_set; + public property id => prop_all | owner_set; } 1; @@ -32,7 +32,7 @@ use IMPL::Class::Property; BEGIN { - public property transactionId => prop_all; + public property transactionId => prop_all; } =end code
--- a/Lib/IMPL/Web/TT/Collection.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/TT/Collection.pm Tue Apr 10 20:08:29 2012 +0400 @@ -7,35 +7,35 @@ our $AUTOLOAD; sub AUTOLOAD { - my $this = shift; - my ($method) = ($AUTOLOAD =~ /(\w+)$/); - - return if $method eq 'DESTROY'; - - if ( @_ >= 1 ) { - # set - - if ($method =~ /^add(\w+)/) { - my ($name,$args) = @_; - return $this->appendChild($this->document->CreateControl($name,$1,$args)); - } - - # we can't assing a node, so this is a dynamic property - return $this->nodeProperty($method,@_); - } else { - # get - # try a dynamic property first - if ( my $val = $this->nodeProperty($method) ) { - return $val; - } else { - # and return a first child node as last opportunity - my @result = $this->selectNodes($method); - - return $result[0] if @result; - } - } - - return; + my $this = shift; + my ($method) = ($AUTOLOAD =~ /(\w+)$/); + + return if $method eq 'DESTROY'; + + if ( @_ >= 1 ) { + # set + + if ($method =~ /^add(\w+)/) { + my ($name,$args) = @_; + return $this->appendChild($this->document->CreateControl($name,$1,$args)); + } + + # we can't assing a node, so this is a dynamic property + return $this->nodeProperty($method,@_); + } else { + # get + # try a dynamic property first + if ( my $val = $this->nodeProperty($method) ) { + return $val; + } else { + # and return a first child node as last opportunity + my @result = $this->selectNodes($method); + + return $result[0] if @result; + } + } + + return; } 1;
--- a/Lib/IMPL/Web/TT/Control.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/TT/Control.pm Tue Apr 10 20:08:29 2012 +0400 @@ -9,37 +9,37 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property controlClass => prop_all; - public property template => prop_all; - public property id => prop_all; + public property controlClass => prop_all; + public property template => prop_all; + public property id => prop_all; } my $nextId = 1; sub CTOR { - my ($this,%args) = @_; - - if ($this->document) { - # load a template - $this->template( $this->document->context->template($args{template})) if ($args{template} and not ref $args{template}); - } - #$this->template($args{template}) if $args{template}; + my ($this,%args) = @_; + + if ($this->document) { + # load a template + $this->template( $this->document->context->template($args{template})) if ($args{template} and not ref $args{template}); + } + #$this->template($args{template}) if $args{template}; - $this->id($this->nodeName . '-' . $nextId++); - $this->controlClass('Control') unless $this->controlClass; + $this->id($this->nodeName . '-' . $nextId++); + $this->controlClass('Control') unless $this->controlClass; } sub Render { - my ($this) = @_; - - if ($this->document) { - if ($this->template) { - return $this->document->context->include($this->template,{ this => $this }) ; - } elsif ($this->document->presenter) { - return $this->document->presenter->print($this); - } else { - return $this->toString().": ".$this->controlClass() . ": ".$this->path; - } - } + my ($this) = @_; + + if ($this->document) { + if ($this->template) { + return $this->document->context->include($this->template,{ this => $this }) ; + } elsif ($this->document->presenter) { + return $this->document->presenter->print($this); + } else { + return $this->toString().": ".$this->controlClass() . ": ".$this->path; + } + } } 1;
--- a/Lib/IMPL/Web/TT/Document.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/TT/Document.pm Tue Apr 10 20:08:29 2012 +0400 @@ -30,29 +30,29 @@ ); sub CTOR { - my ($this,%args) = @_; - - $this->_controlClassMap({}); - $this->registerControlClass( Control => 'IMPL::Web::TT::Control' ); - $this->appendChild( $this->Create(body => 'IMPL::Web::TT::Collection') ); - $this->appendChild( $this->Create(head => 'IMPL::Web::TT::Collection') ); - $this->cache($args{cache}) if $args{cache}; - $this->preprocess($args{preprocess}) if $args{preprocess}; + my ($this,%args) = @_; + + $this->_controlClassMap({}); + $this->registerControlClass( Control => 'IMPL::Web::TT::Control' ); + $this->appendChild( $this->Create(body => 'IMPL::Web::TT::Collection') ); + $this->appendChild( $this->Create(head => 'IMPL::Web::TT::Collection') ); + $this->cache($args{cache}) if $args{cache}; + $this->preprocess($args{preprocess}) if $args{preprocess}; } sub CreateControl { - my ($this,$name,$class,$args) = @_; - - $args = {} unless ref $args eq 'HASH'; - - if (my $info = $this->_controlClassMap->{$class}) { - my %nodeArgs = (%{$info->{args}},%$args); - $nodeArgs{controlClass} = $class; - - return $this->Create($name,$info->{type},\%nodeArgs); - } else { - die new IMPL::Exception('A control is\'t registered', $class, $name); - } + my ($this,$name,$class,$args) = @_; + + $args = {} unless ref $args eq 'HASH'; + + if (my $info = $this->_controlClassMap->{$class}) { + my %nodeArgs = (%{$info->{args}},%$args); + $nodeArgs{controlClass} = $class; + + return $this->Create($name,$info->{type},\%nodeArgs); + } else { + die new IMPL::Exception('A control is\'t registered', $class, $name); + } } sub provider { @@ -79,16 +79,16 @@ document => $this, this => $this, render => sub { - $this->_process(@_); + $this->_process(@_); }, encode => sub { - Encode::encode('utf8',shift); + Encode::encode('utf8',shift); }, dump => sub { - Dumper(shift); + Dumper(shift); }, as_list => sub { - [ map ref($_) eq 'ARRAY' ? @$_ : $_, @_ ] + [ map ref($_) eq 'ARRAY' ? @$_ : $_, @_ ] } }, RECURSION => 1, @@ -99,75 +99,75 @@ } sub resolveVar { - my ($this,$var) = @_; - - return $this->context->stash->get($var); + my ($this,$var) = @_; + + return $this->context->stash->get($var); } sub registerControlClass { - my ($this, $controlClass, $type, $args) = @_; - - $type ||= 'IMPL::Web::TT::Control'; - - die new IMPL::InvalidArgumentException("A controlClass must be a single word",$controlClass) unless $controlClass =~ /^\w+$/; - - eval "require $type; 1;" or die new IMPL::Exception("Failed to load a module",$type,"$@") unless eval { $type->can('new') }; - - die new IMPL::InvalidArgumentException("A type must be subclass of IMPL::DOM::Node",$type) unless $type->isa('IMPL::DOM::Node'); - - # resolve template name to a real template - $args->{template} = $this->context->template($args->{template}) if $args->{template}; - - $this->_controlClassMap->{$controlClass} = { - controlClass => $controlClass, - type => $type, - args => ref $args eq 'HASH' ? $args : {} - }; + my ($this, $controlClass, $type, $args) = @_; + + $type ||= 'IMPL::Web::TT::Control'; + + die new IMPL::InvalidArgumentException("A controlClass must be a single word",$controlClass) unless $controlClass =~ /^\w+$/; + + eval "require $type; 1;" or die new IMPL::Exception("Failed to load a module",$type,"$@") unless eval { $type->can('new') }; + + die new IMPL::InvalidArgumentException("A type must be subclass of IMPL::DOM::Node",$type) unless $type->isa('IMPL::DOM::Node'); + + # resolve template name to a real template + $args->{template} = $this->context->template($args->{template}) if $args->{template}; + + $this->_controlClassMap->{$controlClass} = { + controlClass => $controlClass, + type => $type, + args => ref $args eq 'HASH' ? $args : {} + }; } sub require { - my ($this,$template) = @_; - - my $doc = $this->context->template($template); - - die new IMPL::InvalidOperationException("A specified template isn't a document",$template) unless eval{ $doc -> isa('Template::Document') }; - - my $controlClass = $doc->class; - my $type = $doc->nativeType; - my $controlTemplate; - my $out = ""; - - die new IMPL::InvalidOperationException("A specified template isn't a control",$template) unless $controlClass; - - if (not $this->isControlClass($controlClass)) { - if ($doc->template) { - $controlTemplate = $doc->blocks()->{$doc->template} || $this->context->template($doc->template); - $out = $this->context->include($doc); - } else { - $controlTemplate = $doc; - } - $this->registerControlClass($controlClass,$type,{ template => $controlTemplate } ); - } - - return $out; + my ($this,$template) = @_; + + my $doc = $this->context->template($template); + + die new IMPL::InvalidOperationException("A specified template isn't a document",$template) unless eval{ $doc -> isa('Template::Document') }; + + my $controlClass = $doc->class; + my $type = $doc->nativeType; + my $controlTemplate; + my $out = ""; + + die new IMPL::InvalidOperationException("A specified template isn't a control",$template) unless $controlClass; + + if (not $this->isControlClass($controlClass)) { + if ($doc->template) { + $controlTemplate = $doc->blocks()->{$doc->template} || $this->context->template($doc->template); + $out = $this->context->include($doc); + } else { + $controlTemplate = $doc; + } + $this->registerControlClass($controlClass,$type,{ template => $controlTemplate } ); + } + + return $out; } sub isControlClass { - my ($this,$name) = @_; - return $this->_controlClassMap->{$name} ? 1 : 0; + my ($this,$name) = @_; + return $this->_controlClassMap->{$name} ? 1 : 0; } sub _getControls { - my ($this) = @_; - - my ($node) = $this->selectNodes('controls'); - return $node; + my ($this) = @_; + + my ($node) = $this->selectNodes('controls'); + return $node; } sub _validatePresenter { - my ($this,$value) = @_; - - die new IMPL::InvalidArgumentException("A view object is required") unless blessed($value) and $value->isa('Template::View'); + my ($this,$value) = @_; + + die new IMPL::InvalidArgumentException("A view object is required") unless blessed($value) and $value->isa('Template::View'); } sub LoadFile { @@ -183,9 +183,9 @@ $this->_provider(undef); if (not ref $src) { - my ($vol,$dir,$fileName) = File::Spec->splitpath($src); - unshift @$includes, File::Spec->catpath($vol,$dir,''); - $src = $fileName; + my ($vol,$dir,$fileName) = File::Spec->splitpath($src); + unshift @$includes, File::Spec->catpath($vol,$dir,''); + $src = $fileName; } $this->provider( @@ -200,9 +200,9 @@ ); if ($vars) { - while ( my ($var,$val) = each %$vars ) { - $this->AddVar($var,$val); - } + while ( my ($var,$val) = each %$vars ) { + $this->AddVar($var,$val); + } } $this->context->process($_) foreach $this->preprocess; @@ -210,18 +210,18 @@ my $template = $this->context->template($src); $this->title($template->title); if ( $template->template ) { - $this->context->process($template); - $this->template($template->template); + $this->context->process($template); + $this->template($template->template); } else { - $this->template($template); + $this->template($template); } } sub AddVar { - my ($this,$name,$value) = @_; - - $this->context->stash->set($name,$value); + my ($this,$name,$value) = @_; + + $this->context->stash->set($name,$value); } sub Render { @@ -232,42 +232,42 @@ # Формирует представление для произвольных объектов sub _process { - my ($this,@items) = @_; - - my @result; - - foreach my $item (@items) { - if (blessed($item) and $item->isa('IMPL::Web::TT::Control')) { - push @result, $item->Render(); - } elsif(blessed($item)) { - if ($this->presenter) { - push @result, $this->presenter->print($item); - } else { - push @result, $this->toString; - } - } else { - push @result, $item; - } - } - - return join '',@result; + my ($this,@items) = @_; + + my @result; + + foreach my $item (@items) { + if (blessed($item) and $item->isa('IMPL::Web::TT::Control')) { + push @result, $item->Render(); + } elsif(blessed($item)) { + if ($this->presenter) { + push @result, $this->presenter->print($item); + } else { + push @result, $this->toString; + } + } else { + push @result, $item; + } + } + + return join '',@result; } our $AUTOLOAD; sub AUTOLOAD { - my $this = shift; - my ($method) = ($AUTOLOAD =~ /(\w+)$/); - - if($method =~ /^create(\w+)/) { - my ($name,$args) = @_; - return $this->CreateControl($name,$1,$args); - } - - my @result = $this->selectNodes($method); - - return $result[0] if @result; - carp "Looks like you have a mistake, the document doesn't have a such property or child: $method"; - return; + my $this = shift; + my ($method) = ($AUTOLOAD =~ /(\w+)$/); + + if($method =~ /^create(\w+)/) { + my ($name,$args) = @_; + return $this->CreateControl($name,$1,$args); + } + + my @result = $this->selectNodes($method); + + return $result[0] if @result; + carp "Looks like you have a mistake, the document doesn't have a such property or child: $method"; + return; } sub Dispose { @@ -360,19 +360,19 @@ [% table = document.сreateTable('env') %] [% FOEACH item in document.result %] - [% table.rows.Add( item.get('name','value') ) %] + [% table.rows.Add( item.get('name','value') ) %] [% END %] [% form = document.createForm('login') %] [% form.template = 'LOGIN_FORM'%] [% FOREACH item IN document.childNodes %] - [%render(item)%] + [%render(item)%] [% END %] - + [% BLOCK LOGIN_FORM %] <form method="POST" action='/login.pl'> - user: [% render(this.item('name')) %] password: [% render(this.item('password')) %] <input type="submit"/> + user: [% render(this.item('name')) %] password: [% render(this.item('password')) %] <input type="submit"/> </form> [% END %]
--- a/Lib/IMPL/Web/TT/Form.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/TT/Form.pm Tue Apr 10 20:08:29 2012 +0400 @@ -9,196 +9,196 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property base => prop_all; - public property schema => prop_all; - public property errors => prop_all; - public property data => prop_all; - public property state => prop_all; - public property formResult => prop_all; + public property base => prop_all; + public property schema => prop_all; + public property errors => prop_all; + public property data => prop_all; + public property state => prop_all; + public property formResult => prop_all; } sub CTOR { - my ($this) = @_; - - if (my $form = $this->formResult) { - $this->base($form->{formName}); - $this->errors($form->{formErrors}); - $this->data($form->{formData}); - $this->schema($form->{formSchema}); - $this->state($form->{state}); - } else { - - $this->base($this->nodeName) unless $this->base; - - die new IMPL::InvalidArgumentException('A schema is required for a form',$this->nodeName) - unless eval { $this->schema->isa( typeof IMPL::DOM::Schema ) }; - - die new IMPL::InvalidOperationException('Can\'t find a form definition in a schema',$this->nodeName,$this->base) - unless $this->schema->selectNodes(sub { $_->nodeName eq 'ComplexNode' and $_->name eq $this->base }); - } - - $this->errors([]) unless $this->errors; + my ($this) = @_; + + if (my $form = $this->formResult) { + $this->base($form->{formName}); + $this->errors($form->{formErrors}); + $this->data($form->{formData}); + $this->schema($form->{formSchema}); + $this->state($form->{state}); + } else { + + $this->base($this->nodeName) unless $this->base; + + die new IMPL::InvalidArgumentException('A schema is required for a form',$this->nodeName) + unless eval { $this->schema->isa( typeof IMPL::DOM::Schema ) }; + + die new IMPL::InvalidOperationException('Can\'t find a form definition in a schema',$this->nodeName,$this->base) + unless $this->schema->selectNodes(sub { $_->nodeName eq 'ComplexNode' and $_->name eq $this->base }); + } + + $this->errors([]) unless $this->errors; } sub fillContents { - my ($this) = @_; - - my $schema = $this->schema->selectSingleNode(sub { $_->nodeName eq 'ComplexNode' and $_->name eq $this->base }); - - $this->buildContainer( - $schema, - $schema, - $this->data->isComplex ? $this->data : undef, - $this - ); + my ($this) = @_; + + my $schema = $this->schema->selectSingleNode(sub { $_->nodeName eq 'ComplexNode' and $_->name eq $this->base }); + + $this->buildContainer( + $schema, + $schema, + $this->data->isComplex ? $this->data : undef, + $this + ); } sub buildContainer { - my ($this,$schemaSource,$schema,$domNode,$container,$path) = @_; - - $path = [@{$path || []},{node => $domNode, schemaSource => $schemaSource}]; - - $container ||= $this->document->Create($schemaSource->name,'IMPL::Web::TT::Collection'); - - foreach my $schemaItem ( $schema->content->childNodes ) { - my $schemaItemSource = $schemaItem; - - $schemaItem = $this->schema->resolveType($schemaItem->type) - if typeof $schemaItem eq typeof IMPL::DOM::Schema::Node; - - my @nodesData = $domNode->selectNodes(sub { $_->schemaSource == $schemaItemSource } ) if $domNode; - - push @nodesData, undef unless @nodesData; - - if ($schemaItem->isa(typeof IMPL::DOM::Schema::ComplexNode) ) { - $this->appendChild( $this->buildContainer($schemaItemSource,$schemaItem,$_,undef,$path) ) foreach @nodesData; - } elsif ($schemaItem->isa(typeof IMPL::DOM::Schema::SimpleNode)) { - $this->appendChild( $this->buildControl($schemaItemSource,$schemaItem,$_,$path) ) foreach @nodesData; - } - } - - return $container; + my ($this,$schemaSource,$schema,$domNode,$container,$path) = @_; + + $path = [@{$path || []},{node => $domNode, schemaSource => $schemaSource}]; + + $container ||= $this->document->Create($schemaSource->name,'IMPL::Web::TT::Collection'); + + foreach my $schemaItem ( $schema->content->childNodes ) { + my $schemaItemSource = $schemaItem; + + $schemaItem = $this->schema->resolveType($schemaItem->type) + if typeof $schemaItem eq typeof IMPL::DOM::Schema::Node; + + my @nodesData = $domNode->selectNodes(sub { $_->schemaSource == $schemaItemSource } ) if $domNode; + + push @nodesData, undef unless @nodesData; + + if ($schemaItem->isa(typeof IMPL::DOM::Schema::ComplexNode) ) { + $this->appendChild( $this->buildContainer($schemaItemSource,$schemaItem,$_,undef,$path) ) foreach @nodesData; + } elsif ($schemaItem->isa(typeof IMPL::DOM::Schema::SimpleNode)) { + $this->appendChild( $this->buildControl($schemaItemSource,$schemaItem,$_,$path) ) foreach @nodesData; + } + } + + return $container; } sub buildControl { - my ($this,$schemaSource,$schema,$node,$path) = @_; - - my @errors; - - if ($node) { - @errors = grep { ($_->Node || $_->Parent) == $node } @{$this->errors}; - } else { - @errors = grep $_->Schema == $schemaSource, @{$this->errors}; - } - - return $this->document->CreateControl( - $schemaSource->name, - $this->mapType($schemaSource), - { - schema => $schema, - sourceSchema => $schemaSource, - errors => \@errors, - data => $node, - inputType => $schemaSource->nodeProperty('inputType') || $schema->nodeProperty('inputType'), - nodeValue => $node && $node->nodeValue, # small hack set a non dom class property through - queryParameter => $this->makeParameterName([@$path,{ node => $node, schemaSource => $schemaSource}]) - } - ); + my ($this,$schemaSource,$schema,$node,$path) = @_; + + my @errors; + + if ($node) { + @errors = grep { ($_->Node || $_->Parent) == $node } @{$this->errors}; + } else { + @errors = grep $_->Schema == $schemaSource, @{$this->errors}; + } + + return $this->document->CreateControl( + $schemaSource->name, + $this->mapType($schemaSource), + { + schema => $schema, + sourceSchema => $schemaSource, + errors => \@errors, + data => $node, + inputType => $schemaSource->nodeProperty('inputType') || $schema->nodeProperty('inputType'), + nodeValue => $node && $node->nodeValue, # small hack set a non dom class property through + queryParameter => $this->makeParameterName([@$path,{ node => $node, schemaSource => $schemaSource}]) + } + ); } sub mapType { - my ($this,$schema) = @_; - - $schema->nodeProperty('control') || - ( $schema->type && $this->schema->resolveType($schema->type)->nodeProperty('control') ) - or die new IMPL::Exception("Unable to get control class for the form element",$schema->path); + my ($this,$schema) = @_; + + $schema->nodeProperty('control') || + ( $schema->type && $this->schema->resolveType($schema->type)->nodeProperty('control') ) + or die new IMPL::Exception("Unable to get control class for the form element",$schema->path); } sub makeParameterName { - my ($this,$path) = @_; - - join '/', map { - $_->{node} ? - ( - $_->{node}->nodeProperty('instanceId') ? - $_->{node}->nodeName . '['. ']' : - $_->{node}->nodeName - ) : - ( - $_->{schemaSource}->maxOccur eq 'unbounded' || $_->{schemaSource}->maxOccur > 1 ? - $_->{schemaSource}->name . '[0]' : - $_->{schemaSource}->name - ) - } @$path; + my ($this,$path) = @_; + + join '/', map { + $_->{node} ? + ( + $_->{node}->nodeProperty('instanceId') ? + $_->{node}->nodeName . '['. ']' : + $_->{node}->nodeName + ) : + ( + $_->{schemaSource}->maxOccur eq 'unbounded' || $_->{schemaSource}->maxOccur > 1 ? + $_->{schemaSource}->name . '[0]' : + $_->{schemaSource}->name + ) + } @$path; } sub makeControlArgs{ - my ($this,$path) = @_; - - my $navi = new IMPL::DOM::Navigator::SchemaNavigator($this->schema); - my @path = ($this->base, split(/\./,$path) ); - - $navi->NavigateName($_) or die new IMPL::InvalidArgumentException( - "Can't find a definition for an element", - $_, - $path, - $this->element, - ) foreach @path; - - my $schema = $navi->Current; - my $sourceSchema = $navi->SourceSchemaNode; - my $queryParameter = join '/', @path; - shift @path; - my $node = $this->data ? $this->data->selectSingleNode(@path) : undef; - - my @errors; - - if ($node) { - @errors = grep { ($_->Node || $_->Parent) == $node } @{$this->errors}; - } else { - @errors = grep $_->Schema == $sourceSchema, @{$this->errors}; - } - - return { - schema => $schema, - sourceSchema => $sourceSchema, - errors => \@errors, - data => $node, - nodeValue => $node && $node->nodeValue, # small hack set a non dom class property through - queryParameter => $queryParameter, - inputType => $sourceSchema->nodeProperty('inputType') || $schema->nodeProperty('inputType') - }; + my ($this,$path) = @_; + + my $navi = new IMPL::DOM::Navigator::SchemaNavigator($this->schema); + my @path = ($this->base, split(/\./,$path) ); + + $navi->NavigateName($_) or die new IMPL::InvalidArgumentException( + "Can't find a definition for an element", + $_, + $path, + $this->element, + ) foreach @path; + + my $schema = $navi->Current; + my $sourceSchema = $navi->SourceSchemaNode; + my $queryParameter = join '/', @path; + shift @path; + my $node = $this->data ? $this->data->selectSingleNode(@path) : undef; + + my @errors; + + if ($node) { + @errors = grep { ($_->Node || $_->Parent) == $node } @{$this->errors}; + } else { + @errors = grep $_->Schema == $sourceSchema, @{$this->errors}; + } + + return { + schema => $schema, + sourceSchema => $sourceSchema, + errors => \@errors, + data => $node, + nodeValue => $node && $node->nodeValue, # small hack set a non dom class property through + queryParameter => $queryParameter, + inputType => $sourceSchema->nodeProperty('inputType') || $schema->nodeProperty('inputType') + }; } sub makeContent { - my ($this,$mappings) = @_; - - my $formSchema = $this->schema->selectSingleNode(sub { $_->nodeName eq 'ComplexNode' and $_->name eq $this->base } ) - or die new Exception("Cant find a schema element for the specified form", $this->base); + my ($this,$mappings) = @_; + + my $formSchema = $this->schema->selectSingleNode(sub { $_->nodeName eq 'ComplexNode' and $_->name eq $this->base } ) + or die new Exception("Cant find a schema element for the specified form", $this->base); - my $doc = $this->document; - foreach my $itemSchema ( $formSchema->content->childNodes ) { - my $itemName = $itemSchema->name; - if (my $controlClass = $mappings->{$itemName} ) { - my $contorl = $doc->CreateControl($itemName,$controlClass,$this->makeControlArgs($itemName)); - $this->appendChild($contorl); - } - } - return; + my $doc = $this->document; + foreach my $itemSchema ( $formSchema->content->childNodes ) { + my $itemName = $itemSchema->name; + if (my $controlClass = $mappings->{$itemName} ) { + my $contorl = $doc->CreateControl($itemName,$controlClass,$this->makeControlArgs($itemName)); + $this->appendChild($contorl); + } + } + return; } sub formErrors { - my ($this) = @_; - - if (my $node = $this->data ) { - return [ - grep { - ( $_->Node || $_->Parent) == $node - } @{$this->errors} - ]; - } else { - return []; - } + my ($this) = @_; + + if (my $node = $this->data ) { + return [ + grep { + ( $_->Node || $_->Parent) == $node + } @{$this->errors} + ]; + } else { + return []; + } } 1;
--- a/Lib/IMPL/Web/View/TTControl.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/View/TTControl.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,86 +8,85 @@ use Scalar::Util qw(weaken); use parent qw( - IMPL::DOM::Node + IMPL::DOM::Node ); { - my $nextId = 1; - sub _GetNextId { - return $nextId++; - } + my $nextId = 1; + sub _GetNextId { + return $nextId++; + } } BEGIN { - public _dom property id => PROP_ALL; - - public property context => PROP_GET | PROP_OWNERSET; - public property template => PROP_ALL; + public _dom property id => PROP_ALL; + + public property context => PROP_GET | PROP_OWNERSET; + public property template => PROP_ALL; } sub CTOR { - my ($this,$name,$template,$context,$refProps) = @_; - - $name ||= "control"; - - $this->template( $template ) or die new IMPL::ArgumentException("A template is required"); - $this->context( $context ) or die new IMPL::ArgumentException("A context is required"); - - $this->id($name . "-" . _GetNextId()) unless $this->id; - - weaken($this); # prevent cyclic references produces by the code below - - $context->stash->set('append', sub { $this->appendChild(@_); undef; } ); - $context->stash->set('select', sub { $this->selectNodes(@_); } ); - + my ($this,$name,$template,$context,$refProps) = @_; + + $name ||= "control"; + + $this->template( $template ) or die new IMPL::ArgumentException("A template is required"); + $this->context( $context ) or die new IMPL::ArgumentException("A context is required"); + + $this->id($name . "-" . _GetNextId()) unless $this->id; + + weaken($this); # prevent cyclic references produces by the code below + + $context->stash->set('append', sub { $this->appendChild(@_); undef; } ); + $context->stash->set('select', sub { $this->selectNodes(@_); } ); + } our %CTOR = ( - 'IMPL::DOM::Node' => sub { - nodeName => $_[0], - %{ $_[3] || {} } - } + 'IMPL::DOM::Node' => sub { + nodeName => $_[0], + %{ $_[3] || {} } + } ); sub InitInstance { - my ($this,$args) = @_; - - $args ||= {}; - - if ( my $ctor = $this->template->blocks->{CTOR} ) { - $this->context->process($ctor, { %$args, this => $this } ); - $this->context->stash->set('this',undef); - } + my ($this,$args) = @_; + + $args ||= {}; + + if ( my $ctor = $this->template->blocks->{CTOR} ) { + $this->context->include($ctor, { %$args, this => $this } ); + } } sub renderBlock { - $_[0]->template->blocks->{RENDER} || $_[0]->template; + $_[0]->template->blocks->{RENDER} || $_[0]->template; } sub Render { - my ($this,$args) = @_; - - $args = {} unless ref $args eq 'HASH'; - - if(my $body = $this->renderBlock ) { - return $this->context->include( $body, { %$args, this => $this, template => $this->template, document => $this->document } ); - } else { - return ""; - } + my ($this,$args) = @_; + + $args = {} unless ref $args eq 'HASH'; + + if(my $body = $this->renderBlock ) { + return $this->context->include( $body, { %$args, this => $this, template => $this->template, document => $this->document } ); + } else { + return ""; + } } sub AUTOLOAD { - our $AUTOLOAD; - - my $method = ($AUTOLOAD =~ m/(\w+)$/)[0]; - - return if $method eq 'DESTROY'; - - my $this = shift; - - $this->nodeProperty($method,@_); + our $AUTOLOAD; + + my $method = ($AUTOLOAD =~ m/(\w+)$/)[0]; + + return if $method eq 'DESTROY'; + + my $this = shift; + + $this->nodeProperty($method,@_); } 1;
--- a/Lib/IMPL/Web/View/TTDocument.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/View/TTDocument.pm Tue Apr 10 20:08:29 2012 +0400 @@ -10,127 +10,130 @@ use parent qw( - IMPL::DOM::Document - IMPL::Web::View::TTControl + IMPL::DOM::Document + IMPL::Web::View::TTControl ); BEGIN { - public _dom property layout => PROP_ALL; - public property opts => PROP_GET | PROP_OWNERSET; - public property loader => PROP_GET | PROP_OWNERSET; - public property controls => PROP_GET | PROP_OWNERSET; - - # store the stash separately to make require() method to work correctly - # even when a stash of the context is modified during the processing - public property stash => PROP_GET | PROP_OWNERSET; + public _dom property layout => PROP_ALL; + public property opts => PROP_GET | PROP_OWNERSET; + public property loader => PROP_ALL; + public property controls => PROP_GET | PROP_OWNERSET; + + # store the stash separately to make require() method to work correctly + # even when a stash of the context is modified during the processing + public property stash => PROP_GET | PROP_OWNERSET; } sub CTOR { - my ($this,$template,$refOpts,%args) = @_; - - $this->controls({}); - $this->loader($args{loader}) if $args{loader}; - - $this->layout( $template->layout ) unless $this->layout; - - $this->opts($refOpts); - $this->stash($this->context->stash); - - my $self = $this; - weaken($self); - - $this->templateVars('require', sub { - my $doc = $self; - die new IMPL::Exception("A document is destroyed or invalid") unless $doc; - $doc->require(@_); - }); - - $this->templateVars('document', sub { $self } ); - $this->InitInstance(); + my ($this,$template,$refOpts,$loader,$vars) = @_; + + $this->controls({}); + $this->loader($loader) if $loader; + + $this->layout( $template->layout ) unless $this->layout; + + $this->opts($refOpts); + $this->stash($this->context->stash); + + my $self = $this; + weaken($self); + + $this->templateVars('require', sub { + my $doc = $self; + die new IMPL::Exception("A document is destroyed or invalid") unless $doc; + $doc->require(@_); + }); + + $this->templateVars('document', sub { $self } ); + $this->InitInstance($vars); } our %CTOR = ( - 'IMPL::Web::View::TTControl' => sub { - 'document', - $_[0], # template - new Template::Context($_[1]) # context - }, - 'IMPL::DOM::Document' => sub { - nodeName => 'document' - } + 'IMPL::Web::View::TTControl' => sub { + my ($template,$contextOpts) = @_; + 'document', + $_[0], # template + new Template::Context($_[1]) # context + }, + 'IMPL::DOM::Document' => sub { + nodeName => 'document' + } ); sub templateVars { - my $this = shift; - my $name = shift; - - if (@_) { - return $this->stash->set($name, shift); - } else { - return $this->stash->get($name); - } + my $this = shift; + my $name = shift; + + if (@_) { + return $this->stash->set($name, shift); + } else { + return $this->stash->get($name); + } } sub require { - my ($this, $control, $nodeProps) = @_; - - $nodeProps ||= {}; - $nodeProps->{document} = $this; - - if (my $factory = $this->controls->{$control}) { - return $factory; - } else { - - my $path = $control; - if ( my $template = $this->loader->template($path) ) { + my ($this, $control, $nodeProps) = @_; + + $nodeProps ||= {}; + $nodeProps->{document} = $this; + + if (my $factory = $this->controls->{$control}) { + return $factory; + } else { + + my $path = $control; + if ( my $template = $this->loader->template($path) ) { + my $opts = { %{$this->opts} }; - my $opts = { %{$this->opts} }; - $opts->{STASH} = $this->context->stash->clone(); + # avoid propagation of local variables + $opts->{STASH} = $this->stash->clone(); - my $ctx = new Template::Context($opts); - - $factory = new IMPL::Web::View::TTFactory( - typeof IMPL::Web::View::TTControl, - $template, - $ctx, - $opts, - { document => $this } - ); - - my @parts = split(/\/+/,$control); - - $this->controls->{$control} = $factory; - - return $factory; + my $ctx = new Template::Context($opts); + + $factory = new IMPL::Web::View::TTFactory( + $template->class || typeof IMPL::Web::View::TTControl, + $template, + $ctx, + $opts + ); + + my @parts = split(/\/+/,$control); + + $this->controls->{$control} = $factory; + + return $factory; - } else { - die new IMPL::KeyNotFoundException($control); - } - } + } else { + die new IMPL::KeyNotFoundException($control); + } + } } sub Render { - my ($this,$args) = @_; - - my $output; - - if ($this->layout) { - $output = $this->context->include( - $this->loader->template($this->layout), - { - content => sub { $output ||= $this->RenderContent($args); } - } - ); - } else { - return $this->RenderContent($args); - } - - return $output; + my ($this,$args) = @_; + + my $output; + + if ($this->layout) { + $output = $this->context->include( + $this->loader->template($this->layout), + { + content => sub { $output ||= $this->RenderContent($args); }, + this => $this, + template => $this->template + } + ); + } else { + return $this->RenderContent($args); + } + + return $output; } sub RenderContent { - my $this = shift; - return $this->SUPER::Render(@_); + my $this = shift; + return $this->SUPER::Render(@_); } @@ -215,7 +218,7 @@ =over -=item 1 C<require('my/org/input')> +=item 1 C<TInput = require('my/org/input')> =item 1 Загружает шаблон C<my/org/input.tt> @@ -229,7 +232,7 @@ =over -=item 1 C<< my.org.input.new('login') >> +=item 1 C<< TInput.new('login') >> =item 1 Если это первый элемент управления, то выполняетя статический конструктор в контексте фабрики
--- a/Lib/IMPL/Web/View/TTFactory.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/View/TTFactory.pm Tue Apr 10 20:08:29 2012 +0400 @@ -11,80 +11,75 @@ use parent qw(IMPL::Object::Factory); BEGIN { - public property template => PROP_ALL; - public property context => PROP_ALL; - public property opts => PROP_ALL; - public property nodeProperties => PROP_ALL; - public property instances => PROP_GET | PROP_OWNERSET; + public property template => PROP_ALL; + public property context => PROP_ALL; + public property opts => PROP_ALL; + public property nodeProperties => PROP_ALL; + public property instances => PROP_GET | PROP_OWNERSET; } __PACKAGE__->PassThroughArgs; sub CTOR { - my ($this,$factory,$template,$context,$options,$nodeProps) = @_; - - die IMPL::ArgumentException("A template is required") unless $template; - - $options ||= {}; - $context ||= new Template::Context($options); - - $this->template($template); - $this->context($context); - $this->opts($options); - $this->nodeProperties($nodeProps || {}); - $this->instances(0); - - my $doc = delete $nodeProps->{document}; - weaken($doc); - - $context->stash->set('require', sub { $doc->require(@_); } ); + my ($this,$factory,$template,$context,$options,$nodeProps) = @_; + + die IMPL::ArgumentException("A template is required") unless $template; + + $options ||= {}; + $context ||= new Template::Context($options); + + $this->template($template); + $this->context($context); + $this->opts($options); + $this->nodeProperties($nodeProps || {}); + $this->instances(0); } our %CTOR = ( - 'IMPL::Object::Factory' => sub { - $_[0] - } + 'IMPL::Object::Factory' => sub { + $_[0] + } ); sub MergeParameters { - my ($this,$name,$refProps) = @_; - - my $opts = { %{ $this->opts } }; - $opts->{STASH} = $opts->{STASH}->clone() if $opts->{STASH}; - - my $ctx = new Template::Context($opts); - - return ($name, $this->template, $ctx, hashMerge($this->nodeProperties,$refProps)); + my ($this,$name,$refProps) = @_; + + my $opts = { %{ $this->opts } }; + $opts->{STASH} = $opts->{STASH}->clone() if $opts->{STASH}; + + my $ctx = new Template::Context($opts); + + return ($name, $this->template, $ctx, hashMerge($this->nodeProperties,$refProps)); } sub CreateObject { - my $this = shift; - - my $count = $this->instances; - - unless($count) { - # нужно выполнить именно блок INIT шаблона при создании первого экземпляра - if (my $init = $this->template->blocks->{INIT}) { - $this->context->process($init); - } - } - - my $instance = $this->SUPER::CreateObject(@_); - - $instance->InitInstance(); - - $count++; - $this->instances($count); - - return $instance; + my $this = shift; + + my $count = $this->instances; + + unless($count) { + # нужно выполнить именно блок INIT шаблона при создании первого экземпляра + if (my $init = $this->template->blocks->{INIT}) { + $this->context->process($init); + } + } + + my $instance = $this->SUPER::CreateObject(@_); + + $instance->InitInstance(); + + $count++; + $this->instances($count); + + return $instance; } sub save { - die new IMPL::NotImplementedException("This class doesn't support serialization"); + die new IMPL::NotImplementedException("This class doesn't support serialization"); } sub restore { - die new IMPL::NotImplementedException("This class doesn't support serialization"); + die new IMPL::NotImplementedException("This class doesn't support serialization"); } 1; @@ -102,15 +97,15 @@ =begin code my $factory = new IMPL::Web::View::TTFactory( - typeof IMPL::Web::View::TTControl, - $doc, - $context, - { - TRIM => 1 - }, - { - myprop => 'my value' - }, + typeof IMPL::Web::View::TTControl, + $doc, + $context, + { + TRIM => 1 + }, + { + myprop => 'my value' + }, ); my $input1 = $factory->new('login', { class => "required" } ); @@ -122,9 +117,9 @@ =begin text [% - this.appendChild( - my.org.input.new('login', class = this.errors('login') ? "invalid" : "" ) - ); + this.appendChild( + my.org.input.new('login', class = this.errors('login') ? "invalid" : "" ) + ); %] =end text
--- a/Lib/IMPL/Web/View/TTLoader.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/Web/View/TTLoader.pm Tue Apr 10 20:08:29 2012 +0400 @@ -10,96 +10,100 @@ use IMPL::Web::View::TTDocument(); use parent qw( - IMPL::Object + IMPL::Object ); BEGIN { - public property options => PROP_ALL; - public property provider => PROP_GET | PROP_OWNERSET; - public property context => PROP_GET | PROP_OWNERSET; - public property ext => PROP_ALL; - - public property isInitialized => PROP_GET | PROP_OWNERSET; - public property initializer => PROP_GET | PROP_OWNERSET; + public property options => PROP_ALL; + public property provider => PROP_GET | PROP_OWNERSET; + public property context => PROP_GET | PROP_OWNERSET; + public property ext => PROP_ALL; + + public property isInitialized => PROP_GET | PROP_OWNERSET; + public property initializer => PROP_GET | PROP_OWNERSET; + + private property _globals => PROP_ALL; } sub CTOR { - my ($this,$refOpts,%args) = @_; - - $refOpts ||= {}; - - $this->ext(delete $args{ext}); - $this->initializer(delete $args{initializer}); - - $this->options($refOpts); - - # to aviod cyclic references we need to do a copy of $refOpts - $refOpts->{LOAD_TEMPLATES} = $this->provider(new Template::Provider( { %$refOpts } )); - - $this->context(new Template::Context($refOpts)); + my ($this,$refOpts,%args) = @_; + + $refOpts ||= {}; + + $this->ext($args{ext}) if $args{ext}; + $this->initializer($args{initializer}) if $args{initializer}; + $this->_globals(ref $args{globals} eq 'HASH' ? $args{globals} : {}); + + $this->options($refOpts); + + # to aviod cyclic references we need to do a copy of $refOpts + $refOpts->{LOAD_TEMPLATES} = $this->provider(new Template::Provider( { %$refOpts } )); + + $this->context(new Template::Context($refOpts)); } sub document { - my ($this,$name) = @_; - - my $tt = $this->template($name); - - $this->_init(); - - my $opts = { %{ $this->options } }; - - $opts->{STASH} = $this->context->stash->clone(); - $opts->{LOAD_TEMPLATES} = $this->provider; - - return new IMPL::Web::View::TTDocument( $tt, $opts, loader => $this ); + my ($this,$name,$vars) = @_; + + my $tt = $this->template($name); + + $this->_init(); + + my $opts = { %{ $this->options } }; + + $opts->{STASH} = $this->context->stash->clone(); + $opts->{LOAD_TEMPLATES} = $this->provider; + + return new IMPL::Web::View::TTDocument( $tt, $opts, $this, $vars ); } sub template { - my ($this,$name) = @_; - - $name =~ s/^\s+|\s+$//g; - - die new IMPL::ArgumentException("A valid template name is required") unless length $name; - - $name = $this->_appendExt($name); - - my ($tt,$error) = $this->provider->fetch($name); - - if (defined $error and $error == STATUS_DECLINED) { - die new IMPL::KeyNotFoundException($name); - } elsif (defined $error and $error == STATUS_ERROR) { - die new IMPL::Exception("Failed to load a template", $name, $tt); - } - - return $tt; + my ($this,$name) = @_; + + $name =~ s/^\s+|\s+$//g; + + die new IMPL::ArgumentException("A valid template name is required") unless length $name; + + $name = $this->_appendExt($name); + + my ($tt,$error) = $this->provider->fetch($name); + + if (defined $error and $error == STATUS_DECLINED) { + die new IMPL::KeyNotFoundException($name); + } elsif (defined $error and $error == STATUS_ERROR) { + die new IMPL::Exception("Failed to load a template", $name, $tt); + } + + return $tt; } sub _appendExt { - my ($this,$name) = @_; - - return $name unless $this->ext; - - if (length $this->ext and substr( $name, -length($this->ext) ) eq $this->ext) { - return $name; - } else { - return $name . $this->ext; - } + my ($this,$name) = @_; + + return $name unless $this->ext; + + if (length $this->ext and substr( $name, -length($this->ext) ) eq $this->ext) { + return $name; + } else { + return $name . $this->ext; + } } sub _init { - my ($this) = @_; - - if (!$this->isInitialized) { - if ($this->initializer) { - eval { - $this->context->process($this->initializer); - }; - if (my $e = $@) { - die new IMPL::Exception("Failed to process an initializer", $this->initializer, $e); - } - } - $this->isInitialized(1); - } + my ($this) = @_; + + if (!$this->isInitialized) { + my $initializer = $this->initializer || sub {}; + + eval { + $this->context->process($initializer,$this->_globals); + }; + if (my $e = $@) { + die new IMPL::Exception("Failed to process an initializer", $this->initializer, $e); + } + + $this->isInitialized(1); + } } 1; @@ -119,15 +123,15 @@ use IMPL::Web::View::TTLoader(); my $loader = new IMPL::Web::View::TTLoader( - { - INCLUDE_PATH => [ - '/my/app/tt', - '/my/app/tt/lib' - ] - }, - ext => '.tt', - initializer => 'shared/global' - + { + INCLUDE_PATH => [ + '/my/app/tt', + '/my/app/tt/lib' + ] + }, + ext => '.tt', + initializer => 'shared/global' + ); my $doc = $loader->document('index');
--- a/Lib/IMPL/_core/version.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/_core/version.pm Tue Apr 10 20:08:29 2012 +0400 @@ -3,7 +3,7 @@ our $VERSION = '0.04'; sub import { - *{scalar(caller).'::VERSION'} = \$VERSION; + *{scalar(caller).'::VERSION'} = \$VERSION; } 1;
--- a/Lib/IMPL/clone.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/clone.pm Tue Apr 10 20:08:29 2012 +0400 @@ -6,52 +6,52 @@ our @EXPORT_OK = qw(&clone); { - my %handlers = ( - HASH => sub { - my $class = blessed($_[0]); - - my $new = $_[1]->{ refaddr($_[0]) } = {}; - while (my ($key,$val) = each %{$_[0]}) { - $new->{$key} = clone($val,$_[1]); - } - $class ? bless $new, $class : $new; - }, - ARRAY => sub { - my $class = blessed($_[0]); - - my $new = $_[1]->{ refaddr($_[0]) } = []; - - push @$new, clone($_,$_[1]) foreach @{$_[0]}; - - $class ? bless( $new, $class ) : $new; - }, - SCALAR => sub { - my $class = blessed($_[0]); - - my $v = ${$_[0]}; - $class ? bless \$v, $class : \$v; - }, - REF => sub { - my $class = blessed($_[0]); - my $v; - my $new = $_[1]->{ refaddr($_[0]) } = \$v; - $v = clone ( ${$_[0]},$_[1] ); - $class ? bless \$v, $class : \$v; - - }, - REGEXP => sub { - $_[0]; - } - ); - - sub clone { - return unless @_; - - return $_[0] unless ref $_[0]; - - return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_); - } - + my %handlers = ( + HASH => sub { + my $class = blessed($_[0]); + + my $new = $_[1]->{ refaddr($_[0]) } = {}; + while (my ($key,$val) = each %{$_[0]}) { + $new->{$key} = clone($val,$_[1]); + } + $class ? bless $new, $class : $new; + }, + ARRAY => sub { + my $class = blessed($_[0]); + + my $new = $_[1]->{ refaddr($_[0]) } = []; + + push @$new, clone($_,$_[1]) foreach @{$_[0]}; + + $class ? bless( $new, $class ) : $new; + }, + SCALAR => sub { + my $class = blessed($_[0]); + + my $v = ${$_[0]}; + $class ? bless \$v, $class : \$v; + }, + REF => sub { + my $class = blessed($_[0]); + my $v; + my $new = $_[1]->{ refaddr($_[0]) } = \$v; + $v = clone ( ${$_[0]},$_[1] ); + $class ? bless \$v, $class : \$v; + + }, + REGEXP => sub { + $_[0]; + } + ); + + sub clone { + return unless @_; + + return $_[0] unless ref $_[0]; + + return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_); + } + } 1;
--- a/Lib/IMPL/lang.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/lang.pm Tue Apr 10 20:08:29 2012 +0400 @@ -10,224 +10,224 @@ our @EXPORT = qw(&is); our %EXPORT_TAGS = ( - base => [ - qw( - &is - &clone - ) - ], - constants => [ - qw( - &ACCESS_PUBLIC - &ACCESS_PROTECTED - &ACCESS_PRIVATE - &PROP_GET - &PROP_SET - &PROP_OWNERSET - &PROP_LIST - &PROP_ALL - ) - ], + base => [ + qw( + &is + &clone + ) + ], + constants => [ + qw( + &ACCESS_PUBLIC + &ACCESS_PROTECTED + &ACCESS_PRIVATE + &PROP_GET + &PROP_SET + &PROP_OWNERSET + &PROP_LIST + &PROP_ALL + ) + ], - declare => [ - qw( - &public - &protected - &private - &virtual - &property - &static - &property - ) - ], - compare => [ - qw( - &equals - &equals_s - &hashCompare - ) - ], - hash => [ - qw( - &hashApply - &hashMerge - &hashDiff - &hashCompare - &hashParse - &hashSave - ) - ] + declare => [ + qw( + &public + &protected + &private + &virtual + &property + &static + &property + ) + ], + compare => [ + qw( + &equals + &equals_s + &hashCompare + ) + ], + hash => [ + qw( + &hashApply + &hashMerge + &hashDiff + &hashCompare + &hashParse + &hashSave + ) + ] ); our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; use constant { - ACCESS_PUBLIC => 1, - ACCESS_PROTECTED => 2, - ACCESS_PRIVATE => 3, - PROP_GET => 1, - PROP_SET => 2, - PROP_OWNERSET => 10, - PROP_LIST => 4, - PROP_ALL => 3 + ACCESS_PUBLIC => 1, + ACCESS_PROTECTED => 2, + ACCESS_PRIVATE => 3, + PROP_GET => 1, + PROP_SET => 2, + PROP_OWNERSET => 10, + PROP_LIST => 4, + PROP_ALL => 3 }; sub is($$) { - eval { $_[0]->isa( $_[1] ) }; + eval { $_[0]->isa( $_[1] ) }; } sub virtual($) { - $_[0]->Virtual(1); - $_[0]; + $_[0]->Virtual(1); + $_[0]; } sub public($) { - $_[0]->Access(ACCESS_PUBLIC); - $_[0]->Implement; - $_[0]; + $_[0]->Access(ACCESS_PUBLIC); + $_[0]->Implement; + $_[0]; } sub private($) { - $_[0]->Access(ACCESS_PRIVATE); - $_[0]->Implement; - $_[0]; + $_[0]->Access(ACCESS_PRIVATE); + $_[0]->Implement; + $_[0]; } sub protected($) { - $_[0]->Access(ACCESS_PROTECTED); - $_[0]->Implement; - $_[0]; + $_[0]->Access(ACCESS_PROTECTED); + $_[0]->Implement; + $_[0]; } sub property($$;$) { - my ( $propName, $mutators, $attributes ) = @_; - my $Info = new IMPL::Class::PropertyInfo( - { - Name => $propName, - Mutators => $mutators, - Class => scalar(caller), - Attributes => $attributes - } - ); - return $Info; + my ( $propName, $mutators, $attributes ) = @_; + my $Info = new IMPL::Class::PropertyInfo( + { + Name => $propName, + Mutators => $mutators, + Class => scalar(caller), + Attributes => $attributes + } + ); + return $Info; } sub static($$) { - my ( $name, $value ) = @_; - my $class = caller; - $class->static_accessor( $name, $value ); + my ( $name, $value ) = @_; + my $class = caller; + $class->static_accessor( $name, $value ); } sub equals { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - - return $_[0] == $_[1]; - } else { - return 0 if defined $_[1]; - - return 1; - } + if (defined $_[0]) { + return 0 if (not defined $_[1]); + + return $_[0] == $_[1]; + } else { + return 0 if defined $_[1]; + + return 1; + } } sub equals_s { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - - return $_[0] eq $_[1]; - } else { - return 0 if defined $_[1]; - - return 1; - } + if (defined $_[0]) { + return 0 if (not defined $_[1]); + + return $_[0] eq $_[1]; + } else { + return 0 if defined $_[1]; + + return 1; + } } sub hashDiff { - my ($src,$dst) = @_; - - $dst = $dst ? { %$dst } : {} ; - $src ||= {}; - - my %result; - - foreach my $key ( keys %$src ) { - if (exists $dst->{$key}) { - $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); - delete $dst->{$key}; - } else { - $result{"-$key"} = 1; - } - } - - $result{"+$_"} = $dst->{$_} foreach keys %$dst; - - return \%result; + my ($src,$dst) = @_; + + $dst = $dst ? { %$dst } : {} ; + $src ||= {}; + + my %result; + + foreach my $key ( keys %$src ) { + if (exists $dst->{$key}) { + $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); + delete $dst->{$key}; + } else { + $result{"-$key"} = 1; + } + } + + $result{"+$_"} = $dst->{$_} foreach keys %$dst; + + return \%result; } sub hashMerge { - return hashApply( { %{$_[0]} }, $_[1] ); + return hashApply( { %{$_[0]} }, $_[1] ); } sub hashApply { - my ($target,$diff) = @_; - - while ( my ($key,$value) = each %$diff) { - $key =~ /^(\+|-)?(.*)$/; - my $op = $1 || '+'; - $key = $2; - - if ($op eq '-') { - delete $target->{$key}; - } else { - $target->{$key} = $value; - } - } - - return $target; + my ($target,$diff) = @_; + + while ( my ($key,$value) = each %$diff) { + $key =~ /^(\+|-)?(.*)$/; + my $op = $1 || '+'; + $key = $2; + + if ($op eq '-') { + delete $target->{$key}; + } else { + $target->{$key} = $value; + } + } + + return $target; } sub hashCompare { - my ($l,$r,$cmp) = @_; - - $cmp ||= \&equals_s; - - return 0 unless scalar keys %$l == scalar keys %$r; - &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; - - return 1; + my ($l,$r,$cmp) = @_; + + $cmp ||= \&equals_s; + + return 0 unless scalar keys %$l == scalar keys %$r; + &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; + + return 1; } sub hashParse { - my ($s,$p,$d) = @_; - - $p = $p ? qr/$p/ : qr/\n+/; - $d = $d ? qr/$d/ : qr/\s*=\s*/; - - return { - map split($d,$_,2), split($p,$s) - }; + my ($s,$p,$d) = @_; + + $p = $p ? qr/$p/ : qr/\n+/; + $d = $d ? qr/$d/ : qr/\s*=\s*/; + + return { + map split($d,$_,2), split($p,$s) + }; } sub hashSave { - my ($hash,$p,$d) = @_; - - return "" unless ref $hash eq 'HASH'; - - $p ||= "\n"; - $d ||= " = "; - - return - join( - $p, - map( - join( - $d, - $_, - $hash->{$_} - ), - keys %$hash - ) - ); + my ($hash,$p,$d) = @_; + + return "" unless ref $hash eq 'HASH'; + + $p ||= "\n"; + $d ||= " = "; + + return + join( + $p, + map( + join( + $d, + $_, + $hash->{$_} + ), + keys %$hash + ) + ); } 1;
--- a/Lib/IMPL/template.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/Lib/IMPL/template.pm Tue Apr 10 20:08:29 2012 +0400 @@ -5,42 +5,42 @@ use IMPL::Class::Template(); sub import { - shift; - my %args = @_; - - my $class = caller; - - my @paramNames = grep m/\w+/, @{$args{parameters} || []}; - my $declare = $args{declare}; - my @isa = (@{$args{base} || []}, $class); - my %instances; - - no strict 'refs'; - - push @{"${class}::ISA"}, 'IMPL::Class::Template'; - - *{"${class}::$_"} = sub { die IMPL::InvalidOperationException("A template parameter isn't available here") } - foreach @paramNames; - - *{"${class}::spec"} = sub { - my ($self,@params) = @_; - - my $specClass = $self->makeName(@params); - - return $specClass if $instances{$specClass}; - - $instances{$specClass} = 1; - - for (my $i=0; $i < @paramNames; $i++) { - my $param = $params[$i]; - *{"${specClass}::$paramNames[$i]"} = sub { $param }; - } - - @{"${specClass}::ISA"} = @isa; - - &$declare($specClass) if $declare; - return $specClass; - }; + shift; + my %args = @_; + + my $class = caller; + + my @paramNames = grep m/\w+/, @{$args{parameters} || []}; + my $declare = $args{declare}; + my @isa = (@{$args{base} || []}, $class); + my %instances; + + no strict 'refs'; + + push @{"${class}::ISA"}, 'IMPL::Class::Template'; + + *{"${class}::$_"} = sub { die IMPL::InvalidOperationException("A template parameter isn't available here") } + foreach @paramNames; + + *{"${class}::spec"} = sub { + my ($self,@params) = @_; + + my $specClass = $self->makeName(@params); + + return $specClass if $instances{$specClass}; + + $instances{$specClass} = 1; + + for (my $i=0; $i < @paramNames; $i++) { + my $param = $params[$i]; + *{"${specClass}::$paramNames[$i]"} = sub { $param }; + } + + @{"${specClass}::ISA"} = @isa; + + &$declare($specClass) if $declare; + return $specClass; + }; } 1; @@ -62,19 +62,19 @@ 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; - } + 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'}; + public property id => prop_get | owner_set, { type => 'integer'}; } __PACKAGE__->PassThroughArgs; @@ -85,32 +85,32 @@ 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 ); - } + 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 ) ); + 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 ) ); } package main; use IMPL::require { - TFoo => 'Some::Package::Foo', - TBar => 'Some::Package::Bar' + TFoo => 'Some::Package::Foo', + TBar => 'Some::Package::Bar' }; my $TCol = spec MyCollection(TFoo, TBar);
--- a/_doc/make.pl Tue Apr 10 08:13:22 2012 +0400 +++ b/_doc/make.pl Tue Apr 10 20:08:29 2012 +0400 @@ -25,8 +25,8 @@ my $dir =$OutDir; foreach my $part (@path[0..$#path-1]) { - $dir = File::Spec->catdir($dir,$part); - mkdir $dir unless -d $dir; + $dir = File::Spec->catdir($dir,$part); + mkdir $dir unless -d $dir; } open my $hPod, "<:encoding(utf-8)", $fname or die "Failed to open $fname for input: $!"; @@ -47,43 +47,43 @@ opendir my $hdir, $dirname or die "faield to open dir $dirname: $!"; foreach my $entry (readdir $hdir) { - next if grep $_ eq $entry, '.','..'; - - my $path = "$dirname/$entry"; - - print "$path"; - - if (-d $path) { - print "\n"; - local $index = exists $index->{items}{$entry} ? $index->{items}{$entry} : ($index->{items}{$entry} = {name => $entry}); - process_dir($path,@dirs,$entry); - } elsif ($entry =~ /\.(pm|pod)$/) { - print "\tprocessed\n"; - process_file($path,@dirs,$entry); - } else { - print "\tskipped\n"; - } + next if grep $_ eq $entry, '.','..'; + + my $path = "$dirname/$entry"; + + print "$path"; + + if (-d $path) { + print "\n"; + local $index = exists $index->{items}{$entry} ? $index->{items}{$entry} : ($index->{items}{$entry} = {name => $entry}); + process_dir($path,@dirs,$entry); + } elsif ($entry =~ /\.(pm|pod)$/) { + print "\tprocessed\n"; + process_file($path,@dirs,$entry); + } else { + print "\tskipped\n"; + } } } sub build_index { - my ($hout,$index) = @_; - - print $hout "\n<ul>\n"; - - if ($index->{items}) { - foreach my $itemKey (sort keys %{$index->{items}}) { - my $item = $index->{items}{$itemKey}; - print $hout "<li>"; - print $hout "<a target='content' href='$item->{url}'>" if $item->{url}; - print $hout $item->{name}; - print $hout "</a>" if $item->{url}; - build_index($hout,$item) if $item->{items}; - print $hout "</li>\n"; - } - } - - print $hout "</ul>\n"; + my ($hout,$index) = @_; + + print $hout "\n<ul>\n"; + + if ($index->{items}) { + foreach my $itemKey (sort keys %{$index->{items}}) { + my $item = $index->{items}{$itemKey}; + print $hout "<li>"; + print $hout "<a target='content' href='$item->{url}'>" if $item->{url}; + print $hout $item->{name}; + print $hout "</a>" if $item->{url}; + build_index($hout,$item) if $item->{items}; + print $hout "</li>\n"; + } + } + + print $hout "</ul>\n"; } `rm -r html`; @@ -120,8 +120,8 @@ <title>IMPL reference</title> </head> <frameset cols="20%,*"> - <frame name="toc" src="toc.html"/> - <frame name="content" src="about:blank"/> + <frame name="toc" src="toc.html"/> + <frame name="content" src="about:blank"/> </frameset> </html> FRAMES @@ -135,99 +135,99 @@ my ($self, $pod) = @_; return "<html>\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" /> \n<body bgcolor=\"#ffffff\">\n" - . $pod->content->present($self) + . $pod->content->present($self) . "</body>\n</html>\n"; } sub view_begin { - my ($self,$begin) = @_; - return code_highlight(join ("",$begin->content()),$begin->format); + my ($self,$begin) = @_; + return code_highlight(join ("",$begin->content()),$begin->format); } sub escape_html { - my %esc = ( - '&' => '&', - '>' => '>', - '<' => '<' - ); - - (my $text = shift) =~ s/([&><])/$esc{$1}/gex; - - return $text; + my %esc = ( + '&' => '&', + '>' => '>', + '<' => '<' + ); + + (my $text = shift) =~ s/([&><])/$esc{$1}/gex; + + return $text; } sub view_seq_link { - my ($self,$text) = @_; - - $text =~ s/(\w+(?:\:\:\w+)+)/ - if (my $url = $self->mk_filelink($1)) { - "<a href='$url'>$1<\/a>"; - } else { - $1; - } - /gex; - - return "<code>$text</code>"; + my ($self,$text) = @_; + + $text =~ s/(\w+(?:\:\:\w+)+)/ + if (my $url = $self->mk_filelink($1)) { + "<a href='$url'>$1<\/a>"; + } else { + $1; + } + /gex; + + return "<code>$text</code>"; } sub mk_filelink { - my ($self,$package) = @_; - - return undef unless $package; - - my @path = split /::/, $package; - - if ($path[0] eq 'IMPL') { - shift @path; - if (-f File::Spec->catfile($LibDir,@path).".pm") { - return '../'x($level-1) . File::Spec->catfile(@path).'.html'; - } - } - return undef; + my ($self,$package) = @_; + + return undef unless $package; + + my @path = split /::/, $package; + + if ($path[0] eq 'IMPL') { + shift @path; + if (-f File::Spec->catfile($LibDir,@path).".pm") { + return '../'x($level-1) . File::Spec->catfile(@path).'.html'; + } + } + return undef; } sub view_seq_code { - goto &view_seq_link; + goto &view_seq_link; } sub view_code { - my ($self,$code) = @_; - - return code_highlight($code); + my ($self,$code) = @_; + + return code_highlight($code); } sub code_highlight { - my ($text,$format) = @_; - - if ($format) { - $format =~ s/code//i; - $format =~ s/\s+//g; - } - - $format ||= 'perl'; - - return "<pre>".escape_html($text)."</pre>\n" if $format =~ /^text$/i; - - - - my ($hin,$hout); - local $/ = undef; - my $pid = eval { open2( - $hin, $hout, 'source-highlight' => ( - '--src-lang' => $format, - ) - ) } or return "<pre>".escape_html($text)."</pre>\n"; - - binmode $hout, ':encoding(utf8)'; - binmode $hin, ':encoding(utf8)'; - - print $hout $text; - - undef $hout; - - my $fragment = <$hin>; - - undef $hin; - - return $fragment; - + my ($text,$format) = @_; + + if ($format) { + $format =~ s/code//i; + $format =~ s/\s+//g; + } + + $format ||= 'perl'; + + return "<pre>".escape_html($text)."</pre>\n" if $format =~ /^text$/i; + + + + my ($hin,$hout); + local $/ = undef; + my $pid = eval { open2( + $hin, $hout, 'source-highlight' => ( + '--src-lang' => $format, + ) + ) } or return "<pre>".escape_html($text)."</pre>\n"; + + binmode $hout, ':encoding(utf8)'; + binmode $hin, ':encoding(utf8)'; + + print $hout $text; + + undef $hout; + + my $fragment = <$hin>; + + undef $hin; + + return $fragment; + }
--- a/_test/Resources/TTView.Output/Panel.txt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView.Output/Panel.txt Tue Apr 10 20:08:29 2012 +0400 @@ -1,8 +1,8 @@ <div class="simple" data-dojo-type="dijit.form.Input"> - <div data-dojo-type="dijit.layout.ContentPane">one</div> - <hr /> - <div data-dojo-type="dijit.layout.ContentPane">two</div> - <hr /> - <div data-dojo-type="dijit.layout.ContentPane">hello world</div> - <hr /> - </div> \ No newline at end of file + <div data-dojo-type="dijit.layout.ContentPane">one</div> + <hr /> + <div data-dojo-type="dijit.layout.ContentPane">two</div> + <hr /> + <div data-dojo-type="dijit.layout.ContentPane">hello world</div> + <hr /> + </div> \ No newline at end of file
--- a/_test/Resources/TTView/Layout/default.tt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView/Layout/default.tt Tue Apr 10 20:08:29 2012 +0400 @@ -1,16 +1,16 @@ <html> - <head> - <title>$site.name - $title</title> - [% IF dojo.require.size; - modules = []; - modules.push('"' _ item _ '"') FOREACH item IN dojo.require.unique(); - %] - <script type="text/javascript"> - require([ [% modules.join(', ') %] ]); - </script> - [% END %] - </head> - <body> - [% content %] - </body> + <head> + <title>$site.name - [% document.title || template.title %]</title> + [% IF dojo.require.size; + modules = []; + modules.push('"' _ item _ '"') FOREACH item IN dojo.require.unique(); + %] + <script type="text/javascript"> + require([ [% modules.join(', ') %] ]); + </script> + [% END %] + </head> + <body> + [% content %] + </body> </html> \ No newline at end of file
--- a/_test/Resources/TTView/My/Org/Panel.tt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView/My/Org/Panel.tt Tue Apr 10 20:08:29 2012 +0400 @@ -1,21 +1,21 @@ [% - META version = 1; - BLOCK INIT; - dojoDefaultClass = 'dijit.form.Input'; - dojo.require.push( dojoDefaultClass ); - TPreview = require('My/Org/TextPreview'); - END; - BLOCK CTOR; - dojoClass = dojoDefaultClass; - visualClass = this.visualClass || 'classic'; - FOREACH text IN this.data; - append(TPreview.new('preview', nodeValue = text )); - END; - END; + META version = 1; + BLOCK INIT; + dojoDefaultClass = 'dijit.form.Input'; + dojo.require.push( dojoDefaultClass ); + TPreview = require('My/Org/TextPreview'); + END; + BLOCK CTOR; + this.dojoClass = this.dojoClass || dojoDefaultClass; + this.visualClass = this.visualClass || 'classic'; + FOREACH text IN this.data; + append(TPreview.new('preview', nodeValue = text )); + END; + END; %] -<div class="$visualClass" data-dojo-type="$dojoClass"> - [% FOREACH node IN select('preview') %] - [% node.Render() %] - <hr /> - [% END %] +<div class="$this.visualClass" data-dojo-type="$this.dojoClass"> + [% FOREACH node IN select('preview') %] + [% node.Render() %] + <hr /> + [% END %] </div> \ No newline at end of file
--- a/_test/Resources/TTView/My/Org/TextPreview.tt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView/My/Org/TextPreview.tt Tue Apr 10 20:08:29 2012 +0400 @@ -1,8 +1,8 @@ [% - BLOCK INIT; - dojo.require.push("dijit.layout.ContentPane"); - END; + BLOCK INIT; + dojo.require.push("dijit.layout.ContentPane"); + END; %] [% BLOCK RENDER %] - <div data-dojo-type="dijit.layout.ContentPane">$this.nodeValue</div> + <div data-dojo-type="dijit.layout.ContentPane">$this.nodeValue</div> [% END %] \ No newline at end of file
--- a/_test/Resources/TTView/complex.tt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView/complex.tt Tue Apr 10 20:08:29 2012 +0400 @@ -1,12 +1,12 @@ [% - META version = 1, title = "my document 2", layout= "Layout/default"; + META version = 1, title = "my document 2", layout= "Layout/default"; - BLOCK CTOR; - TPanel = require('My/Org/Panel'); - append( TPanel.new('information', data = this.data ) ); - END; + BLOCK CTOR; + TPanel = require('My/Org/Panel'); + append( TPanel.new('information', data = data ) ); + END; %] [% FOREACH node IN this.childNodes() %] - <div>[% node.Render() %]</div> + <div>[% node.Render() %]</div> [% END %] \ No newline at end of file
--- a/_test/Resources/TTView/global.tt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView/global.tt Tue Apr 10 20:08:29 2012 +0400 @@ -1,6 +1,6 @@ [% META version = 1; - user = 'test_user'; - dojo.require = []; + user = 'test_user'; + dojo.require = []; %] \ No newline at end of file
--- a/_test/Resources/TTView/simple.tt Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Resources/TTView/simple.tt Tue Apr 10 20:08:29 2012 +0400 @@ -1,5 +1,5 @@ [% META title = "Документ 1", version = 10 %] [% BLOCK CTOR; - templateVar = "initialized by the constructor"; + templateVar = "initialized by the constructor"; END; %] $user - $template.title \ No newline at end of file
--- a/_test/Test/Class/Meta.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/Class/Meta.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,39 +8,39 @@ use IMPL::Test qw(test failed); test defineFooClassData => sub { - Foo->class_data(info => {}); + Foo->class_data(info => {}); }; test updateFooClassData => sub { - Foo->class_data('info')->{data} = 'Foo' ; + Foo->class_data('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'; + failed "Wrong class data", "Expected: Foo", "Got: ".Foo->class_data('info')->{data} unless Foo->class_data('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'; + failed "Wrong class data", "Expected: Foo", "Got: ".Baz->class_data('info')->{data} unless Baz->class_data('info')->{data} eq 'Foo'; }; test updateBarClassData => sub { - Bar->class_data('info')->{data} = 'Bar'; + Bar->class_data('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'; + failed "Wrong class data", "Expected: Bar", "Got: ".Bar->class_data('info')->{data} unless Bar->class_data('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'; + failed "Wrong class data", "Expected: Foo", "Got: ".Foo->class_data('info')->{data} unless Foo->class_data('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'; + failed "Wrong class data", "Expected: Foo", "Got: ".Baz->class_data('info')->{data} unless Baz->class_data('info')->{data} eq 'Foo'; }; test getwrongBazClassData => sub { - failed "Wrong class data", "Expected: undef", "Got: ".Foo->class_data( 'info2' ) if Foo->class_data( 'info2' ); + failed "Wrong class data", "Expected: undef", "Got: ".Foo->class_data( 'info2' ) if Foo->class_data( 'info2' ); };
--- a/_test/Test/Class/Template.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/Class/Template.pm Tue Apr 10 20:08:29 2012 +0400 @@ -10,36 +10,36 @@ use IMPL::lang; { - package My::Collection; - use parent qw(IMPL::Object); - use IMPL::Class::Property; - - use IMPL::template ( - parameters => [qw(TValue)], - declare => sub { - my ($class) = @_; - - public $class->CreateProperty( items => prop_get | owner_set | prop_list, { type => $class->TValue } ); - } - ); - - BEGIN { - public property name => prop_all; - } + package My::Collection; + use parent qw(IMPL::Object); + use IMPL::Class::Property; + + use IMPL::template ( + parameters => [qw(TValue)], + declare => sub { + my ($class) = @_; + + public $class->CreateProperty( items => prop_get | owner_set | prop_list, { type => $class->TValue } ); + } + ); + + BEGIN { + public property name => prop_all; + } }; test IsDerivedFromTemplate => sub { - failed "My::Collection should be a subclass of IMPL::Class:Template" unless is('My::Collection','IMPL::Class::Template'); + failed "My::Collection should be a subclass of IMPL::Class:Template" unless is('My::Collection','IMPL::Class::Template'); }; test Specialize => sub { - my $colList = spec My::Collection('IMPL::Object::List'); - my $colObj = spec My::Collection('IMPL::Object'); - my $colList2 = spec My::Collection('IMPL::Object::List'); - - failed "Wrong class name", "expected: My::ColectionLis", "got: $colList" unless $colList eq 'My::CollectionList'; - failed "Wrong template parameter type", "expected: IMPL::Object::List", "got" . $colList->TValue unless $colList->TValue eq 'IMPL::Object::List'; - + my $colList = spec My::Collection('IMPL::Object::List'); + my $colObj = spec My::Collection('IMPL::Object'); + my $colList2 = spec My::Collection('IMPL::Object::List'); + + failed "Wrong class name", "expected: My::ColectionLis", "got: $colList" unless $colList eq 'My::CollectionList'; + failed "Wrong template parameter type", "expected: IMPL::Object::List", "got" . $colList->TValue unless $colList->TValue eq 'IMPL::Object::List'; + }; 1;
--- a/_test/Test/DOM/Node.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/DOM/Node.pm Tue Apr 10 20:08:29 2012 +0400 @@ -47,9 +47,9 @@ }; test DocumentCreateNode => sub { - my ($this) = @_; - - my $child = $this->Root->firstChild->appendNode($this->Root->Create(Info => { uuid => '77f9-9a-6d58' } )) or failed "Failed to append a child node"; + my ($this) = @_; + + my $child = $this->Root->firstChild->appendNode($this->Root->Create(Info => { uuid => '77f9-9a-6d58' } )) or failed "Failed to append a child node"; failed "document property is undef" unless $child->document; failed "document property returned incorrect value" unless $child->document == $this->Root; @@ -105,27 +105,27 @@ }; test SelectNodesPath => sub { - my ($this) = @_; - - my @result = $this->Root->selectNodes('Child','Info'); - - failed "Failed to select a node by path 'Child/Info'" unless @result; + my ($this) = @_; + + my @result = $this->Root->selectNodes('Child','Info'); + + failed "Failed to select a node by path 'Child/Info'" unless @result; }; test SelectByAxisDescendant => sub { - my ($this) = @_; - - my @result = $this->Root->selectNodes( { descendant => ['GrandChild','Info']} ); - - failed "Failed to select a node by path '//(GrandChild|Info)/'" unless @result == 2; + my ($this) = @_; + + my @result = $this->Root->selectNodes( { descendant => ['GrandChild','Info']} ); + + failed "Failed to select a node by path '//(GrandChild|Info)/'" unless @result == 2; }; test SelectByAxisAncestor => sub { - my ($this) = @_; - - my @result = $this->Root->selectSingleNode( { descendant => 'Info'} )->selectNodes( { ancestor => undef } ) ; - - failed "Failed to select a node by path '//Info/ancestor:*'" unless @result == 2; + my ($this) = @_; + + my @result = $this->Root->selectSingleNode( { descendant => 'Info'} )->selectNodes( { ancestor => undef } ) ; + + failed "Failed to select a node by path '//Info/ancestor:*'" unless @result == 2; }; test CheckNodesValues => sub { @@ -156,82 +156,82 @@ }; test setObjectProperty => sub { - my ($this) = @_; - - my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); - - my $name = 'Vergon 6'; - - $node->nodeProperty(name => $name); - failed "Failed to set a property 'name'", "Expected: $name", "Got: ".$node->name unless $node->name eq $name; - - $name = 'entity_vergon_6'; - $node->systemName($name); - failed "Failed to set a property 'systemName'", "Expected: $name", "Got: ".$node->nodeProperty('systemName') unless $node->nodeProperty('systemName') eq $name; + my ($this) = @_; + + my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); + + my $name = 'Vergon 6'; + + $node->nodeProperty(name => $name); + failed "Failed to set a property 'name'", "Expected: $name", "Got: ".$node->name unless $node->name eq $name; + + $name = 'entity_vergon_6'; + $node->systemName($name); + failed "Failed to set a property 'systemName'", "Expected: $name", "Got: ".$node->nodeProperty('systemName') unless $node->nodeProperty('systemName') eq $name; }; test setDynamicProperty => sub { - my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); - - my $uuid = 'entity_76fd98b9e7a'; - $node->nodeProperty(uuid => $uuid); - failed "Failed to set a dynamic property 'uuid'", "Expected: $uuid", "Got: ".$node->nodeProperty('uuid') unless $node->nodeProperty('uuid') eq $uuid; + my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); + + my $uuid = 'entity_76fd98b9e7a'; + $node->nodeProperty(uuid => $uuid); + failed "Failed to set a dynamic property 'uuid'", "Expected: $uuid", "Got: ".$node->nodeProperty('uuid') unless $node->nodeProperty('uuid') eq $uuid; }; test setPrivateProperty => sub { - my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); - - eval { - $node->nodeProperty(_private => 'failed'); - 1; - } and failed "Setting a private property successfull"; + my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); + + eval { + $node->nodeProperty(_private => 'failed'); + 1; + } and failed "Setting a private property successfull"; }; test createNodeWithProps => sub { - my $uuid = 'entity_76fd98b9e7a'; - my $name = 'Vergon 6'; - my $systemName = 'entity_vergon_6'; - - my $node = Test::DOM::TypedNode->new( - nodeName => 'TestNode', - uuid => $uuid, - name => $name, - systemName => $systemName - ); - - failed "Failed to get dynamic property 'uuid'" unless $node->nodeProperty('uuid') eq $uuid; - failed "Failed to get property 'name' through nodeProperty method" unless $node->nodeProperty('name') eq $name; - failed "Failed to get property name directly" unless $node->name eq $name; + my $uuid = 'entity_76fd98b9e7a'; + my $name = 'Vergon 6'; + my $systemName = 'entity_vergon_6'; + + my $node = Test::DOM::TypedNode->new( + nodeName => 'TestNode', + uuid => $uuid, + name => $name, + systemName => $systemName + ); + + failed "Failed to get dynamic property 'uuid'" unless $node->nodeProperty('uuid') eq $uuid; + failed "Failed to get property 'name' through nodeProperty method" unless $node->nodeProperty('name') eq $name; + failed "Failed to get property name directly" unless $node->name eq $name; }; test listNodePredefinedProps => sub { - my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); - - my @props = $node->listProperties; - my @expected = qw(name _private); - - failed "Got wrong list of props", @props unless cmparray(\@props,\@expected); + my $node = Test::DOM::TypedNode->new(nodeName => 'TestNode'); + + my @props = $node->listProperties; + my @expected = qw(name _private); + + failed "Got wrong list of props", @props unless cmparray(\@props,\@expected); }; test listNodeAllProps => sub { - my $node = Test::DOM::TypedNode->new( - nodeName => 'TestNode', - uuid => 'ade58f98b', # dynamic - name => 'noname', # predefined - systemName => 'no sys' # not visible to DOM - ); - - my @props = $node->listProperties; - my @expected = qw(name _private uuid); # systemName is not a DOM prop - - failed "Got wrong list of props", @props unless cmparray(\@props,\@expected); + my $node = Test::DOM::TypedNode->new( + nodeName => 'TestNode', + uuid => 'ade58f98b', # dynamic + name => 'noname', # predefined + systemName => 'no sys' # not visible to DOM + ); + + my @props = $node->listProperties; + my @expected = qw(name _private uuid); # systemName is not a DOM prop + + failed "Got wrong list of props", @props unless cmparray(\@props,\@expected); }; test MemoryLeaks => sub { - my $doc = new IMPL::DOM::Document(nodeName => 'Root'); - weaken($doc); - - assert(not defined $doc); + my $doc = new IMPL::DOM::Document(nodeName => 'Root'); + weaken($doc); + + assert(not defined $doc); }; package Test::DOM::TypedNode; @@ -242,9 +242,9 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public _dom property name => prop_all; - public property systemName => prop_all; - private _dom property _private => prop_all; + public _dom property name => prop_all; + public property systemName => prop_all; + private _dom property _private => prop_all; }
--- a/_test/Test/DOM/Schema.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/DOM/Schema.pm Tue Apr 10 20:08:29 2012 +0400 @@ -102,19 +102,19 @@ }; test LoadXmlSchemaTypes => sub { - my ($this) = @_; - - my $schema = IMPL::DOM::Schema->LoadSchema("Resources/types.xml") or failed "Failed to parse schema"; - - return 1; + my ($this) = @_; + + my $schema = IMPL::DOM::Schema->LoadSchema("Resources/types.xml") or failed "Failed to parse schema"; + + return 1; }; test LoadXmlSchemaData => sub { - my ($this) = @_; - - my $schema = IMPL::DOM::Schema->LoadSchema("Resources/form.xml") or failed "Failed to parse schema"; - - return 1; + my ($this) = @_; + + my $schema = IMPL::DOM::Schema->LoadSchema("Resources/form.xml") or failed "Failed to parse schema"; + + return 1; };
--- a/_test/Test/Lang.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/Lang.pm Tue Apr 10 20:08:29 2012 +0400 @@ -11,101 +11,101 @@ __PACKAGE__->PassThroughArgs; test equals => sub { - assert( equals(1,1) ); - assert( !equals(1,2) ); - - { - my $warns = 0; - local $SIG{__WARN__} = sub { $warns++ }; - - assert( !equals("1","2") ); - assert( equals("sfds","zxcvgfd") ); - assert( $warns == 2); - } - - assert( equals(undef,undef) ); - assert( !equals(1,undef) ); - assert( !equals(undef,"zcx") ); + assert( equals(1,1) ); + assert( !equals(1,2) ); + + { + my $warns = 0; + local $SIG{__WARN__} = sub { $warns++ }; + + assert( !equals("1","2") ); + assert( equals("sfds","zxcvgfd") ); + assert( $warns == 2); + } + + assert( equals(undef,undef) ); + assert( !equals(1,undef) ); + assert( !equals(undef,"zcx") ); }; test equals_s => sub { - assert( equals_s(1,1) ); - assert( !equals_s(1,2) ); - - assert( !equals_s("1","2") ); - assert( !equals_s("sfds","zxcvgfd") ); - - assert( equals_s(undef,undef) ); - assert( !equals_s(1,undef) ); - assert( !equals_s(undef,"zcx") ); - - assert( equals_s("qwerty","qwerty") ); + assert( equals_s(1,1) ); + assert( !equals_s(1,2) ); + + assert( !equals_s("1","2") ); + assert( !equals_s("sfds","zxcvgfd") ); + + assert( equals_s(undef,undef) ); + assert( !equals_s(1,undef) ); + assert( !equals_s(undef,"zcx") ); + + assert( equals_s("qwerty","qwerty") ); }; test hash => sub { - - my %a = ( - a => 'a', - b => 'b', - c => 'c' - ); - - my %b = ( - a => 'a', - c => 'z', - x => 'x', - ); - - my %diff = ( - '-b' => 1, - '+c' => 'z', - '+x' => 'x' - ); - - - assert( ! hashCompare(\%a,\%b) ); - assert( hashCompare(\%a,\%a) ); - - my $res = hashDiff(\%a,\%b); - - assert( ! hashCompare({},$res) ); - assert( hashCompare($res,\%diff) ); - - assert( hashCompare( \%b, hashMerge(\%a,\%diff) ) ); - + + my %a = ( + a => 'a', + b => 'b', + c => 'c' + ); + + my %b = ( + a => 'a', + c => 'z', + x => 'x', + ); + + my %diff = ( + '-b' => 1, + '+c' => 'z', + '+x' => 'x' + ); + + + assert( ! hashCompare(\%a,\%b) ); + assert( hashCompare(\%a,\%a) ); + + my $res = hashDiff(\%a,\%b); + + assert( ! hashCompare({},$res) ); + assert( hashCompare($res,\%diff) ); + + assert( hashCompare( \%b, hashMerge(\%a,\%diff) ) ); + }; test clone => sub { - - my $a; - - my $b = clone($a); - - assert(not defined $b); - - my $lp = { a => '1', rx => qr/abc$/ }; - $lp->{b} = $lp; - - my $c = clone($lp); - - assert($c); - assert($c->{b}); - assert($c->{b} == $c); - assert(reftype $c->{rx} eq 'REGEXP'); - + + my $a; + + my $b = clone($a); + + assert(not defined $b); + + my $lp = { a => '1', rx => qr/abc$/ }; + $lp->{b} = $lp; + + my $c = clone($lp); + + assert($c); + assert($c->{b}); + assert($c->{b} == $c); + assert(reftype $c->{rx} eq 'REGEXP'); + }; -test hashParse => sub { - my $res = hashParse("a = test a\nb = test b\nc c=test c"); - - assert($res->{a} eq "test a"); - assert($res->{b} eq "test b"); - assert($res->{"c c"} eq "test c"); - - $res = hashParse("a:b, c: d",qr/\s*:\s*/,qr/\s*,\s*/); - - assert($res->{a} eq "b"); - assert($res->{c} eq "d"); +test hashParse => sub { + my $res = hashParse("a = test a\nb = test b\nc c=test c"); + + assert($res->{a} eq "test a"); + assert($res->{b} eq "test b"); + assert($res->{"c c"} eq "test c"); + + $res = hashParse("a:b, c: d",qr/\s*:\s*/,qr/\s*,\s*/); + + assert($res->{a} eq "b"); + assert($res->{c} eq "d"); }; 1;
--- a/_test/Test/Object/Fields.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/Object/Fields.pm Tue Apr 10 20:08:29 2012 +0400 @@ -8,47 +8,47 @@ __PACKAGE__->PassThroughArgs; { - package Fields::Foo; - use base qw(IMPL::Object::Fields); - - use fields qw(name info); - - sub CTOR { - my ($this,$name,$info) = @_; - - $this->{name} = $name; - $this->{info} = $info; - } - - package Fields::Bar; - use base qw(Fields::Foo); - use fields qw(id); - - our %CTOR = ( - 'Fields::Foo' => sub { - my %args = @_; - Bar => $args{info}; - } - ); - - sub CTOR { - my ($this,%args) = @_; - - $this->{id} = $args{id}; - } + package Fields::Foo; + use base qw(IMPL::Object::Fields); + + use fields qw(name info); + + sub CTOR { + my ($this,$name,$info) = @_; + + $this->{name} = $name; + $this->{info} = $info; + } + + package Fields::Bar; + use base qw(Fields::Foo); + use fields qw(id); + + our %CTOR = ( + 'Fields::Foo' => sub { + my %args = @_; + Bar => $args{info}; + } + ); + + sub CTOR { + my ($this,%args) = @_; + + $this->{id} = $args{id}; + } } test constructObject => sub { - my $obj = new Fields::Foo( Peter => '34-fg-78' ); - - $obj->{name} eq 'Peter' or failed "A value of 'name' field is wrong","Expected: 'Peter'","Got: '$obj->{name}'"; + my $obj = new Fields::Foo( Peter => '34-fg-78' ); + + $obj->{name} eq 'Peter' or failed "A value of 'name' field is wrong","Expected: 'Peter'","Got: '$obj->{name}'"; }; test inheritance => sub { - my $obj = new Fields::Bar( id => '1ba356f', info => 'standard bar'); - - $obj->{name} eq 'Bar' or failed "A value of 'name' property is wrong","Expected: 'Bar'","Got: '$obj->{name}'"; - $obj->{id} eq '1ba356f' or failed "A value of 'id' property is wrong","Expected: '1ba356f'","Got: '$obj->{id}'"; + my $obj = new Fields::Bar( id => '1ba356f', info => 'standard bar'); + + $obj->{name} eq 'Bar' or failed "A value of 'name' property is wrong","Expected: 'Bar'","Got: '$obj->{name}'"; + $obj->{id} eq '1ba356f' or failed "A value of 'id' property is wrong","Expected: '1ba356f'","Got: '$obj->{id}'"; }; 1;
--- a/_test/Test/SQL/Diff.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/SQL/Diff.pm Tue Apr 10 20:08:29 2012 +0400 @@ -12,37 +12,37 @@ __PACKAGE__->PassThroughArgs; test diff => sub { - my $schemaSrc = new IMPL::SQL::Schema(name => 'simple', version => 1 ); - - my $tbl = $schemaSrc->AddTable({ - name => 'User', - columns => [ - { name => 'name', type => Varchar(255) }, - { name => 'description', type => Varchar(255) } - ] - }); - - $tbl->AddConstraint( unique => { name => 'unique_name', columns => ['name'] }); - - my $schemaDst = new IMPL::SQL::Schema(name => 'simple', version => 2 ); - - my $users = $schemaDst->AddTable({ - name => 'User', - columns => [ - { name => 'id', type => Integer }, - { name => 'login', type => Varchar(255) }, - { name => 'description', type => Text, isNullable => 1 } - ] - }); - - $users->SetPrimaryKey('id'); - $users->AddConstraint( unique => { name => 'unique_login', columns => ['login'] } ); - - #warn Dumper(IMPL::SQL::Schema::Traits::Diff->Diff($schemaSrc,$schemaDst)); - - $schemaSrc->Dispose; - $schemaDst->Dispose; - + my $schemaSrc = new IMPL::SQL::Schema(name => 'simple', version => 1 ); + + my $tbl = $schemaSrc->AddTable({ + name => 'User', + columns => [ + { name => 'name', type => Varchar(255) }, + { name => 'description', type => Varchar(255) } + ] + }); + + $tbl->AddConstraint( unique => { name => 'unique_name', columns => ['name'] }); + + my $schemaDst = new IMPL::SQL::Schema(name => 'simple', version => 2 ); + + my $users = $schemaDst->AddTable({ + name => 'User', + columns => [ + { name => 'id', type => Integer }, + { name => 'login', type => Varchar(255) }, + { name => 'description', type => Text, isNullable => 1 } + ] + }); + + $users->SetPrimaryKey('id'); + $users->AddConstraint( unique => { name => 'unique_login', columns => ['login'] } ); + + #warn Dumper(IMPL::SQL::Schema::Traits::Diff->Diff($schemaSrc,$schemaDst)); + + $schemaSrc->Dispose; + $schemaDst->Dispose; + };
--- a/_test/Test/SQL/Schema.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/SQL/Schema.pm Tue Apr 10 20:08:29 2012 +0400 @@ -74,28 +74,28 @@ }; test SetPrimaryKey => sub { - my ($this) = @_; - - my $tableUser = $this->schemaDB->GetTable('User'); - my $tableRole = $this->schemaDB->GetTable('Role'); - - $tableUser->AddConstraint( pk => { columns => ['Id'], name => 'PK' }); - $tableRole->SetPrimaryKey('Id'); - - $tableUser->primaryKey->HasColumn('Id') or failed "A primary key of 'User' table should contain 'Id' column"; - $tableRole->primaryKey->HasColumn('Id') or failed "A primary key of 'Role' table should contain 'Id' column"; - + my ($this) = @_; + + my $tableUser = $this->schemaDB->GetTable('User'); + my $tableRole = $this->schemaDB->GetTable('Role'); + + $tableUser->AddConstraint( pk => { columns => ['Id'], name => 'PK' }); + $tableRole->SetPrimaryKey('Id'); + + $tableUser->primaryKey->HasColumn('Id') or failed "A primary key of 'User' table should contain 'Id' column"; + $tableRole->primaryKey->HasColumn('Id') or failed "A primary key of 'Role' table should contain 'Id' column"; + }; test LinkTables => sub { - my ($this) = @_; - - my $tableUser = $this->schemaDB->GetTable('User'); - my $tableRole = $this->schemaDB->GetTable('Role'); - - $tableUser->LinkTo($tableRole,'RoleId'); - - $tableUser->GetColumnConstraints('RoleId') == 1 or failed "Wrong constraints count for 'RoleId' column", $tableUser->GetColumnConstraints('RoleId'); + my ($this) = @_; + + my $tableUser = $this->schemaDB->GetTable('User'); + my $tableRole = $this->schemaDB->GetTable('Role'); + + $tableUser->LinkTo($tableRole,'RoleId'); + + $tableUser->GetColumnConstraints('RoleId') == 1 or failed "Wrong constraints count for 'RoleId' column", $tableUser->GetColumnConstraints('RoleId'); }; test AddConstraint => sub { @@ -116,44 +116,44 @@ }; test RemoveConstraint => sub { - my ($this) = @_; - - my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; - my $constraint = $table->GetConstraint('Role_ObsoleteId_Uniq'); - - eval { - $table->RemoveColumn('ObsoleteId'); - 1; - } and failed "Should not remove column with constraint"; - - $table->RemoveColumn('ObsoleteId','force'); + my ($this) = @_; + + my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; + my $constraint = $table->GetConstraint('Role_ObsoleteId_Uniq'); + + eval { + $table->RemoveColumn('ObsoleteId'); + 1; + } and failed "Should not remove column with constraint"; + + $table->RemoveColumn('ObsoleteId','force'); failed "A constraint remains alive after column deletion" unless $constraint->isDisposed; - + }; test RemoveTable => sub { - my ($this) = @_; - - my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; - - $this->schemaDB->RemoveTable('Role'); - - $table->isDisposed or failed "A table remains alive after deletion"; - - my $table2 = $this->schemaDB->GetTable('User'); - - $table2->GetColumnConstraints('RoleId') == 0 or failed "A foreign key keept alive"; + my ($this) = @_; + + my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; + + $this->schemaDB->RemoveTable('Role'); + + $table->isDisposed or failed "A table remains alive after deletion"; + + my $table2 = $this->schemaDB->GetTable('User'); + + $table2->GetColumnConstraints('RoleId') == 0 or failed "A foreign key keept alive"; }; test Clone => sub { - my ($this) = @_; - - my $clone1 = $this->schemaDB->Clone(); - - $clone1->Dispose(); - - $this->schemaDB->isDisposed and failed "An original schema should not be disposed"; + my ($this) = @_; + + my $clone1 = $this->schemaDB->Clone(); + + $clone1->Dispose(); + + $this->schemaDB->isDisposed and failed "An original schema should not be disposed"; }; test Dispose => sub {
--- a/_test/Test/SQL/Traits.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/SQL/Traits.pm Tue Apr 10 20:08:29 2012 +0400 @@ -12,89 +12,89 @@ use IMPL::SQL::Types qw(Integer Varchar DateTime); BEGIN { - shared public property schema => prop_all; + shared public property schema => prop_all; } sub StartUnit { - return { - schema => new IMPL::SQL::Schema( name => 'testTraits', version => 1 ) - }; + return { + schema => new IMPL::SQL::Schema( name => 'testTraits', version => 1 ) + }; } test CreateTable => sub { - my ($this) = @_; - - my $table = $this->schema->AddTable( - new IMPL::SQL::Schema::Traits::Table( - 'user' - ) - ) or failed "Failed to create table"; - - $this->schema->GetTable('user') or failed "Can't get a created table"; - + my ($this) = @_; + + my $table = $this->schema->AddTable( + new IMPL::SQL::Schema::Traits::Table( + 'user' + ) + ) or failed "Failed to create table"; + + $this->schema->GetTable('user') or failed "Can't get a created table"; + }; test InsertColumn => sub { - my ($this) = @_; - - my $table = $this->schema->GetTable('user'); - - $table->InsertColumn( - new IMPL::SQL::Schema::Traits::Column( - id => Integer, tag => { auto_increment => 1 } - ) - ); - - my $column = $table->GetColumn('id') or failed "Column not found"; - - assert( $column->name eq 'id'); - assert( $column->type->SameValue(Integer()) ); - assert( not $column->isNullable ); - assert( $column->tag->{auto_increment} ); - - $table->InsertColumn( - new IMPL::SQL::Schema::Traits::Column( - name => Varchar(255), isNullable => 1 - ) - ); - - $column = $table->GetColumn('name'); - - assert($column); - assert($column->name eq 'name'); - assert($column->type->SameValue(Varchar(255))); - assert($column->isNullable); + my ($this) = @_; + + my $table = $this->schema->GetTable('user'); + + $table->InsertColumn( + new IMPL::SQL::Schema::Traits::Column( + id => Integer, tag => { auto_increment => 1 } + ) + ); + + my $column = $table->GetColumn('id') or failed "Column not found"; + + assert( $column->name eq 'id'); + assert( $column->type->SameValue(Integer()) ); + assert( not $column->isNullable ); + assert( $column->tag->{auto_increment} ); + + $table->InsertColumn( + new IMPL::SQL::Schema::Traits::Column( + name => Varchar(255), isNullable => 1 + ) + ); + + $column = $table->GetColumn('name'); + + assert($column); + assert($column->name eq 'name'); + assert($column->type->SameValue(Varchar(255))); + assert($column->isNullable); }; test CreateTableWithColumns => sub { - my ($this) = @_; - - my $table = $this->schema->AddTable( - new IMPL::SQL::Schema::Traits::Table( - session => [ - new IMPL::SQL::Schema::Traits::Column( id => Varchar(64)), - new IMPL::SQL::Schema::Traits::Column( expires => DateTime ), - new IMPL::SQL::Schema::Traits::Column( role => Varchar(64), defaultValue => 'user' ) - ] - ) - ) or failed "Failed to create table"; - - assert( $table->ColumnsCount == 3 ); - - assert( my $column = $table->GetColumn('id') ); - assert($column->type->SameValue(Varchar(64))); - assert(not $column->isNullable); - - assert( $column = $table->GetColumn('role') ); - assert( $column->defaultValue eq 'user' ); + my ($this) = @_; + + my $table = $this->schema->AddTable( + new IMPL::SQL::Schema::Traits::Table( + session => [ + new IMPL::SQL::Schema::Traits::Column( id => Varchar(64)), + new IMPL::SQL::Schema::Traits::Column( expires => DateTime ), + new IMPL::SQL::Schema::Traits::Column( role => Varchar(64), defaultValue => 'user' ) + ] + ) + ) or failed "Failed to create table"; + + assert( $table->ColumnsCount == 3 ); + + assert( my $column = $table->GetColumn('id') ); + assert($column->type->SameValue(Varchar(64))); + assert(not $column->isNullable); + + assert( $column = $table->GetColumn('role') ); + assert( $column->defaultValue eq 'user' ); }; sub FinishUnit { - my ($self,$session) = @_; - - $self->supercall::FinishUnit(); - - $session->{schema}->Dispose(); + my ($self,$session) = @_; + + $self->supercall::FinishUnit(); + + $session->{schema}->Dispose(); } 1;
--- a/_test/Test/Web/Application.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/Web/Application.pm Tue Apr 10 20:08:29 2012 +0400 @@ -9,34 +9,34 @@ __PACKAGE__->PassThroughArgs; sub CTOR { - # simulate CGI environment - - $ENV{PATH_TRANSLATED} = "Resources/simple.tt"; + # simulate CGI environment + + $ENV{PATH_TRANSLATED} = "Resources/simple.tt"; } test SpawnApp => sub { - my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); - - return 1; + my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); + + return 1; }; test ActivateOnDemand => sub { - my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); - - my $ds = $instance->dataSource; - - return 1; + my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); + + my $ds = $instance->dataSource; + + return 1; }; test SaveXml => sub { - my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); - - $instance->xml or failed "xml property is invalid"; + my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); + + $instance->xml or failed "xml property is invalid"; }; test Run => sub { - my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); - $instance->Run(); + my $instance = spawn Test::Web::Application::Instance('Resources/app.xml'); + $instance->Run(); }; package Test::Web::Application::Instance; @@ -47,10 +47,10 @@ use IMPL::Class::Property; BEGIN { - public property name => prop_all; - public property options => prop_all; - public property dataSource => prop_all; - public property securityMod => prop_all; + public property name => prop_all; + public property options => prop_all; + public property dataSource => prop_all; + public property securityMod => prop_all; }
--- a/_test/Test/Web/View.pm Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/Test/Web/View.pm Tue Apr 10 20:08:29 2012 +0400 @@ -14,184 +14,205 @@ use IMPL::Web::View::TTLoader(); use constant { - TTLoader => typeof IMPL::Web::View::TTLoader, - MProfiler => 'IMPL::Profiler::Memory' + TTLoader => typeof IMPL::Web::View::TTLoader, + MProfiler => 'IMPL::Profiler::Memory' }; sub AssertMemoryLeak { - my $code = shift; - my $dump = shift; - - my $data = MProfiler->Monitor($code); - - if ($data->isLeak and $dump) { - write_file("dump.out", { binmode => ':utf8' }, $data->Dump() ); - } - - assert( not($data->isLeak), "Memory leak detected", GetCallerSourceLine() , @{$data->{objects}} ); + my $code = shift; + my $dump = shift; + + my $data = MProfiler->Monitor($code); + + if ($data->isLeak and $dump) { + write_file("dump.out", { binmode => ':utf8' }, $data->Dump() ); + } + + assert( not($data->isLeak), "Memory leak detected", GetCallerSourceLine() , @{$data->{objects}} ); } sub templatesDir { - $_[0]->GetResourceDir('Resources','TTView'); + $_[0]->GetResourceDir('Resources','TTView'); } sub CreateLoader { - my ($this) = @_; - - my $loader = TTLoader->new( - { - INCLUDE_PATH => [ - $this->templatesDir - ], - INTERPOLATE => 1, - POST_CHOMP => 1, - ENCODING => 'utf-8' - }, - ext => '.tt', - initializer => 'global.tt' - ); + my ($this) = @_; + + my $loader = TTLoader->new( + { + INCLUDE_PATH => [ + $this->templatesDir + ], + INTERPOLATE => 1, + POST_CHOMP => 1, + ENCODING => 'utf-8' + }, + ext => '.tt', + initializer => 'global.tt', + globals => { + site => { + name => 'Test Site' + }, + date => { + now => sub { localtime(time); } + }, + dynamic => sub { 'this is a dynamic value' } + } + ); } test TTLoaderTests => sub { - my ($this) = @_; - - my $loader = $this->CreateLoader(); - - # test the loader to be able to find a desired resource - assert( defined($loader->template('simple') ) ); - - # loader should be initialized on demand - assert( not $loader->isInitialized ); - - # loader should be able to load a document - my $doc = $loader->document('simple'); - assert(defined $doc); - - assert( $loader->isInitialized ); - assert( $loader->context->stash->get('user') eq 'test_user'); - - # document should inherit loader's context - assert( $doc->context->stash->get('user') eq 'test_user'); - - # document should not have 'this' template variable - assert( not $doc->templateVars('this') ); - - assert( $doc->context != $loader->context); # document should have an own context + my ($this) = @_; + + my $loader = $this->CreateLoader(); + + # test the loader to be able to find a desired resource + assert( defined($loader->template('simple') ) ); + + # loader should be initialized on demand + assert( not $loader->isInitialized ); + + # loader should be able to load a document + my $doc = $loader->document('simple'); + assert(defined $doc); + + assert( $loader->isInitialized ); + assert( $loader->context->stash->get('user') eq 'test_user'); + + # document should inherit loader's context + assert( $doc->context->stash->get('user') eq 'test_user'); + + # document should not have 'this' template variable + assert( not $doc->templateVars('this') ); + + assert( $doc->context != $loader->context); # document should have an own context }; test TTDocumentTests => sub { - my ($this) = @_; - my $loader = $this->CreateLoader(); - - my $doc = $loader->document('simple'); - - assert(defined $doc); - - assert($doc->nodeName eq 'document'); - assert(not $doc->can('notexists')); # autoloaded property should be ignored - assert(not defined $doc->notexists); # nonexisting property - assert($doc->template->version == 10); # static metadata - assert($doc->templateVars('notexists') eq ''); #nonexisting template variable - assert($doc->templateVars('user') eq 'test_user'); # global data - assert($doc->templateVars('templateVar') eq 'initialized by the constructor'); # defined in CTOR block - - my $text = $doc->Render(); - my $expected = read_file($this->GetResourceFile('Resources','TTView.Output','simple.txt'), binmode => ':utf8'); - - assert($text eq $expected, "Bad Render() output","Got: $text", "Expected: $expected"); - + my ($this) = @_; + my $loader = $this->CreateLoader(); + + my $doc = $loader->document('simple'); + + assert(defined $doc); + $doc->title('test document'); + + assert($doc->nodeName eq 'document'); + assert($doc->title eq 'test document'); + + assert(not $doc->can('notexists')); # autoloaded property should be ignored + assert(not defined $doc->notexists); # nonexisting property + assert($doc->template->version == 10); # static metadata + assert($doc->templateVars('notexists') eq ''); #nonexisting template variable + assert($doc->templateVars('user') eq 'test_user'); # global data + assert($doc->templateVars('templateVar') eq ''); # defined in CTOR block, should be local + assert($doc->templateVars('dynamic') eq 'this is a dynamic value'); + + my $text = $doc->Render(); + my $expected = read_file($this->GetResourceFile('Resources','TTView.Output','simple.txt'), binmode => ':utf8'); + + assert($text eq $expected, "Bad Render() output","Got: $text", "Expected: $expected"); + }; test TTControlTests => sub { - my ($this) = @_; - - my $loader = $this->CreateLoader(); - - my $doc = $loader->document('simple'); - - assert(defined $doc); - - my $factory = $doc->require('My/Org/Panel'); - - assert(defined $factory); - - - assert($factory->context->stash != $doc->context->stash); - - assert($factory == $doc->require('My/Org/Panel'), "Control should be loaded only once"); - - my $ctl = $factory->new('information', { visualClass => 'simple', data => ['one','two','hello world'] } ); - - assert(defined $ctl); - - assert($ctl->nodeName eq 'information', "Created control should have a name", "Got: ".$ctl->nodeName, "Expected: information"); - - assert($ctl->nodeProperty('visualClass') eq 'simple'); - - assert($factory->instances == 1); - - $doc->appendChild($ctl); - - assert($doc->templateVars('dojo.require')); - assert(ref $doc->templateVars('dojo.require') eq 'ARRAY'); - assert($doc->templateVars('dojo.require')->[0] eq 'dijit.form.Input' ); - - my $text = $ctl->Render(); - - my $expected = read_file($this->GetResourceFile('Resources', 'TTView.Output', 'Panel.txt'), binmode => ':utf8'); - assert($text eq $expected, '$ctl->Render(): Bad output', "Got: $text", "Expected: $expected"); - - - + my ($this) = @_; + + my $loader = $this->CreateLoader(); + + my $doc = $loader->document('simple'); + + assert(defined $doc); + + my $factory = $doc->require('My/Org/Panel'); + + assert(defined $factory); + + + assert($factory->context->stash != $doc->context->stash); + + assert($factory == $doc->require('My/Org/Panel'), "Control should be loaded only once"); + + my $ctl = $factory->new('information', { visualClass => 'simple', data => ['one','two','hello world'] } ); + + assert(defined $ctl); + + assert($ctl->nodeName eq 'information', "Created control should have a name", "Got: ".$ctl->nodeName, "Expected: information"); + + assert($ctl->nodeProperty('visualClass') eq 'simple'); + + assert($factory->instances == 1); + + $doc->appendChild($ctl); + + assert($doc->templateVars('dojo.require')); + assert(ref $doc->templateVars('dojo.require') eq 'ARRAY'); + assert($doc->templateVars('dojo.require')->[0] eq 'dijit.form.Input' ); + + my $text = $ctl->Render(); + + my $expected = read_file($this->GetResourceFile('Resources', 'TTView.Output', 'Panel.txt'), binmode => ':utf8'); + assert($text eq $expected, '$ctl->Render(): Bad output', "Got: $text", "Expected: $expected"); + + + }; test TestDocumentLayout => sub { - my ($this) = @_; - - my $loader = $this->CreateLoader(); - - my $doc = $loader->document('complex'); - assert($doc->layout eq 'Layout/default'); - - my $expected = read_file($this->GetResourceFile('Resources', 'TTView.Output', 'complex.default.txt'), binmode => ':utf8' ); - - assert($doc->templateVars('dojo.require')->[0]); - - my $text = $doc->Render({ data => [qw(one two three)] }); - - assert($text eq $expected, '$doc->Render(): Bad output', "Got: $text", "Expected: $expected"); + my ($this) = @_; + + my $loader = $this->CreateLoader(); + + my $doc = $loader->document( + 'complex', + { + data => [qw(one two three)], + site => { + name => 'Test Site' + } + } + ); + + assert($doc->layout eq 'Layout/default'); + + assert($doc->templateVars('dojo.require')->[0]); + + my $text = $doc->Render(); + + my $expected = read_file($this->GetResourceFile('Resources', 'TTView.Output', 'complex.default.txt'), binmode => ':utf8' ); + assert($text eq $expected, '$doc->Render(): Bad output', "Got: $text", "Expected: $expected"); }; test TestMemoryLeaks => sub { - my ($this) = @_; - - my $loader = $this->CreateLoader(); - $loader->document('simple'); # force loader initialization - - AssertMemoryLeak(sub { - my $doc = $loader->document('simple'); - }); - - AssertMemoryLeak(sub { - my $doc = $loader->document('simple'); - $doc->Render( { self => $doc } ); - }); - - $loader->template('Layout/default'); - $loader->template('My/Org/Panel'); - $loader->template('My/Org/TextPreview'); - AssertMemoryLeak(sub { - my $doc = $loader->document('simple'); - my $factory = $doc->require('My/Org/Panel'); - my $ctl = $doc->AppendChild($factory->new('information', { visualClass => 'complex' }) ); - }); - - $loader->template('complex'); - AssertMemoryLeak(sub { - my $doc = $loader->document('complex'); - $doc->Render(); - },'dump'); - + my ($this) = @_; + + my $loader = $this->CreateLoader(); + $loader->document('simple'); # force loader initialization + + AssertMemoryLeak(sub { + my $doc = $loader->document('simple'); + }); + + AssertMemoryLeak(sub { + my $doc = $loader->document('simple'); + $doc->Render( { self => $doc } ); + }); + + $loader->template('Layout/default'); + $loader->template('My/Org/Panel'); + $loader->template('My/Org/TextPreview'); + AssertMemoryLeak(sub { + my $doc = $loader->document('simple'); + my $factory = $doc->require('My/Org/Panel'); + my $ctl = $doc->AppendChild($factory->new('information', { visualClass => 'complex' }) ); + }); + + $loader->template('complex'); + AssertMemoryLeak(sub { + my $doc = $loader->document('complex'); + $doc->Render(); + },'dump'); + }; 1; \ No newline at end of file
--- a/_test/temp.pl Tue Apr 10 08:13:22 2012 +0400 +++ b/_test/temp.pl Tue Apr 10 20:08:29 2012 +0400 @@ -3,13 +3,13 @@ use Time::HiRes qw(gettimeofday tv_interval); sub func { - 1; + 1; } my $t0 = [gettimeofday()]; for(my $i = 0; $i < 1000000; $i++) { - func(1); + func(1); } print tv_interval($t0),"\n"; @@ -19,7 +19,7 @@ $t0 = [gettimeofday()]; for(my $i = 0; $i < 1000000; $i++) { - &$fn(1); + &$fn(1); } print tv_interval($t0),"\n"; @@ -29,7 +29,7 @@ $t0 = [gettimeofday()]; for(my $i = 0; $i < 1000000; $i++) { - dummy; + dummy; } print tv_interval($t0),"\n"; @@ -37,7 +37,7 @@ $t0 = [gettimeofday()]; for(my $i = 0; $i < 1000000; $i++) { - 1; + 1; } print tv_interval($t0),"\n";