Mercurial > pub > Impl
changeset 170:b88b7fe60aa3
refactoring
| author | sourcer |
|---|---|
| date | Tue, 24 May 2011 01:11:16 +0400 |
| parents | fd92830036c3 |
| children | 59e5fcb59d86 |
| files | Lib/BNFCompiler.pm Lib/CDBI/Map.pm Lib/CDBI/Meta.pm Lib/CDBI/Transform.pm Lib/Common.pm Lib/Configuration.pm Lib/Deployment.pm Lib/Deployment/Batch.pm Lib/Deployment/Batch/Backup.pm Lib/Deployment/Batch/CDBIUpdate.pm Lib/Deployment/Batch/CopyFile.pm Lib/Deployment/Batch/CopyTree.pm Lib/Deployment/Batch/CustomAction.pm Lib/Deployment/Batch/Generic.pm Lib/Deployment/Batch/Temp.pm Lib/Deployment/CDBI.pm Lib/Engine/Action.pm Lib/Engine/Action/URICall.pm Lib/Engine/CGI.pm Lib/Engine/Output/JSON.pm Lib/Engine/Output/Page.pm Lib/Engine/Output/Template.pm Lib/Engine/Security.pm Lib/Engine/Security/AccessDeniedException.pm Lib/Engine/Security/Auth.pm Lib/Engine/Security/Cookies.pm Lib/Engine/Security/IPSession.pm Lib/Form/Container.pm Lib/Form/Filter.pm Lib/Form/Filter/Depends.pm Lib/Form/Filter/Mandatory.pm Lib/Form/Filter/Regexp.pm Lib/Form/Item.pm Lib/Form/ItemId.pm Lib/Form/Transform.pm Lib/Form/ValueItem.pm Lib/Form/ValueItem/List.pm Lib/IMPL/Config.pm Lib/IMPL/Web/Application.pm Lib/IMPL/Web/Application/ControllerUnit.pm Lib/ObjectStore/CDBI/Users.pm Lib/Schema/DB.pm Lib/Schema/DB/Column.pm Lib/Schema/DB/Constraint.pm Lib/Schema/DB/Constraint/ForeignKey.pm Lib/Schema/DB/Constraint/Index.pm Lib/Schema/DB/Constraint/PrimaryKey.pm Lib/Schema/DB/Constraint/Unique.pm Lib/Schema/DB/Table.pm Lib/Schema/DB/Traits.pm Lib/Schema/DB/Traits/mysql.pm Lib/Schema/DB/Type.pm Lib/Schema/DataSource.pm Lib/Schema/DataSource/CDBIBuilder.pm Lib/Schema/DataSource/TypeMapping.pm Lib/Schema/Form.pm Lib/Schema/Form/Container.pm Lib/Schema/Form/Field.pm Lib/Schema/Form/Filter.pm Lib/Schema/Form/Format.pm Lib/Schema/Form/Item.pm Lib/Security/Auth.pm Lib/Security/Auth/Simple.pm Lib/Security/Authz.pm Schema/form.def Schema/query.def Schema/schema.def Schema/type.def |
| diffstat | 68 files changed, 39 insertions(+), 5760 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/BNFCompiler.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,666 +0,0 @@ -package BNFCompiler; -package BNFCompiler::DOM; -package BNFCompiler::DOM::Builder; -package BNFCompiler::DOM::Node; -use strict; - -package BNFCompiler::EventParser; -use strict; -use lib '.'; -use Common; -our @ISA = qw(Object); - -our $EventMapSchema = { - Description => 'Parser events', - Type => 'HASH', - Values => 'SCALAR' -}; - -BEGIN { - DeclareProperty(EventMap => ACCESS_READ); - DeclareProperty(CompiledEvents => ACCESS_NONE); - DeclareProperty(Handler => ACCESS_ALL); -} - -sub CTOR { - my ($this,%args) = @_; - $this->SUPER::CTOR(%args); -} - -sub Compile { - my ($this) = @_; - - delete $this->{$CompiledEvents}; - while (my ($key,$val) = each %{$this->{$EventMap}}) { - $this->{$CompiledEvents}{$key} = qr/\G$val/; - } - 1; -} - -sub Parse { - my ($this,$data) = @_; - - my $StateData; - OUTER: while(pos($data) < length($data)) { - keys %{$this->{$CompiledEvents}}; - while (my ($event,$match) = each %{$this->{$CompiledEvents}}) { - if ($data =~ m/($match)/gc) { - $StateData .= $1; - eval { - undef $StateData if $this->{$Handler}->($event,$StateData); - }; - if ($@) { - die ["Invalid syntax","unexpected $event: $1",pos($data)]; - } - next OUTER; - } - } - die ["Invalid syntax",substr($data,pos($data),10),pos($data)]; - } - - return 1; -} - -# небольшая уловка, поскольку ref от регулярного выражения есть Regexp, можно поставить хуки -package Regexp; -use Data::Dumper; - -sub STORABLE_freeze { - my ($obj,$cloning) = @_; - - return $obj; -} - -sub STORABLE_attach { - my($class, $cloning, $serialized) = @_; - return qr/$serialized/; -} - -package BNFCompiler; -use Common; -use Storable; -use Data::Dumper; -our @ISA = qw(Object); - -our $BNFSchema; -my $ParseAgainstSchema; -my $TransformDOMToBNF; - -BEGIN { - DeclareProperty(Schema => ACCESS_NONE); - DeclareProperty(SchemaCache => ACCESS_NONE); - DeclareProperty(Transform => ACCESS_NONE); -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - $this->{$SchemaCache} .= '/' if ($this->{$SchemaCache} and not $this->{$SchemaCache} =~ /\/$/); -} -{ - my $compiledBNFSchema; - sub LoadBNFSchema { - my ($this,%args) = @_; - - my $CompileBNFText = sub { - my ($this,$text) = @_; - - my %SchemaDOM; - foreach my $item (split /\n{2,}/, $text) { - next if not $item; - $compiledBNFSchema = CompileBNFSchema($BNFSchema) if not $compiledBNFSchema; - my $context = new BNFCompiler::DOM::Builder(); - eval { - my $expr = &$ParseAgainstSchema($compiledBNFSchema,$item,$context); - die ["Unexpected expression", $expr] if $expr; - }; - if ($@) { - if (ref $@ eq 'ARRAY') { - die new Exception(@{$@}); - } else { - die $@; - } - } - - $SchemaDOM{$context->Document->selectNodes('name')->text()} = &$TransformDOMToBNF($context->Document->selectNodes('def')); - - } - - $SchemaDOM{'separator'} = ['re:\\s+']; - $this->{$Schema} = CompileBNFSchema(\%SchemaDOM); - }; - - my $text; - if ($args{'file'}) { - - my $fnameCached; - if ($this->{$SchemaCache}) { - my $fname = $args{'file'}; - $fname =~ tr/\//_/; - $fnameCached = $this->{$SchemaCache}.$fname.'.cbs'; - if ( -e $fnameCached && -f $fnameCached && ( -M $args{'file'} >= -M $fnameCached )) { - my $compiledSchema = retrieve($fnameCached); - if ($compiledSchema) { - $this->{$Schema} = $compiledSchema; - return 1; - } else { - unlink $fnameCached; - } - } - } - open my $hFile, '<', $args{'file'} or die new Exception("Failed to open file",$args{'file'},$!); - local $/ = undef; - my $text = <$hFile>; - - $this->$CompileBNFText($text); - - if ($fnameCached) { - store($this->{$Schema},$fnameCached); - } - } elsif ($args{'Schema'}) { - $this->{$Schema} = CompileBNFSchema($args{'Schema'}); - return 1; - } elsif ($args{'text'}) { - $this->$CompileBNFText( $args{'text'} ); - } else { - die new Exception("'file', 'text' or 'Schema' parameter required"); - } - - } -} - -sub Parse { - my ($this, $string, %flags) = @_; - - my $context = new BNFCompiler::DOM::Builder; - - eval { - my $err; - $err = &$ParseAgainstSchema($this->{$Schema},$string,$context,\%flags) and die new Exception('Failed to parse',substr($err,0,80).' ...'); - }; - if ($@) { - if (ref $@ eq 'ARRAY') { - die new Exception(@{$@}); - } else { - die $@; - } - } - if (not $this->{$Transform}) { - return $context->Document; - } else { - return $this->{$Transform}->($context->Document); - } -} - -sub Dispose { - my ($this) = shift; - CleanSchema($this->{$Schema}); - delete @$this{$Schema, $Transform}; - $this->SUPER::Dispose; -} - -sub CleanSchema { - my ($schema,$table) = @_; - - UNIVERSAL::isa($schema,'ARRAY') or return; - $table or $table = { $schema, 1}; - - for(my $i=0; $i<@$schema;$i++) { - my $item = $schema->[$i]; - if (ref $item) { - next if $table->{$item}; - $table->{$item} = 1; - if (UNIVERSAL::isa($item,'ARRAY')) { - CleanSchema($item,$table); - } elsif( UNIVERSAL::isa($item,'HASH')) { - CleanSchema($item->{'syntax'},$table); - } - undef $schema->[$i]; - } - } -} - - -sub OPT { - return bless [@_], 'OPT'; -} - -sub SWITCH { - return bless [@_], 'SWITCH'; -} - -sub REPEAT { - return bless [@_], 'REPEAT'; -} - -$TransformDOMToBNF = sub { - my ($nodeRoot) = @_; - - return [grep $_, map { - my $nodeName = $_->nodeName; - if (not $nodeName ){ - my $obj = $_; - $obj->text() if (not( grep { $obj->text() eq $_} ('{', '}', '[', ']') ) ); - }elsif($nodeName eq 'name') { - $_->text(); - } elsif ($nodeName eq 'separator') { - OPT('separator'); - } elsif ($nodeName eq 'or_sep') { - # nothing - } elsif ($nodeName eq 'switch_part') { - &$TransformDOMToBNF($_); - } elsif ($nodeName eq 'class') { - my $class = $_->childNodes->[0]->text(); - - $class =~ s{(^<|>$|\\.|[\]\[])}{ - my $char = { '>' => '', '<' => '', '[' => '\\[', ']' => '\\]', '\\\\' => '\\\\'}->{$1}; - defined $char ? $char : ($1 =~ tr/\\// && $1); - }ge; - $class = '['.$class.']'; - $class .= $_->childNodes->[1]->text() if $_->childNodes->[1]; - 're:'.$class; - } elsif ($nodeName eq 'symbol') { - $_->text(); - } elsif ($nodeName eq 'simple') { - @{&$TransformDOMToBNF($_)}; - } elsif ($nodeName eq 'multi_def') { - @{&$TransformDOMToBNF($_)}; - } elsif ($nodeName eq 'optional') { - my $multi_def = &$TransformDOMToBNF($_); - if ($multi_def->[scalar(@{$multi_def})-1] eq '...') { - pop @{$multi_def}; - OPT(REPEAT(@{$multi_def})); - } else { - OPT(@{$multi_def}); - } - } elsif ($nodeName eq 'switch') { - SWITCH(@{&$TransformDOMToBNF($_)}); - } elsif ($nodeName eq 'def') { - @{&$TransformDOMToBNF($_)}; - } else{ - die "unknown nodeName: $nodeName"; - } - } @{$nodeRoot->childNodes}]; -}; - -$BNFSchema = { - syntax => ['name',OPT('separator'),'::=',OPT('separator'),'def'], - name => ['re:\\w+'], - class => ['re:<([^<>\\\\]|\\\\.)+>',OPT('re:\\*|\\+|\\?|\\{\\d+\\}')], - symbol => ['re:[^\\w\\d\\s\\[\\]{}<>\\\\|]+'], - separator => ['re:\\s+'], - simple => [ - SWITCH( - 'name', - 'class', - 'symbol' - ) - ], - multi_def => [ - OPT('separator'), SWITCH('...',[SWITCH('simple','optional','switch'),OPT('multi_def')]) - ], - optional => [ - '[','multi_def', OPT('separator') ,']' - - ], - keyword => [], - or_sep => ['|'], - switch_part => [OPT('separator'),SWITCH('simple','optional','switch'),OPT(REPEAT(OPT('separator'),SWITCH('simple','optional','switch'))),OPT('separator')], - switch => [ - '{','switch_part',OPT(REPEAT('or_sep','switch_part')),'}' - ], - def => [REPEAT(OPT('separator'),SWITCH('simple','optional','switch'))] -}; - -my $CompileTerm; -$CompileTerm = sub { - my ($term,$Schema,$cache,$ref) = @_; - - my $compiled = ref $term eq 'ARRAY' ? ($ref or []) : bless (($ref or []), ref $term); - - die new Exception("Invalid term type $term", $term, ref $term) if not grep ref $term eq $_, qw(ARRAY REPEAT SWITCH OPT); - - foreach my $element (@{$term}) { - if (ref $element) { - push @{$compiled}, &$CompileTerm($element,$Schema,$cache); - } else { - if($element =~/^\w+$/) { - if (exists $Schema->{$element}) { - # reference - my $compiledUnit; - if (exists $cache->{$element}) { - $compiledUnit = $cache->{$element}; - } else { - $compiledUnit = []; - $cache->{$element} = $compiledUnit; - &$CompileTerm($Schema->{$element},$Schema,$cache,$compiledUnit); - } - - push @{$compiled},{ name => $element, syntax => $compiledUnit}; - } else { - # simple word - push @{$compiled}, $element; - } - } elsif ($element =~ /^re:(.*)/){ - # regexp - push @{$compiled},qr/\G(?:$1)/; - } else { - # char sequence - push @{$compiled},$element; - } - } - } - - return $compiled; -}; - -sub CompileBNFSchema { - my($Schema) = @_; - - my %Cache; - return &$CompileTerm($Schema->{'syntax'},$Schema,\%Cache); -} - -my $CompiledSchema = CompileBNFSchema($BNFSchema); - -$ParseAgainstSchema = sub { - my ($Schema,$expression,$context,$flags,$level) = @_; - - $level = 0 if not defined $level; - my $dbgPrint = $flags->{debug} ? sub { - print "\t" x $level, @_,"\n"; - } : sub {}; - - foreach my $elem (@{$Schema}) { - my $type = ref $elem; - $expression = substr $expression,pos($expression) if $type ne 'Regexp' and pos($expression); - - if ($type eq 'HASH') { - $context->NewContext($elem->{'name'}); - &$dbgPrint("$elem->{name} ", join(',',map { ref $_ eq 'HASH' ? $_->{name} : $_ }@{$elem->{'syntax'}})); - eval { - $expression = &$ParseAgainstSchema($elem->{'syntax'},$expression,$context,$flags,$level+1); - }; - if ($@) { - $context->EndContext(0); - &$dbgPrint("/$elem->{name} ", "0"); - die $@; - } else { - &$dbgPrint("/$elem->{name} ", "1"); - $context->EndContext(1); - } - } elsif ($type eq 'ARRAY') { - &$dbgPrint("entering ", join(',',map { ref $_ eq 'HASH' ? $_->{name} : $_ }@{$elem})); - $expression = &$ParseAgainstSchema($elem,$expression,$context,$flags,$level+1); - &$dbgPrint("success"); - } elsif ($type eq 'OPT') { - if (defined $expression) { - &$dbgPrint("optional ",join(',',map { ref $_ eq 'HASH' ? $_->{name} : $_ }@{$elem})); - eval { - $expression = &$ParseAgainstSchema($elem,$expression,$context,$flags,$level+1); - }; - if ($@) { - &$dbgPrint("failed"); - undef $@; - } else { - &$dbgPrint("success"); - } - } - } elsif ($type eq 'SWITCH') { - my $success = 0; - &$dbgPrint("switch"); - LOOP_SWITCH: foreach my $subelem (@{$elem}) { - eval { - &$dbgPrint("\ttry ",join(',',map { ref $_ eq 'HASH' ? $_->{name} : $_ } @{(grep ref $subelem eq $_, qw(ARRAY SWITCH OPT REPEAT)) ? $subelem : [$subelem]})); - $expression = &$ParseAgainstSchema((grep ref $subelem eq $_, qw(ARRAY SWITCH OPT REPEAT)) ? $subelem : [$subelem],$expression,$context,$flags,$level+1); - $success = 1; - }; - if ($@) { - undef $@; - } else { - last LOOP_SWITCH; - } - } - if ($success) { - &$dbgPrint("success"); - } else { - &$dbgPrint("failed"); - die ["syntax error",$expression,$elem]; - } - } elsif ($type eq 'REPEAT') { - my $copy = [@{$elem}]; - my $i = 0; - &$dbgPrint("repeat ",join(',',map { ref $_ eq 'HASH' ? $_->{name} : $_ }@{$elem})); - while (1) { - eval { - $expression = &$ParseAgainstSchema($copy,$expression,$context,$flags,$level+1); - $i++; - }; - if ($@) { - if (not $i) { - &$dbgPrint("failed"); - die $@; - } - &$dbgPrint("found $i matches"); - undef $@; - last; - } - } - } elsif ($type eq 'Regexp') { - my $posPrev = pos($expression) || 0; - if ( $expression =~ m/($elem)/ ) { - $context->Data($1); - pos($expression) = $posPrev+length($1); - &$dbgPrint("Regexp: $1 $elem ", pos($expression)); - } else { - &$dbgPrint("Regexp: $elem failed"); - die ["syntax error",$expression,$elem,$posPrev]; - pos($expression) = $posPrev; - } - } else { - if ((my $val = substr($expression, 0, length($elem),'')) eq $elem) { - &$dbgPrint("Scalar: $val"); - $context->Data($elem); - } else { - &$dbgPrint("Scalar: failed $val expected $elem"); - die ["syntax error",$val.$expression,$elem]; - } - } - - } - - if (pos $expression) { - return substr $expression,(pos($expression) || 0); - } else { - return $expression; - } - -}; - -package BNFCompiler::DOM::Node; -use Common; -our @ISA = qw(Object); - -sub NODE_TEXT { 1 } -sub NODE_ELEM { 2 } - -BEGIN { - DeclareProperty(nodeName => ACCESS_READ); - DeclareProperty(nodeType => ACCESS_READ); - DeclareProperty(nodeValue => ACCESS_READ); - DeclareProperty(childNodes => ACCESS_READ); - DeclareProperty(isComplex => ACCESS_READ); -} - -sub CTOR { - my ($this,%args) = @_; - $args{'nodeType'} = NODE_ELEM if not $args{'nodeType'}; - die new Exception("Invalid args. nodeName reqired.") if $args{'nodeType'} == NODE_ELEM and not $args{nodeName}; - - #for speed reason - #$this->SUPER::CTOR(%args); - - $this->{$nodeName} = $args{'nodeName'} if $args{'nodeName'}; - $this->{$nodeType} = $args{'nodeType'}; - $this->{$nodeValue} = $args{'nodeValue'} if exists $args{'nodeValue'}; - - $this->{$isComplex} = 0; -} - -sub insertNode { - my ($this,$node,$pos) = @_; - - die new Exception("Invalid operation on text node.") if $this->{$nodeType} != NODE_ELEM; - die new Exception("Invalid node type",ref $node) if ref $node ne __PACKAGE__; - - $this->{$childNodes} = [] if not $this->{$childNodes}; - - $pos = scalar(@{$this->{$childNodes}}) if not defined $pos; - die new Exception("Index out of range",$pos) if $pos > scalar(@{$this->{$childNodes}}) or $pos < 0; - - splice @{$this->{$childNodes}},$pos,0,$node; - $this->{$isComplex} = 1 if not $this->{$isComplex} and $node->{$nodeType} == NODE_ELEM; - - return $node; -} - -sub removeNode { - my ($this,$node) = @_; - - die new Exception("Invalid operation on text node.") if $this->{$nodeType} != NODE_ELEM; - @{$this->{$childNodes}} = grep { $_ != $node } @{$this->{$childNodes}}; - - return $node; -} - -sub removeAt { - my ($this,$pos) = @_; - - die new Exception("Invalid operation on text node.") if $this->{$nodeType} != NODE_ELEM; - die new Exception("Index out of range",$pos) if $pos >= scalar(@{$this->{$childNodes}}) or $pos < 0; - - return splice @{$this->{$childNodes}},$pos,1; -} - -sub selectNodes { - my ($this,$name) = @_; - - die new Exception("Invalid operation on text node.") if $this->{$nodeType} != NODE_ELEM; - - my @nodes = grep { $_->{$nodeType} == NODE_ELEM and $_->{$nodeName} eq $name } @{$this->{$childNodes}}; - - if (wantarray) { - return @nodes; - } else { - return shift @nodes; - } -} - -sub text { - my $this = shift; - - if ($this->{$nodeType} == NODE_TEXT) { - return $this->{$nodeValue}; - } else { - my @texts; - - foreach my $node (@{$this->{$childNodes}}) { - push @texts, $node->{$nodeValue} if ($node->{$nodeType}==NODE_TEXT); - } - - if (wantarray) { - return @texts; - } else { - return join '',@texts; - } - } -} - -package BNFCompiler::DOM::Builder; -use Common; -our @ISA=qw(Object); - -BEGIN { - DeclareProperty(Document => ACCESS_READ); - DeclareProperty(currentNode => ACCESS_NONE); - DeclareProperty(stackNodes => ACCESS_NONE); -} - -sub CTOR { - my $this = shift; - - $this->{$Document} = new BNFCompiler::DOM::Node(nodeName => 'Document', nodeType => BNFCompiler::DOM::Node::NODE_ELEM); - $this->{$currentNode} = $this->{$Document}; -} - -sub NewContext { - my ($this,$contextName) = @_; - - push @{$this->{$stackNodes}},$this->{$currentNode}; - $this->{$currentNode} = new BNFCompiler::DOM::Node(nodeName => $contextName, nodeType=> BNFCompiler::DOM::Node::NODE_ELEM); - - return 1; -} -sub EndContext{ - my ($this,$isNotEmpty) = @_; - - if ($isNotEmpty) { - my $child = $this->{$currentNode}; - $this->{$currentNode} = pop @{$this->{$stackNodes}}; - $this->{$currentNode}->insertNode($child); - } else { - $this->{$currentNode} = pop @{$this->{$stackNodes}}; - } -} -sub Data { - my ($this,$data) = @_; - $this->{$currentNode}->insertNode(new BNFCompiler::DOM::Node(nodeType=> BNFCompiler::DOM::Node::NODE_TEXT, nodeValue => $data)); -} - -package BNFCompiler::DOM; - -sub TransformDOMToHash { - my ($root,$options) = @_; - - my %content; - - if (not $root->childNodes) { - die; - } - - foreach my $child (@{$root->childNodes}) { - if ($child->nodeType == BNFCompiler::DOM::Node::NODE_ELEM) { - my @newValue; - my $nodeName = $child->nodeName; - next if $nodeName eq 'separator' and $options->{'skip_spaces'}; - if ($child->isComplex) { - $newValue[0] = TransformDOMToHash($child,$options); - } else { - @newValue = $child->text() - } - - if ($options->{'use_arrays'}) { - push @{$content{$nodeName}},@newValue; - } - - if (exists $content{$nodeName}) { - if (ref $content{$nodeName} eq 'ARRAY') { - push @{$content{$nodeName}}, @newValue; - } else { - $content{$nodeName} = [$content{$nodeName},@newValue]; - } - } else { - $content{$nodeName} = $newValue[0] if scalar(@newValue) == 1; - $content{$nodeName} = \@newValue if scalar(@newValue) > 1; - } - } else { - next if $options->{'skip_text'}; - push @{$content{'_text'}},$child->nodeValue(); - } - } - - return \%content; -} - -1;
--- a/Lib/CDBI/Map.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -package CDBI::Map; -use strict; -use Common; - -BEGIN { - DeclareProperty _Cache => ACCESS_NONE; - DeclareProperty _HoldingType => ACCESS_NONE; -} - -sub _KeyValuePairClass { - my $this = shift; - ($this->{$_HoldingType} = ref $this ) =~ s/^((?:\w+::)*)Map(\w+)$/${1}MapItem${2}/ unless $this->{$_HoldingType}; - return $this->{$_HoldingType}; -} - -# при загрузке кеша нельзя грузить KeyValuePair поскольку получатся циклические ссылки:( -sub GetCache { - my $this = shift; - - if (not $this->{$_Cache}) { - $this->{$_Cache} = { map { $_->ItemKey, { id => $_->id, value => $_->Value} } $this->_KeyValuePairClass->search(Parent => $this) }; - } - - return $this->{$_Cache}; -} - -sub Keys { - my $this = shift; - return wantarray ? keys %{$this->GetCache} : [keys %{$this->GetCache}]; -} - -sub Item { - my ($this,$key,$value,%options) = @_; - - die new Exception('A key must be specified') unless defined $key; - - if (@_ > 2) { - # set - if (my $pairInfo = $this->GetCache->{$key}) { - # update - my $pair = $this->_KeyValuePairClass->retrieve($pairInfo->{id}); - if (defined $value or $options{'keepnull'}) { - $pair->Value($value); - $pair->update; - $pairInfo->{value} = $value; - } else { - #delete - $pair->delete; - delete $this->GetCache->{$key}; - } - } else { - if ( defined $value or $options{'keepnull'}) { - my $pair = $this->_KeyValuePairClass->insert( {Parent => $this, ItemKey => $key, Value => $value } ); - $this->GetCache->{$key} = {id => $pair->id, value => $value }; - } - } - return $value; - } else { - # get - if (my $pairInfo = $this->GetCache->{$key}) { - return $pairInfo->{value}; - } else { - return undef; - } - } -} - -sub Delete { - my ($this,$key) = @_; - - if (my $pair = $this->GetCache->{$key} ) { - $pair->delete; - delete $this->GetCache->{$key}; - return 1; - } - return 0; -} - -sub Has { - my ($this,$key) = @_; - - return exists $this->GetCache->{$key}; -} - -1; -__END__ -=pod -=head1 SYNOPSIS -package App::CDBI; -use parent 'Class::DBI'; - -#.... - -package App::MapString; -use parent 'Class::DBI','CDBI::Map'; - -#.... - - -my $Map = App::MapString->retrieve($id); -print $Map->Item('key'); -$Map->Item('key','value'); -$Map->Delete('key'); -print "the $key is found" if $Map->Has($key); - -=head1 DESCRIPTION - -Provides a set of methods to manipulate with Maps; - -=cut
--- a/Lib/CDBI/Meta.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -package CDBI::Meta::BindingAttribute; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property Binding => prop_get; - public _direct property Name => prop_get; -} - -sub CTOR { - my ($this,$name,$binding) = @_; - $this->{$Binding} = $binding; - $this->{$Name} = $name; -} - -1;
--- a/Lib/CDBI/Transform.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -package CDBI::Transform::FormToObject; -use strict; -use warnings; - -use parent qw(IMPL::Object::Autofill Form::Transform ); -use IMPL::Class::Property; -require IMPL::Exception; - -BEGIN { - public property Class => prop_all; - public property Namespace => prop_all; -} - -sub CTOR { - my $this = shift; - $this->superCTOR(@_); - - die new IMPL::InvalidArgumentException('Class is required') unless $this->Class; -} - -sub TransformContainer { - my ($this,$container) = @_; - - my $class; - if ($container->Name eq 'Form') { - $class = $this->Class; - } else { - $class = $this->_mk_class($container->Attributes->{'cdbi.class'}) or die new IMPL::Exception('cdbi.class isn\'t specified',$container->Id->Canonical); - } - - my %data; - - #my %columns = map {$_,1} $class->columns(); - - no strict 'refs'; - my @accessors = map $_->accessor, $class->columns();# grep $columns{lc $_}, keys %{"${class}::"}; - - # формируем из контейнера формы данные для объекта - foreach my $column ( @accessors, 'id' ) { - my ($val) = $container->GetChild($column); - $data{$column} = $this->Transform($val) if $val; - } - - my $obj; - if ($data{id}) { - # edit value - - - $obj = $class->validateId($data{id}); - my %filter = map { $_, $obj->$_()} @accessors; - $filter{$_} = $data{$_} foreach keys %data; - my ($newObj) = $class->lookup(\%data); - die new IMPL::DuplicateException('The object already exists', $class) if ($newObj and $newObj->id != $data{id}); - - $obj->$_($data{$_}) foreach keys %data; - $obj->update(); - } else { - # new instance - die new IMPL::DuplicateException('The object already exists', $class) if $class->lookup(\%data); - $obj = $class->insert(\%data); - } - return $obj; -} - -sub _mk_class { - my ($this,$name) = @_; - - return unless $name; - return $name if $name =~ /::/; - return $this->Namespace ? $this->Namespace."::$name" : $name; -} - -package CDBI::Transform::ObjectToForm; -use parent qw(IMPL::Transform); - -use IMPL::Class::Property; - -sub CTOR { - my $this = shift; - - $this->superCTOR( - Default => \&TransformObject, - Plain => sub { my ($this,$val) = @_; return $val; } - ); -} - -sub TransformObject { - my ($this,$object) = @_; - - return $object if not ref $object; - - my %data; - foreach my $column ( (map $_->accessor,$object->columns()),'id') { - my $value = $object->$column(); - - if (ref $value eq 'HASH') { - $data{"$column/$_"} = $value->{$_} foreach keys %$value; - } else { - $data{$column} = $value; - } - } - - return \%data; -} -1;
--- a/Lib/Common.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,282 +0,0 @@ -package Common; -use strict; -no strict 'refs'; - -require Exporter; - -our @ISA = qw(Exporter); -our @EXPORT = qw(&ACCESS_NONE &ACCESS_READ &ACCESS_WRITE &ACCESS_ALL &DeclareProperty &DumpCaller &PropertyList &CloneObject); - -our $Debug; - -$Debug = 1 if not defined $Debug; - -my %ListProperties; -my %GlobalContext; - -1; - -sub ACCESS_NONE () { 0 } -sub ACCESS_READ () { 1 } -sub ACCESS_WRITE () { 2 } -sub ACCESS_ALL () {ACCESS_READ | ACCESS_WRITE} - -sub PropertyList { - return $ListProperties{ref($_[0]) || $_[0] || caller} || {}; -} - -sub DeclareProperty { - my ($attrName,$accessRights,%Mutators) = @_; - - my $Package = caller; - my $Method = $Package.'::'.$attrName; - my $fldName; - - my $getMutator = $Mutators{'get'}; - my $setMutator = $Mutators{'set'}; - - ($fldName = $Method) =~ s/:+/_/g; - - $ListProperties{$Package} = {} if not exists $ListProperties{$Package}; - $ListProperties{$Package}->{$attrName} = $fldName; - - if ($Debug) { - *$Method = sub { - my $this = shift; - - die new Exception( 'too many args ['.scalar(@_).'\]' , "'$Method' called from: ".DumpCaller() ) if (@_ > 1); - - my $Rights = $accessRights; - $Rights = ACCESS_ALL if $Package eq caller; - - if (@_){ - die new Exception("access denied 'write $Method'", "'$Method' called from: ".DumpCaller()) if not $Rights & ACCESS_WRITE; - if (defined $setMutator) { - &$setMutator($this,$fldName,shift); - } else { - $this->{$fldName} = $_[0]; - } - - } elsif (defined wantarray) { - die new Exception("access denied 'read $Method'", "'$Method' called from: ".DumpCaller()) if not $Rights & ACCESS_READ; - if (defined $getMutator) { - &$getMutator($this,$fldName); - } else { - if (wantarray){ - if(ref $this->{$fldName} eq 'ARRAY' ) { - return @{$this->{$fldName}}; - } elsif (not exists $this->{$fldName}) { - return; - } else { - return $this->{$fldName}; - } - } else { - return $this->{$fldName}; - } - } - } else { - undef; - } - }; - *$Method = \$fldName; - } else { - *$Method = sub { - my $this = shift; - #return undef if @_ > 1; - #my $Rights = $accessRights; - #$Rights = ACCESS_ALL if $Package eq caller; - - if (@_){ - # return undef if not $Rights & ACCESS_WRITE; - if (defined $setMutator) { - &$setMutator($this,$fldName,shift); - } else { - $this->{$fldName} = shift; - } - } elsif (defined wantarray) { - # return undef if not $Rights & ACCESS_READ; - if (defined $getMutator) { - &$getMutator($this,$fldName); - } else { - if (wantarray){ - if(ref $this->{$fldName} eq 'ARRAY' ) { - return @{$this->{$fldName}}; - } elsif (not defined $this->{$fldName}) { - return; - } else { - return $this->{$fldName}; - } - } else { - return $this->{$fldName}; - } - } - } else { - undef; - } - }; - *$Method = \$fldName; - } -} - -sub DumpCaller { - return join(" ",(caller($_[0]))[1,2],(caller($_[0]+1))[3]); -} - -sub Owner { - return undef if not tied $_[0]; - return undef if not tied($_[0])->UNIVERSAL::can('owner'); - return tied($_[0])->owner(); -}; - -sub CloneObject { - my $object = shift; - if (ref $object == undef) { - return $object; - } elsif (ref $object eq 'SCALAR') { - return \CloneObject(${$object}); - } elsif (ref $object eq 'ARRAY') { - return [map{CloneObject($_)}@{$object}]; - } elsif (ref $object eq 'HASH') { - my %clone; - while (my ($key,$value) = each %{$object}) { - $clone{$key} = CloneObject($value); - } - return \%clone; - } elsif (ref $object eq 'REF') { - return \CloneObject(${$object}); - } else { - if ($object->can('Clone')) { - return $object->Clone(); - } else { - die new Exception('Object doesn\'t supports cloning'); - } - } -} - -package Exception; -use parent qw(IMPL::Exception); - -package Persistent; -import Common; - -sub newSurogate { - my $class = ref($_[0]) || $_[0]; - return bless {}, $class; -} -sub load { - my ($this,$context) = @_; - die new Exception("invalid deserialization context") if ref($context) ne 'ARRAY'; - die new Exception("This is not an object") if not ref $this; - - my %Props = (@{$context}); - foreach my $BaseClass(@{ref($this).'::ISA'}) { - while (my ($key,$value) = each %{PropertyList($BaseClass)}) { - $this->{$value} = $Props{$value} if exists $Props{$value}; - } - } - - while (my ($key,$value) = each %{PropertyList(ref($this))}) { - $this->{$value} = $Props{$key} if exists $Props{$key}; - } - return 1; -} -sub save { - my ($this,$context) = @_; - - foreach my $BaseClass(@{ref($this).'::ISA'}) { - while (my ($key,$value) = each %{PropertyList($BaseClass)}) { - $context->AddVar($value,$this->{$value}); - } - } - - while (my ($key,$value) = each %{PropertyList(ref($this))}) { - $context->AddVar($key,$this->{$value}); - } - return 1; -} - -sub restore { - my ($class,$context,$surogate) = @_; - my $this = $surogate || $class->newNewSurogate; - $this->load($context); - return $this; -} - -package Object; -import Common; - -sub new { - my $class = shift; - my $self = bless {}, ref($class) || $class; - $self->CTOR(@_); - return $self; -} - -sub cast { - return bless {}, ref $_[0] || $_[0]; -} - -our %objects_count; -our %leaked_objects; - -sub CTOR { - my $this= shift; - $objects_count{ref $this} ++ if $Debug; - my %args = @_ if scalar (@_) > 0; - return if scalar(@_) == 0; - - warn "invalid args in CTOR. type: ".(ref $this) if scalar(@_) % 2 != 0; - my @packages = (ref($this)); - my $countArgs = int(scalar(@_) / 2); - #print "Set ", join(', ',keys %args), "\n"; - LOOP_PACKS: while(@packages) { - my $package = shift @packages; - #print "\t$package\n"; - my $refProps = PropertyList($package); - foreach my $name (keys %{$refProps}) { - my $fld = $refProps->{$name}; - if (exists $args{$name}) { - $this->{$fld} = $args{$name}; - #print "\t$countArgs, $name\n"; - delete $args{$name}; - $countArgs --; - last LOOP_PACKS if $countArgs < 1; - } else { - #print "\t-$name ($fld)\n"; - } - } - push @packages, @{$package.'::ISA'}; - } -} - -sub Dispose { - my $this = shift; - - if ($Debug and UNIVERSAL::isa($this,'HASH')) { - my @keys = grep { $this->{$_} and ref $this->{$_} } keys %{$this}; - warn "not all fields of the object were deleted\n".join("\n",@keys) if @keys; - } - - bless $this,'Object::Disposed'; -} - -our $MemoryLeakProtection; - -sub DESTROY { - if ($MemoryLeakProtection) { - my $this = shift; - warn sprintf("Object leaks: %s of type %s %s",$this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : ''); - } -} - -package Object::Disposed; -our $AUTOLOAD; -sub AUTOLOAD { - return if $AUTOLOAD eq __PACKAGE__.'::DESTROY'; - die new Exception('Object have been disposed',$AUTOLOAD); -} - -END { - $MemoryLeakProtection = 0 if not $Debug; -} -1;
--- a/Lib/Configuration.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ -package Configuration; -use strict; - -my $Configured = 0; - -sub import { - my ($class,$site) = @_; - - if ($site and $site ne $Configured) { - Configure($site); - $Configured = $site; - } elsif (not $site and not $Configured) { - $Configured = 1; - require Configuration::Global; - } -} - -our %virtualSite; - -sub Configure { - my $siteName = shift; - require Configuration::Global; - - while ( my ($pattern,$configSite) = each %virtualSite) { - next if not $siteName =~ $pattern; - if (ref $configSite eq 'CODE') { - $configSite->(); - } elsif (not ref $configSite and $configSite) { - require $configSite; - } - last; - } -} - - - -1;
--- a/Lib/Deployment.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -package Deployment; -use strict; - -our %DeploymentScheme; -our %DeployMethod; - -sub isUpdateNeeded { - -} - -sub Update { - -} - -1;
--- a/Lib/Deployment/Batch.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -use strict; - -package Deployment::Batch; - -require URI::file; - -my %Provider; -our $AUTOLOAD; - -our %Dirs; -our %Context; - -$Context{DieOnError} = 1; # dies by default if the action fails to run - -our @history; - -# make all inc absolute; -@INC = map { URI::file->new_abs($_)->dir } @INC; - -sub AUTOLOAD { - my $method = $AUTOLOAD; - - shift if $_[0] eq __PACKAGE__; - - my $class = "$method"; - - if (not $Provider{$method}) { - (my $file = "$class.pm") =~ s/::/\//g; - require $file; - $Provider{$method} = 1; - } - - my $action = $class->new(@_); - - push @history,$action; - if ($Context{Immediate}) { - $action->_Run or ($Context{DieOnError} ? die $_->LastError : return 0); - } - - return 1; -} - -sub SetDir { - shift if $_[0] eq __PACKAGE__; - my ($name,$dir) = @_; - - $Dirs{$name} = URI::file->new_abs($dir); -} - -sub Rollback { - return 1 if not @history; - - $_->_Rollback or $_->Log('Rollback: ',$_->LastError) foreach reverse grep { $_->isProcessed } @history; - undef @history; - return 1; -} - -sub Commit { - return 1 if not @history; - - # during commit we are in the immediate mode - local $Context{Immediate} = 1; - - $_->_Run or $_->Log('Run: ',$_->LastError) and Rollback() and last foreach grep { not $_->isProcessed } @history; - return 0 if not @history; - undef @history; - return 1; -} - -sub DoPackage { - shift if $_[0] eq __PACKAGE__; - my ($package,$inline) = @_; - - Log( "The package is required" ) and return 0 if not $package; - Log( "Processing $package" ); - my $t0 = [Time::HiRes::gettimeofday()]; - - if ($inline and $inline eq 'inline') { - $inline = 1; - } else { - $inline = 0; - } - - if (not $inline) { - my %copy = %Context; - local %Context = %copy; - local @history = (); - $Context{Package} = $Context{PackageDir} ? URI::file->new($package)->abs($Context{PackageDir}) : URI::file->new_abs($package); - $Context{PackageDir} = URI::file->new('./')->abs($Context{Package}); - - undef $@; - do $package or Log("$package: ". ($@ || $!)) and Rollback() and Log("Rollback completed in ",Time::HiRes::tv_interval($t0)," s") and return 0; - - Log("Commiting"); - Commit or Log("Commit failed in ",Time::HiRes::tv_interval($t0)) and return 0; - Log("Commit successful in ",Time::HiRes::tv_interval($t0),' s'); - return 1; - } else { - local $Context{Package} = $Context{PackageDir} ? URI::file->new($package)->abs($Context{PackageDir}) : URI::file->new_abs($package); - local $Context{PackageDir} = URI::file->new('./')->abs($Context{Package}); - - do $package or Log("$package: ". ($@ || $!)) and Rollback() and Log("Rollback completed in ",Time::HiRes::tv_interval($t0),' s') and return 0; - - return 1; - } -} - -sub Dir { - shift if $_[0] eq __PACKAGE__; - my $uriDir = $Dirs{$_[0]} or die "No such directory entry $_[0]"; - shift; - return $uriDir->dir.join('/',@_); -} - -sub PackageDir { - shift if $_[0] eq __PACKAGE__; - return $Context{PackageDir}->dir.join('/',@_); -} - -sub Log { - shift if $_[0] eq __PACKAGE__; - - if (my $hout = $Context{LogOutput}) { - print $hout 'DoPackage: ',@_,"\n"; - } - 1; -} - -1;
--- a/Lib/Deployment/Batch/Backup.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -package Deployment::Batch::Backup; -use parent qw(Deployment::Batch::Generic); -use Common; -use File::Copy; - -BEGIN { - DeclareProperty Action => ACCESS_READ; -} - -sub CTOR { - my ($this,$actionName,$actionArg) = @_; - - $this->{$Action} = { Name => $actionName, Arg => $actionArg }; -} - -sub Run { - my ($this) = @_; - - my $tmpObj; - - # we are in the immediate mode - if ($this->{$Action}{Name} eq 'File') { - $this->Log("Backup file: $this->{$Action}{Arg}"); - if (-e $this->{$Action}{Arg}) { - - Deployment::Batch->Temp( File => \$tmpObj ) or die "Failed to create temp file" ; - - copy ($this->{$Action}{Arg}, $tmpObj->filename) or die "Failed to backup"; - $this->{$Action}{Result} = $tmpObj->filename; - } - } else { - die "Don't know how to backup the $this->{$Action}{Name}"; - } -} - -sub Rollback { - my ($this) = @_; - if ($this->{$Action}{Name} eq 'File') { - $this->Log("Revert file: $this->{$Action}{Arg}"); - if ($this->{$Action}{Result}) { - copy ($this->{$Action}{Result}, $this->{$Action}{Arg}) or die "Failed to backup"; - } else { - unlink $this->{$Action}{Arg} if -f $this->{$Action}{Arg}; - } - } -} - -1;
--- a/Lib/Deployment/Batch/CDBIUpdate.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,139 +0,0 @@ -use strict; -package Deployment::Batch::CDBIUpdate; -use Common; -use parent qw(Deployment::Batch::Generic); - -use DBI; -use Schema::DataSource; -use Schema::DataSource::CDBIBuilder; - - -BEGIN { - DeclareProperty DataSchemaFile => ACCESS_READ; - DeclareProperty DataSourceDir => ACCESS_READ; - DeclareProperty DSNamespace => ACCESS_READ; - DeclareProperty DBConnection => ACCESS_READ; - DeclareProperty DBTraitsClass => ACCESS_READ; - DeclareProperty SchemaPrev => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$DataSchemaFile} = $args{'Source'} or die new Exception('A data shema file is required'); - $this->{$DataSourceDir} = $args{'Output'} or die new Exception('A directory for a data source is required'); - $this->{$DSNamespace} = $args{'Namespace'} || 'DataSource'; - $this->{$DBTraitsClass} = $args{'DBTraits'} or die new Exception('A DBTraitsClass is required'); - - (my $modname = $args{'DBTraits'}.'.pm') =~ s/::/\//g; - $this->Log("Loading DBTraits '$modname'"); - require $modname; -} - -sub Run { - my ($this) = @_; - - $this->{$DBConnection} = $this->Context->{Connection}; - - my $prefix = $this->{$DSNamespace}.'::'; - - my $schemaDS = new Schema::DataSource(DataSourceBuilder => new Schema::DataSource::CDBIBuilder); - $schemaDS->BuildSchema($this->{$DataSchemaFile}); - - my $schemaDB = $schemaDS->DataSourceBuilder->BuildDBSchema(); - (my $fname = $this->{$DataSourceDir}.$this->{$DSNamespace}.'.pm') =~ s/::/\//g; - - # we are in the immediate mode, so the file will be backupped immediatelly; - $this->Log("Backup $fname"); - Deployment::Batch->Backup( File => $fname ); - - $this->Log("Write the datasource '$this->{$DSNamespace}' to '$this->{$DataSourceDir}'"); - $schemaDS->DataSourceBuilder->WriteModules($fname,$prefix); - - if ($this->{$DBConnection}) { - $this->Log("Update the database '$this->{$DBConnection}[0]'"); - - $this->{$SchemaPrev} = $this->UpdateDBToSchema($schemaDB); - - } - $schemaDB->Dispose; -} - -sub Rollback { - my ($this) = @_; - - if ($this->{$SchemaPrev}) { - $this->Log("Rallback the DB schema"); - $this->UpdateDBToSchema($this->{$SchemaPrev})->Dispose; - $this->{$SchemaPrev}->Dispose; - delete $this->{$SchemaPrev}; - } - -} - -sub UpdateDBToSchema { - my ($this,$schemaDB) = @_; - my $dbh = DBI->connect(@{$this->{$DBConnection}}) or die new Exception('Failed to connect to the database',@{$this->{$DBConnection}}); - my $SchemaSource; - - if (UNIVERSAL::can($this->{$DBTraitsClass},'GetMetaTable')) { - $SchemaSource = new Deployment::CDBI::SQLSchemeSource (MetaTable => $this->{$DBTraitsClass}->GetMetaTable($dbh)); - } else { - die new Exception("Can't get a meta table",$this->{$DBTraitsClass}); - } - - my $schemaDBOld = $SchemaSource->ReadSchema($schemaDB->Name); - - my $updater = $this->{$DBTraitsClass}->new(SrcSchema => $schemaDBOld, DstSchema => $schemaDB); - $updater->UpdateSchema(); - - $dbh->do($_) or die new Exception('Failed to execute the sql statement', $_) foreach $updater->Handler->Sql; - - $SchemaSource->SaveSchema($schemaDB); - return $schemaDBOld; -} - -sub DESTROY { - my $this = shift; - - $this->{$SchemaPrev}->Dispose if $this->{$SchemaPrev}; -} - -package Deployment::CDBI::SQLSchemeSource; -use Common; -use Data::Dumper; -use MIME::Base64; -use Storable qw(nstore_fd fd_retrieve); -our @ISA = qw(Object); - -BEGIN { - DeclareProperty MetaTable => ACCESS_NONE; -} - -sub ReadSchema { - my ($this,$name) = @_; - - my $schema = decode_base64($this->{$MetaTable}->ReadProperty("db_schema_$name")); - if ($schema) { - open my $hvar,"<",\$schema or die new Exception("Failed to create a handle to the variable"); - return fd_retrieve($hvar); - } else { - return new Schema::DB(Name => $name, Version => 0); - } -} - -sub SaveSchema { - my ($this,$schema) = @_; - - my $name = $schema->Name; - - my $data = ""; - { - open my $hvar,">",\$data or die new Exception("Failed to create a handle to the variable"); - nstore_fd($schema,$hvar); - } - - $this->{$MetaTable}->SetProperty("db_schema_$name",encode_base64($data)); -} - -1;
--- a/Lib/Deployment/Batch/CopyFile.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -use strict; -package Deployment::Batch; -our %Dirs; -package Deployment::Batch::CopyFile; -use parent qw(Deployment::Batch::Generic); -use File::Copy; -require URI::file; -use Common; - -BEGIN { - DeclareProperty Src => ACCESS_READ; - DeclareProperty Dst => ACCESS_READ; -} - -sub CTOR { - my ($this,$src,$dest,$Dir) = @_; - - $src or die "Source file name is required"; - $dest or die "Destination file name is reqiured"; - - my $uriSrc = URI::file->new($src)->abs($this->Context->{PackageDir}); - - my $uriDest = URI::file->new($dest); - - $uriDest = $uriDest->abs( - ($Dir and $Dirs{$Dir}) ? - $Dirs{$Dir} : - $this->Context->{PackageDir} - ); - - $this->{$Src} = $uriSrc->file; - $this->{$Dst} = $uriDest->file; -} - -sub Run { - my ($this) = @_; - - $this->Log("Copy '$this->{$Src}' to '$this->{$Dst}'"); - - Deployment::Batch->Backup( File => $this->{$Dst} ); - - copy($this->{$Src},$this->{$Dst}) or die "copy failed: $!"; -} - -1;
--- a/Lib/Deployment/Batch/CopyTree.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -package Deployment::Batch::CopyTree; -use parent 'Deployment::Batch::Generic'; -use Common; - -1;
--- a/Lib/Deployment/Batch/CustomAction.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,32 +0,0 @@ -use strict; -package Deployment::Batch::CustomAction; -use parent qw(Deployment::Batch::Generic); -use Common; - -BEGIN { - DeclareProperty handlerRun => ACCESS_READ; - DeclareProperty handlerRollback => ACCESS_READ; - DeclareProperty Name => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$handlerRun} = $args{Run} || sub {}; - $this->{$handlerRollback} = $args{Rollback} || sub {}; - $this->{$Name} = $args{Name} || $this->SUPER::Name(); -} - -sub Run { - my ($this) = @_; - - $this->{$handlerRun}->($this); -} - -sub Rollback { - my ($this) = @_; - - $this->{$handlerRollback}->($this); -} - -1;
--- a/Lib/Deployment/Batch/Generic.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -use strict; -package Deployment::Batch; -our @history; - -package Deployment::Batch::Generic; -use Common; -use Time::HiRes; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty isProcessed => ACCESS_READ; - DeclareProperty LastError => ACCESS_READ; - DeclareProperty LocalHistory => ACCESS_NONE; -} - -sub _Run { - my ($this) = @_; - - undef $@; - local @history = (); - my $t0 = [Time::HiRes::gettimeofday]; - eval { - $this->Run; - }; - $this->Log("completed in ",Time::HiRes::tv_interval($t0)," s"); - - if ($@) { - $this->{$LastError} = $@; - Deployment::Batch::Rollback(); # rallback nested actions - return 0; - } - - $this->{$LocalHistory} = \@history; - $this->{$isProcessed} = 1; - - return 1; -} - -sub Name { - my $this = shift; - (my $mod = ref $this) =~ s/^(?:\w+\:\:)*(\w+)$/$1/; - return $mod; -} - -sub _Rollback { - my ($this) = @_; - - undef $@; - eval { - $this->Rollback; - }; - - if ($@) { - $this->{$LastError} = $@; - } - - $this->{$isProcessed} = 0; - - if ($this->{$LocalHistory}) { - local @history = @{$this->{$LocalHistory}}; - Deployment::Batch::Rollback(); - } - - return 1; -} - -sub Context { - my $this = shift; - - return \%Deployment::Batch::Context; -} - -sub Log { - my $this = shift @_; - if ($this->Context->{LogOutput}) { - my $out = $this->Context->{LogOutput}; - print $out $this->Name,": ",@_,"\n"; - } -} - -sub Run { -} - -sub Rollback { -} - -1;
--- a/Lib/Deployment/Batch/Temp.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,52 +0,0 @@ -use strict; -package Deployment::Batch::Temp; -use parent qw(Deployment::Batch::Generic); -use Common; -use File::Temp; - - -BEGIN { - DeclareProperty TmpObj => ACCESS_READ; - DeclareProperty Ref => ACCESS_NONE; - DeclareProperty TmpObjType => ACCESS_NONE; -} - -sub CTOR { - my ($this,$type,$ref) = @_; - - die "A reference to the temp object can be obtained only in the immediate mode" if $ref and not $this->Context->{Immediate}; - - $this->{$TmpObjType} = $type or die "The type of a temporary object should be specified"; - $this->{$Ref} = $ref; -} - -sub Run { - my ($this) = @_; - - if ($this->{$TmpObjType} eq 'File') { - $this->{$TmpObj} = File::Temp->new; - if ($this->{$Ref}) { - ${$this->{$Ref}} = $this->{$TmpObj}; - } else { - $this->Context('tmpfile') = $this->{$TmpObj}->filename; - } - } elsif ($this->{$TmpObjType} eq 'Dir') { - $this->{$TmpObj} = File::Temp->newdir; - if ($this->{$Ref}) { - ${$this->{$Ref}} = $this->{$TmpObj}; - } else { - $this->Context('tmpdir') = $this->{$TmpObj}->dirname; - } - } else { - die "Don't know how to create a temporary $this->{$TmpObjType}"; - } -} - -sub DESTORY { - my ($this) = @_; - - undef $this->{$TmpObj}; -} - - -1;
--- a/Lib/Deployment/CDBI.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,101 +0,0 @@ -use strict; -package Deployment::CDBI; -use Common; -use DBI; -use Schema::DataSource; -use Schema::DataSource::CDBIBuilder; - -our @ISA = qw(Object); - -BEGIN { - DeclareProperty DataSchemaFile => ACCESS_READ; - DeclareProperty DataSourceDir => ACCESS_READ; - DeclareProperty DSNamespace => ACCESS_READ; - DeclareProperty DBConnection => ACCESS_READ; - DeclareProperty DBTraitsClass => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$DataSchemaFile} = $args{'DataSchemaFile'} or die new Exception('A data shema file is required'); - $this->{$DataSourceDir} = $args{'DataSourceDir'} or die new Exception('A directory for a data source is required'); - $this->{$DSNamespace} = $args{'DSNamespace'} || 'DataSource'; - $this->{$DBTraitsClass} = $args{'DBTraitsClass'} or die new Exception('A DBTraitsClass is required'); - $this->{$DBConnection} = $args{'DBConnection'}; -} - -sub Update { - my ($this) = @_; - - my $prefix = $this->{$DSNamespace}.'::'; - - my $schemaDS = new Schema::DataSource(DataSourceBuilder => new Schema::DataSource::CDBIBuilder); - $schemaDS->BuildSchema($this->{$DataSchemaFile}); - - my $schemaDB = $schemaDS->DataSourceBuilder->BuildDBSchema(); - (my $fname = $this->{$DSNamespace} ) =~ s/::/\//g; - $schemaDS->DataSourceBuilder->WriteModules($this->{$DataSourceDir}.$fname.'.pm',$prefix); - - if ($this->{$DBConnection}) { - - my $dbh = DBI->connect(@{$this->{$DBConnection}}) or die new Exception('Failed to connect to the database',@{$this->{$DBConnection}}); - my $SchemaSource; - if (UNIVERSAL::can($this->{$DBTraitsClass},'GetMetaTable')) { - $SchemaSource = new Deployment::CDBI::SQLSchemeSource (MetaTable => $this->{$DBTraitsClass}->GetMetaTable($dbh)); - } else { - die new Exception("Can't get meta table"); - } - - my $schemaDBOld = $SchemaSource->ReadSchema($schemaDB->Name); - - my $updater = $this->{$DBTraitsClass}->new(SrcSchema => $schemaDBOld, DstSchema => $schemaDB); - $updater->UpdateSchema(); - - $dbh->do($_) or die new Exception('Failed to execute the sql statement', $_) foreach $updater->Handler->Sql; - - $SchemaSource->SaveSchema($schemaDB); - - $schemaDBOld->Dispose; - } - $schemaDB->Dispose; -} - -package Deployment::CDBI::SQLSchemeSource; -use Common; -use Data::Dumper; -use MIME::Base64; -use Storable qw(nstore_fd fd_retrieve); -our @ISA = qw(Object); - -BEGIN { - DeclareProperty MetaTable => ACCESS_NONE; -} - -sub ReadSchema { - my ($this,$name) = @_; - - my $schema = decode_base64($this->{$MetaTable}->ReadProperty("db_schema_$name")); - if ($schema) { - open my $hvar,"<",\$schema or die new Exception("Failed to create a handle to the variable"); - return fd_retrieve($hvar); - } else { - return new Schema::DB(Name => $name, Version => 0); - } -} - -sub SaveSchema { - my ($this,$schema) = @_; - - my $name = $schema->Name; - - my $data; - { - open my $hvar,">",\$data or die new Exception("Failed to create a handle to the variable"); - nstore_fd($schema,$hvar); - } - - $this->{$MetaTable}->SetProperty("db_schema_$name",encode_base64($data)); -} - -1;
--- a/Lib/Engine/Action.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -use strict; - -package Engine::Action; -use Engine::CGI; -use Common; -use URI; -use parent qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill IMPL::Object::EventSource); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -our %Fallout; - -BEGIN { - public _direct property Package => prop_all; - public _direct property Method => prop_all; - public _direct property Output => prop_all; - public _direct property RequestURI => prop_all; - public _direct property Result => prop_all; - __PACKAGE__->CreateEvent('OnPreInvoke'); - __PACKAGE__->CreateEvent('OnPastInvoke'); -} - -sub Invoke { - my ($this,$query) = @_; - - eval { - die new Exception('A package isn\'t specified for the action',$this->RequestURI->as_string) if not $this->{$Package}; - - no strict 'refs'; - eval "require ".$this->{$Package}.";" or die $@; - - $this->OnPreInvoke(); - - $this->{$Package}->can($this->{$Method}) or - die new Exception("The method doesn't exists", $this->{$Method}, $this->{$Package}) - if not ref $this->{$Method} eq 'CODE'; - - my $instance = $this->{$Package}->can('revive') ? $this->{$Package}->revive : $this->{$Package}; - my $method = $this->{$Method}; - - $this->{$Result} = $instance->$method($query,$this); - $this->OnPastInvoke(); - }; - - if($@) { - my $err = $@; - my $module = ref $this->{$Output} || $this->{$Output}; - if(my $uri = $module ? ($Fallout{$module}->{ref $err} || $Fallout{$module}->{Default}) : undef) { - $this->{$RequestURI} = URI->new($uri,'http'); - $this->{$Result} = $Common::Debug ? $err : undef; - } else { - die $err; - } - } -} - -sub Dispose { - my ($this) = @_; - - undef %$this; - - $this->SUPER::Dispose; -} - -1;
--- a/Lib/Engine/Action/URICall.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -package Engine::Action::URICall; -use strict; -use Common; -use Engine::Action; - -our $Namespace; - -our %MapOutput; -our $DefaultMethod; - -%MapOutput = ( page => 'Engine::Output::Page' , xml => 'Engine::Output::Xml' ) if not %MapOutput; - -=pod - /module/submodule/method.format -=cut - -sub ConstructAction { - my ($class,$uriRequest) = @_; - - my @module = $uriRequest->path_segments; - - my ($function,$format) = (((pop @module) or $DefaultMethod) =~ m/^(.*?)(?:\.(\w+))?$/); - @module = grep $_, @module; - my $module = @module ? ($Namespace ? $Namespace . '::' : '').join('::',@module) : $Namespace; - - return new Engine::Action( Package => $module, Method => $function, Output => $class->MapOutput($format), RequestURI => $uriRequest); -} - -sub MapOutput { - my ($class,$format) = @_; - my $module = $MapOutput{$format} or return undef; - - eval "require $module;" or die new Exception('Failed to load output module',$module,$@); - - if ($module->can('construct')) { - return $module->construct($format); - } else { - return $module; - } -} - -1;
--- a/Lib/Engine/CGI.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -use strict; -package Engine::CGI; -use parent 'CGI'; -use Encode; -use Common; - -BEGIN { - DeclareProperty Expires => ACCESS_ALL; -} - -my $query; - -sub Query { - $query = new Engine::CGI unless $query; - return $query; -} - - -my $fcgi_loaded = 0; -sub Accept { - my ($self) = shift; - require CGI::Fast unless $fcgi_loaded; - $fcgi_loaded = 1; - - my $fquery = CGI::Fast->new(); - $query = $fquery ? $self->new($fquery) : undef; - return $query; -} - -sub as_list { - return( map { UNIVERSAL::isa($_,'ARRAY') ? @{$_} : defined $_ ? $_ : () } @_ ); -} - -sub header { - my ($this,%args) = @_; - - $args{'-cookies'} = [as_list($args{'-cookies'}), values %{$this->{'cookies_list'}}] if $this->{'cookies_list'}; - $args{'-expires'} = $this->{$Expires} || 'now'; - - $this->SUPER::header(%args); -} - -sub SetCookies { - my ($this,@cookies) = @_; - - foreach (@cookies) { - $this->{'cookies_list'}{$_->name} = $_; - } -} - -sub param { - my ($this) = shift; - my $charset = $this->charset or die new Exception("Encoding is not defined"); - if (wantarray) { - return map { Encode::is_utf8($_) ? $_ : Encode::decode($charset,$_,Encode::LEAVE_SRC) } $this->SUPER::param( map Encode::encode($charset,$_,Encode::LEAVE_SRC ), @_ ); - } else { - my $val = $this->SUPER::param( map Encode::encode($charset,$_,Encode::LEAVE_SRC ), @_ ); - return (Encode::is_utf8($val) ? $val : Encode::decode($charset,$val,Encode::LEAVE_SRC)); - } -} - -sub param_raw { - my $this = shift; - return $this->SUPER::param(@_); -} - -1;
--- a/Lib/Engine/Output/JSON.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -package Configuration; -our $HtDocsDir; - -package Engine; -our $Encoding; - -package Engine::Output::JSON; -use strict; -use warnings; - -use Encode; -use PerlIO; -use IMPL::Exception; -use JSON; - -sub CTX_TEMPLATE() { 1 } -sub CTX_DATA() { 2 } - -my $context = CTX_DATA; -our $Data; - -sub template() { $context = CTX_TEMPLATE } -sub data() { $context = CTX_DATA } - -sub Print { - my ($class,$query,$action) = @_; - - my @path = $action->RequestURI->path_segments; - shift @path; - - my $result; - - undef $@; - $Data = $action->Result; - eval { - my $fname = $HtDocsDir . join '/', @path; - if ($context == CTX_DATA) { - my $dummy = ''; - open my $hstd, ">>", \$dummy or die new IMPL::Exception('Failed to create inmemory stream'); - local (*STDIN,*STDOUT) = ($hstd,$hstd); - local ${^ENCODING}; - $result = do $fname or die new IMPL::Exception('Failed to evalute the file', $@, $!,$fname); - } else { - die new IMPL::Exception('JSON templates not implemented'); - } - }; - if ($@) { - $result = { errorCode => 1, errorMessage => "$@"}; - } - - print $query->header(-status => 200, -type => 'text/javascript'); - print to_json({ errorCode => 0, result => $result }); -} - - -1;
--- a/Lib/Engine/Output/Page.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ -package Engine; -our $Encoding; - -package Engine::Output::Page; -use strict; - -use Common; -use DOM; - -sub Print { - my ($class,$Query,$Action) = @_; - - if (DOM::Site->can('LoadPage')) { - my $pageId = $Action->RequestURI->path; - DOM::Site->RegisterObject("Request",$Action); - my $Page = DOM::Site->LoadPage($pageId); - print $Query->header(-status => 200); - undef $@; - eval { - $Page->Properties->{Encoding} = $Engine::Encoding; - $Page->Render(*STDOUT); - }; - if ($@) { - print $Query->start_html('Error processing template'); - print $Query->p("Page: $pageId"); - print $Query->p("Error: $@"); - print $Query->end_html; - } - } else { - die new Exception('The site doesn\'t support page output'); - } -} - -1;
--- a/Lib/Engine/Output/Template.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -package Engine; -our $Encoding; - -package Engine::Output::Template; -use strict; -use Common; -use Template; -our @ISA = qw(Object); -our %Formats; - -BEGIN { - DeclareProperty Include => ACCESS_READ; - DeclareProperty ContentType => ACCESS_READ; - DeclareProperty Encoding => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Include} = $args{Include} or die new Exception('An include diretory is required',$args{Format}); - $this->{$ContentType} = $args{ContentType} or die new Exception('A content type must be specied',$args{Format}); - $this->{$Encoding} = $args{Encoding}; -} - -sub Print { - my ($this,$Query,$Action) = @_; - - my $template = new Template( - { - INCLUDE_PATH => $this->{$Include}, - INTERPOLATE => 1, - RECURSION => 1, - ENCODING => $this->{$Encoding} - } - ); - - my @path = $Action->RequestURI->path_segments; - shift @path; - my $Template; - eval { - $Template = $template->context->template(join('/',@path)); - }; - print $Query->header(-type => 'text/html') and die new Exception('Failed to process a template', $@) if $@; - $Query->Expires($Template->Expires); - print $Query->header(-type => $this->{$ContentType}); - print $template->context->process($Template,{Encoding => $Engine::Encoding, Data => $Action->Result, Query => $Query }); -} - -sub construct { - my ($class,$format) = @_; - - $class->new(%{$Formats{$format}},Format => $format); -} - -1;
--- a/Lib/Engine/Security.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -use strict; -package Engine::Security; -use Security::Auth; -use Security; -use Engine::Security::Auth; - -our @AuthMethods; -my $AuthResult; -my $AuthMod; -my $AuthMethod; - -# use last auth method as default -$AuthMethod = Engine::Security::Auth->new(%{$AuthMethods[$#AuthMethods]}) if @AuthMethods; - -sub AuthenticateContext { - Security->CurrentSession(undef); #prevent previous session from closing - foreach my $method (@AuthMethods) { - my $AuthObj = Engine::Security::Auth->new(%$method); - $AuthResult = $AuthObj->DoAuth(); - # обновить текущий контекст безопасности, только если это необходимо - $AuthObj->SetAuthResult($AuthResult) if $AuthResult->State == Security::AUTH_FAILED or $AuthResult->State == Security::AUTH_SUCCESS; - $AuthMethod = $AuthObj and last if $AuthResult->State != Security::AUTH_FAILED and $AuthResult->State != Security::AUTH_NOAUTH; - } - $AuthMod = $AuthMethod->AuthMod if $AuthMethod; -} - -sub SetAuthResult { - shift; - $AuthMethod->SetAuthResult(@_) if $AuthMethod; -} - -sub AuthMod { - return $AuthMethod ? $AuthMethod->AuthMod : undef; -} - -1;
--- a/Lib/Engine/Security/AccessDeniedException.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -package Engine::Security::AccessDeniedException; -use strict; -use Common; -our @ISA = qw(Exception); - -sub CTOR { - my ($this,$message,@args) = @_; - - $this->SUPER::CTOR($message ? $message : 'Access denied',@args); -} - - -1;
--- a/Lib/Engine/Security/Auth.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,94 +0,0 @@ -package Engine::Security::Auth; -use strict; -use Common; -our @ISA = qw(Object); -use Security; -use Security::Auth; -use Engine::Security::AccessDeniedException; - -BEGIN { - DeclareProperty ClientSecData => ACCESS_READ; - DeclareProperty SecPackage => ACCESS_READ; - DeclareProperty DataSource => ACCESS_READ; - DeclareProperty DefaultUser => ACCESS_READ; - DeclareProperty _AuthMod => ACCESS_NONE; # construct on demand -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - eval "require $this->{$ClientSecData};" or warn $@; -} - -sub DoAuth { - my ($this) = @_; - - my $data = $this->{$ClientSecData}->ReadSecData($this); - my $SSID = $this->{$ClientSecData}->ReadSSID($this); - - my $AuthResult; - - if ($SSID) { - $AuthResult = $this->AuthMod->AuthenticateSession($SSID,$data); - } else { - $AuthResult = new Security::AuthResult(State => Security::AUTH_NOAUTH); - } - - if ($AuthResult->State == Security::AUTH_SUCCESS) { - #warn "Session authenticated: ".$AuthResult->Session->User->Name; - } else { - #warn "Session is not authenticated: ".$AuthResult->State; - if ($this->{$DefaultUser}) { - $AuthResult = $this->AuthMod->AuthenticateUser($this->{$DefaultUser},undef); - } - } - - return $AuthResult; -} - -sub SetAuthResult { - my ($this,$AuthResult) = @_; - - if ($AuthResult and $AuthResult->State == Security::AUTH_SUCCESS) { - $this->_CurrentSession($AuthResult->Session); - $this->{$ClientSecData}->WriteSecData($AuthResult->ClientSecData,$this); - } else { - $this->_CurrentSession(undef); - $this->{$ClientSecData}->WriteSecData(undef,$this); - } -} - -sub _CurrentSession { - my ($this,$Session) = @_; - - if (@_ >= 2) { - $this->AuthMod->DS->CloseSession(Security->CurrentSession) if Security->CurrentSession; - - $this->{$ClientSecData}->WriteSSID($Session ? $Session->SSID : undef); - Security->CurrentSession($Session); - } else { - return Security->CurrentSession; - } -} - -sub AuthMod { - my ($this) = @_; - if (not $this->{$_AuthMod}) { - if ($this->{$DataSource} and $this->{$SecPackage}) { - eval qq { - require $this->{$DataSource}; - require $this->{$SecPackage}; - } or warn $@; - $this->{$_AuthMod} = Security::Auth->new( - DS => $this->{$DataSource}, - SecPackage => $this->{$SecPackage} - ); - } else { - #construct default - $this->{$_AuthMod} = Security::Auth->construct; - } - } - return $this->{$_AuthMod}; -} - -1;
--- a/Lib/Engine/Security/Cookies.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -use strict; -package Engine::Security::Cookies; -use Engine::CGI; -use CGI::Cookie; - -sub ReadSecData { - - return Engine::CGI::Query->cookie('SecData'); -} - -sub WriteSecData { - my ($class,$data) = @_; - - Engine::CGI::Query->SetCookies(new CGI::Cookie(-name => 'SecData', -value => $data, -expires => '+1d')); -} - -sub ReadSSID { - return Engine::CGI::Query->cookie('SSID'); -} - -sub WriteSSID { - my ($class,$data) = @_; - - Engine::CGI::Query->SetCookies(new CGI::Cookie(-name => 'SSID', -value => $data, -expires => '+1d')); -} - -1;
--- a/Lib/Engine/Security/IPSession.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -package Engine::Security::IPSession; -use strict; -use Digest::MD5 qw(md5_hex); - -our %IPMap; # { IP_ADDR => {user => 'name', ClientSecData => 'ClientData', InitSecData => 'ServerData'} } - -sub ReadSecData { - - return $IPMap{$ENV{REMOTE_ADDR} || ''} ? $IPMap{$ENV{REMOTE_ADDR} || ''}->{ClientSecData} : undef; # avoid from create hash item -} - -sub WriteSecData { - my ($class,$data) = @_; - # does nothing -} - -sub ReadSSID { - my ($class,$authEngineObj) = @_; - - my $ip = $ENV{REMOTE_ADDR}; - return undef if not $IPMap{$ip || ''}; - my $SSID = md5_hex($ip); - - if (not my $session = $authEngineObj->AuthMod->DS->LoadSession($SSID)) { - my $User = $authEngineObj->AuthMod->DS->FindUser($IPMap{$ip}->{user}) or warn "can't authenticate the $ip: user not found" and return undef; - $authEngineObj->AuthMod->DS->CreateSession($SSID,$User,$authEngineObj->AuthMod->SecPackage->NewAuthData($IPMap{$ip}->{InitSecData})); - } elsif ($session->User->Name ne $IPMap{$ip}->{user}) { - # update user - my $User = $authEngineObj->AuthMod->DS->FindUser($IPMap{$ip}->{user}); - if ($User) { - $session->User($User); - } else { - warn "can't authenticate the $ip: user not found"; - $authEngineObj->AuthMod->DS->CloseSession($session); - } - } - - return $SSID; -} - -sub WriteSSID { - my ($class,$data) = @_; - - #do nothing -} - - -1;
--- a/Lib/Form/Container.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -package Form::Container; -use strict; -use Common; -use Form::Filter; -use parent qw(Form::Item); - -BEGIN { - DeclareProperty Schema => ACCESS_READ; - DeclareProperty Children => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - $args{Schema} or die new Exception('A schema is required'); - - $this->SUPER::CTOR(@args{qw(Id Form Parent Attributes)}); - $this->{$Schema} = $args{Schema}; -} - -sub ResolveItem { - my ($this,$ItemId) = @_; - - if (my $schemaChild = $this->{$Schema}->FindChild($ItemId->Name)) { - if ($schemaChild->isMulti) { - defined $ItemId->InstanceID or die new Exception('Instance id is required for a muti element'); - if (my $child = $this->{$Children}{$ItemId->Name}[$ItemId->InstanceID]){ - return $child; - } else { - return undef if not $this->Form->AutoCreate; - return $this->{$Children}{$ItemId->Name}[$ItemId->InstanceID] = $this->Form->CreateInstance($schemaChild,$ItemId,$this); - } - - } else { - defined $ItemId->InstanceID and die new Exception('The child is a single element',$this->Id->Canonical,$ItemId->Name); - if(my $child = $this->{$Children}{$ItemId->Name}) { - return $child; - } else { - return undef if not $this->Form->AutoCreate; - return $this->{$Children}{$ItemId->Name} = $this->Form->CreateInstance($schemaChild,$ItemId,$this); - } - } - } else { - die new Exception('The requested item isn\'t exists in the schema', $this->Id->Canonical,$ItemId->Name); - } -} - -sub isEmpty { - my ($this) = @_; - - foreach my $child (values %{$this->{$Children} || {} }) { - if (ref $child eq 'ARRAY') { - foreach my $inst (@$child) { - return 0 if not $child->isEmpty; - } - } else { - return 0 if not $child->isEmpty; - } - } - - return 1; -} - -=pod -Получает дочерние контенеры в виде списка, при том только не пустые контейнеры. -Если дочернний контейнер не множественный, то список будет состоять из одного элемента. -=cut -sub GetChild { - my ($this,$name) = @_; - return unless exists $this->{$Children}{$name}; - return( grep $_, map { UNIVERSAL::isa($_,'ARRAY') ? @{$_} : $_ } $this->{$Children}{$name} ); -} - -=pod -Выполняет фильтры по схеме для себя и всех детей. -Фильтры определяются по схеме и вызываются в различнх контекстах - -* сначала для группы, -* потом для детишек, причем если - * детишки множественные, то - * снсчала для набора детишек, а потом - * для каждого в отдельности -=cut -sub Validate { - my ($this,$rhDisableFilters) = @_; - - $rhDisableFilters ||= {}; - - my @errors; - - foreach my $filter (grep {$_->SUPPORTED_CONTEXT & (Form::Filter::CTX_SINGLE) and not exists $rhDisableFilters->{$_}} map {$_->Instance} $this->{$Schema}->Filters) { - my $result = $filter->Invoke($this,Form::Filter::CTX_SINGLE | Form::Filter::CTX_EXISTENT,$this->{$Schema}); - if ($result->State == Form::FilterResult::STATE_SUCCESS_STOP) { - return (); - } elsif ($result->State == Form::FilterResult::STATE_ERROR) { - push @errors,$result; - } - } - - CHILD_LOOP: foreach my $schemaChild ($this->{$Schema}->Children) { - - if ($schemaChild->isMulti) { - my %DisableFilters; - foreach my $filter (grep {$_->SUPPORTED_CONTEXT & Form::Filter::CTX_SET} map {$_->Instance} $schemaChild->Filters) { - - my $result = $filter->Invoke($this->{$Children}{$schemaChild->Name},Form::Filter::CTX_SET,$schemaChild,$this); - if ($result->State == Form::FilterResult::STATE_ERROR) { - push @errors,$result; - # не проверять другие фильтры вообще - next CHILD_LOOP; - } elsif ($result->State == Form::FilterResult::STATE_SUCCESS_STOP) { - # не проверять другие фильтры вообще - next CHILD_LOOP; - } elsif ($result->State == Form::FilterResult::STATE_SUCCESS_STAY) { - # не проверять данный фильтр на каждом экземпляре - $DisableFilters{$filter} = 1; - } else { - # STATE_SUCCESS - все ок - } - } - - $_ and push @errors,$_->Validate(\%DisableFilters) foreach grep !$_->isEmpty, $this->GetChild($schemaChild->Name); - - } else { - my %DisableFilters; - - # проверяем фильтры, которые могут применяться на несуществующем значении - foreach my $filter (grep { $_->SUPPORTED_CONTEXT & Form::Filter::CTX_SINGLE and not $_->SUPPORTED_CONTEXT & Form::Filter::CTX_EXISTENT} map {$_->Instance} $schemaChild->Filters) { - my $result = $filter->Invoke($this->{$Children}{$schemaChild->Name},Form::Filter::CTX_SINGLE,$schemaChild,$this); - - if ($result->State == Form::FilterResult::STATE_ERROR) { - push @errors,$result; - # не проверять другие фильтры вообще - next CHILD_LOOP; - } elsif ($result->State == Form::FilterResult::STATE_SUCCESS_STOP) { - # не проверять другие фильтры вообще - next CHILD_LOOP; - } else { - # STATE_SUCCESS(_STAY) - все ок - $DisableFilters{$filter} = 1; - } - } - - # если значение существует, то применяем оставшиеся фильтры - push @errors,$this->{$Children}{$schemaChild->Name}->Validate(\%DisableFilters) if $this->{$Children}{$schemaChild->Name}; - } - - } - - return @errors; -} - -sub Dispose { - my ($this) = @_; - - foreach my $child (values %{ $this->{$Children} || {} }) { - if (ref $child eq 'ARRAY') { - foreach my $inst (@$child) { - $inst->Dispose; - } - } else { - die new IMPL::Exception("Child is null",%{ $this->{$Children} }) if not $child; - $child->Dispose; - } - } - - delete @$this{$Schema,$Children}; - - $this->SUPER::Dispose; -} -1;
--- a/Lib/Form/Filter.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -package Form::Filter; -use strict; -use Common; -our @ISA = qw(Object); - -use constant { - CTX_SINGLE => 1, # значение поля - CTX_SET => 2, # множество значений - CTX_EXISTENT => 4 # только существующие значения -}; - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Message => ACCESS_READ; -} - -sub CTOR { - my ($this,$name,$message) = @_; - $this->{$Name} = $name or die new Exception('A filter name is required'); - $this->{$Message} = $message; -} - -sub FormatMessage { - my ($this,$object) = @_; - - (my $message = $object->Attributes->{$this->{$Name}} || $this->{$Message} || ($Common::Debug ? "$this->{$Name}: %name%" : '')) =~ s{%(\w+(?:\.\w+)*)%}{ - my $value = $object->Attributes->{$1} || ($Common::Debug ? $object->Name.'.'.$1 : ''); - }ge; - - return $message; -} - -package Form::FilterResult; -use Common; -our @ISA = qw(Object); - -use constant { - STATE_ERROR => 0, # ошибочное значение - STATE_SUCCESS => 1, # значение корректное, можно продолжать выполнение - STATE_SUCCESS_STOP => 2, # значение корректное, выполнение остальных фильтров не требуется - STATE_SUCCESS_STAY => 3 # значение корректное, выполнение данного фильтра более не требуется -}; - -BEGIN { - DeclareProperty State => ACCESS_READ; - DeclareProperty Message => ACCESS_READ; - DeclareProperty Target => ACCESS_READ; - DeclareProperty Container => ACCESS_READ; -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - UNIVERSAL::isa($this->{$Target},'Form::Item') or UNIVERSAL::isa($this->{$Container},'Form::Container') or die new Exception("Invalid Target or Container property") if $this->{$State} == STATE_ERROR; -} - -sub Item { - my $this = shift; - - return ref $this->{$Target} ? - ($this->{$Target}->isa('Form::Item') ? $this->{$Target} : $this->{$Container}->Item( $this->{$Target}->isMulti ? $this->{$Target}->Name . '0' : $this->{$Target}->Name ) ) - : - ($this->{$Target}); -} - -1;
--- a/Lib/Form/Filter/Depends.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ -package Form::Filter::Depends; -use parent qw(Form::Filter); - -use Common; - -BEGIN { - DeclareProperty Fields => ACCESS_READ; -} - -sub SUPPORTED_CONTEXT { Form::Filter::CTX_SINGLE | Form::Filter::CTX_SET } - -sub CTOR { - my ($this,$name,$message,@fields) = @_; - - $this->SUPER::CTOR($name,$message); - $this->{$Fields} = \@fields; -} - -sub Invoke { - my ($this,$object,$context,$schemaTarget) = @_; - - foreach my $field (@{$this->{$Fields}}) { - my $objProv = $object->Navigate($object->Form->MakeItemId($field,$object->Parent)); - - if ( not $objProv or $objProv->isEmpty ) { - return new Form::FilterResult(State => Form::FilterResult::STATE_STOP); - } - - } - - return new Form::FilterResult(State => Form::FilterResult::STATE_SUCCESS_STAY); -} - -1;
--- a/Lib/Form/Filter/Mandatory.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,34 +0,0 @@ -package Form::Filter::Mandatory; -use strict; -use Common; -use parent qw(Form::Filter); - -sub SUPPORTED_CONTEXT { Form::Filter::CTX_SINGLE | Form::Filter::CTX_SET } - -sub Invoke { - my ($this,$target,$context,$schemaTarget,$parent) = @_; - - my @list; - if ($context & Form::Filter::CTX_SET) { - @list = @{$target || []}; - } elsif ($context & (Form::Filter::CTX_SINGLE | Form::Filter::CTX_EXISTENT)) { - @list = ($target); - } - - foreach my $object (@list) { - if (defined $object and not $object->isEmpty) { - return Form::FilterResult->new( - State => Form::FilterResult::STATE_SUCCESS_STAY - ); - } - } - - return Form::FilterResult->new( - State => Form::FilterResult::STATE_ERROR, - Message => $this->FormatMessage($schemaTarget), - Target => $schemaTarget, - Container => $parent - ); -} - -1;
--- a/Lib/Form/Filter/Regexp.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -package Form::Filter::Regexp; -use strict; -use Common; -use Form::Filter; -use parent qw(Form::Filter); - -BEGIN { - DeclareProperty Regexp => ACCESS_READ; -} - -sub CTOR { - my ($this,@args) = @_; - - $this->SUPER::CTOR(@args[0,1]); - - my $re = $args[2] or die new Exception('A regular expression is required'); - - $this->{$Regexp} = qr/$re/; -} - -sub SUPPORTED_CONTEXT { Form::Filter::CTX_SINGLE | Form::Filter::CTX_EXISTENT } - -sub Invoke { - my ($this,$object) = @_; - - if ($object->isa('Form::ValueItem')) { - my $re = $this->{$Regexp}; - if ($object->isEmpty or $object->Value =~ m/$re/) { - return new Form::FilterResult(State => Form::FilterResult::STATE_SUCCESS); - } else { - return new Form::FilterResult(Sate => Form::FilterResult::STATE_ERROR, Message => $this->FormatMessage($object), Target => $object ); - } - } else { - die new Exception('Only a value items can be verified against a regular expression'); - } -} - -1;
--- a/Lib/Form/Item.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,79 +0,0 @@ -package Form::Item; -use strict; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Parent => ACCESS_READ; - DeclareProperty Form => ACCESS_READ; - DeclareProperty Id => ACCESS_READ; - DeclareProperty Attributes => ACCESS_ALL; -} - -sub CTOR { - my ($this,$id,$form,$parent,$attrib) = @_; - - $this->{$Id} = $id or die new Exception('An Id i required for the form item'); - $this->{$Form} = $form or die new Exception('A form is required for the form item'); - $this->{$Parent} = $parent; - $this->{$Attributes} = $attrib || {}; -} - -sub Name { - my ($this) = @_; - return $this->{$Id}->Name; -} - -sub Navigate { - my ($this,$ItemId) = @_; - - $ItemId or die new Exception("An item id is undefined"); - - return $this->NavigatePath([$ItemId->ToNAVPath]); -} - -sub Item { - my ($this,$strId) = @_; - - return $this->Navigate($this->Form->MakeItemId($strId,$this)); -} - -sub NavigatePath { - my ($this,$refPath) = @_; - - my $ItemId = shift @$refPath or die new Exception("An item id is undefined"); - my $current; - - if ($ItemId->isa('Form::ItemId::Prev')) { - $this->{$Parent} or die new Exception('Can\'t navigate to upper level'); - $current = $this->{$Parent}; - } elsif ($ItemId->isa('Form::ItemId::Root')) { - $current = $this->{$Form}; - } else { - $current = $this->ResolveItem($ItemId); - } - - if (@$refPath > 0) { - die new Exception('The item not found', $ItemId->Canonical) if not $current; - return $current->NavigatePath($refPath); - } else { - return $current; - } -} - -sub ResolveItem { - my ($this,$ItemId) = @_; - - die new Exception('Item not found',$ItemId->Name); -} - -sub Dispose { - my ($this) = @_; - - undef %$this; - - $this->SUPER::Dispose; -} - - -1;
--- a/Lib/Form/ItemId.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -package Form::ItemId; -use strict; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Canonical => ACCESS_READ; - DeclareProperty InstanceID => ACCESS_READ; - DeclareProperty Parent => ACCESS_READ; -} - -sub CTOR { - my ($this,$name,$instance_id,$parent) = @_; - - $this->{$Name} = $name or die new Exception('A name is required for the item id'); - $this->{$InstanceID} = $instance_id; - $this->{$Parent} = $parent; - - $this->{$Canonical} = ($parent && !$parent->isa('Form::ItemId::Root') ? $parent->Canonical.'/':'').$name.(defined $instance_id ? $instance_id : ''); -} - -sub ToNAVPath { - my ($this) = @_; - - return ($this->{$Parent} ? ($this->{$Parent}->ToNAVPath,$this) : $this); -} - -package Form::ItemId::Prev; -our @ISA = qw(Form::ItemId); - -sub CTOR { - my ($this,$parent) = @_; - $this->SUPER::CTOR('(prev)',undef,$parent); -} - -package Form::ItemId::Root; -our @ISA = qw(Form::ItemId); - -sub CTOR { - my ($this,$parent) = @_; - $this->SUPER::CTOR('(root)',undef,$parent); -} - - -1;
--- a/Lib/Form/Transform.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -package Form::Transform; -use strict; -use warnings; -use parent qw(IMPL::Transform); - -sub CTOR { - my ($this) = @_; - - $this->superCTOR( - Templates => { - 'Form::Container' => sub { my $this = shift; $this->TransformContainer(@_); }, - 'Form' => sub { my $this = shift; $this->TransformContainer(@_); } - }, - Default => \&TransformItem - ); -} - -sub TransformContainer { - my ($this,$container) = @_; -} - -sub TransformItem { - my ($this,$item) = @_; - return $item->isEmpty ? undef : $item->Value; -} - - - -1;
--- a/Lib/Form/ValueItem.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -package Form::ValueItem; -use strict; -use parent qw(Form::Item); -use Common; -use Form::Filter; - -BEGIN { - DeclareProperty Value => ACCESS_ALL; - DeclareProperty Type => ACCESS_READ; - DeclareProperty Schema => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->SUPER::CTOR(@args{qw(Id Form Parent Attributes)}); - $this->{$Type} = $args{'Type'}; - $this->{$Schema} = $args{'Schema'} or die new Exception('A field schema is required'); -} - -sub isEmpty { - my ($this) = @_; - - return length $this->{$Value} ? 0 : 1; -} - -sub Validate { - my ($this,$rhDisableFilters) = @_; - - $rhDisableFilters ||= {}; - - my @errors; - - foreach my $filter (grep {$_->SUPPORTED_CONTEXT & (Form::Filter::CTX_SINGLE) and not exists $rhDisableFilters->{$_}} map {$_->Instance} $this->{$Schema}->Filters) { - my $result = $filter->Invoke($this,Form::Filter::CTX_SINGLE | Form::Filter::CTX_EXISTENT,$this->{$Schema},$this->Parent); - if ($result->State == Form::FilterResult::STATE_SUCCESS_STOP) { - return (); - } elsif ($result->State == Form::FilterResult::STATE_ERROR) { - push @errors,$result; - } - } - - return @errors; -} - - -1;
--- a/Lib/Form/ValueItem/List.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,107 +0,0 @@ -package Form::ValueItem::List; -use Common; -use parent qw(Form::ValueItem); - -BEGIN { - DeclareProperty ListValues => ACCESS_READ; - DeclareProperty CurrentItem => ACCESS_READ; -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - $this->{$ListValues} = []; - - my $source = $this->Form->Bindings->{$this->Attributes->{source}}; - - if (ref $source eq 'CODE') { - $this->LoadList($source->()); - } elsif (ref $source and (UNIVERSAL::isa($source,'HASH') or UNIVERSAL::isa($source,'ARRAY'))){ - $this->LoadList($source); - } else { - if (not $source) { - warn "a source isn't specified for the listvalue ".$this->Id->Canonical; - } else { - warn "an unsupported source type ".(ref $source)." for the listvalue".$this->Id->Canonical; - } - } -} - -sub Value { - my $this = shift; - - if (@_) { - my $newValue = shift; - - $this->{$CurrentItem}->{active} = 0 if $this->{$CurrentItem}; - - my ($item) = (defined $newValue ? grep {defined $_->{id} and $_->{id} eq $newValue} @{$this->{$ListValues}} : undef); - - if ($item) { - $this->{$CurrentItem} = $item; - $item->{active} = 1; - return $this->SUPER::Value($newValue); - } else { - undef $this->{$CurrentItem}; - return $this->SUPER::Value(undef); - } - } else { - return $this->SUPER::Value; - } -} - -sub LoadList { - my ($this,$refList) = @_; - - if (ref $refList and UNIVERSAL::isa($refList,'HASH')) { - $this->{$CurrentItem} = undef; - $this->{$ListValues} = [ sort { $a->{name} cmp $b->{name} } map { Form::ValueItem::List::Item->new($_,ref $refList->{$_} eq 'ARRAY' ? @{$refList->{$_}} : $refList->{$_})} keys %{$refList}]; - $this->SUPER::Value(undef); - } elsif (ref $refList and UNIVERSAL::isa($refList,'ARRAY')) { - $this->{$CurrentItem} = undef; - $this->{$ListValues} = [map { Form::ValueItem::List::Item->new(ref $_ eq 'ARRAY' ? @$_ : $_ )} @$refList]; - $this->SUPER::Value(undef); - } else { - die new Exception('An unexpected list type'); - } -} - -package Form::ValueItem::List::Item; -use fields qw( - id - description - name - active -); - -sub new { - my ($class,$id,$name,$desc) = @_; - - my $this=fields::new($class); - $this->{id} = $id; - $this->{name} = $name; - $this->{description} = $desc; - - return $this; -} - -#compatibility with TToolkit - -sub Id { - $_[0]->{id}; -} - -sub Description { - $_[0]->{description}; -} - -sub Active { - $_[0]->{active}; -} - -sub Name { - $_[0]->{name}; -} - -1;
--- a/Lib/IMPL/Config.pm Tue May 17 00:04:28 2011 +0400 +++ b/Lib/IMPL/Config.pm Tue May 24 01:11:16 2011 +0400 @@ -6,6 +6,8 @@ __PACKAGE__->PassThroughArgs; +use File::Spec(); + use IMPL::Class::Member; use IMPL::Class::PropertyInfo; use IMPL::Exception; @@ -13,7 +15,7 @@ use IMPL::Serialization; use IMPL::Serialization::XmlFormatter; - +our $ConfigBase ||= ''; sub LoadXMLFile { my ($self,$file) = @_; @@ -89,7 +91,8 @@ } sub spawn { - goto &LoadXMLFile; + my ($this,$file) = @_; + return $this->LoadXMLFile( File::Spec->catfile($ConfigBase,$file) ); } sub get {
--- a/Lib/IMPL/Web/Application.pm Tue May 17 00:04:28 2011 +0400 +++ b/Lib/IMPL/Web/Application.pm Tue May 24 01:11:16 2011 +0400 @@ -12,20 +12,19 @@ __PACKAGE__->PassThroughArgs; -BEGIN { - public property handlerError => prop_all; - public property actionFactory => prop_all; - public property handlersQuery => prop_all | prop_list; - public property responseCharset => prop_all; - public property security => prop_all; - public property options => prop_all; - public property fetchRequestMethod => prop_all; -} +public property handlerError => prop_all; +public property actionFactory => prop_all; +public property handlersQuery => prop_all | prop_list; +public property responseCharset => prop_all; +public property security => prop_all; +public property options => prop_all; +public property fetchRequestMethod => prop_all; + sub CTOR { my ($this) = @_; - $this->actionFactory('IMPL::Web::Application::Action') unless $this->actionFactory; + $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;
--- a/Lib/IMPL/Web/Application/ControllerUnit.pm Tue May 17 00:04:28 2011 +0400 +++ b/Lib/IMPL/Web/Application/ControllerUnit.pm Tue May 24 01:11:16 2011 +0400 @@ -26,10 +26,12 @@ public property formErrors => prop_get | owner_set; } -my %publicProps = map {$_->Name , 1} __PACKAGE__->get_meta(typeof IMPL::Class::PropertyInfo); +my %publicProps = map {$_->Name , 1} __PACKAGE__->get_meta(typeof IMPL::Class::PropertyInfo); __PACKAGE__->class_data(CONTROLLER_METHODS,{}); +our @schemaInc; + sub CTOR { my ($this,$action,$args) = @_; @@ -185,14 +187,31 @@ sub loadSchema { my ($self,$name) = @_; + + foreach my $path (map File::Spec->catfile($_,$name) ,@schemaInc) { + return IMPL::DOM::Schema->LoadSchema($path) if -f $path; + } - if (-f $name) { - return IMPL::DOM::Schema->LoadSchema($name); - } else { - my ($vol,$dir,$file) = File::Spec->splitpath( Class::Inspector->resolved_filename(ref $self || $self) ); + 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(File::Spec->catfile($vol,$dir,$name)); + return IMPL::DOM::Schema->LoadSchema($path) if -f $path; } + + return undef; } sub discover {
--- a/Lib/ObjectStore/CDBI/Users.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -#!/usr/bin/perl -w -use strict; - -package ObjectStore::CDBI::Users; -use Common; -use Digest::MD5 qw(md5_hex); -our @ISA = qw(Object); - -our $Namespace; -our $DataModule; - -our $Prefix = $Namespace ? $Namespace.'::' : ''; - -if ($DataModule) { - $DataModule =~ s/::/\//g; - $DataModule .= '.pm'; - require $DataModule; -} - -BEGIN { - DeclareProperty DSNamespace => ACCESS_NONE; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$DSNamespace} = $args{'DSNamespace'}; -} - -sub ClassName { - return $_[0]->{$DSNamespace} ? $_[0]->{$DSNamespace}. $_[1] : $_[1]; -} - -sub FindUser { - my ($this,$uname) = @_; - - my @Users = $this->ClassName('Principal')->search(Name => $uname); - return shift @Users; -} - -sub CreateUser { - my ($this,$uname,$description,$active) = @_; - - if (my $user = $this->FindUser($uname)) { - die new Exception("The user is already exists",$uname); - } else { - return $this->ClassName('Principal')->insert({Name => $uname, Description => $description, Active => $active}); - } -} - -sub DeleteUser { - my ($this,$objUser) = @_; - - $objUser->delete; -} - -sub GetUserAuthData { - my ($this,$objUser,$objSecPackage) = @_; - - my @Data = $this->ClassName('AuthData')->search(User => $objUser,Package => $objSecPackage->Name); - return $Data[0]; -} - -sub SetUserAuthData { - my ($this,$objUser,$objSecPackage,$objAuthData) = @_; - - if (my $AuthData = $this->GetUserAuthData($objUser,$objSecPackage)) { - $AuthData->AuthData(objAuthData->SessionAuthData); - $AuthData->update; - } else { - $this->ClassName('AuthData')->insert({ User => $objUser, Package => $objSecPackage->Name, AuthData => $objAuthData->SessionAuthData}); - } -} - -sub CreateSession { - my ($this,$SSID,$objUser,$objAuthData) = @_; - - my $session = $this->ClassName('Session')->insert({SSID => $SSID, User => $objUser, SecData => $objAuthData->SessionAuthData, LastUsage => DateTime->now() }); - $session->autoupdate(1); - return $session; -} - -sub CloseSession { - my ($this,$objSession) = @_; - - $objSession->delete; -} - -sub LoadSession { - my ($this,$SSID) = @_; - my @Data = $this->ClassName('Session')->search(SSID => $SSID); - if ($Data[0]) { - $Data[0]->autoupdate(1); - return $Data[0]; - } -} - -sub construct { - return __PACKAGE__->new(DSNamespace => $Prefix); -}
--- a/Lib/Schema/DB.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -use strict; -package Schema::DB; -use Common; -use Schema::DB::Table; - -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Version => ACCESS_READ; - DeclareProperty Name => ACCESS_READ; - DeclareProperty Tables => ACCESS_READ; -} - -sub AddTable { - my ($this,$table) = @_; - - if (UNIVERSAL::isa($table,'Schema::DB::Table')) { - $table->Schema == $this or die new Exception('The specified table must belong to the database'); - not exists $this->{$Tables}->{$table->Name} or die new Exception('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 Exception('a table with the same name already exists in the database'); - $table->{'Schema'} = $this; - $table = new Schema::DB::Table(%{$table}); - } else { - die new Exception('Either a table object or a hash with table parameters is required'); - } - - $this->{$Tables}{$table->Name} = $table; -} - -sub RemoveTable { - my ($this,$table) = @_; - - my $tn = UNIVERSAL::isa($table,'Schema::DB::Table') ? $table->Name : $table; - $table = delete $this->{$Tables}{$tn} or die new Exception('The table doesn\'t exists',$tn); - - # drop foreign keys - map { $_->Table->RemoveConstraint($_) } values %{$table->PrimaryKey->ConnectedFK} if $table->PrimaryKey; - - # drop table contents - $table->Dispose(); - - return 1; -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose foreach values %{$this->{$Tables}}; - - delete $this->{$Tables}; - - $this->SUPER::Dispose; -} - - -1;
--- a/Lib/Schema/DB/Column.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -package Schema::DB::Column; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Type => ACCESS_READ; - DeclareProperty CanBeNull => ACCESS_READ; - DeclareProperty DefaultValue => ACCESS_READ; - DeclareProperty Tag => ACCESS_READ; -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - $this->{$Name} or die new Exception('a column name is required'); - $this->{$CanBeNull} = 0 if not exists $this->{$CanBeNull}; - UNIVERSAL::isa($this->{$Type},'Schema::DB::Type') or die new Exception('a type is required for the column',$this->{$Name}); -} - -sub isEqualsStr { - my ($a,$b) = @_; - - if (defined $a and defined $b) { - return $a eq $b; - } else { - if (defined $a or defined $b) { - return 0; - } else { - return 1; - } - } -} - -sub isEquals { - my ($a,$b) = @_; - - if (defined $a and defined $b) { - return $a == $b; - } else { - if (defined $a or defined $b) { - return 0; - } else { - return 1; - } - } -} - -sub isSame { - my ($this,$other) = @_; - - return ($this->{$Name} eq $other->{$Name} and $this->{$CanBeNull} == $other->{$CanBeNull} and isEqualsStr($this->{$DefaultValue}, $other->{$DefaultValue}) and $this->{$Type}->isSame($other->{$Type})); -} - -1;
--- a/Lib/Schema/DB/Constraint.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -package Schema::DB::Constraint; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Table => ACCESS_READ; - DeclareProperty Columns => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - die new Exception("The table argument must be an instance of a table object") if not UNIVERSAL::isa($args{'Table'},'Schema::DB::Table'); - $this->{$Name} = $args{'Name'}; - $this->{$Table} = $args{'Table'}; - $this->{$Columns} = [map { ResolveColumn($this->Table,$_) } @{$args{'Columns'}}]; -} - -sub ResolveColumn { - my ($Table,$Column) = @_; - - my $cn = UNIVERSAL::isa($Column,'Schema::DB::Column') ? $Column->Name : $Column; - - my $resolved = $Table->Column($cn); - die new Exception("The column is not found in the table", $cn, $Table->Name) if not $resolved; - return $resolved; -} - -sub HasColumn { - my ($this,@Columns) = @_; - - my %Columns = map { $_, 1} @Columns; - - return scalar(grep { $Columns{$_->Name} } $this->Columns) == scalar(@Columns); -} - -sub UniqName { - my ($this) = @_; - return $this->{$Table}->Name.'_'.$this->{$Name}; -} - -sub Dispose { - my ($this) = @_; - - delete @$this{$Table,$Columns}; - $this->SUPER::Dispose; -} -1;
--- a/Lib/Schema/DB/Constraint/ForeignKey.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,58 +0,0 @@ -package Schema::DB::Constraint::ForeignKey; -use strict; -use Common; -use parent qw(Schema::DB::Constraint); - -BEGIN { - DeclareProperty ReferencedPrimaryKey => ACCESS_READ; - DeclareProperty OnDelete => ACCESS_READ; - DeclareProperty OnUpdate => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->SUPER::CTOR(%args); - - - die new Eexception("Referenced table must be an instance of a table object") if not UNIVERSAL::isa($args{'ReferencedTable'},'Schema::DB::Table'); - - die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'ReferencedColumns'},'ARRAY') or not scalar(@{$args{'ReferencedColumns'}}); - - my @ReferencedColumns = map {Schema::DB::Constraint::ResolveColumn($args{'ReferencedTable'},$_)} @{$args{'ReferencedColumns'}}; - my $ForeingPK = $args{'ReferencedTable'}->PrimaryKey or die new Exception('The referenced table doesn\'t have a primary key'); - - scalar (@ReferencedColumns) == scalar(@{$this->Columns}) or die new Exception('A foreing key columns doesn\'t match refenced columns'); - my @ColumnsCopy = @ReferencedColumns; - - die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->Type->isSame((shift @ColumnsCopy)->Type)} $this->Columns; - - @ColumnsCopy = @ReferencedColumns; - die new Exception('The foreign key must match to the primary key of the referenced table',$this->Name) if grep { not $_->Type->isSame(shift(@ColumnsCopy)->Type)} $ForeingPK->Columns; - - $this->{$ReferencedPrimaryKey} = $ForeingPK; - - $ForeingPK->ConnectFK($this); -} - -sub Dispose { - my ($this) = @_; - - $this->{$ReferencedPrimaryKey}->DisconnectFK($this) if not $this->{$ReferencedPrimaryKey}->isa('Object::Disposed'); - delete $this->{$ReferencedPrimaryKey}; - - $this->SUPER::Dispose; -} - -sub isSame { - my ($this,$other) = @_; - - uc $this->OnDelete eq uc $other->OnDelete or return 0; - uc $this->OnUpdate eq uc $other->OnUpdate or return 0; - - return $this->SUPER::isSame($other); -} - - - -1;
--- a/Lib/Schema/DB/Constraint/Index.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -package Schema::DB::Constraint::Index; -use strict; -use Common; -use parent qw(Schema::DB::Constraint); - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - my %colnames; - not grep { $colnames{$_}++ } $this->Columns or die new Exception('Each column in the index can occur only once'); -} - -1;
--- a/Lib/Schema/DB/Constraint/PrimaryKey.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -package Schema::DB::Constraint::PrimaryKey; -use strict; -use Common; -use parent qw(Schema::DB::Constraint::Index); - -BEGIN { - DeclareProperty ConnectedFK => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->SUPER::CTOR(%args); - - $this->{$ConnectedFK} = {}; -} - -sub ConnectFK { - my ($this,$FK) = @_; - - UNIVERSAL::isa($FK,'Schema::DB::Constraint::ForeignKey') or die new Exception('Aprimary key could be connected only to a foreign key'); - not exists $this->{$ConnectedFK}->{$FK->UniqName} or die new Exception('This primary key already conneted with the specified foreing key',$FK->Name,$FK->Table->Name); - - $this->{$ConnectedFK}->{$FK->UniqName} = $FK; -} - -sub DisconnectFK { - my ($this,$FK) = @_; - - delete $this->{$ConnectedFK}->{$FK->UniqName}; -} - -sub Dispose { - my ($this) = @_; - - delete $this->{$ConnectedFK}; - $this->SUPER::Dispose; -} - -1;
--- a/Lib/Schema/DB/Constraint/Unique.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -package Schema::DB::Constraint::PrimaryKey; -use strict; -use Common; -use parent qw(Schema::DB::Constraint::Index); - -1;
--- a/Lib/Schema/DB/Table.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,168 +0,0 @@ -use strict; -package Schema::DB::Table; -use Carp; -use Common; - -use Schema::DB::Column; -use Schema::DB::Constraint; -use Schema::DB::Constraint::PrimaryKey; -use Schema::DB::Constraint::ForeignKey; - -our @ISA = qw(Object); - -srand time; - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Schema => ACCESS_READ; - DeclareProperty Columns => ACCESS_READ; - DeclareProperty Constraints => ACCESS_READ; - DeclareProperty ColumnsByName => ACCESS_NONE; - DeclareProperty PrimaryKey => ACCESS_READ; - DeclareProperty Tag => ACCESS_ALL; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Name} = $args{'Name'} or die new Exception('a table name is required'); - $this->{$Schema} = $args{'Schema'} or die new Exception('a parent schema is required'); -} - -sub InsertColumn { - my ($this,$column,$index) = @_; - - $index = ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0) if not defined $index; - - die new Exception("Index is out of range") if ($index < 0 || $index > ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0)); - - if (UNIVERSAL::isa($column,'Schema::DB::Column')) { - - } elsif (UNIVERSAL::isa($column,'HASH')) { - $column = new Schema::DB::Column(%{$column}); - } else { - die new Exception("The invalid parameter"); - } - - if (exists $this->{$ColumnsByName}->{$column->Name}) { - die new Exception("The column already exists",$column->name); - } else { - $this->{$ColumnsByName}->{$column->Name} = $column; - splice @{$this->{$Columns}},$index,0,$column; - } - - return $column; -} - -sub RemoveColumn { - my ($this,$NameOrColumn,$Force) = @_; - - my $ColName; - if (UNIVERSAL::isa($NameOrColumn,'Schema::DB::Column')) { - $ColName = $NameOrColumn->Name; - } elsif (not ref $NameOrColumn) { - $ColName = $NameOrColumn; - } - - if (exists $this->{$ColumnsByName}->{$ColName}) { - my $index = 0; - foreach my $column(@{$this->{$Columns}}) { - last if $column->Name eq $ColName; - $index++; - } - - my $column = $this->{$Columns}[$index]; - if (my @constraints = $this->GetColumnConstraints($column)){ - $Force or die new Exception('Can\'t remove column which is used in the constraints',@constraints); - $this->RemoveConstraint($_) foreach @constraints; - } - - my $removed = splice @{$this->{$Columns}},$index,1; - delete $this->{$ColumnsByName}->{$ColName}; - return $removed; - } else { - die new Exception("The column not found",$NameOrColumn->Name); - } -} - -sub Column { - my ($this,$name) = @_; - - return $this->{$ColumnsByName}->{$name}; -} - -sub ColumnAt { - my ($this,$index) = @_; - - die new Exception("The index is out of range") if $index < 0 || $index >= ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0); - - return $this->{$Columns}[$index]; -} - -sub AddConstraint { - my ($this,$Constraint) = @_; - - die new Exception('The invalid parameter') if not UNIVERSAL::isa($Constraint,'Schema::DB::Constraint'); - - $Constraint->Table == $this or die new Exception('The constaint must belong to the target table'); - - if (exists $this->{$Constraints}->{$Constraint->Name}) { - die new Exception('The table already has the specified constraint',$Constraint->Name); - } else { - if (UNIVERSAL::isa($Constraint,'Schema::DB::Constraint::PrimaryKey')) { - not $this->{$PrimaryKey} or die new Exception('The table already has a primary key'); - $this->{$PrimaryKey} = $Constraint; - } - - $this->{$Constraints}->{$Constraint->Name} = $Constraint; - } -} - -sub RemoveConstraint { - my ($this,$Constraint,$Force) = @_; - - my $cn = UNIVERSAL::isa($Constraint,'Schema::DB::Constraint') ? $Constraint->Name : $Constraint; - $Constraint = $this->{$Constraints}->{$cn} or die new Exception('The specified constraint doesn\'t exists',$cn); - - if (UNIVERSAL::isa($Constraint,'Schema::DB::Constraint::PrimaryKey')) { - not scalar keys %{$this->{$PrimaryKey}->ConnectedFK} or die new Exception('Can\'t remove Primary Key unless some foreign keys referenses it'); - - delete $this->{$PrimaryKey}; - } - $Constraint->Dispose; - delete $this->{$Constraints}->{$cn}; - return $cn; -} - -sub GetColumnConstraints { - my ($this,@Columns) = @_; - - my @cn = map { UNIVERSAL::isa($_ ,'Schema::DB::Column') ? $_ ->Name : $_ } @Columns; - exists $this->{$ColumnsByName}->{$_} or die new Exception('The specified column isn\'t found',$_) foreach @cn; - - return grep {$_->HasColumn(@cn)} values %{$this->{$Constraints}}; -} - -sub SetPrimaryKey { - my ($this,@ColumnList) = @_; - - $this->AddConstraint(new Schema::DB::Constraint::PrimaryKey(Name => $this->{$Name}.'_PK', Table => $this,Columns => \@ColumnList)); -} - -sub LinkTo { - my ($this,$table,@ColumnList) = @_; - $table->PrimaryKey or die new Exception('The referenced table must have a primary key'); - my $constraintName = $this->{$Name}.'_'.$table->Name.'_FK_'.join('_',map {ref $_ ? $_->Name : $_} @ColumnList); - $this->AddConstraint(new Schema::DB::Constraint::ForeignKey(Name => $constraintName, Table => $this,Columns => \@ColumnList, ReferencedTable => $table, ReferencedColumns => scalar($table->PrimaryKey->Columns))); -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose() foreach values %{$this->{$Constraints}}; - - undef %{$this}; - $this->SUPER::Dispose(); -} - -1;
--- a/Lib/Schema/DB/Traits.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,268 +0,0 @@ -package Schema::DB::Traits; -use strict; -use Common; -our @ISA = qw (Object); - -use constant { - STATE_NORMAL => 0, - STATE_UPDATED => 1, - STATE_CREATED => 2, - STATE_REMOVED => 3, - STATE_PENDING => 4 -} ; - -BEGIN { - DeclareProperty SrcSchema => ACCESS_NONE; - DeclareProperty DstSchema => ACCESS_NONE; - DeclareProperty PendingActions => ACCESS_READ; - DeclareProperty TableInfo => ACCESS_READ; - DeclareProperty Handler => ACCESS_READ; - DeclareProperty TableMap => ACCESS_NONE; - DeclareProperty KeepTables => ACCESS_ALL; -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - $this->{$SrcSchema} or die new Exception('A source schema is required'); - $this->{$DstSchema} or die new Exception('A destination schema is required'); - $this->{$Handler} or die new Exception('A handler is required to produce the update batch'); - - $this->{$TableInfo} = {}; - $this->{$PendingActions} = []; - -} - -sub UpdateTable { - my ($this,$srcTable) = @_; - - return 1 if $this->{$TableInfo}->{$srcTable->Name}->{'processed'}; - - my $dstTableName = $this->{$TableMap}->{$srcTable->Name} ? $this->{$TableMap}->{$srcTable->Name} : $srcTable->Name; - my $dstTable = $this->{$DstSchema}->Tables->{$dstTableName}; - - $this->{$TableInfo}->{$srcTable->Name}->{'processed'} = 1; - - if (not $dstTable) { - $this->DropTable($srcTable) if not $this->{$KeepTables}; - return 1; - } - - if ( not grep {$srcTable->Column($_->Name)} $dstTable->Columns ) { - - $this->{$TableInfo}->{$srcTable->Name}->{'NewName'} = $dstTable->Name if $srcTable->Name ne $dstTable->Name; - - $this->DropTable($srcTable); - $this->CreateTable($dstTable); - - return 1; - } - - if ($srcTable->Name ne $dstTableName) { - $this->RenameTable($srcTable,$dstTableName); - } - - my %dstConstraints = %{$dstTable->Constraints}; - - foreach my $srcConstraint (values %{$srcTable->Constraints}) { - if (my $dstConstraint = delete $dstConstraints{$srcConstraint->Name}) { - $this->UpdateConstraint($srcConstraint,$dstConstraint); - } else { - $this->DropConstraint($srcConstraint); - } - } - - my $i = 0; - my %dstColumns = map { $_->Name, $i++} $dstTable->Columns ; - - # сначала удаляем столбцы - # потом добавляем недостающие и изменяем столбцы в нужном порядке - - my @columnsToUpdate; - - foreach my $srcColumn ($srcTable->Columns) { - if (defined (my $dstColumnIndex = delete $dstColumns{$srcColumn->Name})) { - push @columnsToUpdate, { Action => 'update', ColumnSrc => $srcColumn, ColumnDst => $dstTable->ColumnAt($dstColumnIndex), NewPosition => $dstColumnIndex}; - } else { - $this->DropColumn($srcTable,$srcColumn); - } - } - push @columnsToUpdate, map { {Action => 'add', ColumnDst => $dstTable->ColumnAt($_), NewPosition => $_} } values %dstColumns; - - foreach my $action (sort {$a->{'NewPosition'} <=> $b->{'NewPosition'}} @columnsToUpdate ) { - if ($action->{'Action'} eq 'update') { - $this->UpdateColumn($srcTable,@$action{'ColumnSrc','ColumnDst'},$dstTable,$action->{'NewPosition'}); # change type and position - }elsif ($action->{'Action'} eq 'add') { - $this->AddColumn($srcTable,$action->{'ColumnDst'},$dstTable,$action->{'NewPosition'}); # add at specified position - } - } - - foreach my $dstConstraint (values %dstConstraints) { - $this->AddConstraint($dstConstraint); - } - - $this->{$TableInfo}{$srcTable->Name}{'State'} = STATE_UPDATED; -} - -sub UpdateConstraint { - my ($this,$src,$dst) = @_; - - if (not ConstraintEquals($src,$dst)) { - if (UNIVERSAL::isa($src,'Schema::DB::Constraint::PrimaryKey')) { - $this->UpdateTable($_->Table) foreach values %{$src->ConnectedFK}; - } - $this->DropConstraint($src); - $this->AddConstraint($dst); - } else { - $this->{$TableInfo}->{$this->MapTableName($src->Table->Name)}->{'Constraints'}->{$src->Name} = STATE_UPDATED; - } -} - -sub ConstraintEquals { - my ($src,$dst) = @_; - - ref $src eq ref $dst or return 0; - - my @dstColumns = $dst->Columns; - scalar(@{$src->Columns}) == scalar(@{$dst->Columns}) and not grep { my $column = shift @dstColumns; not $column->isSame($_) } $src->Columns or return 0; - - not UNIVERSAL::isa($src,'Schema::DB::Constraint::ForeignKey') or ConstraintEquals($src->ReferencedPrimaryKey,$dst->ReferencedPrimaryKey) or return 0; - - 1; -} - -sub UpdateSchema { - my ($this) = @_; - - my %Updated = map { $this->UpdateTable($_); $this->MapTableName($_->Name) , 1; } values %{$this->{$SrcSchema}->Tables ? $this->{$SrcSchema}->Tables : {} }; - - $this->CreateTable($_) foreach grep {not $Updated{$_->Name}} values %{$this->{$DstSchema}->Tables}; - - $this->ProcessPendingActions(); -} - -sub RenameTable { - my ($this,$tblSrc,$tblDstName) = @_; - - $this->{$Handler}->AlterTableRename($tblSrc->Name,$tblDstName); - $this->{$TableInfo}->{$tblSrc->Name}->{'NewName'} = $tblDstName; -} - -sub MapTableName { - my ($this,$srcName) = @_; - - $this->{$TableInfo}->{$srcName}->{'NewName'} ? $this->{$TableInfo}->{$srcName}->{'NewName'} : $srcName; -} - -sub DropTable { - my ($this,$tbl) = @_; - - if ($tbl->PrimaryKey) { - $this->UpdateTable($_->Table) foreach values %{$tbl->PrimaryKey->ConnectedFK}; - } - - $this->{$Handler}->DropTable($this->MapTableName($tbl->Name)); - $this->{$TableInfo}{$this->MapTableName($tbl->Name)}{'State'} = STATE_REMOVED; - $this->{$TableInfo}{$this->MapTableName($tbl->Name)}{'Constraints'} = {map {$_,STATE_REMOVED} keys %{$tbl->Constraints}}; - $this->{$TableInfo}{$this->MapTableName($tbl->Name)}{'Columns'} = {map { $_->Name, STATE_REMOVED} $tbl->Columns}; - - return 1; -} - -sub CreateTable { - my ($this,$tbl) = @_; - - # создаем таблицу, кроме внешних ключей - $this->{$Handler}->CreateTable($tbl,skip_foreign_keys => 1); - - $this->{$TableInfo}->{$tbl->Name}->{'State'} = STATE_CREATED; - - $this->{$TableInfo}->{$tbl->Name}->{'Columns'} = {map { $_->Name, STATE_CREATED } $tbl->Columns}; - $this->{$TableInfo}->{$tbl->Name}->{'Constraints'} = {map {$_->Name, STATE_CREATED} grep { not UNIVERSAL::isa($_,'Schema::DB::Constraint::ForeignKey') } values %{$tbl->Constraints}}; - - $this->AddConstraint($_) foreach grep { UNIVERSAL::isa($_,'Schema::DB::Constraint::ForeignKey') } values %{$tbl->Constraints}; - - return 1; -} - -sub AddColumn { - my ($this,$tblSrc,$column,$tblDst,$pos) = @_; - - $this->{$Handler}->AlterTableAddColumn($this->MapTableName($tblSrc->Name),$column,$tblDst,$pos); - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$column->Name} = STATE_CREATED; - - return 1; -} - -sub DropColumn { - my ($this,$tblSrc,$column) = @_; - $this->{$Handler}->AlterTableDropColumn($this->MapTableName($tblSrc->Name),$column->Name); - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$column->Name} = STATE_REMOVED; - - return 1; -} - -sub UpdateColumn { - my ($this,$tblSrc,$srcColumn,$dstColumn,$tblDst,$pos) = @_; - - if ($srcColumn->isSame($dstColumn) and $pos < @{$tblSrc->Columns} and $tblSrc->ColumnAt($pos) == $srcColumn) { - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$dstColumn->Name} = STATE_UPDATED; - return 1; - } - - $this->{$Handler}->AlterTableChangeColumn($this->MapTableName($tblSrc->Name),$dstColumn,$tblDst,$pos); - $this->{$TableInfo}->{$this->MapTableName($tblSrc->Name)}->{'Columns'}->{$dstColumn->Name} = STATE_UPDATED; - - return 1; -} - -sub DropConstraint { - my ($this,$constraint) = @_; - - $this->{$Handler}->AlterTableDropConstraint($this->MapTableName($constraint->Table->Name),$constraint); - $this->{$TableInfo}->{$constraint->Table->Name}->{'Constraints'}->{$constraint->Name} = STATE_REMOVED; - - return 1; -} - -sub IfUndef { - my ($value,$default) = @_; - - return defined $value ? $value : $default; -} - -sub AddConstraint { - my ($this,$constraint) = @_; - - # перед добавлением ограничения нужно убедиться в том, что созданы все необходимые столбцы и сопутствующие - # ограничения (например первичные ключи) - - my $pending; - - $pending = grep { my $column = $_; not grep { IfUndef($this->{$TableInfo}{$constraint->Table->Name}{'Columns'}{$column->Name}, STATE_NORMAL) == $_ } (STATE_UPDATED, STATE_CREATED) } $constraint->Columns; - - if ($pending) { - push @{$this->{$PendingActions}},{Action => \&AddConstraint, Args => [$constraint]}; - return 2; - } else { - if (UNIVERSAL::isa($constraint,'Schema::DB::Constraint::ForeignKey')) { - if (not grep { IfUndef($this->{$TableInfo}{$constraint->ReferencedPrimaryKey->Table->Name}{'Constraints'}{$constraint->ReferencedPrimaryKey->Name},STATE_NORMAL) == $_} (STATE_UPDATED, STATE_CREATED)) { - push @{$this->{$PendingActions}},{Action => \&AddConstraint, Args => [$constraint]}; - return 2; - } - } - $this->{$Handler}->AlterTableAddConstraint($constraint->Table->Name,$constraint); - $this->{$TableInfo}->{$constraint->Table->Name}->{'Constraints'}->{$constraint->Name} = STATE_CREATED; - } -} - -sub ProcessPendingActions { - my ($this) = @_; - - while (my $action = shift @{$this->{$PendingActions}}) { - $action->{'Action'}->($this,@{$action->{'Args'}}); - } -} - -1;
--- a/Lib/Schema/DB/Traits/mysql.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,549 +0,0 @@ -package Schema::DB::Traits::mysql::Handler; -use strict; -use Common; -our @ISA=qw(Object); - -BEGIN { - DeclareProperty SqlBatch => ACCESS_NONE; -} - -sub formatTypeNameInteger { - my ($type) = @_; - - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeNameReal { - my ($type) = @_; - - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeNameNumeric { - my ($type) = @_; - $type->MaxLength or die new Exception('The length and precission must be specified',$type->Name); - return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : ''); -} - -sub formatTypeName { - my ($type) = @_; - return $type->Name; -} - -sub formatTypeNameChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'Schema::DB::Type::mysql::CHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameVarChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'Schema::DB::Type::mysql::VARCHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameEnum { - my ($type) = @_; - die new Exception('Enum must be a type of either Schema::DB::Type::mysql::ENUM or Schema::DB::Type::mysql::SET') if not (UNIVERSAL::isa($type,'Schema::DB::Type::mysql::ENUM') or UNIVERSAL::isa($type,'Schema::DB::Type::mysql::SET')); - return ( - $type->Name.'('.join(',',map {quote($_)} $type->Values).')' - ); -} - -sub quote{ - if (wantarray) { - return map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } -} - -sub quote_names { - if (wantarray) { - return map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } -} - -sub formatStringValue { - my ($value) = @_; - - if (ref $value) { - if (UNIVERSAL::isa($value,'Schema::DB::mysql::Expression')) { - return $value->as_string; - } else { - die new Exception('Can\'t format the object as a value',ref $value); - } - } else { - return quote($value); - } -} - - -sub formatNumberValue { - my ($value) = @_; - - if (ref $value) { - if (UNIVERSAL::isa($value,'Schema::DB::mysql::Expression')) { - return $value->as_string; - } else { - die new Exception('Can\'t format the object as a value',ref $value); - } - } else { - $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ or die new Exception('The specified value isn\'t a valid number',$value); - return $value; - } -} - - -my %TypesFormat = ( - TINYINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - SMALLINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - MEDIUMINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - INTEGER => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - BIGINT => { - formatType => \&formatTypeNameInteger, - formatValue => \&formatNumberValue - }, - REAL => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DOUBLE => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - FLOAT => { - formatType => \&formatTypeNameReal, - formatValue => \&formatNumberValue - }, - DECIMAL => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - NUMERIC => { - formatType => \&formatTypeNameNumeric, - formatValue => \&formatNumberValue - }, - DATE => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TIMESTAMP => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - DATETIME => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - CHAR => { - formatType => \&formatTypeNameChar, - formatValue => \&formatStringValue - }, - VARCHAR => { - formatType => \&formatTypeNameVarChar, - formatValue => \&formatStringValue - }, - TINYBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - BLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGBLOB => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TINYTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - TEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - MEDIUMTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - LONGTEXT => { - formatType => \&formatTypeName, - formatValue => \&formatStringValue - }, - ENUM => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - }, - SET => { - formatType => \&formatTypeNameEnum, - formatValue => \&formatStringValue - } -); - - -=pod -CREATE TABLE 'test'.'New Table' ( - 'dd' INTEGER UNSIGNED NOT NULL AUTO_INCREMENT, - `ff` VARCHAR(45) NOT NULL, - `ffg` VARCHAR(45) NOT NULL DEFAULT 'aaa', - `ddf` INTEGER UNSIGNED NOT NULL, - PRIMARY KEY(`dd`), - UNIQUE `Index_2`(`ffg`), - CONSTRAINT `FK_New Table_1` FOREIGN KEY `FK_New Table_1` (`ddf`) - REFERENCES `user` (`id`) - ON DELETE RESTRICT - ON UPDATE RESTRICT -) -ENGINE = InnoDB; -=cut -sub formatCreateTable { - my ($table,$level,%options) = @_; - - my @sql; - - # table body - push @sql, map { formatColumn($_,$level+1) } $table->Columns ; - if ($options{'skip_foreign_keys'}) { - push @sql, map { formatConstraint($_,$level+1) } grep {not UNIVERSAL::isa($_,'Schema::DB::Constraint::ForeignKey')} values %{$table->Constraints}; - } else { - push @sql, map { formatConstraint($_,$level+1) } values %{$table->Constraints}; - } - - for(my $i = 0 ; $i < @sql -1; $i++) { - $sql[$i] .= ','; - } - - unshift @sql, "CREATE TABLE ".quote_names($table->Name)."("; - - if ($table->Tag) { - push @sql, ")"; - push @sql, formatTableTag($table->Tag,$level); - $sql[$#sql].=';'; - } else { - push @sql, ');'; - } - - return map { ("\t" x $level) . $_ } @sql; -} - -sub formatDropTable { - my ($tableName,$level) = @_; - - return "\t"x$level."DROP TABLE ".quote_names($tableName).";"; -} - -sub formatTableTag { - my ($tag,$level) = @_; - return map { "\t"x$level . "$_ = ".$tag->{$_} } grep {/^(ENGINE)$/i} keys %{$tag}; -} - -sub formatColumn { - my ($column,$level) = @_; - $level ||= 0; - return "\t"x$level.quote_names($column->Name)." ".formatType($column->Type)." ".($column->CanBeNull ? 'NULL' : 'NOT NULL').($column->DefaultValue ? formatValueToType($column->DefaultValue,$column->Type) : '' ).($column->Tag ? ' '.join(' ',$column->Tag) : ''); -} - -sub formatType { - my ($type) = @_; - my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); - $format->{formatType}->($type); -} - -sub formatValueToType { - my ($value,$type) = @_; - - my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name); - $format->{formatValue}->($value); -} - -sub formatConstraint { - my ($constraint,$level) = @_; - - if (UNIVERSAL::isa($constraint,'Schema::DB::Constraint::ForeignKey')) { - return formatForeignKey($constraint,$level); - } else { - return formatIndex($constraint, $level); - } -} - -sub formatIndex { - my ($constraint,$level) = @_; - - my $name = quote_names($constraint->Name); - my $columns = join(',',map quote_names($_->Name),$constraint->Columns); - - if (ref $constraint eq 'Schema::DB::Constraint::PrimaryKey') { - return "\t"x$level."PRIMARY KEY ($columns)"; - } elsif ($constraint eq 'Schema::DB::Constraint::Unique') { - return "\t"x$level."UNIQUE $name ($columns)"; - } elsif ($constraint eq 'Schema::DB::Constraint::Index') { - return "\t"x$level."INDEX $name ($columns)"; - } else { - die new Exception('The unknown constraint', ref $constraint); - } - -} - -sub formatForeignKey { - my ($constraint,$level) = @_; - - my $name = quote_names($constraint->Name); - my $columns = join(',',map quote_names($_->Name),$constraint->Columns); - - not $constraint->OnDelete or grep { uc $constraint->OnDelete eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new Exception('Invalid ON DELETE reference',$constraint->OnDelete); - not $constraint->OnUpdate or grep { uc $constraint->OnUpdate eq $_ } ('RESTRICT','CASCADE','SET NULL','NO ACTION','SET DEFAULT') or die new Exception('Invalid ON UPDATE reference',$constraint->OnUpdate); - - my $refname = quote_names($constraint->ReferencedPrimaryKey->Table->Name); - my $refcolumns = join(',',map quote_names($_->Name),$constraint->ReferencedPrimaryKey->Columns); - return ( - "\t"x$level. - "CONSTRAINT $name FOREIGN KEY $name ($columns) REFERENCES $refname ($refcolumns)". - ($constraint->OnUpdate ? 'ON UPDATE'.$constraint->OnUpdate : ''). - ($constraint->OnDelete ? 'ON DELETE'.$constraint->OnDelete : '') - ); -} - -sub formatAlterTableRename { - my ($oldName,$newName,$level) = @_; - - return "\t"x$level."ALTER TABLE ".quote_names($oldName)." RENAME TO ".quote_names($newName).";"; -} - -sub formatAlterTableDropColumn { - my ($tableName, $columnName,$level) = @_; - - return "\t"x$level."ALTER TABLE ".quote_names($tableName)." DROP COLUMN ".quote_names($columnName).";"; -} - -=pod -ALTER TABLE `test`.`user` ADD COLUMN `my_col` VARCHAR(45) NOT NULL AFTER `name2` -=cut -sub formatAlterTableAddColumn { - my ($tableName, $column, $table, $pos, $level) = @_; - - my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); - - return "\t"x$level."ALTER TABLE ".quote_names($tableName)." ADD COLUMN ".formatColumn($column) .' '. $posSpec.";"; -} - -=pod -ALTER TABLE `test`.`manager` MODIFY COLUMN `description` VARCHAR(256) NOT NULL DEFAULT NULL; -=cut -sub formatAlterTableChangeColumn { - my ($tableName,$column,$table,$pos,$level) = @_; - my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name); - return "\t"x$level."ALTER TABLE ".quote_names($tableName)." MODIFY COLUMN ".formatColumn($column).' '. $posSpec.";"; -} - -=pod -ALTER TABLE `test`.`manager` DROP INDEX `Index_2`; -=cut -sub formatAlterTableDropConstraint { - my ($tableName,$constraint,$level) = @_; - my $constraintName; - if (ref $constraint eq 'Schema::DB::Constraint::PrimaryKey') { - $constraintName = 'PRIMARY KEY'; - } elsif (ref $constraint eq 'Schema::DB::Constraint::ForeignKey') { - $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name); - } elsif (UNIVERSAL::isa($constraint,'Schema::DB::Constraint::Index')) { - $constraintName = 'INDEX '.quote_names($constraint->Name); - } else { - die new Exception("The unknow type of the constraint",ref $constraint); - } - return "\t"x$level."ALTER TABLE ".quote_names($tableName)." DROP $constraintName;"; -} - -=pod -ALTER TABLE `test`.`session` ADD INDEX `Index_2`(`id`, `name`); -=cut -sub formatAlterTableAddConstraint { - my ($tableName,$constraint,$level) = @_; - - return "\t"x$level."ALTER TABLE ".quote_names($tableName)." ADD ".formatConstraint($constraint,0).';'; -} - -sub CreateTable { - my ($this,$tbl,%option) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatCreateTable($tbl,0,%option)); - - return 1; -} - -sub DropTable { - my ($this,$tbl) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatDropTable($tbl,0)); - - return 1; -} - -sub RenameTable { - my ($this,$oldName,$newName) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableRename($oldName,$newName,0)); - - return 1; -} - -sub AlterTableAddColumn { - my ($this,$tblName,$column,$table,$pos) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddColumn($tblName,$column,$table,$pos,0)); - - return 1; -} -sub AlterTableDropColumn { - my ($this,$tblName,$columnName) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropColumn($tblName,$columnName,0)); - - return 1; -} - -sub AlterTableChangeColumn { - my ($this,$tblName,$column,$table,$pos) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableChangeColumn($tblName,$column,$table,$pos,0)); - - return 1; -} - -sub AlterTableAddConstraint { - my ($this,$tblName,$constraint) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddConstraint($tblName,$constraint,0)); - - return 1; -} - -sub AlterTableDropConstraint { - my ($this,$tblName,$constraint) = @_; - - push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropConstraint($tblName,$constraint,0)); - - return 1; -} - -sub Sql { - my ($this) = @_; - if (wantarray) { - $this->SqlBatch; - } else { - return join("\n",$this->SqlBatch); - } -} - -package Schema::DB::Traits::mysql; -use Common; -use parent qw(Schema::DB::Traits); - -BEGIN { - DeclareProperty PendingConstraints => ACCESS_NONE; -} - -sub CTOR { - my ($this,%args) = @_; - - $args{'Handler'} = new Schema::DB::Traits::mysql::Handler; - $this->SUPER::CTOR(%args); -} - -sub DropConstraint { - my ($this,$constraint) = @_; - - if (UNIVERSAL::isa($constraint,'Schema::DB::Constraint::Index')) { - return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != Schema::DB::Traits::STATE_REMOVED} $constraint->Columns; - my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns); - if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'Schema::DB::Constraint::ForeignKey')) { - my $fk = shift @constraints; - if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != Schema::DB::Traits::STATE_REMOVED) { - push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]}; - $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++; - - die new Exception('Can\'t drop the primary key becouse of the foreing key',$fk->UniqName) if $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} > 2; - return 2; - } - } - } - $this->SUPER::DropConstraint($constraint); -} - -sub GetMetaTable { - my ($class,$dbh) = @_; - - return Schema::DB::Traits::mysql::MetaTable->new( DBHandle => $dbh); -} - -package Schema::DB::Traits::mysql::MetaTable; -use Common; -our @ISA=qw(Object); - -BEGIN { - DeclareProperty DBHandle => ACCESS_NONE; -} - -sub ReadProperty { - my ($this,$name) = @_; - - local $this->{$DBHandle}->{PrintError}; - $this->{$DBHandle}->{PrintError} = 0; - my ($val) = $this->{$DBHandle}->selectrow_array("SELECT value FROM _Meta WHERE name like ?", undef, $name); - return $val; -} - -sub SetProperty { - my ($this,$name,$val) = @_; - - if ( $this->{$DBHandle}->selectrow_arrayref("SELECT TABLE_NAME FROM information_schema.`TABLES` T where TABLE_SCHEMA like DATABASE() and TABLE_NAME like '_Meta'")) { - if ($this->{$DBHandle}->selectrow_arrayref("SELECT name FROM _Meta WHERE name like ?", undef, $name)) { - $this->{$DBHandle}->do("UPDATE _Meta SET value = ? WHERE name like ?",undef,$val,$name); - } else { - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES ('$name',?)",undef,$val); - } - } else { - $this->{$DBHandle}->do(q{ - CREATE TABLE `_Meta` ( - `name` VARCHAR(255) NOT NULL, - `value` LONGTEXT NULL, - PRIMARY KEY(`name`) - ); - }) or die new Exception("Failed to create table","_Meta"); - - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val); - } -} - -1;
--- a/Lib/Schema/DB/Type.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -use strict; -package Schema::DB::Type; -use Common; -our @ISA=qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty MaxLength => ACCESS_READ; - DeclareProperty Scale => ACCESS_READ; - DeclareProperty Unsigned => ACCESS_READ; - DeclareProperty Zerofill => ACCESS_READ; - DeclareProperty Tag => ACCESS_READ; -} - -sub CTOR { - my $this = shift; - $this->SUPER::CTOR(@_); - - $this->{$Scale} = 0 if not $this->{$Scale}; -} - -sub isEquals { - my ($a,$b) = @_; - - if (defined $a and defined $b) { - return $a == $b; - } else { - if (defined $a or defined $b) { - return 0; - } else { - return 1; - } - } -} - -sub isSame { - my ($this,$other) = @_; - - return ($this->{$Name} eq $other->{$Name} and isEquals($this->{$MaxLength},$other->{$MaxLength}) and isEquals($this->{$Scale},$other->{$Scale})); -} - -1;
--- a/Lib/Schema/DataSource.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,138 +0,0 @@ -package Configuration; -our $DataDir; -package Schema::DataSource; -use Common; -use strict; -use parent qw(Object); - -use BNFCompiler; -use Schema::DB; -use Schema; -use URI::file; - -BEGIN { - DeclareProperty ProcessedSchemas => ACCESS_NONE; #{ uri => schema } - DeclareProperty Types => ACCESS_READ; # Schema - DeclareProperty DataSourceBuilder => ACCESS_READ; - DeclareProperty Compiler => ACCESS_NONE; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$DataSourceBuilder} = $args{'DataSourceBuilder'} or die new Exception('A data source builder is required'); - $this->{$Types} = new Schema; - $this->{$Compiler} = new BNFCompiler(SchemaCache => "${DataDir}Cache/",Transform => sub { BNFCompiler::DOM::TransformDOMToHash(@_,{skip_spaces => 1})} ); - $this->{$Compiler}->LoadBNFSchema(file => 'Schema/schema.def'); -} - -sub as_list { - return( map { UNIVERSAL::isa($_,'ARRAY') ? @{$_} : defined $_ ? $_ : () } @_ ); -} - -sub ProcessSchema { - my ($this,$uriFile) = @_; - - return 1 if $this->{$ProcessedSchemas}{$uriFile->as_string}; - - my $uriDir = URI::file->new('./')->abs($uriFile); - $this->{$ProcessedSchemas}->{$uriFile->as_string} = 1; - - my $Schema = $this->ParseSchema($uriFile); - - foreach my $item (as_list($Schema->{'header'}{'include_item'})) { - my $uriItem = URI::file->new($item->{'file_name'})->abs($uriDir); - $this->ProcessSchema($uriItem); - } - - $this->ConstructTypes($Schema); - -} - -sub ParseSchema { - my ($this,$fileUri) = @_; - - my $fileName = $fileUri->file; - open my $hfile,"$fileName" or die new Exception('Failed to read the file',$fileName,$!); - local $/ = undef; - my $Schema = $this->{$Compiler}->Parse(<$hfile>); - - return $Schema; -} - -sub ConstructTypes { - my ($this,$schema) = @_; - return if not $schema->{'class'}; - - foreach my $class (as_list($schema->{'class'})){ - # объявление типа - my $type; - my $builder; - if ($class->{'type_definition'}{'args_list'}) { - $type = $this->{$Types}->CreateTemplate($class->{'type_definition'}{'name'},as_list($class->{'type_definition'}{'args_list'}{'name'})); - } else { - $type = $this->{$Types}->CreateType($class->{'type_definition'}{'name'}); - } - - $type->SetAttributes(ValueType => 1) if $class->{'value_type'}; - - my $mappingTip = $this->{$DataSourceBuilder}->GetClassMapping($type); - - - # обрабатываем список базовых классов - - if ($class->{'base_types'}) { - foreach my $typename (as_list($class->{'base_types'}{'type'})) { - $type->AddBase(MakeTypeName($typename)); - } - } - - # обрабатываем список свойств - if ($class->{'property_list'}) { - foreach my $property (as_list($class->{'property_list'}{'property'})) { - $type->InsertProperty($property->{'name'},MakeTypeName($property->{'type'})); - if (my $mapping = $property->{'mapping'}) { - $mappingTip->PropertyMapping($property->{'name'},Column => $mapping->{'column_name'},DBType => $mapping->{'db_type'}); - } - } - } - } -} - -sub MakeTypeName { - my ($typename) = @_; - - return new Schema::TypeName( - $typename->{'name'}, - ( - $typename->{'template_list'} ? - map { MakeTypeName($_) } as_list($typename->{'template_list'}{'type'}) - : - () - ) - ); -} - -sub BuildSchema { - my ($this,$fileName) = @_; - - my $uriFile = URI::file->new_abs($fileName); - - $this->ProcessSchema($uriFile); - - $this->{$Types}->Close(); - - foreach my $type ($this->{$Types}->EnumTypes(skip_templates => 1)) { - $this->{$DataSourceBuilder}->AddType($type); - } -} - -sub DESTROY { - my ($this) = @_; - - $this->{$Compiler}->Dispose; - $this->{$DataSourceBuilder}->Dispose; - $this->{$Types}->Dispose; -} - -1;
--- a/Lib/Schema/DataSource/CDBIBuilder.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,326 +0,0 @@ -use strict; -package Schema::DataSource::CDBIBuilder; -use Schema::DataSource::TypeMapping; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty ClassMappings => ACCESS_NONE; - DeclareProperty TypeMapping => ACCESS_READ; - DeclareProperty ValueTypeReflections => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$TypeMapping} = $args{'TypeMapping'} || Schema::DataSource::TypeMapping::Std->new; - $this->{$ValueTypeReflections} = { DateTime => 'DateTime'}; -} - -sub ReflectValueType { - my ($this,$Type) = @_; - return $this->{$ValueTypeReflections}{$Type->Name->Simple}; -} - -sub GetClassMapping { - my ($this,$type) = @_; - - if (my $mapping = $this->{$ClassMappings}->{$type->Name->Canonical}) { - return $mapping; - } else { - $mapping = new Schema::DataSource::CDBIBuilder::ClassMapping(Class => $type,Parent => $this); - $this->{$ClassMappings}{$type->Name->Canonical} = $mapping; - return $mapping - } -} - -sub EnumClassMappings { - my ($this) = @_; - return $this->{$ClassMappings} ? values %{$this->{$ClassMappings}} : (); -} - -sub AddType { - my ($this,$type) = @_; - $this->GetClassMapping($type); -} - -sub BuildDBSchema { - my ($this) = @_; - - my $schemaDB = new Schema::DB(Name => 'auto', Version => time); - - if ($this->{$ClassMappings}) { - $_->CreateTable($schemaDB) foreach values %{ $this->{$ClassMappings} }; - $_->CreateConstraints($schemaDB) foreach values %{ $this->{$ClassMappings} }; - } - - return $schemaDB; -} - -sub WriteModules { - my ($this,$fileName,$prefix) = @_; - - my $text; - $text = <<ModuleHeader; -#autogenerated script don't edit -package ${prefix}DBI; -use parent 'Class::DBI'; - -require DateTime; - -our (\$DSN,\$User,\$Password,\$Init); -\$DSN ||= 'DBI:null'; # avoid warning - -__PACKAGE__->connection(\$DSN,\$User,\$Password); - -# initialize -foreach my \$action (ref \$Init eq 'ARRAY' ? \@{\$Init} : \$Init) { - next unless \$action; - - if (ref \$action eq 'CODE') { - \$action->(__PACKAGE__->db_Main); - } elsif (not ref \$action) { - __PACKAGE__->db_Main->do(\$action); - } -} - -ModuleHeader - - if ($this->{$ClassMappings}) { - $text .= join ("\n\n", map $_->GenerateText($prefix.'DBI',$prefix), sort {$a->Class->Name->Canonical cmp $b->Class->Name->Canonical } values %{ $this->{$ClassMappings} } ); - } - - $text .= "\n1;"; - - open my $out, ">$fileName" or die new Exception("Failed to open file",$fileName,$!); - print $out $text; -} - -sub Dispose { - my ($this) = @_; - - delete @$this{$ClassMappings,$TypeMapping,$ValueTypeReflections}; - - $this->SUPER::Dispose; -} - -package Schema::DataSource::CDBIBuilder::ClassMapping; -use Common; -use Schema; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Table => ACCESS_READ; - DeclareProperty PropertyTables => ACCESS_READ; - DeclareProperty PropertyMappings => ACCESS_READ; - - DeclareProperty Class => ACCESS_READ; - DeclareProperty Parent => ACCESS_NONE; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Class} = $args{'Class'} or die new Exception('The class must be specified'); - $this->{$Parent} = $args{'Parent'} or die new Exception('The parent must be specified'); - -} - -sub PropertyMapping { - my ($this,%args) = @_; - $this->{$PropertyMappings}{$args{'name'}} = { Column => $args{'Column'},DBType => $args{'DBType'} }; -} - -sub CreateTable { - my ($this,$schemaDB) = @_; - - return if $this->{$Class}->isTemplate or $this->{$Class}->GetAttribute('ValueType') or $this->{$Class}->Name->Simple eq 'Set'; - - # CreateTable - my $table = $schemaDB->AddTable({Name => $this->{$Class}->Name->Canonical}); - $table->InsertColumn({ - Name => '_id', - Type => $this->{$Parent}->TypeMapping->DBIdentifierType, - Tag => ['AUTO_INCREMENT'] - }); - $table->SetPrimaryKey('_id'); - foreach my $prop ( grep { UNIVERSAL::isa($_,'Schema::Property') } $this->{$Class}->ListMembers ) { - if ($prop->Type->Name->Name eq 'Set') { - # special case for multiple values - my $propTable = $this->CreatePropertyTable($schemaDB,$prop); - $propTable->LinkTo($table,'parent'); - } else { - $table->InsertColumn({ - Name => $prop->Name, - Type => $this->{$Parent}->TypeMapping->MapType($prop->Type), - CanBeNull => 1 - }); - } - } - $this->{$Table} = $table; - return $table; -} - -sub CreatePropertyTable { - my ($this,$schemaDB,$property) = @_; - - my $table = $schemaDB->AddTable({Name => $this->{$Class}->Name->Canonical.'_'.$property->Name}); - $table->InsertColumn({ - Name => '_id', - Type => $this->{$Parent}->TypeMapping->DBIdentifierType, - Tag => ['AUTO_INCREMENT'] - }); - $table->SetPrimaryKey('_id'); - - $table->InsertColumn({ - Name => 'parent', - Type => $this->{$Parent}->TypeMapping->DBIdentifierType - }); - - $table->InsertColumn({ - Name => 'value', - Type => $this->{$Parent}->TypeMapping->MapType($property->Type->GetAttribute('TemplateInstance')->{'Parameters'}{'T'}), - CanBeNull => 1 - }); - - $this->{$PropertyTables}->{$property->Name} = $table; - - return $table; -} - -sub CreateConstraints { - my ($this,$schemaDB) = @_; - return if $this->{$Class}->isTemplate or $this->{$Class}->GetAttribute('ValueType') or $this->{$Class}->Name->Simple eq 'Set'; - - foreach my $prop ( grep { UNIVERSAL::isa($_,'Schema::Property') } $this->{$Class}->ListMembers ) { - if ($prop->Type->Name->Name eq 'Set' ) { - # special case for multiple values - if (not $prop->Type->GetAttribute('TemplateInstance')->{'Parameters'}{'T'}->GetAttribute('ValueType')) { - $this->{$PropertyTables}->{$prop->Name}->LinkTo( - $this->{$Parent}->GetClassMapping($prop->Type->GetAttribute('TemplateInstance')->{'Parameters'}{'T'})->Table, - 'value' - ); - } - } elsif (not $prop->Type->GetAttribute('ValueType')) { - $this->{$Table}->LinkTo( - scalar($this->{$Parent}->GetClassMapping($prop->Type)->Table), - $prop->Name - ); - } - } -} - -sub GeneratePropertyTableText { - my ($this,$prop,$baseModule,$prefix) = @_; - - my $packageName = $this->GeneratePropertyClassName($prop,$prefix); - my $tableName = $this->{$PropertyTables}->{$prop->Name}->Name; - my $parentName = $this->GenerateClassName($prefix); - my $text .= "package $packageName;\n"; - $text .= "use parent '$baseModule';\n\n"; - $text .= "__PACKAGE__->table('`$tableName`');\n"; - $text .= "__PACKAGE__->columns(Essential => qw/_id parent value/);\n"; - $text .= "__PACKAGE__->has_a( parent => '$parentName');\n"; - - my $typeValue; - if ($prop->Type->Name->Simple eq 'Set') { - $typeValue = $prop->Type->GetAttribute('TemplateInstance')->{'Parameters'}{'T'}; - } else { - $typeValue = $prop->Type; - } - if ($typeValue->GetAttribute('ValueType')) { - if (my $reflectedClass = $this->{$Parent}->ReflectValueType($typeValue)) { - $text .= "__PACKAGE__->has_a( value => '$reflectedClass');\n"; - } - } else { - my $foreignName = $this->{$Parent}->GetClassMapping($prop->Type->GetAttribute('TemplateInstance')->{'Parameters'}{'T'})->GenerateClassName($prefix); - $text .= "__PACKAGE__->has_a( value => '$foreignName');\n"; - } - - return $text; -} - -sub GeneratePropertyClassName { - my ($this,$prop,$prefix) = @_; - - my $packageName = $this->{$Class}->Name->Canonical; - $packageName =~ s/\W//g; - return $prefix.$packageName.$prop->Name.'Ref'; -} - -sub GenerateClassName { - my ($this,$prefix) = @_; - my $packageName = $this->{$Class}->Name->Canonical; - $packageName =~ s/\W//g; - return $prefix. $packageName; -} - -sub GenerateText { - my ($this,$baseModule,$prefix) = @_; - - return if $this->{$Class}->isTemplate or $this->{$Class}->GetAttribute('ValueType') or $this->{$Class}->Name->Simple eq 'Set'; - - my @PropertyModules; - my $text; - my $packageName = $this->GenerateClassName($prefix); - - my $tableName = $this->{$Table}->Name; - my $listColumns = join ',', map { '\''. $_->Name . '\''} $this->{$Table}->Columns; - - $text .= "package $packageName;\n"; - $text .= "use parent '$baseModule'". ($this->{$Class}->Name->Name eq 'Map' ? ',\'CDBI::Map\'' : '' ).";\n\n"; - - $text .= "__PACKAGE__->table('`$tableName`');\n"; - $text .= "__PACKAGE__->columns(Essential => $listColumns);\n"; - - foreach my $prop ( grep { UNIVERSAL::isa($_,'Schema::Property') } $this->{$Class}->ListMembers ) { - my $propName = $prop->Name; - if ($prop->Type->Name->Name eq 'Set') { - # has_many - push @PropertyModules, $this->GeneratePropertyTableText($prop,$baseModule,$prefix); - my $propClass = $this->GeneratePropertyClassName($prop,$prefix); - $text .= <<ACCESSORS; -__PACKAGE__->has_many( ${propName}_ref => '$propClass'); -sub $propName { - return map { \$_->value } ${propName}_ref(\@_); -} -sub add_to_$propName { - return add_to_${propName}_ref(\@_); -} -ACCESSORS - - } elsif (not $prop->Type->GetAttribute('ValueType')) { - # has_a - my $ForeignClass = $this->{$Parent}->GetClassMapping($prop->Type)->GenerateClassName($prefix); - $text .= "__PACKAGE__->has_a( $propName => '$ForeignClass');\n"; - } else { - if (my $reflectedClass = $this->{$Parent}->ReflectValueType($prop->Type)) { - $text .= "__PACKAGE__->has_a( $propName => '$reflectedClass');\n"; - } - } - } - - # создаем список дочерних классов - foreach my $descedantMapping (grep {$_->{$Class}->isType($this->{$Class},1)} $this->{$Parent}->EnumClassMappings) { - next if $descedantMapping == $this; - $text .= "__PACKAGE__->might_have('m".$descedantMapping->GenerateClassName('')."' => '".$descedantMapping->GenerateClassName($prefix)."');\n"; - } - - # создаем ссылки на все классы, которые могут ссылаться на наш - # вид свойства ссылки: refererClassProp - foreach my $referer (grep {not $_->Class->isTemplate} $this->{$Parent}->EnumClassMappings) { - next if $referer == $this; - foreach my $prop ( grep { $_->isa('Schema::Property') } $referer->{$Class}->ListMembers ) { - if($prop->Type->Equals($this->{$Class})) { - $text .= "__PACKAGE__->has_many('referer".$referer->GenerateClassName('').$prop->Name."' => '".$referer->GenerateClassName($prefix)."','".$prop->Name."');\n"; - } elsif ($prop->Type->Name->Name eq 'Set' and $this->{$Class}->Equals($prop->Type->GetAttribute('TemplateInstance')->{'Parameters'}{'T'}) ) { - # если класс был параметром множества и $prop->Type и есть это множество - $text .= "__PACKAGE__->has_many('referer".$referer->GeneratePropertyClassName($prop,'')."value' => '".$referer->GeneratePropertyClassName($prop,$prefix)."','value');\n"; - } - } - } - - return (@PropertyModules,$text); -} - -1;
--- a/Lib/Schema/DataSource/TypeMapping.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -use strict; -package Schema::DataSource::TypeMapping; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Mappings => ACCESS_NONE; - DeclareProperty DBIdentifierType => ACCESS_READ; - DeclareProperty DBValueType => ACCESS_READ; -} - -sub MapType { - my ($this,$Type) = @_; - - if (my $mapped = $this->{$Mappings}->{$Type->Name->Canonical}) { - return $mapped; - } elsif ($Type->Attributes and $Type->GetAttribute('ValueType')) { - return $this->{$DBValueType}; - } else { - return $this->{$DBIdentifierType}; - } -} - -package Schema::DataSource::TypeMapping::Std; -use Schema::DB::Type; -our @ISA = qw(Schema::DataSource::TypeMapping); - -sub CTOR { - my ($this) = @_; - $this->SUPER::CTOR( - Mappings => { - Identifier => new Schema::DB::Type(Name => 'Integer'), - String => new Schema::DB::Type(Name => 'varchar', MaxLength => 255), - Integer => new Schema::DB::Type(Name => 'Integer'), - Float => new Schema::DB::Type(Name => 'Real'), - DateTime => new Schema::DB::Type(Name => 'DateTime'), - Bool => new Schema::DB::Type(Name => 'Tinyint'), - Blob => new Schema::DB::Type(Name => 'Blob'), - Text => new Schema::DB::Type(Name => 'Text') - }, - DBIdentifierType => new Schema::DB::Type(Name => 'Integer'), - DBValueType => new Schema::DB::Type(Name => 'varchar', MaxLength => 255) - ); -} - -1;
--- a/Lib/Schema/Form.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,252 +0,0 @@ -package Configuration; -our $DataDir; -package Schema::Form; -use strict; -use Storable; -use Common; -use URI::file; -use BNFCompiler; -use Schema::Form::Container; -use Schema::Form::Field; -use Schema::Form::Filter; -use Schema::Form::Format; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Body => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Name} = $args{Name}; - -} - -sub SetBody { - my ($this, $containerBody) = @_; - $this->{$Body} = $containerBody; -} - -sub list { - return( map { UNIVERSAL::isa($_,'ARRAY') ? @{$_} : defined $_ ? $_ : () } @_ ); -} - -sub LoadForms { - my ($class,$File,$CacheDir,$Encoding) = @_; - - $Encoding or die new Exception('An encoding must be specified for forms'); - - my $Compiler = new BNFCompiler(SchemaCache => "${DataDir}Cache/",Transform => sub { BNFCompiler::DOM::TransformDOMToHash(@_,{skip_spaces => 1})} ); - $Compiler->LoadBNFSchema(file => 'Schema/form.def'); - - my %Context = (Compiler => $Compiler, Encoding => $Encoding); - - $class->ProcessFile(URI::file->new_abs($File),URI::file->new_abs($CacheDir),\%Context); - - $Compiler->Dispose; - - return $Context{Forms}; -} - -sub ProcessFile { - my ($class,$uriFile,$uriCacheDir,$refContext) = @_; - - return 1 if $refContext->{'Processed'}{$uriFile->as_string}; - $refContext->{'Processed'}{$uriFile->as_string} = 1; - - my $Data; - my $file = $uriFile->file; - my $fnameCached = $file; - $fnameCached =~ s/[\\\/:]+/_/g; - $fnameCached .= '.cfm'; - $fnameCached = URI::file->new($fnameCached)->abs($uriCacheDir)->file; - - if ( -e $fnameCached && -f $fnameCached && ( -M $file >= -M $fnameCached ) ) { - $Data = retrieve($fnameCached); - } else { - my $Compiler = $refContext->{'Compiler'}; - local $/ = undef; - open my $hfile,"<:encoding($refContext->{Encoding})",$file or die new Exception('Failed to open file',$file); - $Data = $Compiler->Parse(<$hfile>); - store($Data,$fnameCached); - } - - - my $uriDir = URI::file->new('./')->abs($uriFile); - - my $needRebuild = 0; - - foreach my $inc (list $Data->{_include}) { - $needRebuild ||= $class->ProcessFile(URI::file->new($inc->{file_name})->abs($uriDir),$uriCacheDir,$refContext); - } - - foreach my $use (list $Data->{_use}) { - $refContext->{Filters}{$use->{alias}} = { Class => join '', list $use->{mod_name} }; - $refContext->{Require}{$use->{mod_name}} = 1; - } - - foreach my $container (list $Data->{container}) { - if ($container->{type} eq 'Form') { - $class->ConstructForm($container,$refContext); - } elsif ($container->{type} eq 'Format') { - $class->ConstructFormat($container,$refContext); - } elsif ($container->{type} eq 'Filter') { - $class->ConstructFilter($container,$refContext); - } - } -} - -sub ProcessContainer { - my ($class,$container,$refContext) = @_; -} - -sub ConstructForm { - my ($class,$container,$refContext) = @_; - - $container->{type} eq 'Form' or die new Exception("Unexpected container type"); - - not $refContext->{Forms}{$container->{name}} or die new Exception('The form is already exists',$container->{name}); - - my $Form = new Schema::Form(Name => $container->{name}); - - $Form->SetBody($class->ConstructGroup($container,$refContext)); - - $refContext->{Forms}{$Form->Name} = $Form; -} - -sub ConstructGroup { - my($class,$container,$refContext) = @_; - - my $Group = new Schema::Form::Container( - Name => $container->{name}, - isMulti => ($container->{multi} ? 1 : 0) - ); - - foreach my $child (list $container->{body}{container}) { - my $obj; - if ($child->{type} eq 'Group') { - $obj = $class->ConstructGroup($child,$refContext); - } else { - $obj = $class->ConstructField($child,$refContext); - } - $Group->AddChild($obj); - } - - foreach my $filter (list $container->{expression}) { - $Group->AddFilter($class->FilterInstance($filter,$refContext,$container->{name})); - } - - foreach my $attr (list $container->{body}{body_property}) { - $Group->Attributes->{$attr->{complex_name}} = $class->ScalarExpression($attr->{expression},$container->{name}); - } - - return $Group; -} - -sub ConstructField { - my ($class,$container,$refContext) = @_; - - my $Format = $refContext->{Formats}{$container->{type}} or die new Exception('An undefined format name', $container->{type}); - - my $Field = Schema::Form::Field->new( - Name => $container->{name}, - isMulti => ($container->{multi} ? 1 : 0), - Format => $Format - ); - - foreach my $filter (list $container->{expression}) { - $Field->AddFilter($class->FilterInstance($filter,$refContext,$container->{name})); - } - - foreach my $attr (list $container->{body}{body_property}) { - $Field->Attributes->{ref $attr->{complex_name} ? join '', @{$attr->{complex_name}} : $attr->{complex_name}} = $class->ScalarExpression($attr->{expression},$container->{name}); - } - - return $Field; -} - -sub FilterInstance { - my ($class,$expr,$refContext,$where) = @_; - - my $filter = $expr->{instance} or die new Exception('Invalid filter syntax',$where); - - my $filterClass = $refContext->{Filters}{$filter->{name}}{Class} or die new Exception('Using undefined filter name',$filter->{name},$where); - - my @Args = map { $class->ScalarExpression($_,$where) } list $filter->{expression}; - - my $Filter = Schema::Form::Filter->new( - Name => $filter->{name}, - Class => $filterClass, - Args => \@Args - ); - - if ($refContext->{Filters}{$filter->{name}}{Attributes}) { - while (my ($name,$value) = each %{$refContext->{Filters}{$filter->{name}}{Attributes}}) { - $Filter->Attributes->{$name} = $value; - } - } - - return $Filter; -} - -sub ScalarExpression { - my ($class,$expr,$where) = @_; - - my $val; - if ($expr->{instance}) { - $val = $expr->{instance}{name}; - } elsif ($expr->{string}) { - $val = join '', list $expr->{string}; - $val =~ s/\\(.)/ - if ($1 eq '"' or $1 eq '\\') { - $1; - } else { - "\\$1"; - } - /ge; - } elsif ($expr->{number}) { - $val = join '', list $expr->{number}; - } else { - die new Exception('Scalar expression required'); - } - - return $val; -} - -sub ConstructFormat { - my ($class,$container,$refContext) = @_; - - my $Format = Schema::Form::Format->new ( - Name => $container->{name} - ); - - foreach my $filter (list $container->{expression}) { - $Format->AddFilter($class->FilterInstance($filter,$refContext,$container->{name})); - } - - foreach my $attr (list $container->{body}{body_property}) { - $Format->Attributes->{ref $attr->{complex_name} ? join '', @{$attr->{complex_name}} : $attr->{complex_name}} = $class->ScalarExpression($attr->{expression},$container->{name}); - } - - $refContext->{Formats}{$Format->Name} = $Format; -} - -sub ConstructFilter { - my ($class,$container,$refContext) = @_; - - foreach my $attr (list $container->{body}{body_property}) { - $refContext->{Filters}{$container->{name}}{Attributes}{ref $attr->{complex_name} ? join '', @{$attr->{complex_name}} : $attr->{complex_name}} = $class->ScalarExpression($attr->{expression},$container->{name}); - } -} - -=pod -Form schema - описание формы ввода и правила контроля - -Form instance - значения элементов формы - -=cut - - -1;
--- a/Lib/Schema/Form/Container.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -package Schema::Form::Container; -use Form::Container; -use Common; -use parent qw(Schema::Form::Item); - -BEGIN { - DeclareProperty Children => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->SUPER::CTOR(@args{qw(Name isMulti Filters)}); - - $this->{$Children} = []; - -} - -sub AddChild { - my ($this,$child) = @_; - - not grep { $_->Name eq $child->Name } $this->Children or die new Exception("The item already exists",$child->Name); - - push @{$this->{$Children}},$child; -} - -sub FindChild { - my ($this,$name) = @_; - - my @result = grep { $_->Name eq $name} $this->Children; - return $result[0]; -} - -sub Dispose { - my ($this) = @_; - - delete $this->{$Children}; - - $this->SUPER::Dispose; -} -1;
--- a/Lib/Schema/Form/Field.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package Schema::Form::Field; -use strict; -use Common; -use parent qw(Schema::Form::Item); - -BEGIN { - DeclareProperty Format => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $args{'Format'} or die new Exception('A format is required for a field'); - - $args{'Attributes'} = { %{$args{Format}->Attributes},%{$args{Attributes} || {} } }; - - $this->SUPER::CTOR(@args{qw(Name isMulti Filters Attributes)}); - $this->{$Format} = $args{'Format'}; -} - -=pod -Сначала применить фильтры формата а потом фильтры поля -=cut -sub Filters { - my ($this) = @_; - - my @filters = $this->{$Format}->Filters; - push @filters,$this->SUPER::Filters; - - return @filters; -} - -1;
--- a/Lib/Schema/Form/Filter.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -package Schema::Form::Filter; -use strict; -use Common; -our @ISA = qw(Object); - -my %LoadedModules; - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Class => ACCESS_READ; - DeclareProperty Args => ACCESS_READ; - DeclareProperty Attributes => ACCESS_READ; - DeclareProperty _Instance => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Name} = $args{'Name'} or die new Exception('A filter name is required'); - $this->{$Class} = $args{'Class'} or die new Exception('A filter class is required'); - $this->{$Args} = $args{'Args'}; - $this->{$Attributes} = {}; -} - -sub Create { - my ($this) = @_; - - if (not $LoadedModules{$this->{$Class}}) { - eval "require $this->{$Class};" or die new Exception('Can\'t load the specified filter',$this->{$Name},$this->{$Class},$@); - $LoadedModules{$this->{$Class}} = 1; - } - - return $this->{$Class}->new($this->{$Name},$this->{$Attributes}{'message'},$this->Args); -} - -sub Instance { - my ($this) = @_; - - if (my $instance = $this->{$_Instance}) { - return $instance; - } else { - return $this->{$_Instance} = $this->Create; - } -} - -1;
--- a/Lib/Schema/Form/Format.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,26 +0,0 @@ -package Schema::Form::Format; -use strict; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty Filters => ACCESS_READ; - DeclareProperty Attributes => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Name} = $args{'Name'} or die new Exception('A format name is required'); - $this->{$Filters} = []; - $this->{$Attributes} = $args{'Attributes'} || {}; -} - -sub AddFilter { - my ($this,$filter) = @_; - - push @{$this->{$Filters}},$filter; -} - -1;
--- a/Lib/Schema/Form/Item.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -package Schema::Form::Item; -use strict; -use Common; -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Name => ACCESS_READ; - DeclareProperty isMulti => ACCESS_READ; - DeclareProperty Filters => ACCESS_READ; - DeclareProperty Attributes => ACCESS_READ; -} - -sub CTOR { - my ($this,$name,$multi,$filters,$attributes) = @_; - - $this->{$Name} = $name or die new Exception("A name is required for the item"); - $this->{$isMulti} = defined $multi ? $multi : 0; - $this->{$Filters} = $filters || []; - $this->{$Attributes} = $attributes || {}; -} - -sub AddFilter { - my ($this,$filter) = @_; - - push @{$this->{$Filters}}, $filter; -} - -sub isMandatory { - my ($this) = @_; - - return ( grep $_->Name eq 'mandatory', $this->Filters ) ? 1 : 0 ; -} - -sub GetFirstFilter { - my ($this,$filterName) = @_; - - my ($filter) = grep $_->Name eq $filterName, $this->Filters; - return $filter; -} - -1;
--- a/Lib/Security/Auth.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,108 +0,0 @@ -package Security::Auth; -use strict; -use Common; -use Security; -use DateTime; -use Digest::MD5 qw(md5_hex); -our @ISA = qw(Object); - -our $Package; -our $DataSource; - -srand time; - -BEGIN { - DeclareProperty DS => ACCESS_READ; - DeclareProperty SecPackage => ACCESS_READ; -} - -{ - my $i = 0; - sub GenSSID() { - return md5_hex(time,rand,$i++); - } -} - -sub CTOR { - my ($this,%args) = @_; - $this->{$DS} = $args{'DS'} or die new Exception('A data source is required'); - $this->{$SecPackage} = $args{'SecPackage'} or die new Exception('A security package is required'); -} - -sub AuthenticateUser { - my ($this,$Name,$SecData) = @_; - - my $User = $this->{$DS}->FindUser($Name); - if (not $User or not $User->Active ) { - return new Security::AuthResult ( - State => Security::AUTH_FAILED, - AuthModule => $this - ); - } else { - - - if (my $StoredData = $this->{$DS}->GetUserAuthData($User,$this->{$SecPackage})) { - my $AuthData = $this->{$SecPackage}->ConstructAuthData($StoredData->AuthData); - if ((my $status = $AuthData->DoAuth($SecData)) != Security::AUTH_FAILED) { - $AuthData = $this->{$SecPackage}->NewAuthData(GenSSID); - return new Security::AuthResult ( - State => $status, - Session => $this->{$DS}->CreateSession(GenSSID,$User,$AuthData), - ClientSecData => $AuthData->ClientAuthData, - AuthModule => $this - ) - } else { - return new Security::AuthResult ( - State => Security::AUTH_FAILED, - AuthModule => $this - ); - } - } else { - # the user isn't allowed to authenticate using this method - return new Security::AuthResult ( - State => Security::AUTH_FAILED, - AuthModule => $this - ); - } - } -} - -sub AuthenticateSession { - my ($this,$SSID,$SecData) = @_; - - my $Session = $this->{$DS}->LoadSession($SSID) or return new Security::AuthResult(State => Security::AUTH_FAILED); - - my $AuthData = $this->{$SecPackage}->ConstructAuthData($Session->SecData); - if ((my $status = $AuthData->DoAuth($SecData)) != Security::AUTH_FAILED) { - $Session->SecData($AuthData->SessionAuthData); - $Session->LastUsage(DateTime->now()); - return new Security::AuthResult(State => $status, Session => $Session, ClientSecData => $AuthData->ClientAuthData, AuthModule => $this); - } else { - $this->{$DS}->CloseSession($Session); - return new Security::AuthResult(State => Security::AUTH_FAILED, AuthModule => $this); - } -} - -sub CreateUser { - my ($this,$uname,$description,$active,$secData) = @_; - - my $user = $this->{$DS}->CreateUser($uname,$description,$active); - $this->{$DS}->SetUserAuthData($user,$this->{$SecPackage},$this->{$SecPackage}->NewAuthData($secData)); - - return $user; -} - -sub try_construct { - my $package = shift; - return $package->can('construct') ? $package->construct() : $package; -} - -sub construct { - $Package or die new Exception('A security package is reqiured'); - $DataSource or die new Exception('A data source is required'); - eval "require $DataSource;" or die new Exception('Failed to load the data source module',$@) if not ref $DataSource; - eval "require $Package;" or die new Exception('Failed to load the security package module',$@) if not ref $Package; - return __PACKAGE__->new(DS => try_construct($DataSource), SecPackage => try_construct($Package)); -} - -1;
--- a/Lib/Security/Auth/Simple.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,73 +0,0 @@ -package Security::Auth::Simple; -use strict; -use Common; - -our $Strict; - -our @ISA = qw(Object); - -sub Name { - return 'Simple'; -} - -sub ConstructAuthData { - my ($class,$SecData) = @_; - return new Security::Auth::Simple::AuthData(DataMD5 => $SecData); -} - -sub NewAuthData { - my ($class,$SecData) = @_; - return new Security::Auth::Simple::AuthData(Data => $SecData); - -} - -package Security::Auth::Simple::AuthData; -use Common; -use Security; -use Security::Auth; -use Digest::MD5 qw(md5_hex); -our @ISA = qw(Object); - -BEGIN { - DeclareProperty Data => ACCESS_READ; - DeclareProperty DataMD5 => ACCESS_READ; -} - -sub CTOR { - my ($this,%args) = @_; - - if ($args{'Data'}) { - $args{'DataMD5'}= $args{'Data'} ? md5_hex($args{'Data'}) : undef ; - $this->{$Data} = $args{'Data'}; - } - $this->{$DataMD5} = $args{'DataMD5'}; -} - -sub DoAuth { - my ($this,$SecData) = @_; - - if (not ($this->{$DataMD5} or $SecData) or $this->{$DataMD5} eq md5_hex($SecData)) { - if ($Strict) { - $this->{$Data} = Security::Auth::GenSSID; - $this->{$DataMD5} = md5_hex($this->{$Data}); - } else { - $this->{$Data} = $SecData; - } - return Security::AUTH_SUCCESS; - } else { - return Security::AUTH_FAILED; - } -} - -sub SessionAuthData { - my ($this) = @_; - - return $this->{$DataMD5}; -} - -sub ClientAuthData { - my ($this) = @_; - return $this->{$Data}; -} - -1;
--- a/Lib/Security/Authz.pm Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -package Security::Authz; -use Common; -use Security; - -our @ISA = qw(Object); - -BEGIN { - DeclareProperty User => ACCESS_READ; -} - -sub _CurrentUser { - my ($class) = @_; - - if (ref $class) { - return $class->{$User}; - } else { - if (Security->CurrentSession) { - Security->CurrentSession->User; - } else { - return undef; - } - } -} - -sub demand { - my ($class,@Roles) = @_; - - return 0 if not $class->_CurrentUser; - - my %UserRoles = map { $_->Name, 1 } $class->_CurrentUser->Roles; - - return not grep {not $UserRoles{$_}} @Roles; -}
--- a/Schema/form.def Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -syntax ::= {{_include|_use}|container}[ {{_include|_use}|container} ...] - -name ::=<\w>+ - -file_name ::=<\w./>+ - -mod_name ::= <\w>+[::<\w>+...] - -_include ::= include file_name ; - -_use ::= use alias mod_name ; - -alias ::= <\w>+ - -type ::=<\w>+ - -multi ::=* - -container ::=type [multi] name[ : expression [, expression ...]] [body]; - -instance ::= name[ ( expression [, expression ...])] - -string ::=[{<^\\">+|<\\><\w\W>}...] - -number ::=[{+|-}] <0-9>+[.<0-9>+[e[-]<0-9>+]] - -bin_op ::={+|-|&|<|>|=} - -un_op ::=! - -expression ::= {"string"|number|instance|(expression)|{"string"|number|instance|(expression)} bin_op expression|un_op expression} - -body ::= <{> - [{body_property|container} ...] -<}> - -complex_name ::= <\w>+[.<\w>+...] - -body_property ::= complex_name = expression;
--- a/Schema/query.def Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -syntax ::= select expr_list from var_defs where condition - -name ::= <\w>+ - -fqdn ::= name[.name...] - -string ::= '[{<^'>+|<'>{2}}...]' - -number ::= [{+|-}] <\d>+ - -math_op ::= {+|-|*|/} - -compare_op ::= {<\>>|<\<>|==|!=} - -log_op ::= {OR|AND} - -not_op ::= NOT - -expr ::= {string|number|fqdn} [math_op {string|number|fqdn|( expr )} ...] - -expr_list ::= expr [, expr ...] - -type ::= name [<\<>type [, type ...]<\>>] - -condition ::= [not_op] expr compare_op expr [log_op {condition|( condition )} ...] - -var_defs ::= name as type [, name as type ...]
--- a/Schema/schema.def Tue May 17 00:04:28 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -syntax ::= header[ class ...] - -name ::= <\w>+ - -column_name ::= {<\w>+|<[><^[]>+<]>} - -type ::= name [<\<> template_list <\>>] - -type_definition ::= name [<\<> args_list <\>>] - -args_list ::= name [, name ...] - -db_type ::= <\w>+[(<\d>+[,<\d>+])] - -template_list ::= type[, type ...] - -mapping ::= column_name [as db_type] - -property ::= type name[ =<\>> mapping] - -comment ::= #<^\n>*<\n>[ #<^\n>*<\n>...] - -property_list ::= property ; [comment] [property ; [comment] ...] - -base_types ::= type [, type ...] - -value_type ::= value - -class ::= -[comment][value_type ]type_definition [: base_types] <{> - [comment] - [property_list] -<}> - -header_value ::= {*<^;>+ {;<\n>| header_value}|<^\n>+[;]} - -header_prop ::= name = header_value - -file_name ::=<\w./>+ - -include_item ::= include ( file_name )[;] - -header ::=[ {header_prop|include_item} ...]