Mercurial > pub > Impl
changeset 0:03e58a454b20
Создан репозитарий
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.hgignore Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,1 @@ +glob:.svn/
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/BNFCompiler.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,666 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/CDBI/Map.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,110 @@ +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 base 'Class::DBI'; + +#.... + +package App::MapString; +use base '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 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/CDBI/Meta.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,20 @@ +package CDBI::Meta::BindingAttribute; +use strict; +use warnings; + +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/CDBI/Transform.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,105 @@ +package CDBI::Transform::FormToObject; +use strict; +use warnings; + +use base 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 base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Common.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,282 @@ +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 base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Configuration.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,37 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,19 @@ +package DOM; +require DOM::Site; +use Common; + +my $GlobalSite; + +sub Site { + my $self = shift; + + $GlobalSite = construct DOM::Site if not $GlobalSite; + return $GlobalSite; +} + +sub Cleanup { + $GlobalSite->Dispose if $GlobalSite; + undef $GlobalSite; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Page.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,241 @@ +package DOM::Page; +use Common; +use Template::Context; +use strict; + +our @ISA = qw(Object); +our $AUTOLOAD; + +BEGIN { + DeclareProperty(Title => ACCESS_ALL); + DeclareProperty(NavChain => ACCESS_READ); + DeclareProperty(Menus => ACCESS_READ); + DeclareProperty(Properties => ACCESS_READ); + DeclareProperty(Template => ACCESS_READ); + DeclareProperty(TemplatesProvider => ACCESS_NONE); + DeclareProperty(Site => ACCESS_READ); +} + +sub CTOR { + my ($this,%args) = @_; + $this->{$Site} = $args{'Site'}; + $this->{$TemplatesProvider} = $args{'TemplatesProvider'}; + $this->{$Properties} = $args{'Properties'} || {}; + $this->{$Title} = $args{'Template'}->Title() || $args{'Properties'}->{'Title'}; + $this->{$Template} = $args{'Template'}; + $this->{$NavChain} = $args{'NavChain'}; + $this->{$Menus} = $args{'Menus'}; +} + +sub Render { + my ($this,$hOut) = @_; + + my $context = new Template::Context({ + VARIABLES => $this->{$Site}->Objects(), + LOAD_TEMPLATES => $this->{$TemplatesProvider} + }); + + print $hOut $this->{$Template}->process($context); +} + +sub Dispose { + my ($this) = @_; + + undef %$this; + + $this->SUPER::Dispose; +} + +sub Container { + my ($this) = @_; + my $nav = $this->{$NavChain}; + return $nav->[@{$nav}-1]; +} + +sub AUTOLOAD { + my $this = shift; + + my $name = $AUTOLOAD; + $name =~ s/.*://; + + return $this->{$Properties}->{$name}; +} + +=pod +Ìåíþ + [ + Ýëåìåíò ìåíþ + { + Key => Êëþ÷ ïóíêòà ìåíþ, äëÿ áûñòðîãî îáðàùåíèÿ ê ýëåìåíòó è ñëèÿíèè ìåíþ + Name => Èìÿ ïóíêòà ìåíþ, êîòîðîå áóäåò âèäåëü ïîëüçîâàòåëü + Expand => ôëàã òîãî, ÷òî ìåíþ âûáðàíî + Value => {[ ýëåìåíò ìåíþ ...] | ÷òî-òî åùå, îáû÷íî óðë} + } + ] +=cut + +package DOM::PageMenu; +use Common; + +our @ISA = qw(Object); + +BEGIN { + DeclareProperty('Items'); # ìàññèâ + DeclareProperty('Keys'); # êëþ÷è äëÿ ïóíêòîâ ìåíþ, åñëè òàêîâûå èìåþòñÿ +} + +sub CTOR { + my ($this,%args) = @_; + if (ref $args{'DATA'} eq 'ARRAY') { + foreach my $item (@{$args{'DATA'}}) { + if (ref $item eq 'HASH') { + $this->Append($item->{'Name'},_ProcessData($item->{'Value'}), Expand => $item->{'Expand'}, Key => $item->{'Key'}, Url => $item->{'Url'}); + } elsif (ref $item eq 'ARRAY') { + $this->Append($item->[0],_ProcessData($item->[1]), Expand => $item->[2], Key => $item->[3], Url => $item->[4]); + } + } + } +} + +sub Item { + my ($this,$index) = @_; + + return $this->{$Items}[$index]; +} + +sub ItemByKey { + my ($this,$key) = @_; + + return $this->{$Keys}->{$key}; +} + +sub InsertBefore { + my ($this,$index,$name,$data,%options) = @_; + + my $item = {Name => $name, Value => _ProcessData($data), %options}; + splice @{$this->{$Items}},$index,0,$item; + + if ($options{'Key'}) { + $this->{$Keys}->{$options{'Key'}} = $item; + } +} + +sub Append { + my ($this,$name,$data,%options) = @_; + + my $item = {Name => $name, Value => _ProcessData($data), %options}; + + push @{$this->{$Items}},$item; + + if ($options{'Key'}) { + $this->{$Keys}->{$options{'Key'}} = $item; + } +} + +sub SubMenu { + my ($this,$path) = @_; + my $item = $this; + foreach my $key ( split /\/+/,$path ) { + $item = $item->{$Keys}->{$key}; + if (not $item ) { + die new Exception('Item does\'t exist', $path, $key); + } + $item = $item->{Value}; + if (not UNIVERSAL::isa($item,'DOM::PageMenu')) { + $item = ($this->{$Keys}->{$key}->{Value} = new DOM::PageMenu()); + } + } + + return $item; +} + +sub Dump { + use Data::Dumper; + + return Dumper(shift); +} + +sub AppendItem { + my ($this,$item) = @_; + + push @{$this->{$Items}},$item; + + if ($item->{'Key'}) { + $this->{$Keys}->{$item->{'Key'}} = $item; + } +} + +sub RemoveAt { + my ($this,$index) = @_; + + my $item = splice @{$this->{$Items}},$index,1; + + if ($item->{'Key'}) { + delete $this->{$Keys}->{$item->{'Key'}}; + } + + return 1; +} + +sub ItemsCount { + my $this = shift; + return scalar(@{$this->{$Items}}); +} + +sub Sort { + my $this = shift; + + $this->{$Items} = \sort { $a->{'Name'} <=> $b->{'Name'} } @{$this->{$Items}}; + + return 1; +} + +sub as_list { + my $this = shift; + return $this->{$Items} || []; +} + +sub Merge { + my ($this,$that) = @_; + + foreach my $itemThat ($that->Items) { + my $itemThis = $itemThat->{'Key'} ? $this->{$Keys}->{$itemThat->{'Key'}} : undef; + if ($itemThis) { + $this->MergeItems($itemThis,$itemThat); + } else { + $this->AppendItem($itemThat); + } + } +} + +sub MergeItems { + my ($this,$itemLeft,$itemRight) = @_; + + while (my ($prop,$value) = each %{$itemRight}) { + if ($prop eq 'Value') { + if (UNIVERSAL::isa($itemLeft->{$prop},__PACKAGE__) && UNIVERSAL::isa($value,__PACKAGE__)) { + $itemLeft->{$prop}->Merge($value); + } else { + $itemLeft->{$prop} = $value if defined $value; + } + } else { + $itemLeft->{$prop} = $value if defined $value; + } + } + + return 1; +} + +sub _ProcessData { + my $refData = shift; + + if (ref $refData eq 'ARRAY') { + return new DOM::PageMenu(DATA => $refData); + } else { + return $refData; + } +} + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Providers/Form.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,49 @@ +package Configuration; +our $DataDir; +package DOM::Providers::Form; +use strict; +use Form; +use Schema::Form; +use Common; +our @ISA = qw(Object); + +our $Encoding ; +our $CacheDir ||= "${DataDir}Cache/"; +warn "The encoding for the DOM::Provider::Form isn't specified" if not $Encoding; +$Encoding ||= 'utf-8'; + +sub GetProviderInfo { + return { + Name => 'Form', + Host => 'DOM::Site', + Methods => { + LoadForm => \&SiteLoadForm + } + } +} + +BEGIN { + DeclareProperty FormsEncoding => ACCESS_READ; + DeclareProperty DataCacheDir => ACCESS_READ; +} + +sub SiteLoadForm { + my ($this,$site,$file,$form) = @_; + return $site->RegisterObject('Form',$this->LoadForm($file,$form)); +} + +sub LoadForm { + my ($this,$file, $formName) = @_; + + my $formSchema = Schema::Form->LoadForms($file,$this->{$DataCacheDir},$this->{$FormsEncoding})->{$formName} or die new Exception('The form isn\'t found',$formName,$file); + return Form->new($formSchema); +} + +sub construct { + my ($class) = @_; + + return $class->new(FormsEncoding => $Encoding, DataCacheDir => $CacheDir); +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Providers/Gallery.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,200 @@ +use strict; +package DOM::Gallery; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty(Id => ACCESS_READ); + DeclareProperty(Name => ACCESS_READ); + DeclareProperty(Description => ACCESS_READ); + DeclareProperty(Images => ACCESS_READ); + DeclareProperty(CurrentImage => ACCESS_READ); + DeclareProperty(NextImage => ACCESS_READ); + DeclareProperty(PrevImage => ACCESS_READ); +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$Id} = $args{'Id'}; + $this->{$Name} = $args{'Name'}; + $this->{$Description} = $args{'Description'}; +} + +sub GroupList { + my ($this,$GroupCount, $option) = @_; + + my @images = map { $this->{$Images}->{$_} } sort keys %{$this->{$Images}}; + + my @listGroups; + my $group; + for (my $i = 0; $i < $GroupCount; $i++ ) { + #last unless scalar(@images) or $option =~ /align/i; + push (@$group, shift(@images)); + if ($i == $GroupCount - 1) { + push @listGroups, $group; + undef $group; + $i = -1; + last if not scalar(@images); + } + } + + return \@listGroups; +} + +sub SelectImage { + my ($this,$imageId) = @_; + + my @images = sort keys %{$this->{$Images}}; + + for (my $i=0; $i <= @images; $i++) { + if ($images[$i] eq $imageId) { + $this->{$CurrentImage} = $this->{$Images}->{$images[$i]}; + $this->{$PrevImage} = $i-1 >= 0 ? $this->{$Images}->{$images[$i-1]} : undef; + $this->{$NextImage} = $i+1 < @images ? $this->{$Images}->{$images[$i+1]} : undef; + return 1; + } + } + die new Exception("An image '$imageId' not found in the gallery '$this->{$Id}'"); +} + +sub AddImage { + my ($this,$image) = @_; + + $this->{$Images}->{$image->Id()} = $image; +} + +package DOM::Gallery::Image; +use Common; +our @ISA = qw(Object); +BEGIN { + DeclareProperty(Id => ACCESS_READ); + DeclareProperty(Name => ACCESS_READ); + DeclareProperty(Gallery => ACCESS_READ); + DeclareProperty(URL => ACCESS_READ); + DeclareProperty(ThumbURL => ACCESS_READ); +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$Id} = $args{'Id'} or die new Exception ('An Id should be specified for an image'); + $this->{$Name} = $args{'Name'}; + $this->{$Gallery} = $args{'Gallery'} or die new Exception('An Gallery should be specified for an image'); + $this->{$URL} = $args{'URL'}; + $this->{$ThumbURL} = $args{'ThumbURL'}; +} + +package DOM::Providers::Gallery; +use Common; +our @ISA = qw(Object); + +our $RepoPath; +our $ImagesURL; +our $Encoding; + +BEGIN { + DeclareProperty(GalleryCache => ACCESS_NONE); + DeclareProperty(Repository => ACCESS_NONE); +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$Repository} = $args {'Repository'} or die new Exception('A path to an galleries repository should be specified'); +} + +sub GetProviderInfo() { + return { + Name => 'Gallery', + Host => 'DOM::Site', + Methods => { + LoadGallery => \&SiteLoadGallery #($this,$site,$galleryId) + } + }; +} + +sub SiteLoadGallery { + my ($this,$site,$galleryId) = @_; + + my $gallery = $this->LoadGallery($galleryId); + + $site->RegisterObject('Gallery',$gallery); + + return $gallery; +} + +sub LoadGallery { + my ($this,$galleryId) = @_; + + die new Exception("Invalid Gallery Id: $galleryId") if $galleryId =~ /\\|\//; + + my $galleryIdPath = $galleryId; + $galleryIdPath =~ s/\./\//g; + + my $GalleryPath = $this->{$Repository} . $galleryIdPath .'/'; + + die new Exception("A gallery '$galleryId' isn't found",$GalleryPath) if not -d $GalleryPath; + + open my $hDesc, "<:encoding($Encoding)", $GalleryPath.'index.htm' or die new Exception("Invalid gallery: $galleryId","Failed to open ${GalleryPath}index.htm: $!"); + + my $GalleryName; + while (<$hDesc>) { + if (/<title>(.+?)<\/title>/i) { + $GalleryName = $1; + last; + } + } + undef $hDesc; + + my $ImagesPath = $GalleryPath.'images/'; + my $ThumbsPath = $GalleryPath.'thumbnails/'; + + opendir my $hImages, $ImagesPath or die new Exception("Invalid gallery: $galleryId","Can't open images repository: $!"); + + my @imageIds = grep { -f $ImagesPath.$_ } readdir $hImages; + + my %imageNames; + + if (-f $GalleryPath.'description.txt') { + local $/="\n"; + if (open my $hfile,"<:encoding($Encoding)",$GalleryPath.'description.txt') { + while (<$hfile>) { + chomp; + my ($id,$name) = split /\s*=\s*/; + $imageNames{$id} = $name; + } + } + } + + undef $hImages; + + if ($Common::Debug) { + foreach (@imageIds) { + warn "A tumb isn't found for an image: $_" if not -f $ThumbsPath.$_; + } + } + + my $gallery = new DOM::Gallery(Id => $galleryId, Name => $GalleryName); + + foreach my $imageId (@imageIds) { + $gallery->AddImage(new DOM::Gallery::Image( + Id => $imageId, + URL => $ImagesURL.$galleryIdPath.'/images/'.$imageId, + ThumbURL => $ImagesURL.$galleryIdPath.'/thumbnails/'.$imageId, + Gallery => $gallery, + Name => $imageNames{$imageId} + ) + ); + } + + return $gallery; +} + +sub construct { + my $self = shift; + + return new DOM::Providers::Gallery( Repository => $RepoPath); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Providers/Headlines.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,128 @@ +package DOM::Providers::Headlines::Headline; +use Common; +use Time::Local; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty(Id => ACCESS_READ); + DeclareProperty(DateModify => ACCESS_READ); + DeclareProperty(DateExpire => ACCESS_READ); + DeclareProperty(URL => ACCESS_READ); + DeclareProperty(Text => ACCESS_READ); + DeclareProperty(Channel => ACCESS_READ); +} + +sub str2time { + my $str = shift; + + if ($str =~ /^(\d{4})-(\d{2})-(\d{2})(?:\s(\d{2}):(\d{2}):(\d{2}))?$/) { + my ($year,$month,$day,$hh,$mm,$ss) = ($1,$2-1,$3,(defined $4 ? $4 : 0),(defined $5 ? $5 : 0),(defined $6 ? $6 : 0)); + return timelocal($ss,$mm,$hh,$day,$month,$year); + } else { + die new Exception("A string '$str' isn't an ISO standard time"); + } +} + +sub IsActive { + my ($this) = @_; + my $timeExpire = str2time($this->{$DateExpire}); + + return ($timeExpire > time()); +} + +package DOM::Providers::Headlines::Collection; +use Common; +our @ISA = qw (Object); + +BEGIN { + DeclareProperty(Items => ACCESS_READ); +} + +sub CTOR { + my ($this,%args) = @_; + + foreach my $headline (@{$args{'Items'}}) { + $this->{$Items}->{$headline->Id()} = $headline if ($headline->IsActive) + } +} + +sub as_list { + my $this = shift; + + return [ map { $this->{$Items}->{$_} } sort keys %{$this->{$Items}} ]; +} + +sub GenerateRandomSequence { + my ($count,$max) = @_; + + my %hash; + $hash{rand()} = $_ foreach (0 .. $max - 1); + my @sequence = map { $hash{$_} } sort keys %hash; + return splice @sequence,0,$count; +} + +sub Random { + my ($this,$count) = @_; + + my $list = $this->as_list(); + + return [map { $list->[$_] } GenerateRandomSequence($count,scalar(@$list))]; +} + +sub Recent { + my ($this,$count) = @_; + + my @result = sort { $b->DateModify() cmp $a->DateModify() } values %{$this->{$Items}}; + splice @result,$count; + + return \@result; +} + +sub AddItem { + my ($this,$newItem) = @_; + + $this->{$Items}->{$newItem->Id()} = $newItem; +} + +package DOM::Providers::Headlines; +use Common; +use ObjectStore::Headlines; + +our $DBPath; +our $Encoding; + +my %Channels; + +eval { + LoadHeadlines(); +}; + +if ($@) { + my $err = $@; + if (ref $err eq 'Exception') { + die $err->ToString(); + } else { + die $err; + } +} + + +sub GetProviderInfo { + return { + Name => 'Headlines', + Host => 'DOM::Site', + Objects => \%Channels + } +} + +sub LoadHeadlines { + my $dsHeadlines = new ObjectStore::Headlines(DBPath => $DBPath, HeadlineClass => 'DOM::Providers::Headlines::Headline', Encoding => $Encoding); + + foreach my $headline (@{$dsHeadlines->Search(Filter => sub { return $_[0]->IsActive(); } )}) { + my $channel = $headline->Channel() || 'main'; + $Channels{$channel} = new DOM::Providers::Headlines::Collection() if not exists $Channels{$channel}; + $Channels{$channel}->AddItem($headline); + } +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Providers/Page.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,258 @@ +use strict; + +package DOM::Providers::Page; +use Template::Provider; +#use PerfCounter; +use DOM::Page; +use Common; +use Encode; + +our @ISA= qw(Object Exporter); + +our $UseIndexPage; #optional +our $PagesPath; #required +our $IncludesPath; #optional +our $CacheSize; #optional +our $CachePath; #optional +our $Encoding; #optional +our $AllowExtPath; #optional +our $PageResolver; #optional + + +BEGIN { + DeclareProperty('PageResolver'); + DeclareProperty('PagesBase'); + DeclareProperty('IndexPage'); + DeclareProperty('TemplatesProvider'); + DeclareProperty('PageEnc'); +} + +sub as_list { + return( map { UNIVERSAL::isa($_,'ARRAY') ? @{$_} : defined $_ ? $_ : () } @_ ); +} + +sub GetProviderInfo { + return { + Name => 'Page', + Host => 'DOM::Site', + Methods => { + LoadPage => \&SiteLoadPage, + ReleasePage => \&SiteReleasePage, + } + } +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$PageResolver} = $args{'PageResolver'}; + $this->{$PagesBase} = $args{'TemplatesPath'}; + $this->{$IndexPage} = $args{'IndexPage'} || 'index.html'; + $this->{$PageEnc} = $args{'Encoding'}; + $this->{$TemplatesProvider} = new Template::Provider( INCLUDE_PATH => [$this->{$PagesBase}, as_list($args{'IncludePath'}) ], COMPILE_DIR => $args{'CachePath'}, CACHE_SIZE => $args{'CacheSize'}, ENCODING => $args{'Encoding'}, ABSOLUTE => $AllowExtPath, RELATIVE => $AllowExtPath, INTERPOLATE => 1, PRE_CHOMP => 3); +} + +sub ResolveId { + my ($this,$pageId) = @_; + + if ($this->{$PageResolver} && UNIVERSAL::can($this->{$PageResolver},'ResolveId')) { + return $this->{$PageResolver}->ResolveId($pageId); + } else { + return grep { $_ } split /\//,$pageId; + } +} + +sub MakePageId { + my ($this,$raPath) = @_; + + if ($this->{$PageResolver} && UNIVERSAL::can($this->{$PageResolver},'MakeId')) { + return $this->{$PageResolver}->MakeId($raPath); + } else { + return join '/',@$raPath; + } +} + +sub PageIdToURL { + my ($this,$pageId) = @_; + + if ($this->{$PageResolver} && UNIVERSAL::can($this->{$PageResolver},'PageIdToURL')) { + return $this->{$PageResolver}->PageIdToURL($pageId); + } else { + return '/'.$pageId; + } +} + +sub SiteLoadPage { + my ($this,$site,$pageId) = @_; + + return $site->RegisterObject('Page', $this->LoadPage($pageId, Site => $site)); +} +sub LoadPage { + my ($this,$pageId,%args) = @_; + + #StartTimeCounter('LoadPageTime'); + + my @pathPage = $this->ResolveId($pageId); + + my $pageNode = $this->LoadNode(\@pathPage); + + pop @pathPage; + + my @pathNode; + + # ïîñêîëüêó ïóòü óêàçàí îòíîñèòåëüíî êîðíåâîãî êîíòåéíåðà, òî íóæíî åãî äîáàâèòü â íà÷àëî + my @NavChain = map { push @pathNode, $_; $this->LoadNode(\@pathNode); } ('.',@pathPage); + + if ($pageNode->{'Type'} eq 'Section') { + push @NavChain,$pageNode; + $pageNode = $this->LoadNode($pageNode->{'pathIndexPage'}); + } + + # ôîðìèðóåì ìåíþ ñòðàíèöû + my %PageMenus; + foreach my $MenuSet (map { $_->{'Menus'}} @NavChain, $pageNode->{'Menus'} ) { + foreach my $menuName (keys %$MenuSet) { + if ($PageMenus{$menuName}) { + $PageMenus{$menuName}->Merge($MenuSet->{$menuName}); + } else { + $PageMenus{$menuName} = $MenuSet->{$menuName}; + } + } + } + + # ôîðìèðóåì êëþ÷åâûå ñëîâà è ñâîéñòâà + my @keywords; + my %Props; + foreach my $PropSet ( (map { $_->{'Props'}} @NavChain), $pageNode->{'Props'} ) { + if(ref $PropSet->{'Keywords'} eq 'ARRAY') { + push @keywords, @{$PropSet->{'Keywords'}}; + } elsif (not ref $PropSet->{'Keywords'} and exists $PropSet->{'Keywords'}) { + push @keywords, $PropSet->{'Keywords'}; + } + + while (my ($prop,$value) = each %$PropSet) { + next if $prop eq 'Keywords'; + $Props{$prop} = $value; + } + } + + #StopTimeCounter('LoadPageTime'); + # çàãðóæàåì øàáëîí + + #StartTimeCounter('FetchTime'); + my ($Template,$error) = $this->{$TemplatesProvider}->fetch($pageNode->{'TemplateFileName'}); + die new Exception("Failed to load page $pageId",$Template ? $Template->as_string : 'Failed to parse') if $error; + #StopTimeCounter('FetchTime'); + + my $page = new DOM::Page(TemplatesProvider => $this->{$TemplatesProvider}, Properties => \%Props, Menus => \%PageMenus, NavChain => \@NavChain, Template => $Template, %args); + $page->Properties->{url} = $this->PageIdToURL($pageId); + return $page; +} + +sub LoadNode { + my ($this,$refNodePath) = @_; + + my $fileNameNode = $this->{$PagesBase} . join('/',grep $_, @$refNodePath); + my $fileNameMenus; + my $fileNameProps; + + my %Node; + + if ( -d $fileNameNode ) { + $Node{'Type'} = 'Section'; + $fileNameMenus = $fileNameNode . '/.menu.pl'; + $fileNameProps = $fileNameNode . '/.prop.pl'; + } elsif ( -e $fileNameNode ) { + $Node{'Type'} = 'Page'; + $Node{'TemplateFileName'} = join('/',@$refNodePath);; + $fileNameMenus = $fileNameNode . '.menu.pl'; + $fileNameProps = $fileNameNode . '.prop.pl'; + } else { + die new Exception("Page not found: $fileNameNode"); + } + + if ( -f $fileNameProps ) { + local ${^ENCODING}; + my $dummy = ''; + open my $hnull,'>>',\$dummy; + local (*STDOUT,*STDIN) = ($hnull,$hnull); + $Node{'Props'} = do $fileNameProps or warn "can't parse $fileNameProps: $@"; + } + + if ( -f $fileNameMenus ) { + local ${^ENCODING}; + my $dummy = ''; + open my $hnull,'>>',\$dummy; + local (*STDOUT,*STDIN) = ($hnull,$hnull); + $Node{'Menus'} = do $fileNameMenus or warn "can't parse $fileNameMenus: $@"; + } + + if ($Node{'Menus'}) { + my %Menus; + foreach my $menu (keys %{$Node{'Menus'}}) { + $Menus{$menu} = new DOM::PageMenu( DATA => $Node{'Menus'}->{$menu} ); + } + $Node{'Menus'} = \%Menus; + } + + $Node{'pathIndexPage'} = [@$refNodePath, $Node{'Props'}->{'IndexPage'} || $this->{$IndexPage}] if $Node{'Type'} eq 'Section'; + + return \%Node; +} + +sub SiteReleasePage { + my ($this,$site) = @_; + + my $page = $site->Objects()->{'Page'}; + $page->Release() if $page; + + return 1; +} + +sub construct { + my $self = shift; + + return new DOM::Providers::Page(TemplatesPath => $PagesPath, IncludePath => $IncludesPath, IndexPage => $UseIndexPage, CachePath => $CachePath, CacheSize => $CacheSize, Encoding => $Encoding); +} + +sub DecodeData { + my ($Encoding, $data) = @_; + + if (ref $data) { + if (ref $data eq 'SCALAR') { + my $decoded = Encode::decode($Encoding,$$data,Encode::LEAVE_SRC); + return \$decoded; + } elsif (UNIVERSAL::isa($data, 'HASH')) { + return {map {Encode::decode($Encoding,$_,Encode::LEAVE_SRC),DecodeData($Encoding,$data->{$_})} keys %$data }; + } elsif (UNIVERSAL::isa($data, 'ARRAY')) { + return [map {DecodeData($Encoding,$_)} @$data]; + } elsif (ref $data eq 'REF') { + my $decoded = DecodeData($Encoding,$$data); + return \$decoded; + } else { + die new Exception('Cant decode data type', ref $data); + } + } else { + return Encode::decode($Encoding,$data,Encode::LEAVE_SRC); + } +} + +1; + +=pod +Õðàíèëèùå øàáëîíîâ íà îñíîâå ôàéëîâîé ñèñòåìû. + +Õðàíèëèùå ñîñòîèò èç ðàçäåëîâ, êàæäûé ðàçäåë èìååò íàáîð ñâîéñòâ è ìåíþ +Ñïåöèàëüíû ñâîéñòâà ðàçäåëîâ + Keywords Êëþ÷åâûå ñëîâà + Name Íàçâàíèå + IndexPage ñòðàíèöà ïî óìîë÷àíèþ + + ðàçäåëàõ íàõîäÿòñÿ ñòðàíèöû, êàæäàÿ ñòðàíèöà èìååò íàáîð ñâîéñòâ è ìåíþ + +Ïðè çàãðóçêå ñòðàíèöû ïîëíîñòüþ çàãðóæàþòñÿ âñå ðîäèòåëüñêèå êîíòåéíåðû, +Ïðè ýòîì îäíîèìåííûå ìåíþ ñëèâàþòñÿ, +Ñâîéñòâà keywords îáúåúåäèíÿþòñÿ, +Åñëè èìÿ ñòðàíèöû íå çàäàíî, òî èñïîëüçóåòñÿ èìÿ ðàçäåëà + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Providers/Perfomance.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,15 @@ +use strict; + +package DOM::Providers::Perfomance; +use PerfCounter; + +sub GetProviderInfo { + return { + Name => 'Perfomance', + Host => 'DOM::Site', + Objects => { + Counters => \%PerfCounter::Counters + } + } +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Providers/Security.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,19 @@ +use strict; + +package DOM::Providers::Security; +use Security; + +sub GetProviderInfo { + return { + Name => 'Security', + Host => 'DOM::Site', + Objects => { + Session => \&GetSession + } + } +} + +sub GetSession { + return Security->CurrentSession; +} +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DOM/Site.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,80 @@ +package DOM::Site; +use strict; +use Common; +our @ISA = qw(Object); + +our $Name; +our @Providers; +our $AUTOLOAD; + +BEGIN { + DeclareProperty(Objects => ACCESS_READ); + DeclareProperty(Providers => ACCESS_NONE); +} + +sub RegisterObject { + my ($this,$name,$object) = @_; + + $this->{$Objects}->{$name} = $object; +} + +sub RegisterProvider { + my ($this,$provider) = @_; + + my $refInfo = $provider->GetProviderInfo(); + + if ($refInfo->{'Host'} eq __PACKAGE__) { + die new Exception("Provider $refInfo->{'Name'} already registered") if exists $this->{$Providers}->{$refInfo->{'Name'}}; + while (my ($name,$method) = each %{$refInfo->{'Methods'}}) { + no strict 'refs'; + no warnings 'redefine'; + *{__PACKAGE__ . '::' . $name} = sub { + shift; + $method->($provider,$this,@_); + }; + } + + while (my ($name,$object) = each %{$refInfo->{'Objects'}}) { + $this->{$Objects}->{$refInfo->{'Name'}}->{$name} = $object; + } + + $this->{$Providers}->{$refInfo->{'Name'}} = 1; + } +} + +sub construct { + my $self = shift; + + my $site = $self->new(); + $site->RegisterObject(Site => { Name => $Name}); + foreach my $provider (@Providers) { + my $providerFile = $provider; + $providerFile =~ s/::/\//g; + $providerFile .= '.pm'; + eval { + require $providerFile; + }; + if ($@) { + my $InnerErr = $@; + die new Exception("Failed to load provider $provider", $InnerErr); + } + if ($provider->can('construct')) { + $site->RegisterProvider($provider->construct()); + } else { + $site->RegisterProvider($provider); + } + } + return $site; +} + +sub Dispose { + my ($this) = @_; + + UNIVERSAL::can($_,'Dispose') and $_->Dispose foreach values %{$this->{$Objects} || {}}; + + undef %$this; + + $this->SUPER::Dispose; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/DateTime.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,312 @@ +use strict; +package DateTime::Span; +package DateTime; +use Common; +use Time::Local; +use Time::Zone; +use Date::Format; +our @ISA = qw(Object); + +use overload + '+' => \&opAdd, + '-' => \&opSubtract, + '<=>' => \&opCompare, + 'bool' => \&opAsBool, + 'fallback' => 1, + '""' => \&opAsString; + +BEGIN { + DeclareProperty UnixTime => ACCESS_READ; +} + +sub CTOR { + my $this = shift; + + if (@_ >= 2) { + my(%args) = @_; + + $this->{$UnixTime} = $args{UnixTime} or die new Exception("A correct unix time value is required"); + } else { + $this->{$UnixTime} = $this->ParseISOTime(shift,'+000'); + } +} + +sub ParseISOTime { + my ($class,$time,$timezone) = @_; + + if ($time =~ /^(\d{4})-(\d{2})-(\d{2})(?:.(\d{2}):(\d{2}):(\d{2})(?:\.\d{3})?)?/ ) { + my ($yyyy,$mm,$dd,$hh,$MM,$SS) = ($1-1900,$2-1,$3,$4 || 0,$5 || 0,$6 || 0); + if ($timezone) { + return tz_offset($timezone) + timegm($SS,$MM,$hh,$dd,$mm,$yyyy); + } else { + return timelocal($SS,$MM,$hh,$dd,$mm,$yyyy); + } + } else { + die new Exception("The specified string isn\'t a correct ISO date",$time); + } +} + +sub new_ISO { + my ($class,$ISOTime,$zone) = @_; + return $class->new(UnixTime => $class->ParseISOTime($ISOTime,$zone)); +} + +sub now { + my ($class) = @_; + return $class->new(UnixTime => time); +} + +sub AsISOString { + my ($this,$zone) = @_; + return time2str("%Y-%m-%dT%H:%M:%S",$this->{$UnixTime},$zone); +} + +sub AsFormatString { + my ($this,$format,$zone) = @_; + return time2str($format,$this->{$UnixTime},$zone); +} + +sub opAdd { + my ($a,$b,$flag) = @_; + + if (UNIVERSAL::isa($b,'DateTime::Span')) { + return new DateTime(UnixTime => $a->{$UnixTime} + $b->SecondsSpan); + } elsif (not ref $b){ + return new DateTime(UnixTime => $a->UnixTime + $b); + } else { + die new Exception("Only a time span can be added to the DateTime object",$b); + } +} + +sub GetDate { + my ($this) = @_; + + return DateTime->new_ISO($this->AsFormatString('%Y-%m-%d')); +} + +sub opSubtract { + my ($a,$b,$flag) = @_; + + if (UNIVERSAL::isa($b,'DateTime')) { + return new DateTime::Span(Seconds => $a->{$UnixTime}-$b->{$UnixTime}); + } elsif (UNIVERSAL::isa($b,'DateTime::Span')) { + return new DateTime(UnixTime => $flag ? $b->SecondsSpan - $a->UnixTime: $a->UnixTime - $b->SecondsSpan); + } elsif (not ref $b){ + return new DateTime(UnixTime => $flag ? $b - $a->UnixTime : $a->UnixTime - $b); + } else { + die new Exception("Only an another DateTime object or a time span can be subtracted from the DateTime",$b); + } +} + +sub opCompare { + my ($a,$b,$flag) = @_; + + if (UNIVERSAL::isa($b,'DateTime')) { + return $flag ? $b->{$UnixTime} <=> $a->{$UnixTime} : $a->{$UnixTime} <=> $b->{$UnixTime}; + } else { + die new Exception("Only a DateTime object can be compared to the DateTime object", $b); + } +} + +sub opAsString { + my $this = shift; + $this->AsISOString('+000'); +} + +sub opAsBool { + 1; +} + +package DateTime::Span; +use Common; +our @ISA = qw(Object); + +use overload + '-' => \&opSub, + '+' => \&opAdd, + '<=>' => \&opCmp, + 'fallback' => 1; + +BEGIN { + DeclareProperty SecondsSpan=>ACCESS_READ; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$SecondsSpan} = ($args{'Seconds'} || 0) + ($args{'Minutes'} || 0)*60 + ($args{'Hours'} || 0)*3600 + ($args{'Days'} || 0)*86400; +} + +sub Days { + my ($this) = @_; + + return int($this->{$SecondsSpan}/86400); +} + +sub Hours { + my ($this) = @_; + + return int($this->{$SecondsSpan}/3600); +} +sub Minutes { + my ($this) = @_; + + return int($this->{$SecondsSpan}/60); +} + +sub opAdd { + my ($a,$b,$flag) = @_; + + if (UNIVERSAL::isa($b,'DateTime::Span')) { + return new DateTime::Span(Seconds => $a->{$SecondsSpan} + $b->{$SecondsSpan}); + } elsif (not ref $b) { + return new DateTime::Span(Seconds => $a->{$SecondsSpan} + $b); + } else { + die new Exception("Only a time span can be added to the time span"); + } +} + +sub opSub { + my ($a,$b,$flag) = @_; + + if (UNIVERSAL::isa($b,'DateTime::Span')) { + return new DateTime::Span(Seconds => $flag ? $b->{$SecondsSpan} - $a->{$SecondsSpan} : $a->{$SecondsSpan} - $b->{$SecondsSpan}); + } elsif (not ref $b) { + return new DateTime::Span(Seconds => $flag ? $b - $a->{$SecondsSpan} : $a->{$SecondsSpan} - $b); + } else { + die new Exception("Only a time span can be subtracted from the time span"); + } +} + +sub opCmp { + my ($a,$b,$flag) = @_; + + if (UNIVERSAL::isa($b,'DateTime::Span')) { + return $flag ? $b->{$SecondsSpan} <=> $a->{$SecondsSpan} : $a->{$SecondsSpan} <=> $b->{$SecondsSpan}; + } elsif (not ref $b) { + return $flag ? $b <=> $a->{$SecondsSpan} : $a->{$SecondsSpan} <=> $b; + } else { + die new Exception("Only a time span can be compared to the time span"); + } +} + +package DateTime::TimeLine; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty Timeline => ACCESS_READ; +} + +sub CTOR { + my ($this) = @_; + + $this->{$Timeline} = [ {Date => undef} ]; +} + +# ðåêóðñèâíî êîïèðóåò ïðîñòûå ñòðóêòóðû +sub SimpleCopy { + my ($refObject,$cache) = @_; + + return undef if not defined $refObject; + + $cache ||= {}; + + if ($cache->{$refObject}) { + return $cache->{$refObject}; + } + + local $_; + + if (ref $refObject eq 'HASH' ) { + return ($cache->{$refObject} = { map { $_, SimpleCopy($refObject->{$_},$cache) } keys %$refObject }); + } elsif (ref $refObject eq 'ARRAY' ) { + return ($cache->{$refObject} = [ map { SimpleCopy($_,$cache) } @$refObject]); + } else { + return ($cache->{$refObject} = $refObject); + } +} + +sub Split { + my ($this,$date) = @_; + + die new Exception('Can\'t split the timeline with an undefined date') unless $date; + + for (my $i = 0; $i < @{$this->{$Timeline}}; $i++) { + my $Elem = $this->{$Timeline}[$i]; + if ($Elem->{Date} and $Elem->{Date} >= $date ) { + if ($Elem->{Date} == $date) { + return $Elem; + } else { + my $newElem = SimpleCopy($this->{$Timeline}[$i-1]); + $newElem->{Date} = $date; + use Data::Dumper; + + splice @{$this->{$Timeline}},$i,0,$newElem; + return $newElem; + } + } + } + my $Elem = { Date => $date }; + push @{$this->{$Timeline}},$Elem; + return $Elem; +} + +sub Select { + my ($this,$start,$end) = @_; + + my @result; + + for (my $i=0; $i< @{$this->{$Timeline}}; $i++) { + my $Elem = $this->{$Timeline}[$i]; + my $Next = $this->{$Timeline}[$i+1]; + if ( + (not $Elem->{Date} or not $start or $Elem->{Date} < $start) + and + (not $Next->{Date} or not $start or $Next->{Date} > $start) + ) { + # ------*++++(++++*----...--)--- + push @result,$Elem; + } elsif ( + $Elem->{Date} + and + (not $start or $Elem->{Date} >= $start) + and + (not $end or $Elem->{Date} < $end ) + ) { + # ------*---(----*++...++*++)+++*---- + push @result,$Elem; + } elsif ( $Elem->{Date} and $end and $Elem->{Date} >= $end) { + last; + } + } + + return @result; +} + +sub SelectStrict { + my ($this,$start,$end) = @_; + $this->Split($start); + $this->Split($end); + return grep { + $_->{Date} + and + $start ? $_->{Date} >= $start : 1 + and + $end ? $_->{Date} < $end : 1 + } @{$this->{$Timeline}}; +} + +sub SelectAsPeriod { + my ($this,$start,$end) = @_; + + my @Dates = $this->Select($start,$end); + for (my $i = 0; $i< @Dates; $i++) { + $Dates[$i]->{Start} = $Dates[$i]->{Date}; + $Dates[$i]->{End} = $Dates[$i+1] ? $Dates[$i+1]->{Date} : undef + } + + return @Dates; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,15 @@ +package Deployment; +use strict; + +our %DeploymentScheme; +our %DeployMethod; + +sub isUpdateNeeded { + +} + +sub Update { + +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,129 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/Backup.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,48 @@ +package Deployment::Batch::Backup; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/CDBIUpdate.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,139 @@ +use strict; +package Deployment::Batch::CDBIUpdate; +use Common; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/CopyFile.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,45 @@ +use strict; +package Deployment::Batch; +our %Dirs; +package Deployment::Batch::CopyFile; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/CopyTree.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,5 @@ +package Deployment::Batch::CopyTree; +use base 'Deployment::Batch::Generic'; +use Common; + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/CustomAction.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,32 @@ +use strict; +package Deployment::Batch::CustomAction; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/Generic.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,87 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/Batch/Temp.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,52 @@ +use strict; +package Deployment::Batch::Temp; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Deployment/CDBI.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,101 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Action.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,65 @@ +use strict; + +package Engine::Action; +use Engine::CGI; +use Common; +use URI; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Action/URICall.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,42 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/CGI.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,67 @@ +use strict; +package Engine::CGI; +use base '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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Output/JSON.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,56 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Output/Page.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,34 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Output/Template.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,55 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Security.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,36 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Security/AccessDeniedException.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,13 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Security/Auth.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,94 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Security/Cookies.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,27 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Engine/Security/IPSession.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,48 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,147 @@ +package Form; +use strict; +use Common; +use base qw(Form::Container); +use Form::ItemId; +use Form::ValueItem; + +BEGIN { + DeclareProperty AutoCreate => ACCESS_ALL; + DeclareProperty isValidated => ACCESS_READ; + DeclareProperty isValid => ACCESS_READ; + DeclareProperty ValidationErrors => ACCESS_READ; + DeclareProperty MapFieldClasses => ACCESS_READ; + DeclareProperty LoadedFiledClasses => ACCESS_NONE; + DeclareProperty Bindings => ACCESS_READ; +} + +sub CTOR { + my ($this,$schema,$bind) = @_; + + $this->SUPER::CTOR( + Schema => $schema->Body, + Id => Form::ItemId->new('Form',undef,Form::ItemId::Root->new()), + Form => $this + ); + $this->{$MapFieldClasses} = { + SelectBox => 'Form::ValueItem::List', + RadioSelect => 'Form::ValueItem::List', + MultiCheckBox => 'Form::ValueItem::List' + }; + $this->{$LoadedFiledClasses} = { 'Form::ValueItem' => 1 }; + $this->{$Bindings} = $bind || {}; + $this->{$isValid} = 0; + $this->{$isValidated} = 0; +} + +sub NavigatePath { + my ($this,$path) = @_; + + shift @$path if $path->[0]->Name eq 'Form'; # eat root node in Form/Item + + return $this->SUPER::NavigatePath($path); +} + +sub Item { + my ($this,$strId) = @_; + + return $this->Navigate($this->MakeItemId($strId,undef)); +} + +sub MakeItemId { + my ($this,$Name,$BaseObject) = @_; + + my $ItemId; + if ($BaseObject and $BaseObject->isa('Form::Item')) { + $ItemId = $BaseObject->Id; + } else { + $ItemId = new Form::ItemId::Root; + } + + foreach my $item (split /\//,$Name) { + if ($item =~ /^(\w+?)(\d+)?$/) { + $ItemId = Form::ItemId->new($1,$2,$ItemId); + } else { + die new Exception('The invalid identifier',$Name); + } + } + return $ItemId; +} + +sub CreateInstance { + my ($this,$schema,$ItemId,$parent) = @_; + + my $obj; + if ($schema->isa('Schema::Form::Container')) { + $obj = new Form::Container( + Id => Form::ItemId->new($ItemId->Name,$ItemId->InstanceID,($parent ? $parent->Id : undef)), + Form => $this, + Parent => $parent, + Schema => $schema, + Attributes => {%{$schema->Attributes}} + ); + } elsif ($schema->isa('Schema::Form::Field')) { + my $class = $this->{$MapFieldClasses}{$schema->Format->Name} || 'Form::ValueItem'; + if (not $this->{$LoadedFiledClasses}{$class}) { + eval "require $class;" or die new Exception('Failed to load a module',$class,$@); + $this->{$LoadedFiledClasses}{$class} = 1; + } + $obj = $class->new( + Id => Form::ItemId->new($ItemId->Name,$ItemId->InstanceID,($parent ? $parent->Id : undef)), + Form => $this, + Parent => $parent, + Type => $schema->Format->Name, + Schema => $schema, + Attributes => {%{$schema->Attributes}} + ); + } else { + die new Exception('Unexpected schema type', ref $schema); + } + + return $obj; +} + +sub Validate { + my ($this) = @_; + + my @errors = $this->SUPER::Validate; + $this->{$isValidated} = 1; + if (@errors) { + $this->{$isValid} = 0; + $this->{$ValidationErrors} = \@errors; + } else { + $this->{$isValid} = 1; + delete $this->{$ValidationErrors}; + } + + return @errors; +} + +sub SelectErrors { + my ($this,$parentId) = @_; + + return [grep $_->Item->Parent->Id->Canonical eq $parentId, $this->ValidationErrors]; +} + +sub LoadValues { + my ($this,$rhValues) = @_; + + $this->{$isValidated} = 0; + $this->{$isValid} = 0; + + foreach my $key (keys %$rhValues) { + eval { $this->Item($key)->Value($rhValues->{$key}) }; + undef $@; + } +} + + +sub Dispose { + my ($this) = @_; + + delete @$this{$ValidationErrors,$MapFieldClasses,$LoadedFiledClasses,$Bindings}; + + $this->SUPER::Dispose; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Container.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,170 @@ +package Form::Container; +use strict; +use Common; +use Form::Filter; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Filter.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,67 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Filter/Depends.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,34 @@ +package Form::Filter::Depends; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Filter/Mandatory.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,34 @@ +package Form::Filter::Mandatory; +use strict; +use Common; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Filter/Regexp.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,38 @@ +package Form::Filter::Regexp; +use strict; +use Common; +use Form::Filter; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Item.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,79 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/ItemId.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,46 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/Transform.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,29 @@ +package Form::Transform; +use strict; +use warnings; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/ValueItem.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,47 @@ +package Form::ValueItem; +use strict; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Form/ValueItem/List.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,107 @@ +package Form::ValueItem::List; +use Common; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/Member.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,37 @@ +package IMPL::Class::Member; +use strict; +use base qw(Exporter); +our @EXPORT = qw(virtual public private protected); + +use IMPL::Class::Meta; +require IMPL::Class::MemberInfo; + +use constant { + MOD_PUBLIC => 1, + MOD_PROTECTED => 2, + MOD_PRIVATE => 3 +}; + +sub virtual($) { + $_[0]->Virtual(1); + $_[0]; +} + +sub public($) { + $_[0]->Access(MOD_PUBLIC); + $_[0]->Implement; + $_[0]; +} + +sub private($) { + $_[0]->Access(MOD_PRIVATE); + $_[0]->Implement; + $_[0]; +} + +sub protected($) { + $_[0]->Access(MOD_PROTECTED); + $_[0]->Implement; + $_[0]; +} +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/MemberInfo.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,48 @@ +package IMPL::Class::MemberInfo; +use strict; +use base qw(IMPL::Object::Accessor); + +require IMPL::Exception; +require IMPL::Class::Member; + +__PACKAGE__->mk_accessors( + qw( + Name + Access + Virtual + Class + Frozen + Implementor + Attributes + ) +); +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + die new IMPL::Exception('The name is required for the member') unless $this->Name; + die new IMPL::Exception('The class is required for the member') unless $this->Class; + + $this->Frozen(0); + $this->Virtual(0) unless defined $this->Virtual; + $this->Access(3) unless $this->Access; +} + +sub Implement { + my ($this) = @_; + $this->Implementor->Make($this); + $this->Frozen(1); + $this->Class->set_meta($this); + return; +} + +sub set { + my $this = shift; + if ($this->Frozen) { + die new IMPL::Exception('The member information can\'t be modified', $this->Name); + } + $this->SUPER::set(@_); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/Meta.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,43 @@ +package IMPL::Class::Meta; +use strict; + +my %class_meta; + +sub set_meta { + my ($class,$meta_data) = @_; + $class = ref $class if ref $class; + + # òóò íåëüçÿ èñïîëüçîâàòü ñòàíäàðòíîå èñêëþ÷åíèå, ïîñêîëüêó äëÿ íåãî èñïîëüçóåòñÿ + # êëàññ IMPL::Object::Accessor, êîòîðûé íàñëåäóåòñÿ îò òåêóùåãî êëàññà + die "The meta_data parameter should be an object" if not ref $meta_data; + + push @{$class_meta{$class}{ref $meta_data}},$meta_data; +} + +sub get_meta { + my ($class,$meta_class,$predicate,$deep) = @_; + $class = ref $class if ref $class; + no strict 'refs'; + my @result; + + if ($deep) { + @result = map { $_->can('get_meta') ? $_->get_meta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'}; + } + + if ($predicate) { + push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) ); + } else { + push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ); + } + wantarray ? @result : \@result; +} + +=pod +__PACKAGE_->set_meta($metaObject); +__PACKAGE_->get_meta('MyMetaClass',sub { + my ($item) = @_; + $item->Name eq 'Something' ? 1 : 0 +} ); +=cut + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/Property.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,35 @@ +package IMPL::Class::Property; +use strict; +use base qw(Exporter); +BEGIN { + our @EXPORT = qw(property prop_get prop_set owner_set prop_none prop_all prop_list CreateProperty); +} + +require IMPL::Class::Member; +require IMPL::Class::PropertyInfo; + +sub import { + __PACKAGE__->export_to_level(1,@_); + IMPL::Class::Member->export_to_level(1,@_); +} + +sub prop_get { 1 }; +sub prop_set { 2 }; +sub owner_set { 2 }; +sub prop_none { 0 }; +sub prop_all { 3 }; +sub prop_list { 4 }; + +sub property($$;$) { + my ($propName,$mutators,$attributes) = @_; + my $Info = new IMPL::Class::PropertyInfo( {Name => $propName, Mutators => $mutators, Class => scalar(caller), Attributes => $attributes } ); + return $Info; +} + +sub CreateProperty { + my ($class,$propName,$mutators,$attributes) = @_; + my $Info = new IMPL::Class::PropertyInfo( {Name => $propName, Mutators => $mutators, Class => $class, Attributes => $attributes} ); + return $Info; +}; + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/Property/Direct.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,111 @@ +package IMPL::Class::Property::Direct; +use strict; + +use base qw(IMPL::Object::Accessor Exporter); +our @EXPORT = qw(_direct); + +use IMPL::Class::Property; +require IMPL::Exception; + +__PACKAGE__->mk_accessors qw(ExportField); + +sub _direct($) { + my ($prop_info) = @_; + $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) ); + return $prop_info; +} + +my $access_private = "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"; +my $access_protected = "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless caller eq \$class;"; + +my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; +my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; +my $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );'; +my $accessor_get = 'return( $this->{$field} );'; +my $list_accessor_set = 'return( @{ ($this->{$field} = ( (@_ == 1 and ref $_[0] eq \'ARRAY\') ? $_[0] : [@_] ) || [] ) } );'; +my $list_accessor_get = 'return( @{ $this->{$field} || [] } );'; +my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; +my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; + +my %accessor_cache; +sub mk_acessor { + my ($virtual,$access,$class,$name,$mutators,$field) = @_; + + my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set); + my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')); + my $factory = $accessor_cache{$key}; + if (not $factory) { + my $code = +<<BEGIN; +sub { + my (\$class,\$name,\$set,\$get,\$field) = \@_; + my \$accessor; + \$accessor = sub { + my \$this = shift; +BEGIN + $code .= <<VCALL if $virtual; + my \$method = \$this->can(\$name); + return \$this->\$method(\@_) unless \$method == \$accessor or caller->isa(\$class); +VCALL + $code .= "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE; + $code .= "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED; + my ($codeGet,$codeSet); + if (ref $mutators) { + $codeGet = $get ? $custom_accessor_get : $accessor_get_no; + $codeSet = $set ? $custom_accessor_set : $accessor_set_no; + } else { + if ($mutators & prop_list) { + $codeGet = $get ? $list_accessor_get : $accessor_get_no; + $codeSet = $set ? $list_accessor_set : $accessor_set_no; + } else { + $codeGet = $get ? $accessor_get : $accessor_get_no; + $codeSet = $set ? $accessor_set : $accessor_set_no; + } + } + $code .= +<<END; + if (\@_) { + $codeSet + } else { + $codeGet + } + } +} +END + $factory = eval $code or die new IMPL::Exception('Failed to generate the accessor',$@); + $accessor_cache{$key} = $factory; + } + return $factory->($class,$name,$set,$get, $field); +} + +sub Make { + my ($self,$propInfo) = @_; + + my $isExportField = ref $self ? ($self->ExportField || 0) : 0; + my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); + (my $field = "${class}_$name") =~ s/::/_/g; + + my $propGlob = $class.'::'.$name; + + no strict 'refs'; + *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field); + *$propGlob = \$field if $isExportField; + + if (ref $mutators) { + $propInfo->canGet( $mutators->{get} ? 1 : 0); + $propInfo->canSet( $mutators->{set} ? 1 : 0); + } else { + $propInfo->canGet( ($mutators & prop_get) ? 1 : 0); + $propInfo->canSet( ($mutators & prop_set) ? 1 : 0); + } +} + +sub FieldName { + my ($self,$propInfo) = @_; + + my ($class,$name) = $propInfo->get qw(Class Name); + (my $field = "${class}_$name") =~ s/::/_/g; + return $field; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/PropertyInfo.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,38 @@ +package IMPL::Class::PropertyInfo; +use strict; + +use base qw(IMPL::Class::MemberInfo); + +__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet)); +__PACKAGE__->PassThroughArgs; + +our @Implementors = ( ['IMPL::Object' => 'IMPL::Class::Property::Direct'] ); + +my %LoadedModules; + +sub CTOR { + my $this = shift; + + my $implementor = $this->Implementor($this->SelectImplementor()); + if (my $class = ref $implementor ? undef : $implementor) { + if (not $LoadedModules{$class}) { + (my $package = $class.'.pm') =~ s/::/\//g; + require $package; + $LoadedModules{$class} = 1; + } + } + + $this->Mutators(0) unless defined $this->Mutators; +} + +sub SelectImplementor { + my ($this) = @_; + + foreach my $item (@Implementors) { + return $item->[1] if $this->Class->isa($item->[0]); + } + + die new IMPL::Exception('Can\'t find a property implementor for the specified class',$this->Class); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Config.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,128 @@ +package IMPL::Config; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Serializable IMPL::Object::Autofill); + +__PACKAGE__->PassThroughArgs; + +use IMPL::Class::Member; +use IMPL::Class::PropertyInfo; +use IMPL::Exception; + +use IMPL::Serialization; +use IMPL::Serialization::XmlFormatter; + +sub LoadXMLFile { + my ($self,$file) = @_; + + my $class = ref $self || $self; + + my $serializer = new IMPL::Serializer( + Formatter => new IMPL::Serialization::XmlFormatter( + IdentOutput => 1, + SkipWhitespace => 1 + ) + ); + + open my $hFile,'<',$file or die new IMPL::Exception("Failed to open file",$file,$!); + + my $obj; + eval { + $obj = $serializer->Deserialize($hFile); + }; + + if ($@) { + my $e=$@; + die new IMPL::Exception("Can't load the configuration file",$file,$e); + } + return $obj; +} + +sub SaveXMLFile { + my ($this,$file) = @_; + + my $serializer = new IMPL::Serializer( + Formatter => new IMPL::Serialization::XmlFormatter( + IdentOutput => 1, + SkipWhitespace => 1 + ) + ); + + open my $hFile,'>',$file or die new IMPL::Exception("Failed to open file",$file,$!); + + $serializer->Serialize($hFile, $this); +} + +sub xml { + my $this = shift; + my $serializer = new IMPL::Serializer( + Formatter => new IMPL::Serialization::XmlFormatter( + IdentOutput => 1, + SkipWhitespace => 1 + ) + ); + my $str = ''; + open my $hFile,'>',\$str or die new IMPL::Exception("Failed to open stream",$!); + + $serializer->Serialize($hFile, $this); + + undef $hFile; + + return $str; +} + +sub save { + my ($this,$ctx) = @_; + + foreach my $info ($this->get_meta('IMPL::Class::PropertyInfo')) { + next if $info->Access != IMPL::Class::Member::MOD_PUBLIC; # save only public properties + + my $name = $info->Name; + $ctx->AddVar($name => $this->$name()) if $this->$name(); + } +} + +1; +__END__ + +=pod + +=h1 SYNOPSIS + +package App::Config +use base qw(IMPL::Config) + +use IMPL::Class::Property; +use IMPL::Config::Class; + +BEGIN { + public property SimpleString => prop_all; + public property MyClass => prop_all; +} + +sub CTOR { + my $this = shift; + $this->superCTOR(@_); + + $this->MyClass(new IMPL::Config::Class(Type => MyClass)) unless $this->MyClass; +} + +=head1 DESCRIPTION + +Ïîçâîëÿåò ñîõðàíèòü/çàãðóçèòü êîíôèãóðàöèþ. Òàêæå âñå êëàññû êîíôèãóðàöèè +äîëæíû íàñëåäîâàòüñÿ îò äàííîãî êëàññà, è âñå Public ñâîéñòâà áóäóò +àâòîìàòè÷åñêè ñîõðàíÿòüñÿ è âîññòàíàâëèâàòüñÿ. + +=head1 MEMBERS + +=item static LoadXMLFile($fileName) +Ñîçäàåò èç XML ôàéëà ýêçåìïëÿð ïðèëîæåíèÿ + +=item SaveXMLFile($fileName) +Ñîõðàíÿåò ïðèëîæåíèå â ôàéë + +=item xml +Ñîõðàíÿåò êîíôèãóðàöèþ ïðèëîæåíèÿ â XML ñòðîêó + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Config/Class.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,52 @@ +package IMPL::Config::Class; +use strict; +use warnings; + +use base qw(IMPL::Config); +use IMPL::Exception; +use IMPL::Class::Property; + +BEGIN { + public property Type => prop_all; + public property Parameters => prop_all; + public property IsSingleton => prop_all; + private property _Instance => prop_all; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + die new IMPL::Exception("A Type parameter is required") unless $this->Type; + +} + +sub _is_class { + no strict 'refs'; + scalar keys %{"$_[0]::"} ? 1 : 0; +} + +sub instance { + my $this = shift; + + my $type = $this->Type; + + if ($this->IsSingleton) { + if ($this->_Instance) { + return $this->_Instance; + } else { + my %args = (%{$this->Parameters || {}},@_); + eval "require $type" unless _is_class($type); + my $inst = $type->new(%args); + $this->_Instance($inst); + return $inst; + } + } else { + my %args = (%{$this->Parameters || {}},@_); + eval "require $type" unless _is_class($type); + return $type->new(%args); + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Config/Container.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,40 @@ +package IMPL::Config::Container; +use strict; +use warnings; + +use base qw(IMPL::Config); +use IMPL::Class::Property; + +BEGIN { + public property Chidren => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->Chidren(\%args); +} + +sub save { + my ($this,$ctx) = @_; + + while (my ($key,$value) = each %{$this->Chidren}) { + $ctx->AddVar($key,$value); + } +} + +our $AUTOLOAD; +sub AUTOLOAD { + my $this = shift; + + (my $prop = $AUTOLOAD) =~ s/.*?(\w+)$/$1/; + + my $child = $this->Chidren->{$prop}; + if (ref $child and $child->isa('IMPL::Config::Class')) { + return $child->instance(@_); + } else { + return $child; + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Navigator.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,11 @@ +package IMPL::DOM::Navigator; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(); + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Node.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,64 @@ +package IMPL::DOM::Node; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Serializable IMPL::Object::Autofill); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use Scalar::Util qw(weaken); + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property nodeName => prop_get | owner_set; + public property isComplex => prop_get | owner_set; + public property nodeValue => prop_get | owner_set; + public property childNodes => prop_get | owner_set| prop_list; + public property parentNode => prop_get | owner_set; + private property _propertyMap => prop_all; +} + +sub CTOR { + my $this = @_; + + $this->_propertyMap({}); +} + +sub insertNode { + my ($this,$node,$pos) = @_; +} + +sub removeNode { + my ($this,$node) = @_; +} + +sub removeAt { + my ($this,$pos) = @_; +} + +sub selectNodes { + my ($this,$name) = @_; +} + +sub setParent { + my ($this,$parentNode) = @_; +} + +sub text { + my ($this) = @_; +} + +sub Property { + my $this = shift; + my $name = shift; + + if (@_) { + # set + return $this->_propertyMap->{$name} = shift; + } else { + return $this->_propertyMap->{$name}; + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Exception.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,113 @@ +package IMPL::Exception; +use strict; +use overload + '""' => \&ToString, + 'fallback' => 1; +use Carp qw(longmess shortmess); +use Scalar::Util qw(refaddr); + +BEGIN { + require Error; +} + +use base qw(IMPL::Object::Accessor Error); + +BEGIN { + __PACKAGE__->mk_accessors( qw(Message Args CallStack Source) ); +} + +sub indent { + my ($str,$level) = @_; + $level ||= 0; + $str = '' unless defined $str; + join ("\n", map( "\t"x$level.$_ , split(/\n/,$str) ) ); +} + +sub new { + my $class = shift; + $class = ref $class || $class; + + my $this = $class->Error::new() or die "Failed to create an exception"; + + $this->callCTOR(@_); + $this->{-text} = $this->Message; + + local $Carp::CarpLevel = 0; + + $this->CallStack(longmess); + $this->Source(shortmess); + + return $this; +} + +sub CTOR { + my ($this,$message,@args) = @_; + $this->Message($message || ''); + die new IMPL::Exception("Fatal erorr: cyclic structure in the exceptions were detected, do not use \$\@ while throwing the exception!") if grep ref $_ ? refaddr($this) == refaddr($_) : 0 , @args; + $this->Args([map defined $_ ? $_ : 'undef', @args]); +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar(Message => $this->Message) if $this->Message; + $ctx->AddVar(Args => $this->Args) if @{$this->Args}; + $ctx->AddVar(Source => $this->Source); + $ctx->AddVar(CallStack => $this->CallStack); +} + +sub restore { + my ($class,$data,$instance) = @_; + + my %args = @$data; + + if ($instance) { + $instance->callCTOR($args{Message},@{$args{Args}}); + } else { + $instance = $class->new($args{Message},@{$args{Args}}); + } + + $instance->Source($args{Source}); + $instance->CallStack($args{CallStack}); + + return $instance; +} + +sub ToString { + my $this = shift; + + $this->toString(); +} + +sub toString { + my ($this,$notrace) = @_; + $this->Message . join("\n",'',map { my $s = $_; local $_; indent("$s",1) } @{$this->Args} ) . ( $notrace ? '' : "\n" . $this->CallStack); +} + +package IMPL::InvalidOperationException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::InvalidArgumentException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::DuplicateException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::NotImplementedException; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package Exception; +our @ISA = qw(IMPL::Exception); +__PACKAGE__->PassThroughArgs; + +package IMPL::DeprecatedException; +our @ISA = qw(IMPL::Exception); +our %CTOR = ( + 'IMPL::Exception' => sub { @_ ? @_ : "The method is deprecated" } +); + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/ORM.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,123 @@ +package IMPL::ORM; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use Scalar::Util qw(weaken refaddr); + +use IMPL::Exception; + +our $Depth = 1; # çàãðóæàòü îáúåêò + 1 óðîâåíü äåòåé +our $UseProxy = 1; + +BEGIN { + private property _ObjectCache => prop_all; + private property _MapInstances => prop_all; + private property _WorkUnit => prop_all; + public property Schema => prop_all; +} + +sub ObjectInfoById { + my ($this,$oid) = @_; + + return $this->_ObjectCache->{$oid}; +} + +sub ObjectInfo { + my ($this,$inst) = @_; + + die new IMPL::InvalidOperationException("This method can be used only for a reference") unless ref $inst; + + return $this->_MapInstances->{refaddr $inst}; +} + + +1; +__END__ +=pod +=head1 SYNOPSIS + +use IMPL::ORM::Sql; + +my $DB = new IMPL::ORM::Sql("connection string"); + +local $IMPL::ORM::Depth = 1; # load childs only, no more + +my $artist = $DB->Lookup( Artist => { name => 'Beatles' } ); + +my $order = new Order(); +$order->AddItem($_) foreach $artist->Albums->List; + +$DB->Save($order); + +my $label = $artist->Albums->Index(0)->Label; + +$DB->Populate($label); #load $label + +=head1 DESCRIPTION +=head2 MEMBERS +=level 4 +=back +=head2 Variables +=head2 INTERNALS +=head3 Object Representation + +Êàæäûé êëàññ îòîáðàæàåìûé â èñòî÷íèê äàííûõ ïðåäñòàâëÿåòñÿ â âèäå íàáîðà +ñóùíîñòåé, êàæäàÿ èç êîòîðûõ ïðåäñòàâëÿåò ñîñòîÿíèå áàçîâîãî êëàññà. + +Foo entityFoo + Bar entityBar + Baz entityBaz + +Ïðè ñîõðàíåíèè âèðòóàëüíûõ ñâîéñòâ êëàññîâ â ñîîòâåòñòâóþùèõ ñóùíîñòÿõ çàâîäèòñÿ +äâà ïîëÿ - îäíî ïîä ñîõðàíåíèå ñîáñòâåííîãî çíà÷åíèÿ ñâîéñòâà, äðóãîå - äëÿ +õðåíåèÿ âèðòóàëüíîãî çíà÷åíèÿ. + +Foo + public virtual property Name => prop_all, {Type => String}; + +entityFoo + string m_Name - ñîáñòâåííîå çíà÷åíèå + string v_Name - âðòóàëüíîå çíà÷åíèå + +Êàæäûé ñîõðàíåííûé îáúåêò â áàçå èìååò ñîáñòâåííûé èäåíòèôèêàòîð. +Íîâûå îáúåêòû èäåíòèôèêàòîðà íå èìåþò, äî òåõ ïîð ïîêà îíè íå áóäóò ñîõðàíåíû. + +=head3 Object Cache + +Äëÿ ó÷åòà îáúåêòîâ, êîòîðûå ïðèñóòñòâóþò â èñòî÷íèêå äàííûõ èñïîëüçóåòñÿ êåø +îáúåêòîâ. Ñþäà ïîïàäàþò ïîëó÷åííûå èç áàçû îáúåêòû, à òàêæå âíîâü äîáàâëåííûå +îáúåêòû. + +ObjectInfo => { + instance => weak ref + _id => data source dependent id + state => {persistent|null|new|deleted} + work_unit => ref to the work unit where object is acting +} + +äàííàÿ ñòðóêòóðà äîñòóïíà ÷åðåç äâå ôóíêöèè ObjectInfoById è ObjectInfo + +=head3 Type mapping + +Èñòî÷íèê äàííûõ èìååò â ñåáå ñõåìó äàííûõ, êîòîðàÿ îïðåäåëÿåò íàáîð òèïîâ, +õðàíèìûõ â äàííîì èñòî÷íèêå. Åñòü íåñêîëüêî âèäîâ îòîáðàæåíèÿ òèïîâ: + +=level 4 + +=item 1 + +Îòîáðàæåíèå êëàññîâ, êîãäà êëàññ ðàññìàðèâàåòñÿ â èäå íàáîðà ñâîéñòâ + +=item + +Îòîáðàæåíèå êëàññîâ â îäíî çíà÷åíèå (íàïðìåð ñòðîêó, äàííûå è ò.ï.) + +=item + +Êëàññû, êîòîðûå íà ïðÿìóþ ðàáîòàþò ñ èñòî÷íèêîì äàííûõ, òàêèå êàê êîëëåêöèè. + +=back + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/ORM/Entity.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,13 @@ +package IMPL::ORM::Entity; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); +use IMPL::Class::Property; + +# Name +# Fields +# Relations + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/ORM/MapInfo.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,22 @@ +use strict; +use warnings; + +package IMPL::ORM::MapInfo; +use base qw(IMPL::Object); +use IMPL::Class::Property; + +BEGIN { + public property Entities => prop_all; + public property Cumulative => prop_all; +} + +package IMPL::ORM::MapEntityInfo; +use base qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; + +BEGIN { + public property Name => prop_all; + public property Fields => prop_all; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/ORM/Sql.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,11 @@ +package IMPL::ORM::Sql; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(); + + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/ORM/WorkUnit.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,8 @@ +package IMPL::ORM::WorkUnit; +use strict; +use warnings; + +use base qw(IMPL::Object); + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,187 @@ +package IMPL::Object; +use strict; + +use base qw(IMPL::Class::Meta); + +our $MemoryLeakProtection; +my $Cleanup = 0; +our $Debug; +our %leaked_objects; + +my %cacheCTOR; + + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + + $self->$_(@_) foreach @{$cacheCTOR{ref $self} || cache_ctor(ref $self)}; + + $self; +} +my $t = 0; +sub cache_ctor { + my $class = shift; + + no strict 'refs'; + my @sequence; + + my $refCTORS = *{"${class}::CTOR"}{HASH}; + + foreach my $super ( @{"${class}::ISA"} ) { + my $superSequence = $cacheCTOR{$super} || cache_ctor($super); + + my $mapper = $refCTORS ? $refCTORS->{$super} : undef; + if (ref $mapper eq 'CODE') { + if ($mapper == *_pass_throgh_mapper{CODE}) { + push @sequence,@$superSequence; + } else { + push @sequence, sub { + my $this = shift; + $this->$_($mapper->(@_)) foreach @$superSequence; + }; + } + } else { + warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; + push @sequence, sub { + my $this = shift; + $this->$_() foreach @$superSequence; + }; + } + } + + push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; + + $cacheCTOR{$class} = \@sequence; + return \@sequence; +} + +sub callCTOR { + my $self = shift; + my $class = ref $self; + + $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)}; +} + +sub surrogate { + bless {}, ref $_[0] || $_[0]; +} + +sub superCTOR { + my $this = shift; + + warn "The mehod is deprecated, at " . caller; +} + +sub toString { + my $self = shift; + + return (ref $self || $self); +} + +sub DESTROY { + if ($MemoryLeakProtection and $Cleanup) { + my $this = shift; + warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : ''); + } +} + +sub END { + $Cleanup = 1; + $MemoryLeakProtection = 0 unless $Debug; +} + +sub _pass_throgh_mapper { + @_; +} + +sub PassThroughArgs { + my $class = shift; + $class = ref $class || $class; + no strict 'refs'; + no warnings 'once'; + ${"${class}::CTOR"}{$_} = \&_pass_throgh_mapper foreach @{"${class}::ISA"}; +} + +package self; + +our $AUTOLOAD; +sub AUTOLOAD { + goto &{caller(). substr $AUTOLOAD,4}; +} + +package supercall; + +our $AUTOLOAD; +sub AUTOLOAD { + my $sub; + my $methodName = substr $AUTOLOAD,11; + no strict 'refs'; + $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'}; +} + +=pod +=h1 SYNOPSIS + +package Foo; +use base qw(IMPL::Object); + +sub CTOR { + my ($this,$arg) = @_; + print "Foo: $arg\n"; +} + +package Bar; +use base qw(IMPL::Object); + +sub CTOR { + my ($this,$arg) = @_; + print "Bar: $arg\n"; +} + +package Baz; +use base qw(Foo Bar); + +our %CTOR = ( + Foo => sub { my %args = @_; $args{Mazzi}; }, + Bar => sub { my %args = @_; $args{Fugi}; } +); + +package Composite; +use base qw(Baz Foo Bar); + +our %CTOR = ( + Foo => undef, + Bar => undef +); + +sub CTOR { + my ($this,%args) = @_; + + print "Composite: $args{Text}\n"; +} + +package main; + +my $obj = new Composite( + Text => 'Hello World!', + Mazzi => 'Mazzi', + Fugi => 'Fugi' +); + +# will print +# +# Foo: Mazzi +# Bar: Fugi +# Foo: +# Bar: +# Composite: Hello World! + +=h1 Description +Áàçîâûé êëàññ äëÿ îáúåêòîâ. Ðåàëèçóåò ìíîæåñòâåííîå íàñëåäîâàíèå + + +=h1 Members +=cut + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/Accessor.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,15 @@ +package IMPL::Object::Accessor; +use strict; +use base qw(IMPL::Object Class::Accessor IMPL::Class::Meta); + +sub new { + my $class = shift; + my $self = $class->Class::Accessor::new( @_ == 1 && ref $_[0] && UNIVERSAL::isa($_[0],'HASH') ? $_[0] : ()); + $self->callCTOR(@_); + return $self; +} + +sub surrogate { + $_[0]->Class::Accessor::new; +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/Autofill.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,110 @@ +package IMPL::Object::Autofill; +use strict; +use IMPL::Class::Property; + +sub CTOR { + my $this = shift; + no strict 'refs'; + + my $fields = @_ == 1 ? $_[0] : {@_}; + + $this->_fill(ref $this,$fields); +} + +sub _fill { + my ($this,$class,$fields) = @_; + + $class->_autofill_method->($this,$fields); + + no strict 'refs'; + $this->_fill($_,$fields) foreach grep $_->isa('IMPL::Object::Autofill'), @{"${class}::ISA"}; +} + +sub DisableAutofill { + my $self = shift; + + my $class = ref $self || $self; + + *{"${class}::_impl_object_autofill"} = sub {}; +} + +sub _autofill_method { + my ($class) = @_; + + $class = ref $class if ref $class; + + # äëÿ àâòîçàïîëíåíèÿ íóæåí ñâîé ìåòîä âåðõíåãî óðîâíÿ + my $method; + { + no strict 'refs'; + $method = ${$class.'::'}{_impl_object_autofill}; + } + + if ($method) { + return $method; + } else { + my $text = <<HEADER; +package $class; +sub _impl_object_autofill { + my (\$this,\$fields) = \@_; +HEADER + + + if ($class->can('get_meta')) { + # meta supported + foreach my $prop_info (grep { + my $mutators = $_->Mutators; + ref $mutators ? (exists $mutators->{set}) : ($mutators & prop_set || $_->Implementor->isa('IMPL::Class::Property::Direct')); + } $class->get_meta('IMPL::Class::PropertyInfo')) { + my $name = $prop_info->Name; + if (ref $prop_info->Mutators || !$prop_info->Implementor->isa('IMPL::Class::Property::Direct')) { + $text .= "\t\$this->$name(\$fields->{$name}) if exists \$fields->{$name};\n"; + } else { + my $fld = $prop_info->Implementor->FieldName($prop_info); + if ($prop_info->Mutators & prop_list) { + $text .= "\t\$this->{$fld} = ref \$fields->{$name} ? \$fields->{$name} : [\$fields->{$name}] if exists \$fields->{$name};\n"; + } else { + $text .= "\t\$this->{$fld} = \$fields->{$name} if exists \$fields->{$name};\n"; + } + } + } + } else { + # meta not supported + #$text .= "\t".'$this->$_($fields->{$_}) foreach keys %$fields;'."\n"; + } + $text .= "}\n\\&_impl_object_autofill;"; + return eval $text; + } +} + +1; + +__END__ + +=pod +=head1 SYNOPSIS +package MyClass; +use base qw(IMPL::Object IMPL::Object::Autofill); + +BEGIN { + private property PrivateData => prop_all; + public property PublicData => prop_get; +} + +sub CTOR { + my $this = shift; + $this->superCTOR(@_); + # or eqvivalent + # $this->supercall::CTOR(@_); + + print $this->PrivateData,"\n"; + print $this->PublicData,"\n"; +} + +my $obj = new MyClass(PrivateData => 'private', PublicData => 'public', Other => 'some data'); + +will print +private +public + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/Disposable.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,34 @@ +package IMPL::Object::Disposable; +use strict; + +our $Strict = 1; + +sub Dispose { + my ($this) = @_; + + bless $this, 'IMPL::Object::Disposed'; +} + +sub DESTROY { + my ($this) = @_; + + warn sprintf('The object %s were marked as disposable but isn\'t disposed properly', $this->can('ToString') ? $this->ToString() : (ref $this || $this) ); +} + +sub superDispose { + my ($this) = @_; + + my $package = caller; + + no strict 'refs'; + + ($_.'::Dispose')->($this) foreach @{$package.'::ISA'}; +} + +package IMPL::Object::Disposed; +our $AUTOLOAD; +sub AUTOLOAD { + return if $AUTOLOAD eq __PACKAGE__.'::DESTROY'; + die new IMPL::Exception('Object have been disposed',$AUTOLOAD); +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/EventSource.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,133 @@ +package IMPL::Object::EventSource; +use strict; +require IMPL::Exception; +use IMPL::Class::Property; + +sub CreateEvent { + my ($class,$event) = @_; + + die new IMPL::Exception('A name is required for the event') unless $event; + + (my $fullEventName = "$class$event") =~ s/:://g; + + my $globalEventTable = new IMPL::Object::EventSource::EventTable($fullEventName); + my $propEventTable = $event.'Table'; + public CreateProperty($class,$propEventTable,prop_all); + public CreateProperty($class,$event, + { + get => sub { + my $this = shift; + if (not defined wantarray and caller(1) eq $class) { + (ref $this ? $this->$propEventTable() || $globalEventTable : $globalEventTable)->Invoke($this); + } else { + if (ref $this) { + if (my $table = $this->$propEventTable()) { + return $table; + } else { + $table = new IMPL::Object::EventSource::EventTable($fullEventName,$globalEventTable); + $this->$propEventTable($table); + return $table; + } + } else { + return $globalEventTable; + } + } + }, + set => sub { + (ref $_[0] ? $_[0]->$propEventTable() || $globalEventTable : $globalEventTable)->Invoke(@_); + } + } + ); +} + +sub CreateStaticEvent { + my ($class,$event) = @_; + + die new IMPL::Exception('A name is required for the event') unless $event; + + (my $fullEventName = "$class$event") =~ s/:://g; + + my $globalEventTable = new IMPL::Object::EventSource::EventTable($fullEventName); + + no strict 'refs'; + *{"${class}::$event"} = sub { + my $class = shift; + if (not @_) { + if (not defined wantarray and caller(1) eq $class) { + $globalEventTable->Invoke($class); + } else { + return $globalEventTable; + } + } else { + $globalEventTable->Invoke(@_); + } + }; +} + +package IMPL::Object::EventSource::EventTable; +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use Scalar::Util qw(weaken); + +use overload + '+=' => \&opSubscribe, + 'fallback' => 1; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Handlers => { get => \&get_handlers }; + private _direct property Next => prop_all; + private _direct property NextId => prop_all; +} + +sub CTOR { + my $this = shift; + $this->SUPER::CTOR(); + + $this->{$Handlers} = {}; + $this->{$Name} = shift; + $this->{$Next} = shift; + $this->{$NextId} = 1; +} + +sub get_handlers { + my $this = shift; + return values %{$this->{$Handlers}}; +} + +sub Invoke { + my $this = shift; + + my $tmp; + $tmp = $_ and local($_) or &$tmp(@_) foreach values %{$this->{$Handlers}}; + + $this->{$Next}->Invoke(@_) if $this->{$Next}; +} + +sub Subscribe { + my ($this,$consumer,$nameHandler) = @_; + + my $id = $this->{$NextId} ++; + + if (ref $consumer eq 'CODE') { + $this->{$Handlers}{$id} = $consumer; + } else { + $nameHandler ||= $this->Name or die new IMPL::Exception('The name for the event handler method must be specified'); + my $method = $consumer->can($nameHandler) or die new IMPL::Exception('Can\'t find the event handler method',$nameHandler,$consumer); + + weaken($consumer) if ref $consumer; + $this->{$Handlers}{$id} = sub { + unshift @_, $consumer; + $consumer ? goto &$method : delete $this->{$Handlers}{$id}; + }; + } + + return $id; +} + +sub Remove { + my ($this,$id) = @_; + return delete $this->{$Handlers}{$id}; +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/Meta.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,23 @@ +package IMPL::Object::Meta; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property Container => prop_get; +} + +sub meta { + my $class = shift; + my $caller = caller; + my $meta = $class->surrogate(); + $meta->{$Container} = $caller; + $meta->callCTOR(@_); + $caller->set_meta($meta); +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/Serializable.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,54 @@ +package IMPL::Object::Serializable; +use strict; +use warnings; + +require IMPL::Exception; +use IMPL::Class::Property; + +sub restore { + my ($class,$data,$refSurrogate) = @_; + + if ($refSurrogate) { + $refSurrogate->callCTOR(@$data); + return $refSurrogate; + } else { + return $class->new(@$data); + } +} + +sub save { + my ($this,$ctx,$predicate) = @_; + + ($this->_get_save_method)->($this,$ctx); +} + +sub _get_save_method { + my ($class) = @_; + + $class = ref $class || $class; + + no strict 'refs'; + if (my $method = *{"${class}::_impl_auto_save"}{CODE}) { + return $method; + } else { + my $code = <<SAVE_METHOD; +package $class; +sub _impl_auto_save { + my (\$this,\$ctx) = \@_; +SAVE_METHOD + + $code .= + join "\n", map "\t".'$ctx->AddVar('.$_->Name.' => ' . + ((not ref $_->Mutators and $_->Mutators & prop_list) ? ('[$this->'.$_->Class.'::'.$_->Name.'()]') : ('$this->'.$_->Class.'::'.$_->Name.'()')) . + ') if defined ' . '$this->'.$_->Class.'::'.$_->Name.'()' . ';', grep $_->canGet, $class->get_meta('IMPL::Class::PropertyInfo',undef,1); + $code .= <<SAVE_METHOD; + +} +\\\&_impl_auto_save; +SAVE_METHOD + + return (eval $code || die new IMPL::Exception("Failed to generate serialization method",$class,$@)); + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Profiler.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,139 @@ +package IMPL::Profiler; + +our $Enabled; +our %TrappedModules; +our %InvokeInfo; +our $InvokeTime = 0; +my $level; + +BEGIN { + $level = 0; + if ($Enabled) { + warn "profiler enabled"; + no warnings 'once'; + *CORE::GLOBAL::caller = sub { + my $target = (shift || 0)+1; + my $realFrame = 1; + + for (my $i = 1; $i<$target; $i++) { + $realFrame ++; + my $caller = CORE::caller($realFrame-1) or return; + $realFrame ++ if $caller eq 'IMPL::Profiler::Proxy'; #current frame is proxy + } + + my @frame = CORE::caller($realFrame) or return; + if ( $frame[0] eq 'IMPL::Profiler::Proxy' ) { + my @next = CORE::caller($realFrame+1) or return; + @frame[0..2] = @next[0..2]; + } + + #warn "\t"x$level,"$frame[0] - $frame[3]"; + return wantarray ? @frame : $frame[0]; + }; + } +} +use strict; +use warnings; +use Time::HiRes; +require Scalar::Util; + + + +sub trap_all { + return if not $Enabled; + no strict 'refs'; + foreach my $class (@_) { + next if $TrappedModules{$class}; + $TrappedModules{$class} = 1; + + eval "warn 'load $class'; require $class;" if not %{"${class}::"}; + die $@ if $@; + + no strict 'refs'; + my $table = \%{"${class}::"}; + trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table); + } +} + +sub trap { + my ($class,$method) = @_; + + return if not $Enabled; + + no strict 'refs'; + my $prevCode = \&{"${class}::${method}"}; + my $proto = prototype $prevCode; + + if (defined $proto and not $proto) { + return; + } + { + package IMPL::Profiler::Proxy; + no warnings 'redefine'; + my $sub = sub { + my $t0 = [Time::HiRes::gettimeofday]; + my @arr; + my $scalar; + my $entry = $prevCode; + my ($timeOwn,$timeTotal); + my $context = wantarray; + { + local $InvokeTime = 0; + #warn "\t"x$level,"enter ${class}::$method"; + $level ++; + if ($context) { + @arr = &$entry(@_); + } else { + if (defined $context) { + $scalar = &$entry(@_); + } else { + &$entry(@_); + } + } + $timeTotal = Time::HiRes::tv_interval($t0); + $timeOwn = $timeTotal - $InvokeTime; + } + $InvokeInfo{"${class}::${method}"}{Count} ++; + $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal; + $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn; + $InvokeTime += $timeTotal; + $level --; + #warn "\t"x$level,"leave ${class}::$method"; + return $context ? @arr : $scalar; + }; + if ($proto) { + Scalar::Util::set_prototype($sub => $proto); + } + *{"${class}::${method}"} = $sub; + } + +} + +sub PrintStatistics { + my $hout = shift || *STDERR; + print $hout "-- modules --\n"; + print $hout "$_\n" foreach sort keys %TrappedModules; + print $hout "\n-- stats --\n"; + print $hout + pad($_,50), + pad("$InvokeInfo{$_}{Count}",10), + pad(sprintf("%.3f",$InvokeInfo{$_}{Own}),10), + pad(sprintf("%.3f",$InvokeInfo{$_}{Total}),10), + "\n" + foreach sort { $InvokeInfo{$b}{Own} <=> $InvokeInfo{$a}{Own} } keys %InvokeInfo; +} + +sub ResetStatistics { + $InvokeTime = 0; + %InvokeInfo = (); +} + +sub pad { + my ($str,$len) = @_; + if (length $str < $len) { + return $str.(' 'x ($len- length $str)); + } else { + return $str; + } +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Profiler/Memory.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,57 @@ +package IMPL::Profiler::Memory; + +use strict; +use Carp qw(longmess shortmess); +use Scalar::Util qw(refaddr weaken isweak); + +my %instances; + +BEGIN { + *CORE::GLOBAL::bless = sub { + $_[1] |= caller unless $_[1]; + my $ref = CORE::bless $_[0],$_[1]; + + my $id = refaddr($ref); + + $instances{$id} = { + Class => $_[1], + WeakRef => $ref + }; + + weaken($instances{$id}{WeakRef}); + + return $ref; + } +} + +sub DumpAlive { + my ($hout) = @_; + $hout = *STDOUT unless $hout; + print $hout "Alive objects table\n"; + print $hout "-------------------\n"; + while (my ($id,$info) = each %instances) { + delete $instances{$id} and next unless $info->{WeakRef}; + print "$info->{Class} $id: $info->{WeakRef}\n"; + } +} + +sub StatClasses { + my ($hout) = @_; + $hout = *STDOUT unless $hout; + print $hout "Statistics by class\n"; + print $hout "-------------------\n"; + my %stat; + while (my ($id,$info) = each %instances) { + #$stat{$info->{Class}}{total} ++; + delete $instances{$id} and next unless $info->{WeakRef}; + $stat{$info->{Class}}{alive} ++; + } + + print $hout "$_ $stat{$_}{alive} \n" foreach sort keys %stat; +} + +sub Clear { + undef %instances; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Resources.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,59 @@ +package IMPL::Resources; +use strict; +use warnings; + +our $Encoding ||= 'utf-8'; +our %Files; + +my %Data; + + + foreach my $group (keys %Files) { + $Data{$group} = ParseResource($Files{$group}); + } + +sub findFile { + my ($fname) = @_; + + foreach my $dir (',',@INC) { + my $fullfname = "$dir/$fname"; + return $fullfname if -f $fullfname; + } + + return $fname; +} + +sub ParseResource { + my ($fname) = @_; + + open my $hRes, "<:encoding($Encoding)", findFile($fname) or die "Failed to open file $fname: $!"; + + my %Map; + my $line = 1; + while (<$hRes>) { + chomp; + $line ++ and next if /^\s*$/; + + if (/^(\w+)\s*=\s*(.*)$/) { + $Map{$1} = $2; + } else { + die "Invalid resource format in $fname at $line"; + } + $line ++; + } + + return \%Map; +} + +sub import { + my ($class,@groups) = @_; + my $caller = caller; + my %merged = map %{$Data{$_} || {} }, @groups; + + no strict 'refs'; + foreach my $item ( keys %merged ) { + *{"${caller}::ids_$item"} = sub { sprintf($merged{$item},@_) } + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SVN.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,15 @@ +package IMPL::SVN; +use strict; + +use base qw(IMPL::Object); +use IMPL::Object::Property; + +BEGIN { + public virtual _direct property SvnClient => get; +} + +sub UpdateBatch { + my ($this,$revstart,$revend) = @_; + + +} \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Security.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,3 @@ +package IMPL::Security; + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Security/AuthResult.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,16 @@ +package IMPL::Security::AuthResult; +use strict; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property State => prop_get; + public _direct property Session => prop_get; + public _direct property ClientSecData => prop_get; + public _direct property AuthMod => prop_get; +} + + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Serialization.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,409 @@ + +# 20060222 +# Ìîäóëü äëÿ ñåðèàëèçàöèè ñòðóêòóð äàííûõ +# (ö) Sourcer, cin.sourcer@gmail.com +# revision 3 (20090517) + + +package IMPL::Serialization; +use strict; + +package IMPL::Serialization::Context; +use base qw(IMPL::Object); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use IMPL::Exception; +use Scalar::Util qw(refaddr); + +BEGIN { + private _direct property ObjectWriter => prop_all; # îáúåêò, çàïèñûâàþùèé äàííûå â ïîòîê + private _direct property Context => prop_all; # êîíòåêñò (îáúåêòû êîòîðûå óæå ñåðèàëèçîâàíû, èõ èäåíòèôèêàòîðû) + private _direct property NextID => prop_all;# ñëåäóþùèé èäåíòèôèêàòîð äëÿ îáúåêòà + + # ïðîöåäóðà, êîòîðàÿ çíàåò, êàê ñåðèàëèçîâûâàòü îïðåäåëåííûå òèïû. Ïåðâûì ïàðàìåòðîì + # ïîëó÷àåì ññûëêó íà IMPL::Serialization::Context, âòîðûì ïàðàìåòðîì ññûëêó íà îáúåêò + public _direct property Serializer => prop_all; + + private _direct property State => prop_all; # ñîñòîÿíèå êîíòåêñòà ñåðèàëèçàöèè +} + +# êîíòåêñò çàêðûò, ò.å. íèêàêîé îáúåêò íå íà÷àò +sub STATE_CLOSED () { 0 } +# êîíòåêñò îòêðûò, ò.å. îáúåêò íà÷àò, íî â íåì åùå íè÷åãî íå ëåæèò +sub STATE_OPENED () { 1 } +# êîíòåêñò îòêðûò è â íåãî ìîãóò áûòü äîáàâëåíû òîëüêî ïîäîáúåêòû +sub STATE_COMPLEX () { 2 } +# êîíòåêñò îòêðûò è â íåãî óæå íè÷åãî íå ìîæåò áûòü äîáàâëåíî, òàì ëåæàò äàííûå +sub STATE_DATA () { 3 } + +sub CTOR { + my ($this,%args) = @_; + + $this->{$ObjectWriter} = $args{'ObjectWriter'}; + #$this->{$Context} = {}; + $this->{$NextID} = 1; + $this->{$Serializer} = ($args{'Serializer'} ? $args{'Serializer'} : \&DefaultSerializer ); + $this->{$State} = STATE_CLOSED; + + return 1; +} + +sub AddVar { + my ($this,$sName,$Var) = @_; + + die new Exception ('Invalid operation') if $this->{$State} == STATE_DATA; + + if (not ref $Var) { + # íåìíîãî äóáëèðóåòñÿ òî, ÷òî ñíèçó, íî ýòî ðàäè òîãî, ÷òîáû îáúåêòû, êîòîðûå èäóò + # íå ïî ññûëêå, íå ïîëó÷àëè èäåíòèôèêàòîðà, èì îí íå íóæåí + my $prevState = $this->{$State}; + + $this->{$ObjectWriter}->BeginObject(name => $sName);#, type => 'SCALAR'); + $this->{$State} = STATE_OPENED; + + $this->{$Serializer}->($this,\$Var); + + $this->{$ObjectWriter}->EndObject(); + + if ($prevState == STATE_OPENED) { + $this->{$State} = STATE_COMPLEX; + } else { + $this->{$State} = $prevState; + } + return 0; + } + + my $PrevState = $this->{$State}; + + my $ObjID = $this->{$Context}->{refaddr $Var}; + if ($ObjID) { + $this->{$ObjectWriter}->BeginObject(name => $sName, refid => $ObjID); + $this->{$ObjectWriter}->EndObject(); + return $ObjID; + } + + $ObjID = $this->{$NextID}; + $this->{$NextID} = $ObjID + 1; + + $this->{$Context}->{refaddr $Var} = $ObjID; + + $this->{$ObjectWriter}->BeginObject(name => $sName, type => ref($Var), id => $ObjID); + + $this->{$State} = STATE_OPENED; + $this->{$Serializer}->($this,$Var); + + $this->{$ObjectWriter}->EndObject(); + + if ($PrevState == STATE_OPENED) { + $this->{$State} = STATE_COMPLEX; + } else { + $this->{$State} = $PrevState; + } + + return $ObjID; +} + +sub SetData { + my ($this,$Data,$Type) = @_; + + die new Exception ('The object should be a scalar value') if ref $Data; + die new Exception ('Invalid operation') if $this->{$State} != STATE_OPENED; + + $this->{$ObjectWriter}->SetData($Data,$Type); + + $this->{$State} = STATE_DATA; + + return 1; +} + +sub DefaultSerializer { + my ($Context, $refObj) = @_; + + if (ref($refObj) eq 'SCALAR') { + $Context->SetData($$refObj, 'SCALAR'); + } elsif (ref($refObj) eq 'ARRAY') { + $Context->AddVar('item',$_) foreach @$refObj; + } elsif (ref($refObj) eq 'HASH') { + while (my ($key,$value) = each %$refObj) { + $Context->AddVar($key,$value); + } + } elsif (ref($refObj) eq 'REF') { + $Context->AddVar('ref',$$refObj); + } else { + if (ref $refObj and $refObj->UNIVARSAL::can('save')) { + $refObj->save($Context); + } else { + die new Exception('Cant serialize the object of the type: '.ref($refObj)); + } + } + + return 1; +} + +package IMPL::Deserialization::Context; +use base qw(IMPL::Object); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use IMPL::Exception; + +BEGIN { + # óæå äåñåðèàëèçîâàííûå îáúåêòû, õåø, êëþ÷ - èäåíòèôèêàòîð, çíà÷åíèå - ññûëêà. + private _direct property Context => prop_all; + + # òåêóùèé îáúåêò. èíôîðìàöèÿ äëÿ äåñåðèàëèçàöèè + # { + # Type => 'typename', + # Name => 'object_name', + # Data => $Data, + # Id => 'object_id' + # } + private _direct property CurrentObject => prop_all; + + # ñòåê îáúåêòîâ. ñþäà äîáàâëÿþòñÿ îïèñàíèÿ îáúåêòîâ ïî ìåðå âñòðå÷àíèÿ íîâûõ îáúåêòîâ. + private _direct property ObjectsPath => prop_all; + + # ñþäà ïîïàäåò êîðåíü ãðàôà îáúåêòîâ + public _direct property Root => prop_get; + + # ñîçäàåò îáúåêò è âîçâðàùàåò íà íåãî ññûëêó + # ObjectFactory($Type,$DeserializationData,$refSurogate) + # $Type - èìÿ òèïà äàííûõ + # $DeserializationData - ëèáî ññûëêà íà ìàññèâ ñ äàííûìè äëÿ äåñåðèàëèçàöèè ïîëåé, + # ëèáî ñêàëÿð ñîäåðæàùèé äàííûå. + # $refSurogate - ññûëêà íà ïðåäâàðèòåëüíî ñîçäàííûé, íå èíèöèàëèçèðîâàííûé îáúåêò. + # ìîæåò ïðèíèìàòü çíà÷åíèå undef + private _direct property ObjectFactory => prop_all; + + # Ñîçäàåò íåèíèöèàëèçèðîâàííûå îáúåêòû. + # SurogateHelper($Type) + # $Type èìÿ òèïïà, ÷åé ñóðîãàò íóæíî ñîçäàòü. + private _direct property SurogateHelper => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + $this->{$CurrentObject} = undef; + $this->{$Root} = undef; +} + +sub OnObjectBegin { + my ($this,$name,$rhProps) = @_; + + die new Exception("Invalid data from an ObjectReader","An object reader should pass a referense to a hash which contains attributes of an object") if (ref $rhProps ne 'HASH'); + die new Exception("Trying to create second root object") if not $this->{$CurrentObject} and $this->{$Root}; + + if ($rhProps->{'refid'}) { + my $refObj = $this->{$Context}->{$rhProps->{'refid'}}; + die new Exception("A reference to a not existing object found") if not $refObj; + my $rhCurrentObj = $this->{$CurrentObject}; + + die new Exception("Found a reference to an object as a root of an object's graph") if not $rhCurrentObj; + + if ($rhCurrentObj->{'Data'}) { + die new Exception("Invalid serializaed data","Plain deserialization data for an object already exist") if not ref $rhCurrentObj->{'Data'}; + push @{$rhCurrentObj->{'Data'}}, $name,$refObj; + } else { + $rhCurrentObj->{'Data'} = [$name,$refObj]; + } + + # ýòî çàòåì, ÷òî áóäåò âûçâàí OnObjectEnd äëÿ îáúåêòà, êîòîðûé áûë ïðîñòîé ññûëêîé. ò.î. ìû íå íàðóøèì ñòåê + push @{$this->{$ObjectsPath}},$rhCurrentObj; + $this->{$CurrentObject} = undef; + + } else { + push @{$this->{$ObjectsPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; + + $this->{$CurrentObject} = { + Name => $name, + Type => $rhProps->{'type'} || 'SCALAR', + Id => $rhProps->{'id'}, + refId => $rhProps->{'refid'} + }; + $this->{$Context}->{$rhProps->{'id'}} = $this->{$SurogateHelper} ? $this->{$SurogateHelper}->($rhProps->{'type'}) : DefaultSurogateHelper($rhProps->{'type'}) if defined $rhProps->{'id'}; + } + + return 1; +} + +sub OnObjectData { + my ($this,$data) = @_; + + my $rhObject = $this->{$CurrentObject}; + + die new Exception("Trying to set data for an object which not exists") if not $rhObject; + + die new Exception("Deserialization data already exists for a current object", "ObjectName= $rhObject->{'Name'}") if $rhObject->{'Data'}; + + $rhObject->{'Data'} = $data; + + return 1; +} +{ + my $AutoId = 0; + sub OnObjectEnd { + my ($this,$name) = @_; + + my $rhObject = $this->{$CurrentObject}; + my $rhPrevObject = pop @{$this->{$ObjectsPath}}; + + # åñëè òåêóùèé îáúåêò íå îïðåäåëåí, à ïðåäûäóùèé - îïðåäåëåí, çíà÷èò òåêóùèé - ýòî ññûëêà + # ïðîñòî âîññòàíàâëèâàåì ïðåäûäóùèé â òåêóùèé è íè÷åãî áîëåå íå äåëàåì + if ((not defined($rhObject)) && $rhPrevObject) { + $this->{$CurrentObject} = $rhPrevObject; + return 1; + } + + my $refObj = $this->{$ObjectFactory} ?$this->{$ObjectFactory}->($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef) : DefaultFactory($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef); + + die new Exception("Trying to close a non existing oject") if not $rhObject; + + my $Data; + + if ($rhObject->{'Id'}) { + $this->{$Context}->{$rhObject->{'Id'}} = $refObj; + $Data = $refObj; + } else { + if (ref $refObj ne 'SCALAR') { + $rhObject->{Id} = "auto$AutoId"; + $AutoId ++; + $this->{$Context}->{$rhObject->{'Id'}} = $refObj; + $Data = $refObj; + } else { + $Data = ${$refObj}; + } + } + + if (not $rhPrevObject) { + $this->{$Root} = $Data; + } else { + if ($rhPrevObject->{'Data'}) { + die new Exception("Trying append a reference to an object to the plain data") if not ref $rhPrevObject->{'Data'}; + push @{$rhPrevObject->{'Data'}},$rhObject->{'Name'},$Data; + } else { + $rhPrevObject->{'Data'} = [$rhObject->{'Name'},$Data]; + } + } + + $this->{$CurrentObject} = $rhPrevObject; + + return 1; + } +} + +sub _is_class { + no strict 'refs'; + scalar keys %{"$_[0]::"} ? 1 : 0; +} + +sub DefaultSurogateHelper { + my ($Type) = @_; + + if ($Type eq 'SCALAR' or $Type eq 'REF') { + my $var; + return \$var; + } elsif ($Type eq 'ARRAY') { + return []; + } elsif ($Type eq 'HASH') { + return {}; + } else { + eval "require $Type" unless _is_class($Type); + if ($Type->UNIVERSAL::can('surrogate')) { + return $Type->surrogate(); + } else { + return bless {}, $Type; + } + } +} + +# deserialization context: +# [ +# 'var_name',value, +# .... +# ] + +sub DefaultFactory { + my ($Type,$Data,$refSurogate) = @_; + + if ($Type eq 'SCALAR') { + die new Exception("SCALAR needs a plain data for a deserialization") if ref $Data; + if ($refSurogate) { + $$refSurogate = $Data; + return $refSurogate; + } else { + return \$Data; + } + } elsif ($Type eq 'ARRAY') { + die new Exception("Invalid a deserialization context when deserializing ARRAY") if not ref $Data and defined $Data; + if (not ref $refSurogate) { + my @Array; + $refSurogate = \@Array; + } + for (my $i = 0; $i < scalar(@{$Data})/2; $i++) { + push @$refSurogate,$Data->[$i*2+1]; + } + return $refSurogate; + } elsif ($Type eq 'HASH') { + die new Exception("Invalid a deserialization context when deserializing HASH") if not ref $Data and defined $Data; + if (not ref $refSurogate) { + $refSurogate = {}; + } + for (my $i = 0; $i< @$Data; $i+= 2) { + $refSurogate->{$Data->[$i]} = $Data->[$i+1]; + } + return $refSurogate; + } elsif ($Type eq 'REF') { + die new Exception("Invalid a deserialization context when deserializing REF") if not ref $Data and defined $Data; + if (not ref $refSurogate) { + my $ref = $Data->[1]; + return \$ref; + } else { + $$refSurogate = $Data->[1]; + return $refSurogate; + } + } else { + eval "require $Type" unless _is_class($Type); + if ( $Type->UNIVERSAL::can('restore') ) { + return $Type->restore($Data,$refSurogate); + } else { + die new Exception("Don't know how to deserialize $Type"); + } + } +} + +package IMPL::Serializer; +use base qw(IMPL::Object); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use IMPL::Exception; + +BEGIN { + private _direct property Formatter => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + $this->Formatter($args{'Formatter'}) or die new Exception("Omitted mandatory parameter 'Formatter'"); +} + +sub Serialize { + my $this = shift; + my ($hStream,$Object) = @_; + my $ObjWriter = $this->Formatter()->CreateWriter($hStream); + my $Context = new IMPL::Serialization::Context(ObjectWriter => $ObjWriter); + $Context->AddVar('root',$Object); + return 1; +} + +sub Deserialize { + my $this = shift; + my ($hStream) = @_; + my $Context = new IMPL::Deserialization::Context(); + my $ObjReader = $this->Formatter()->CreateReader($hStream,$Context); + $ObjReader->Parse(); + return $Context->Root(); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Serialization/XmlFormatter.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,202 @@ +package IMPL::Serialization::XmlObjectWriter; +use strict; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +use IMPL::Serialization; +use XML::Writer; +use IMPL::Exception; + +sub CONTAINER_EMPTY () { 1 } +sub CONTAINER_NORMAL () { 2 } + +BEGIN { + public _direct property Encoding => prop_all; + public _direct property hOutput => prop_all; + public _direct property IdentOutput => prop_all; + + private _direct property CurrentObject => prop_all; + private _direct property ObjectPath => prop_all; + private _direct property XmlWriter => prop_all; + private _direct property IdentLevel => prop_all; + private _direct property IdentNextTag => prop_all; +} + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + $self->CTOR(@_); + return $self; +} + +sub CTOR { + my $this = shift; + my %args = @_; + $this->{$hOutput} = $args{'hOutput'}; + $this->{$Encoding} = $args{'Encoding'}; + $this->{$CurrentObject} = undef; + $this->{$IdentOutput} = $args{'IdentOutput'}; + $this->{$IdentLevel} = 0; + $this->{$IdentNextTag} = 0; + #$this->{$ObjectPath} = []; + return 1; +} + +sub BeginObject { + my $this = shift; + my %args = @_; + + if (not $this->{$CurrentObject}) { + my $xmlWriter = new XML::Writer(OUTPUT => $this->{$hOutput}, ENCODING => $this->{$Encoding}); + $this->{$XmlWriter} = $xmlWriter; + $xmlWriter->xmlDecl(); + } + + push @{$this->{$ObjectPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; + + my %ObjectProperties = %args; + delete $ObjectProperties{'name'}; + delete $args{'container_type'}; + + $this->{$CurrentObject} = \%ObjectProperties; + + my $tagname; + if (_CheckName($args{'name'})) { + $tagname = $args{'name'}; + } else { + $tagname = 'element'; + $ObjectProperties{'extname'} = $args{'name'}; + } + + if ($args{'refid'}) { + $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; + $this->{$XmlWriter}->emptyTag($tagname,%ObjectProperties); + $ObjectProperties{'container_type'} = CONTAINER_EMPTY; + } else { + $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; + $this->{$XmlWriter}->startTag($tagname,%ObjectProperties); + $ObjectProperties{'container_type'} = CONTAINER_NORMAL; + } + + $this->{$IdentLevel} ++; + $this->{$IdentNextTag} = $this->{$IdentOutput}; + + return 1; +} + +sub EndObject { + my $this = shift; + + my $hCurrentObject = $this->{$CurrentObject} or return 0; + + $this->{$IdentLevel} --; + + if ( $hCurrentObject->{'container_type'} != CONTAINER_EMPTY ) { + $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag}; + $this->{$XmlWriter}->endTag(); + } + + $this->{$IdentNextTag} = $this->{$IdentOutput}; + + $this->{$CurrentObject} = pop @{$this->{$ObjectPath}} if exists $this->{$ObjectPath}; + $this->{$XmlWriter} = undef if (not $this->{$CurrentObject}); + + return 1; +} + +sub SetData { + my $this = shift; + #my $hCurrentObject = $this->{$CurrentObject} or return 0; + + if ($this->{$CurrentObject}->{'container_type'} == CONTAINER_NORMAL) { + $this->{$XmlWriter}->characters($_[0]) if defined $_[0]; + $this->{$IdentNextTag} = 0; + return 1; + } else { + return 0; + } +} + +sub _CheckName { + return 0 if not $_[0]; + return $_[0] =~ /^(_|\w|\d)+$/; +} + +package IMPL::Serialization::XmlObjectReader; +use base qw(XML::Parser); + +sub new { + my $class = shift; + my %args = @_; + die new Exception("Handler parameter is reqired") if not $args{'Handler'}; + die new Exception("Handler parameter must be a reference") if not ref $args{'Handler'}; + + #my $this = $class->SUPER::new(Style => 'Stream', Pkg => 'Serialization::XmlObjectReader', 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); + my $this = $class->SUPER::new(Handlers => { Start => \&StartTag, End => \&EndTag, Char => \&Text} , 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } ); + return $this; +} + +sub Parse { + my $this = shift; + $this->parse($this->{'Non-Expat-Options'}->{'hInput'}); + return 1; +} + +sub StartTag { + my $this = shift; + my $name = shift; + my %Attr = @_; + $name = $Attr{'extname'} if defined $Attr{'extname'}; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectBegin($name,\%Attr); + return 1; +} + +sub EndTag { + my ($this,$name) = @_; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectEnd($name); + return 1; +} + +sub Text { + my ($this) = shift; + $_ = shift; + return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and /^\n*\s*\n*$/; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($_); + return 1; +} + +package IMPL::Serialization::XmlFormatter; +use base qw(IMPL::Object); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property Encoding => prop_all; + public _direct property SkipWhitespace => prop_all; + public _direct property IdentOutput => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->Encoding($args{'Encoding'} || 'utf-8'); + $this->SkipWhitespace($args{'SkipWhitespace'}); + $this->IdentOutput($args{'IdentOutput'}); + + return 1; +} + +sub CreateWriter { + my ($this,$hStream) = @_; + return new IMPL::Serialization::XmlObjectWriter(Encoding =>$this->Encoding() , hOutput => $hStream, IdentOutput => $this->IdentOutput()); +} + +sub CreateReader { + my ($this,$hStream,$refHandler) = @_; + return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace()); +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,32 @@ +package IMPL::Test; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&test &shared); + +require IMPL::Test::Unit; +use IMPL::Class::Member; + +sub test($$) { + my ($name,$code) = @_; + my $class = caller; + + $class->set_meta( + new IMPL::Test::Unit::TestInfo( $name, $code ) + ); +} + +sub shared($) { + my ($propInfo) = @_; + + my $class = caller; + + die new IMPL::Exception("Only properties could be declared as shared",$propInfo->Name) unless eval {$propInfo->isa('IMPL::Class::PropertyInfo')}; + die new IMPL::Exception("You can't mark the readonly property as shared",$propInfo->Name) unless $propInfo->canSet; + die new IMPL::Exception("Only public properties could be declared as shared",$propInfo->Name) unless $propInfo->Access == IMPL::Class::Member::MOD_PUBLIC; + + $class->set_meta(new IMPL::Test::Unit::SharedData($propInfo->Name)); +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/BadUnit.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,49 @@ +package IMPL::Test::BadUnit; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +use IMPL::Class::Property; + +BEGIN { + public property UnitName => prop_all; + public property Message => prop_all; + public property Error => prop_all; +} + +our %CTOR = ( + 'IMPL::Test::Unit' => sub { + my ($unit,$message,$error) = @_; + return new IMPL::Test::Unit::TestInfo( + BadUnitTest => sub { + die new IMPL::Test::FailException($message,$unit,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) + } + ); + } +); + +sub CTOR { + my ($this,$name,$message,$error) = @_; + + $this->UnitName($name); + $this->Message($message); + $this->Error($error); +} + +sub save { + my ($this,$ctx) = @_; + + defined ($this->$_()) and $ctx->AddVar($_ => $this->$_()) foreach qw(UnitName Message); +} + +sub restore { + my ($class,$data,$inst) = @_; + + my %args = @$data; + + $inst ||= $class->surrogate; + $inst->callCTOR(@args{qw(UnitName Message)}); +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/FailException.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,22 @@ +package IMPL::Test::FailException; +use strict; +use warnings; + +use base qw(IMPL::Exception); + +__PACKAGE__->PassThroughArgs; + +sub toString { + my $this = shift; + + $this->Message . join("\n",'',map IMPL::Exception::indent($_,1), @{$this->Args} ); +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar(Message => $this->Message); + $ctx->AddVar(Args => $this->Args) if @{$this->Args}; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/HarnessRunner.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,37 @@ +package IMPL::Test::HarnessRunner; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); +use IMPL::Class::Property; +use Test::Harness; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property Strap => prop_all; +} + +sub CTOR { + my $this = shift; + + die new IMPL::InvalidArgumentException("The Strap parameter must be specified") unless $this->Strap; +} + +sub RunTests { + my ($this,@files) = @_; + + local $Test::Harness::Strap = $this->Strap; + + return runtests(@files); +} + +sub ExecuteTests { + my ($this,%args) = @_; + + local $Test::Harness::Strap = $this->Strap; + + return Test::Harness::execute_tests(%args); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/Plan.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,200 @@ +package IMPL::Test::Plan; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; + +use IMPL::Exception; +use IMPL::Test::Result; +use IMPL::Test::BadUnit; +use Error qw(:try); + +use IMPL::Serialization; +use IMPL::Serialization::XmlFormatter; + +BEGIN { + public property Units => prop_all | prop_list; + public property Results => prop_all | prop_list; + public property Listeners => prop_all | prop_list; + private property _Cache => prop_all | prop_list; + private property _Count => prop_all; +} + +sub CTOR { + my $this = shift; + $this->Units(\@_); +} + +sub restore { + my ($class,$data,$instance) = @_; + + $instance ||= $class->surrogate; + + $instance->callCTOR(); + + my %args = @$data; + + $instance->Units($args{Units}); + $instance->Results($args{Results}) if $args{Results}; + $instance->Listeners($args{Listeners}) if $args{Listeners}; +} + +sub save { + my ($this,$ctx) = @_; + + $ctx->AddVar(Units => [$this->Units]); + $ctx->AddVar(Results => [$this->Results]) if $this->Results; + $ctx->AddVar(Listeners => [$this->Listeners]) if $this->Listeners; +} + +sub AddListener { + my ($this,$listener) = @_; + + $this->Listeners($this->Listeners,$listener); +} + +sub Prepare { + my ($this) = @_; + + my $count = 0; + my @cache; + + foreach my $Unit ($this->Units){ + my %info; + + $info{Unit} = $Unit; + try { + $info{Tests} = [map $Unit->new($_), $Unit->List]; + } otherwise { + $info{Tests} = [$info{Unit} = new IMPL::Test::BadUnit($Unit->UnitName,"Failed to extract tests",$@)]; + }; + $count += @{$info{Tests}}; + push @cache, \%info if @{$info{Tests}}; + } + + $this->_Count($count); + $this->_Cache(\@cache); +} + +sub Count { + my ($this) = @_; + return $this->_Count; +} + +sub Run { + my $this = shift; + + die new IMPL::InvalidOperationException("You must call the prepare method before running the plan") unless $this->_Cache; + + $this->_Tell(RunPlan => $this); + + my @resultsTotal; + + foreach my $info ($this->_Cache) { + $this->_Tell(RunUnit => $info->{Unit}); + + my $data; + undef $@; + eval { + $data = $info->{Unit}->StartUnit; + }; + + my @results; + + if (not $@) { + foreach my $test (@{$info->{Tests}}) { + $this->_Tell(RunTest => $test); + my $result = $test->Run($data); + $this->_Tell(EndTest => $test,$result); + push @results,$result; + } + } else { + my $e = $@; + foreach my $test (@{$info->{Tests}}) { + $this->_Tell(RunTest => $test); + my $result = new IMPL::Test::Result( + Name => $test->Name, + State => IMPL::Test::Result::FAIL, + Exception => $e + ); + $this->_Tell(EndTest => $test,$result); + push @results,$result; + } + } + + eval { + $info->{Unit}->FinishUnit($data); + }; + + undef $@; + + push @resultsTotal, { Unit => $info->{Unit}, Results => \@results}; + + $this->_Tell(EndUnit => $info->{Unit},\@results); + } + + $this->Results(\@resultsTotal); + $this->_Tell(EndPlan => $this); +} + +sub _Tell { + my ($this,$what,@args) = @_; + + $_->$what(@args) foreach $this->Listeners; +} + +sub SaveXML { + my ($this,$out) = @_; + + my $h; + + if (ref $out eq 'GLOB') { + $h = $out; + } elsif ($out and not ref $out) { + open $h, ">", $out or die new IMPL::Exception("Failed to open file",$out); + } else { + die new IMPL::InvalidOperationException("Invalid output specified"); + } + + my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); + $s->Serialize($h,$this); +} + +sub LoadXML { + my ($self,$in) = @_; + + my $h; + + if (ref $in eq 'GLOB') { + $h = $in; + } elsif ($in and not ref $in) { + open $h, ">", $in or die new IMPL::Exception("Failed to open file",$in); + } else { + die new IMPL::InvalidOperationException("Invalid input specified"); + } + + my $s = new IMPL::Serializer(Formatter => new IMPL::Serialization::XmlFormatter( IdentOutput => 1, SkipWhitespace => 1) ); + return $s->Deserialize($h); +} + +sub xml { + my $this = shift; + my $str = ''; + + open my $h,'>',\$str or die new IMPL::Exception("Failed to create stream"); + $this->SaveXML($h); + undef $h; + return $str; +} + +sub LoadXMLString { + my $self = shift; + my $str = shift; + + open my $h,'<',\$str or die new IMPL::Exception("Failed to create stream"); + return $self->LoadXML($h); +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/Result.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,32 @@ +package IMPL::Test::Result; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +use constant { + SUCCESS => 0, + FAIL => 1, + ERROR => 2 +}; + +BEGIN { + public property Name => prop_all; + public property State => prop_all; + public property Exception => prop_all; + public property TimeExclusive => prop_all; + public property TimeInclusive => prop_all; +} + +sub CTOR { + my ($this) = @_; + + $this->TimeInclusive(0) unless defined $this->TimeInclusive; + $this->TimeExclusive(0) unless defined $this->TimeExclusive; +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/SkipException.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,8 @@ +package IMPL::Test::SkipException; + +use base qw(IMPL::Test::FailException); + +__PACKAGE__->PassThroughArgs; + +1; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/Straps.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,90 @@ +package IMPL::Test::Straps; +use strict; +use warnings; + +use base qw(Test::Harness::Straps IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property Executors => prop_all | prop_list; +} + +sub new { + my $class = shift; + my $this = $class->Test::Harness::Straps::new(); + + $this->callCTOR(@_); + + return $this; +} + +sub surrogate { + my $class = shift; + return $class->Test::Harness::Straps::new(); +} + +sub analyze_file { + my($self, $file) = @_; + + unless( -e $file ) { + $self->{error} = "$file does not exist"; + return; + } + + unless( -r $file ) { + $self->{error} = "$file is not readable"; + return; + } + + # *sigh* this breaks under taint, but open -| is unportable. + my $h = $self->ExecuteFile($file); + unless ($h) { + print "can't run $file. $!\n"; + return; + } + + my $results = $self->analyze_fh($file, $h); + my $exit = close $h; + + $results->set_wait($?); + if ( $? && $self->{_is_vms} ) { + $results->set_exit($?); + } + else { + $results->set_exit( Test::Harness::Straps::_wait2exit($?) ); + } + $results->set_passing(0) unless $? == 0; + + $self->_restore_PERL5LIB(); + + return $results; +} + +sub SelectExecutor { + my ($this,$file) = @_; + + return $_->{Executor} foreach grep $file =~ /$_->{Re}/i, $this->Executors; +} + +sub ExecuteFile { + my ($this,$file) = @_; + + if (my $executor = $this->SelectExecutor($file)) { + return $executor->Execute($file); + } + return undef; +} + +sub Execute { + my ($self,$file) = @_; + + local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; + + open my $h,'-|',$self->_command_line($file) or return undef; + + return $h; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/Straps/ShellExecutor.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,32 @@ +package IMPL::Test::Straps::ShellExecutor; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Serializable); + +if ($^O =~ /win32/i) { + require Win32::Console; +} + +sub Execute { + my ($this,$file) = @_; + + my $h; + + if ($^O =~ /win32/i) { + Win32::Console::OutputCP(65001); + unless ( open $h,'-|',$file ) { + return undef; + } + binmode $h,':encoding(utf-8)'; + } else { + unless ( open $h,'-|',$file ) { + return undef; + } + } + + return $h; +} + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/TAPListener.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,70 @@ +package IMPL::Test::TAPListener; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Serializable); +use IMPL::Class::Property; +use IMPL::Test::Result; + +BEGIN { + private property _Output => prop_all; + private property _testNo => prop_all; +} + +sub CTOR { + my ($this,$out) = @_; + + $this->_Output($out || *STDOUT); + $this->_testNo(1); +} + +sub RunPlan { + my ($this,$plan) = @_; + + my $out = $this->_Output; + + print $out "1..",$plan->Count,"\n"; +} + +sub EndPlan { + +} + +sub RunUnit { + my ($this,$unit) = @_; + + my $out = $this->_Output; + + print $out "#\n",join("\n",map "# $_", split /\n/, "Running unit: " . $unit->UnitName, ),"\n#\n"; +} + +sub EndUnit { + +} + +sub RunTest { + +} + +sub EndTest { + my ($this,$test,$result) = @_; + + my $out = $this->_Output; + my $n = $this->_testNo; + + $this->_testNo($n+1); + + print $out ( + $result->State == IMPL::Test::Result::SUCCESS ? + "ok $n " . join("\n# ", split(/\n/, $result->Name) ) + : + "not ok $n " . (eval { $result->Exception->isa('IMPL::Test::SkipException') } ? '# SKIP ' : '') . join("\n# ", split(/\n/, $result->Name."\n".$result->Exception || '') ) + ),"\n"; + +} + +sub save { + +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Test/Unit.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,143 @@ +package IMPL::Test::Unit; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; + +use Time::HiRes qw(gettimeofday tv_interval); + +use Error qw(:try); +use IMPL::Test::Result; +use IMPL::Test::FailException; +use IMPL::Exception; + +BEGIN { + public property Name => prop_all; + public property Code => prop_all; +} + +sub CTOR { + my ($this,$info) = @_; + + die new IMPL::InvalidArgumentException("TestInfo should be supplied as an argument") unless $info; + + $this->Name($info->Name || 'Annon'); + $this->Code($info->Code)or die new IMPL::InvalidOperationException("Can't create test without entry point"); +} + +sub UnitName { + my ($self) = @_; + $self->toString; +} + +sub Setup { + 1; +} + +sub Cleanup { + 1; +} + +sub StartUnit { + my $class = shift; + + return {}; +} + +sub InitTest { + my ($this,$session) = @_; + + $this->$_($session->{$_}) foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData'); +} + +sub FinishUnit { + my ($class,$session) = @_; + + 1; +} + +sub List { + my $self = shift; + + return $self->get_meta('IMPL::Test::Unit::TestInfo',undef,1); # deep search with no criteria +} + +sub Run { + my ($this,$session) = @_; + + my $t = [gettimeofday]; + return try { + $this->InitTest($session); + $this->Setup; + my $code = $this->Code; + + + my $t0 = [gettimeofday]; + my $elapsed; + + try { + $this->$code(); + $elapsed = tv_interval ( $t0 ); + } finally { + # we need to call Cleanup anyway + $this->Cleanup; + }; + + return new IMPL::Test::Result( + Name => $this->Name, + State => IMPL::Test::Result::SUCCESS, + TimeExclusive => $elapsed, + TimeInclusive => tv_interval ( $t ) + ); + } catch IMPL::Test::FailException with { + my $e = shift; + return new IMPL::Test::Result( + Name => $this->Name, + State => IMPL::Test::Result::FAIL, + Exception => $e, + TimeInclusive => tv_interval ( $t ) + ); + } otherwise { + my $e = shift; + return new IMPL::Test::Result( + Name => $this->Name, + State => IMPL::Test::Result::ERROR, + Exception => $e, + TimeInclusive => tv_interval ( $t ) + ); + } +} + +package IMPL::Test::Unit::TestInfo; +use base qw(IMPL::Object::Meta); +use IMPL::Class::Property; + +require IMPL::Exception; + +BEGIN { + public property Name => prop_all; + public property Code => prop_all; +} + +sub CTOR { + my ($this,$name,$code) = @_; + + $this->Name($name); + $this->Code($code) or die new IMPL::InvalidArgumentException("The Code is a required parameter"); +} + +package IMPL::Test::Unit::SharedData; +use base qw(IMPL::Object::Meta); +use IMPL::Class::Property; + +BEGIN { + public property DataList => prop_all | prop_list; +} + +sub CTOR { + my $this = shift; + + $this->DataList(\@_); +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Transform.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,65 @@ +package IMPL::Transform; +use base qw(IMPL::Object IMPL::Object::Autofill); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + protected _direct property Templates => prop_all; + protected _direct property Default => prop_all; + protected _direct property Plain => prop_all; +} + +__PACKAGE__->PassThroughArgs; + +sub Transform { + my ($this,$object) = @_; + + if (not ref $object) { + die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$Plain}; + my $template = $this->{$Plain}; + return $this->$template($object); + } else { + + my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object); + + return $this->$template($object); + } +} + +sub MatchTemplate { + my ($this,$object) = @_; + my $class = ref $object; + + foreach my $tClass ( keys %{$this->Templates || {}} ) { + return $this->Templates->{$tClass} if ($tClass eq $class); + } +} + +package IMPL::Transform::NoTransformException; +use base qw(IMPL::Exception); + +1; + +__END__ + +=pod +=head1 SYNOPSIS + +my $obj = new AnyObject; + +my $t = new Transform ( + AnyClass => sub { + my ($this,$object) = @_; + return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) }) + }, + DocClass => sub { + my ($this,$object) = @_; + return new DocPreview(Author => $object->Author, Text => $object->Data); + } +); + +=head1 Summary +Ïðåîáðàçóåò äàííûå ñîäåðæàùèåñÿ â ôîðìå â ðåàëüíûå îáúåêòû èñïîëüçóÿ ñïåöèàëüíîå ïðåîáðàçîâàíèå. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Tree/Batch.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,3 @@ +package IMPL::Tree::Batch; +use strict; +use base qw(IMP::Object); \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Mailer.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,69 @@ +package Mailer; +use strict; + +use Encode qw (encode); +use Encode::MIME::Header; +use MIME::Base64 qw(encode_base64); +use Email::Simple; + +our $SENDMAIL; + +sub DeliverMessage { + my $message = shift; + + $message = shift if $message eq __PACKAGE__ or ref $message eq __PACKAGE__; + + my $email = new Email::Simple($message); + + $email->header_set('Content-Transfer-Encoding' => 'base64'); + $email->header_set('MIME-Version' => '1.0') if !$email->header('MIME-Version'); + $email->header_set('Content-Type' => 'text/plain; charset="utf-8"'); + my $raw = $email->body(); + utf8::encode($raw) if utf8::is_utf8($raw); + $email->body_set(encode_base64($raw)); + + foreach my $field ($email->header_names()) { + $email->header_set($field, map { encode('MIME-Header', utf8::is_utf8($_) ? $_ : Encode::decode('utf-8',$_) ) } $email->header($field) ); + } + + return SendMail($email,@_); +} + +sub _find_sendmail { + return $SENDMAIL if defined $SENDMAIL; + + my @path = split /:/, $ENV{PATH}; + my $sendmail; + for (@path) { + if ( -x "$_/sendmail" ) { + $sendmail = "$_/sendmail"; + last; + } + } + return $sendmail; +} + +sub SendMail { + my ($message, %args) = @_; + my $mailer = _find_sendmail; + + local *SENDMAIL; + if( $args{'TestFile'} ) { + open SENDMAIL, '>', $args{TestFile} or die "Failed to open $args{TestFile}: $!"; + binmode(SENDMAIL); + print SENDMAIL "X-SendMail-Cmd: sendmail ",join(' ',%args),"\n"; + } else { + my @args = %args; + die "sendmail not found" unless $mailer; + die "Found $mailer but cannot execute it" + unless -x $mailer; + open SENDMAIL, "| $mailer -t -oi @args" + or die "Error executing $mailer: $!"; + } + print SENDMAIL $message->as_string + or die "Error printing via pipe to $mailer: $!"; + close SENDMAIL; + return 1; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/ObjectStore/CDBI/Users.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,100 @@ +#!/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); +} \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/PerfCounter.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,161 @@ +package PerfCounter; +use strict; +use Common; +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(&GetTimeCounter &StartTimeCounter &StopTimeCounter &SetDBIPerfCounter); + +our %Counters; + +sub Reset() { + $_->Reset foreach values %Counters; +} + +sub GetTimeCounter { + my $counter = $Counters{$_[0]}; + die new Exception("'$_[0]' already exists and isn't a time counter.") if ref $counter and ref $counter ne 'PerfInterval'; + if (not ref $counter) { + $counter = new PerfInterval; + $Counters{$_[0]} = $counter; + } + return $counter; +} + +sub StartTimeCounter { + my $counter = GetTimeCounter($_[0]); + if (not $counter->IsOpened) { + $counter->OpenInterval; + } +} + +sub StopTimeCounter { + my $counter = GetTimeCounter($_[0]); + if ($counter->IsOpened) { + $counter->CloseInterval; + } +} + +sub SetDBIPerfCounter{ + my ($dbh,$name) = @_; + $name ||= 'DBI'; + $Counters{$name} = DBIPerfomance->new(DBH => $dbh); +} + +package PerfInterval; +use Common; +use Time::HiRes qw(gettimeofday tv_interval); + +sub new { + my $class = shift; + my $self = bless { StartTime => scalar(gettimeofday()) }, $class; + return $self; +} + +sub CloseInterval { + my $this = shift; + + if (not $this->{'EndTime'}) { + $this->{'EndTime'} = scalar(gettimeofday()); + $this->{'Value'} += $this->{'EndTime'} - $this->{'StartTime'}; + } + + return $this->{'Value'}; +} + +sub Value { + my $this = shift; + + if (not $this->{'EndTime'}) { + return sprintf ( '%.3f+',scalar(gettimeofday()) - $this->{'StartTime'}); + } else { + return sprintf ( '%.3f',$this->{'Value'}); + } +} + +sub Add { + my ($this,$interval) = @_; + + if(ref $interval eq 'PerfInterval') { + $this->{'Value'} += $interval->{'Value'}; + } else { + $this->{'Value'} += $interval; + } + + return $this->{'Value'}; +} + +sub IsOpened { + my $this = shift; + return( not $this->{'EndTime'} ); +} + +sub OpenInterval { + my $this = shift; + + $this->{'StartTime'} = gettimeofday(); + delete $this->{'EndTime'}; + + return 1; +} + +sub Reset { + my ($this) = @_; + + $this->CloseInterval(); + $this->{'Value'} = 0; +} + +package DBIPerfomance; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty DBH => ACCESS_READ; + +} + +sub CTOR { + my $this=shift; + $this->SUPER::CTOR(@_); + + + $this->DBH->{Profile} = 6; +} + +sub Reset { + my $this = shift; + $this->DBH->{Profile} = 6; +} + +sub Value { + my ($this,%opt) = @_; + + my $infoSelect = { count => 0, time => 0}; + my $infoUpdate = { count => 0, time => 0}; + my $infoTotal; + + foreach my $stmt (grep /^SELECT/i,keys %{$this->DBH->{Profile}->{Data} || {}}) { + $infoSelect->{'count'} += $this->DBH->{Profile}{Data}{$stmt}{execute}[0] || 0; + $infoSelect->{'time'} += $this->DBH->{Profile}{Data}{$stmt}{execute}[1] || 0; + } + + foreach my $stmt (grep /^UPDATE/i,keys %{$this->DBH->{Profile}->{Data} || {}}) { + $infoUpdate->{'count'} += $this->DBH->{Profile}{Data}{$stmt}{execute}[0] || 0; + $infoUpdate->{'time'} += $this->DBH->{Profile}{Data}{$stmt}{execute}[1] || 0; + } + + $infoTotal->{'count'} = $infoSelect->{'count'} + $infoUpdate->{'count'}; + $infoTotal->{'time'} = $infoSelect->{'time'} + $infoUpdate->{'time'}; + + if ($opt{'extended'}) { + return ($infoSelect,$infoUpdate,$infoTotal); + } else { + return sprintf( '%i (%.2f)', $infoTotal->{count},$infoTotal->{time} ); + } +} + +sub Queries { + my ($this) = @_; + return [ map { "$this->{$DBH}{Profile}{Data}{$_}{execute}[0] x $_"} sort grep $_, keys %{$this->DBH->{Profile}->{Data}}]; +} +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,748 @@ +package Schema; +package Schema::TypeName; +package Schema::Type; +package Schema::Template; +package Schema::TemplateSpec; +package Schema::Member; +package Schema::Property; + +package Schema::TypeName; +use Common; + +#our @ISA = qw(Object); + +# ìîæíî îïòèìèçèðîâàòü ïðîèçâîäèòåëüíîñòü, ñîçäàâàÿ îáúåêò ñêàëàÿð äëÿ ïðîñòûõ +# èìåí è îáõåêò õåø äëÿ ñïåöèàëèçàöèé +# ñäåëàíî + +sub new { + my $class = shift; + my $this; + + my $name = shift; + my @list = map { ref $_ eq 'Schema::TypeName' ? $_ : new Schema::TypeName($_) } @_; + + die new Exception('TypeName soud be a simple identifier',$name) if not $name =~ /^\w+$/; + + if (@list) { + $this = bless {}, $class; + $this->{Name} = $name; + $this->{TemplateList} = \@list if @list; + } else { + $this = bless \$name, $class; + } + + return $this; +} + +sub Name { + my $this = shift; + return (UNIVERSAL::isa($this,'HASH') ? $this->{Name} : $$this); +} + +sub Simple { + return $_[0]->Name; +} + +# ñïèñîê ïàðàìåòðîâ òèïà +sub TemplateList { + my $this = shift; + return (UNIVERSAL::isa($this,'HASH') ? (wantarray ? @{$this->{TemplateList}} : $this->{TemplateList} ) : (wantarray ? return () : undef)); +} + +# èìÿ òèïà ÿâëÿåòñÿ èìåíåì øàáëîíà +sub isTemplateSpec { + my $this = shift; + return( UNIVERSAL::isa($this,'HASH') ? 1 : 0 ); +} + +sub CanonicalName { + my $this = shift; + + if (UNIVERSAL::isa($this,'HASH')) { + if (my $result = $this->{SavedCanonicalName}) { + $result; + } else { + $result = $this->{Name}; + $result .= '@'. join('#',map {ref $_ eq __PACKAGE__ ? $_->CanonicalName : $_} @{$this->{TemplateList}}) . '@@'; + $this->{SavedCanonicalName} = $result; + } + } else { + $$this; + } +} + +sub Canonical { + return $_[0]->CanonicalName; +} + +# Íå ðåãèñòðèðóåò âíîâü ñîçäàííûõ òèïîâ â òàáëèöå +# Ýòî èç-çà ñëó÷àÿ, êîãäà: +# MyClass { Hash<int> my_map; }, òîåñòü ïîëó÷åííûé òèï Hahs<int> óæå ñïåöèàëèçèðîâàí è îí áóäåò ñðàçó èíñòàíòèíîðîâàí +# DoNotCreate äëÿ ñïåöèàëèçàöèè øàáëîíà òîëüêî ñóùåñòâóþùèìè òèïàìè +sub Resolve { + my ($this,$TypeTable,$DoNotCreate) = @_; + + if (my $type = $TypeTable->ResolveType($this,$DoNotCreate)) { + # ïðåäïîëàãàåòñÿ, ÷òî ñõåìà àâòîìàòè÷åñêè ñîçäàåò ññûëêè âïåðåä íà íåîïðåäåëåííûå ïðîñòûå òèïû + return $type; + } else { + if ($this->isTemplateSpec) { + return new Schema::TemplateSpec($this->Name,map {ref $_ eq __PACKAGE__ ? $_->Resolve($TypeTable,$DoNotCreate) : Schema::TypeName->new($_)->Resolve($TypeTable,$DoNotCreate)} @{$this->{TemplateList}} ); + } else { + die new Exception("Simple type not found", $this->Name); + } + } +} + +package Schema::TypeTable; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty(Table => ACCESS_NONE); + DeclareProperty(NextTable => ACCESS_NONE); +} + +sub CTOR { + my ($this,$nextTable) = @_; + $this->{$NextTable} = $nextTable; +} + +sub ResolveType { + my ($this,$TypeName,@args) = @_; + + if (my $Type = $this->{$Table}->{$TypeName->CanonicalName}) { + return $Type; + } elsif($this->{$NextTable}) { + return $this->{$NextTable}->ResolveType($TypeName,@args); + } else { + return undef; + } +} + +sub RegisterType { + my ($this,$Type) = @_; + + if (not $this->{$Table}->{$Type->Name->CanonicalName}) { + $this->{$Table}->{$Type->Name->CanonicalName} = $Type; + } else { + die new Exception("A type already registered",$Type->Name->CanonicalName); + } +} + +sub _ListTypes { + my $this = shift; + return values %{$this->{$Table}}; +} + +sub Dispose { + my $this = shift; + + $_->Dispose foreach values %{$this->{$Table} ? $this->{$Table} : {} }; + + delete $this->{$Table}; + + $this->SUPER::Dispose; +} + +# Ñïåöèàëèçàöèÿ øàáëîíà - ýòî èìÿ ñïåöèàëèçèðóåìîãî øàáëîíà è ïàðàìåòðû, êîòîðûå áóäóò åìó ïåðåäàíû (âàæåí ïîðÿäîê ïàðàìåòðîâ) +# Ñïåöèàëèçàöèÿ øàáëîíà ïàðàìåòðàìè ïîðàæäàåò ÷àñòè÷íî ñïåöèàëèçèðîâàííûé øàáëîí, êîòîðûé ïî ñóòè òàêæå ÿâëÿåòñÿ øàáëîíîì +# Åñëè ñïåöèàëèçàöèÿ ïîëíàÿ, òî ìîæíî ñîçäàòü ýêçåìïëÿð øàáëîíà, òîåñòü ïîëíîöåííûé òèï +package Schema::TemplateSpec; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty(Name => ACCESS_READ); + DeclareProperty(Parameters => ACCESS_READ); + DeclareProperty(TemplateList => ACCESS_READ); +} + +sub CTOR { + my ($this,$templateName,@typeList) = @_; + + my %Params; + + $this->{$TemplateList} = \@typeList; + + # âû÷èñëÿåì ïàðàìåòðû äàííîé ñïåöèàëèçàöèè + my @nameList; + foreach $typeItem (@typeList) { + map { $Params{$_->Name} = $_ } @{$typeItem->Parameters} if $typeItem->isTemplate; + push @nameList, $typeItem->Name; + } + + $this->{$Parameters} = [ values %Params ]; + $this->{$Name} = new Schema::TypeName($templateName,@nameList); +} + +sub isTemplate { + 1; +} + +sub canInstantinate { + my ($this) = @_; + if (@{$this->{$Parameters}}) { + 0; + } else { + 1; + } +} + +sub Specialize { + my ($this,$refParams,$TypeTable) = @_; + + my @specializedList = map {$_->isTemplate && !$_->canInstantinate ? $_->Specialize($refParams,$TypeTable) : $_ } @{$this->{$TemplateList}}; + + if ($TypeTable) { + + my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList); + my $templateSpec = $TypeTable->ResolveType($TypeName); + if (not $templateSpec) { + $templateSpec = new Schema::TemplateSpec($this->Name->Name,@specializedList); + $TypeTable->RegisterType($templateSpec); + } + return $templateSpec; + } else { + return new Schema::TemplateSpec($this->Name->Name,@specializedList); + } +} + +# Ïàðàìåòð øàáëîíà +# Ïî ñóòè ÿâëÿåòñÿ øàáëîíîì òèïà Param_Name<T> -> T; +package Schema::Parameter; + +sub new { + my $TypeName = new Schema::TypeName($_[1]); + bless \$TypeName,$_[0]; +} + +sub Name { + ${shift()}; +} + +sub Specialize { + my ($this,$refArgs) = @_; + return $refArgs->{$$this->Name}; +} + +sub isTemplate { + 1; +} + +sub canInstantinate { + 0; +} + +sub Parameters { + if (wantarray) { + shift; + } else { + [shift]; + } +} + + +# ×ëåí êëàññà +package Schema::Member; +use Common; +our @ISA = qw(Object); +our $Abstract = 1; + +BEGIN { + DeclareProperty(Name => ACCESS_READ); +} +sub CTOR { + my($this,$name) = @_; + + $this->{$Name} = $name; +} + +# ×ëåí êëàññà - ñâîéñòâî. +# Ñâîéñòâî ìîæåò áûòü øàáëîíîì, åñëè øàáëîíîì ÿâëÿåòñÿ åãî òèï +package Schema::Property; +use Common; +our @ISA = qw(Schema::Member); + +BEGIN { + DeclareProperty(Type => ACCESS_READ); +} + +sub CTOR { + my ($this,$name,$type) = @_; + $this->SUPER::CTOR($name); + + $this->{$Type} = $type or die new Exception("A type for the property must be specified",$name); +} + +sub isTemplate { + my $this = shift; + return $this->{$Type}->isTemplate; +} + +sub canInstantinate { + my $this = shift; + return $this->{$Type}->canInstantinate; +} + +sub Instantinate { + my ($this,$Schema) = @_; + return new Schema::Property($this->Name,$Schema->Instantinate($this->{$Type})); +} + +sub Specialize { + my ($this,$refParams,$TypeTable) = @_; + return new Schema::Property($this->Name,$this->{$Type}->Specialize($refParams,$TypeTable)); +} + +# Òèï, îïèñûâàåò òèï îáúåêòà +package Schema::Type; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty(Name => ACCESS_READ); + DeclareProperty(Schema => ACCESS_READ); + DeclareProperty(Members => ACCESS_READ); + DeclareProperty(BaseList => ACCESS_READ); + DeclareProperty(Attributes => ACCESS_READ); #hash of attributes +} + +sub CTOR { + my ($this,$argSchema,$name) = @_; + + $this->{$Name} = ref $name eq 'Schema::TypeName' ? $name : new Schema::TypeName($name); + $this->{$Schema} = $argSchema; +} + +sub isTemplate { + 0; +} + +sub Equals { + my ($this,$other) = @_; + if (UNIVERSAL::isa($other,'Schema::Type')) { + return ($this->Name->CanonicalName eq $other->Name->CanonicalName); + } else { + return 1; + } +} + +sub CreateProperty { + my ($this,$PropName,$TypeName) = @_; + + $PropType = $this->_ResolveType($TypeName); + + return new Schema::Property($PropName,$PropType); +} + +sub AddBase { + my ($this,$type) = @_; + + $type = $this->_ResolveType($type); + + not $type->isType($this) or die new Exception('Cant derive from the class which is derived from self', $this->Name->CanonicalName, $type->Name->CanonicalName); + + push @{$this->{$BaseList}},$type; +} + +sub isType { + my ($this,$type,$maxlevel) = @_; + + return 0 if defined $maxlevel and $maxlevel < 0; + my $typeName = UNIVERSAL::isa($type,'Schema::Type') ? $type->Name : $type ; + + return ( + $this->{$Name}->CanonicalName eq $typeName->CanonicalName ? + 1 + : + scalar (grep {$_->isType($typeName,defined $maxlevel ? $maxlevel - 1 : undef)} $this->BaseList) + ); +} + +sub ValidateType { + my ($this,$type) = @_; + + die new Exception('Can\'t use an unspecialized template',$type->Name->CanonicalName) if ($type->isa('Schema::TypeTemplate')); + + if ($type->isTemplate and not $type->canInstantinate) { + die new Exception('Cant use a not fully specialized template in a simple type',$type->Name->CanonicalName, $this->Name->Name) if not $this->isTemplate; + + my %Params = map {$_->Name->Name() , 1} @{$this->Parameters}; + my @Unresolved = grep {not $Params{$_->Name->Name}} @{$type->Parameters()}; + + die new Exception('Not all parameters can be rsolved',map {$_->Name->Name} @Unresolved) if @Unresolved; + } +} + +sub InsertProperty { + my ($this,$PropName,$PropType) = @_; + + $PropType = $this->_ResolveType($PropType); + + my $prop = new Schema::Property($PropName,$PropType); + + push @{$this->{$Members}}, $prop; + + return $prop; +} + +sub AddMember { + my ($this,$member) = @_; + + push @{$this->{$Members}},$member; +} + +sub GetTypeTable { + my $this = shift; + return $this->{$Schema}; +} + +sub _ResolveType { + my ($this,$type) = @_; + if ($type->isa('Schema::TypeName')) { + $type = $type->Resolve($this->GetTypeTable()); + } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) { + $this->ValidateType($type); + } else { + die new Exception('Invalid type',$type); + } + + $type = $this->{$Schema}->Instantinate($type) if ($type->isTemplate and $type->canInstantinate and not $this->isTemplate); + return $type; +} + +sub ListMembers { + my ($this,%options) = @_; + + my @members; + + if ($options{'foreign'}) { + push @members, $_->isa('Schema::Type') ? $_->ListMembers(%options) : () foreach @{$this->{$BaseList} ? $this->{$BaseList} : []}; + } + push @members, @{$this->{$Members} ? $this->{$Members} : []}; + + return @members; +} + +sub FindMembers { + my ($this,$memberName,%options) = @_; + + my @members = grep { $_->Name eq $memberName} @{$this->{$Members} ? $this->{$Members} : []}; + + if ($options{'deep'}) { + push @members,$_->ListMembers(%options) foreach @{$this->{$BaseList} ? $this->{$BaseList} : []}; + } + + if(wantarray) { + return @members; + } else { + return shift @members; + } +} + +sub SetAttributes { + my ($this,%attributes) = @_; + + while (my ($key,$value) = each %attributes) { + $this->{$Attributes}{$key} = $value; + } +} + +sub GetAttribute { + my ($this,$name) = @_; + + return $this->{$Attributes}{$name}; +} + +sub _dump { + my ($this) = @_; + return $this->Name->CanonicalName; +} + +sub Dispose { + my ($this) = @_; + + undef %{$this}; + $this->SUPER::Dispose; +} + +# Øàáëîí - ïðàìåòðèçîâàííûé òèï +package Schema::Template; +use Common; +our @ISA = qw(Schema::Type); + +BEGIN { + DeclareProperty(Parameters => ACCESS_READ); + DeclareProperty(LocalTypes => ACCESS_NONE); + +} + +sub CTOR { + my ($this,$Schema,$name,@args) = @_; + # ïàðàìåòðû íå ÿâëÿþòñÿ ÷à÷òüþ èìåíè + $this->SUPER::CTOR($Schema,$name); + + $this->{$Parameters} = [ map {new Schema::Parameter($_) } @args ]; + my $TypeTable = new Schema::TypeTable($Schema); + $TypeTable->RegisterType($_) foreach @{$this->{$Parameters} }; + $this->{$LocalTypes} = $TypeTable; +} + +sub GetTypeTable { + my ($this) = @_; + return $this->{$LocalTypes}; +} + +sub isTemplate { + 1; +} + +sub Specialize { + my ($this,$refArgs,$TypeTable) = @_; + + my @specializedList = map {$_->Specialize($refArgs)} @{$this->{$Parameters}}; + + # ñîçäàåì ñïåöèàëèçàöèþ øàáëîíà + my $specializedType; + + if ($TypeTable) { + my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList); + + if(my $specializedType = $TypeTable->ResolveType($TypeName)) { + return $specializedType; + } else { + $specializedType = new Schema::TemplateSpec($this->Name->Name, @specializedList ); + $TypeTable->RegisterType($specializedType); + return $specializedType; + } + } else { + return new Schema::TemplateSpec($this->Name->Name, @specializedList ); + } +} + +sub canInstantinate { + 0; +} + +# ñîçäàíèå ýêçåìïëÿðà øàáëîíà. +# Ñîçäàòü øàáëîí = ïîëíîñòüþ åãî ñïåöèàëèçèðîâàòü +# Ïðèíèìàåò íàáîð ïàðàìåòðîâ øàáëîíà è ñîçäàåò íîâûé òèï èëè âîçâðàùàåò èç ñõåìû +sub Instantinate { + my ($this,$refArgs,$instance) = @_; + + my %ParamInstances; + my @TemplateListNames; + + foreach my $param (@{$this->{$Parameters}}) { + my $type = $refArgs->{$param->Name->Name}; + die new Exception("Parameter not specified",$param->Name->Name) if not $type; + if ($type->isTemplate) { + if ($type->canInstantinate) { + $type = $this->Schema->Instantinate($type); + } else { + die new Exception("Parameter must be a fully speciazlied type",$param->Name->Name); + } + } + + $ParamInstances{$param->Name->Name} = $type; + push @TemplateListNames, $type->Name; + } + + # ïàðàìåòðû ïðåäñòàâëÿþò ñîáîé ðåàëüíûå òèïû, ïåðåõîäèì ê ñîçäàíèþ òèïà + # äàííàÿ ôóíêöèÿ áåóñëîâíî ñîçäàåò íîâûé òèï, ýòó ôóíêöèþ èñïîëüçóåò ñõåì + + $instance = $this->Schema->CreateType( new Schema::TypeName($this->Name->Name,@TemplateListNames) ) if not $instance; + + $instance->SetAttributes(%{$this->Attributes}) if $this->Attributes; + $instance->SetAttributes( + TemplateInstance => { + Template => $this, + Parameters => \%ParamInstances + } + ); + + foreach my $Ancestor ($this->BaseList) { + $instance->AddBase( + $Ancestor->isTemplate ? + ( $Ancestor->canInstantinate ? + $this->Schema->Instantinate($Ancestor) + : + $this->Schema->Instantinate($Ancestor->Specialize(\%ParamInstances,$this->GetTypeTable)) + ) + : + $Ancestor + ); + } + + foreach my $Member ($this->Members) { + $instance->AddMember( + $Member->isTemplate ? + ($Member->canInstantinate ? + $Member->Instantinate($this->Schema) + : + $Member->Specialize(\%ParamInstances,$this->GetTypeTable)->Instantinate($this->Schema) + ) + : + $Member + ); + } + + return $instance; +} + +sub _ResolveType { + my ($this,$type) = @_; + if ($type->isa('Schema::TypeName')) { + $type = $type->Resolve($this->GetTypeTable()); + if (not $this->{$LocalTypes}->ResolveType($type->Name)) { + $this->{$LocalTypes}->RegisterType($type); + } + } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) { + $this->ValidateType($type); + } else { + die new Exception('Invalid type',$type); + } + + return $type; +} + + +package Schema; +use strict; +use Common; +our @ISA = qw(Schema::TypeTable); + +BEGIN { + DeclareProperty(PendingInstances => ACCESS_NONE); + DeclareProperty(UnresolvedTypes => ACCESS_NONE); +} + +sub CTOR { + +} + +# Ñõåìà àâòîìàòè÷åñêè ñîçäàåò ññûëêè âïåðåä íà íåñóùåñòâóþùèå ïðîñòûå òèïû +sub ResolveType { + my ($this,$TypeName,$DoNotCreate) = @_; + + if (my $type = $this->SUPER::ResolveType($TypeName)) { + return $type; + } else { + if (not $TypeName->isTemplateSpec and not $DoNotCreate) { + $type = new Schema::Type($this,$TypeName); + $this->RegisterType($type); + $this->{$UnresolvedTypes}->{$TypeName->CanonicalName} = $TypeName; + return $type; + } else { + return undef; + } + } +} + +sub CreateType { + my ($this,$TypeName) = @_; + + $TypeName = new Schema::TypeName($TypeName) if ref $TypeName ne 'Schema::TypeName'; + + if (my $type = $this->SUPER::ResolveType($TypeName)) { + if ($this->{$UnresolvedTypes}->{$TypeName->CanonicalName}) { + delete $this->{$UnresolvedTypes}->{$TypeName->CanonicalName}; + return $type; + } else { + die new Exception("Type already exists",$TypeName->CanonicalName); + } + } else { + $type = new Schema::Type($this,$TypeName); + $this->SUPER::RegisterType($type); + return $type; + } +} + +sub CreateTemplate { + my ($this,$TemplateName,@ParamNames) = @_; + + die new Exception("Parameters required for the template") if not @ParamNames; + + if (ref $TemplateName eq 'Schema::TypeName') { + die new Exception('Template specialization is not valid name for a new template',$TemplateName->CanonicalName) if $TemplateName->isTemplateSpec; + } else { + $TemplateName = new Schema::TypeName($TemplateName); + } + + if (my $type = $this->SUPER::ResolveType($TemplateName)) { + die new Exception('Type already exists'); + } else { + $type = new Schema::Template($this,$TemplateName,@ParamNames); + $this->SUPER::RegisterType($type); + return $type; + } +} + +# ñîçäàíèå ýêçåìïëÿðà øàáëîíà +# ñîçäàåòñÿ íîâûé ïóñòîé òèï, äîáàâëÿåòñÿ â PendingInstances +sub Instantinate { + my ($this,$TemplateSpec) = @_; + + # ïðè ñïåöèàëèçàöèè íàïðìåð ýòîãî: T m_var; ïîëó÷èì äëÿ èíñòàíòèíèöèè real_type m_var; è íå ïðîâåðÿÿ îòäàäèì åãî íà ñïåöèàëèçàöèþ, + # âîò è îáðàáîòêà + return $TemplateSpec if not $TemplateSpec->isTemplate; + + die new Exception('Only a template specialization can be instantinated') if ref $TemplateSpec ne 'Schema::TemplateSpec'; + die new Exception('Only fully specialized template can be instantinated') if not $TemplateSpec->canInstantinate; + + my $TypeName = $TemplateSpec->Name; + + if (my $type = $this->SUPER::ResolveType($TypeName)) { + return $type; + } else { + $type = new Schema::Type($this,$TypeName); + $this->SUPER::RegisterType($type); + push @{$this->{$PendingInstances}},[$TemplateSpec,$type]; + return $type; + } +} + +sub Close { + my ($this) = @_; + + if (keys %{$this->{$UnresolvedTypes}}) { + die new Exception('Some type definitions are absent',keys %{$this->{$UnresolvedTypes}}); + } + + if ($this->{$PendingInstances}) { + while( my $ref = shift @{$this->{$PendingInstances}} ) { + my ($spec,$instance) = @$ref; + if (my $typeTemplate = $this->SUPER::ResolveType( new Schema::TypeName($spec->Name->Name) )) { + die new Exception('Can\'t instantinate a specialization of the simple type',$instance->Name->CanonicalName) if not $typeTemplate->isTemplate; + if (scalar(@{$typeTemplate->Parameters}) == scalar(@{$spec->TemplateList})) { + my @Params = @{$typeTemplate->Parameters}; + $typeTemplate->Instantinate({map { (shift @Params)->Name->Name, $_ } @{$spec->TemplateList}},$instance); + } else { + die new Exception('A template parameters doesn\'t match to the specialization list',$instance->Name->CanonicalName); + } + } else { + die new Exception('Can\'t instantinate a specialization, the specified template isn\'t found', $instance->Name->CanonicalName); + } + } + + delete $this->{$PendingInstances}; + } +} + +sub EnumTypes { + my ($this,%options) = @_; + + return grep { ($_->isTemplate and not $options{'skip_templates'}) or (not $_->isTemplate and not $options{'skip_classes'}) } $this->_ListTypes; +} + +sub Dispose { + my ($this) = @_; + + delete $this->{$UnresolvedTypes}; + + $this->SUPER::Dispose; +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,57 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Column.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,56 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Constraint.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,48 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Constraint/ForeignKey.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,58 @@ +package Schema::DB::Constraint::ForeignKey; +use strict; +use Common; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Constraint/Index.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,14 @@ +package Schema::DB::Constraint::Index; +use strict; +use Common; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Constraint/PrimaryKey.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,40 @@ +package Schema::DB::Constraint::PrimaryKey; +use strict; +use Common; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Constraint/Unique.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,6 @@ +package Schema::DB::Constraint::PrimaryKey; +use strict; +use Common; +use base qw(Schema::DB::Constraint::Index); + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Table.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,168 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Traits.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,268 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Traits/mysql.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,549 @@ +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 base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DB/Type.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,42 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DataSource.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,138 @@ +package Configuration; +our $DataDir; +package Schema::DataSource; +use Common; +use strict; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DataSource/CDBIBuilder.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,326 @@ +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 base '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 base '$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 base '$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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/DataSource/TypeMapping.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,46 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/Form.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,252 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/Form/Container.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,41 @@ +package Schema::Form::Container; +use Form::Container; +use Common; +use base 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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/Form/Field.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,33 @@ +package Schema::Form::Field; +use strict; +use Common; +use base 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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/Form/Filter.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,46 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/Form/Format.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,26 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Schema/Form/Item.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,41 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Security.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,38 @@ +use strict; +package Security; + +use constant { + AUTH_FAILED => 0, + AUTH_SUCCESS => 1, + AUTH_INCOMPLETE => 2, + AUTH_NOAUTH => 3 +}; + +my $CurrentSession; + +sub CurrentSession { + my ($class,$newSession) = @_; + + $CurrentSession = $newSession if @_>=2; + return $CurrentSession; +} + +package Security::AuthResult; +use Common; +our @ISA = qw(Object); + +BEGIN { + DeclareProperty State => ACCESS_READ; + DeclareProperty Session => ACCESS_READ; + DeclareProperty ClientSecData => ACCESS_READ; + DeclareProperty AuthMod => ACCESS_READ; +} + +sub isSuccess { + my ($this) = @_; + return $this->{$State} == Security::AUTH_SUCCESS; +} + + +1; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Security/Auth.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,108 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Security/Auth/Simple.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,73 @@ +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;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/Security/Authz.pm Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,33 @@ +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; +} \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Schema/form.def Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,39 @@ +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; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Schema/query.def Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,27 @@ +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 ...] \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Schema/schema.def Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,43 @@ +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} ...] \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Schema/type.def Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,3 @@ +syntax ::= name [<\<>syntax [, syntax ...]<\>>] + +name ::= <\w>+ \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/object.t Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; + +package Foo; +use base qw(IMPL::Object); + +sub CTOR { + my ($this,%args) = @_; + print "CTOR Foo $args{Name}\n"; +} + +sub Hello { + print "Hello"; +} + +package Bar; +use base qw(Foo); + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + print "CTOR Bar\n"; +} + +package main; + +my $obj = new Bar ( Name => 'Tom') ; + +Hello $obj; + +no strict 'refs'; +print "$_\n" foreach sort keys %{'Bar::'}; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/impl.kpf Tue Jul 14 12:54:37 2009 +0400 @@ -0,0 +1,475 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!-- Komodo Project File - DO NOT EDIT --> +<project id="66c7d414-175f-45b6-92fe-dbda51c64843" kpf_version="4" name="impl.kpf"> +<preference-set idref="155f1fd9-8a20-46fe-90d5-8fbe879632d8"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="231b32db-32cc-4b4f-a1fd-ec418c60fb9e"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="348513f9-f7e1-48ab-834f-a76f43719a26"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="3780f0c1-052f-4f34-8cb6-468c31e84394"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843"> + <boolean id="import_live">1</boolean> +</preference-set> +<preference-set idref="7e7fa5c6-0123-4570-8540-b1366b09b7dd"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="8299da70-10fd-4473-9ebd-34fb743d1271"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="8c398590-1760-4ade-a1cb-1b8a5e391306"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="8cc14854-53cc-4857-bed8-bf9bb929620e"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="b2468e36-4932-4ffc-9ab9-200b1e54a7f0"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="c01c5f46-5002-426d-9a5a-0bb1a41bf197"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="ca1ec41d-47db-484f-8eae-b3d4f4b901b7"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="d1e2b231-7a47-44e7-97f9-d51957c66878"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="d92426a8-1235-4c1e-88ee-7501053cfacb"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="da9d3317-c70c-485c-abf4-cd8bb1cba727"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="dbdc5a72-bd97-4191-812d-cefac1b65891"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="e999586b-011c-4db1-bf57-6bdede03ca91"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="f1269b8e-02ae-42cc-98a6-6373ee338440"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +<preference-set idref="f1aa4569-54e1-499d-a6f5-f4b27c1ed611"> +<preference-set id="Invocations"> +<preference-set id="default"> + <string id="cookieparams"></string> + <string id="cwd"></string> + <long id="debugger.io-port">9011</long> + <string id="documentRoot"></string> + <string id="executable-params"></string> + <string relative="path" id="filename">_test/object.t</string> + <string id="getparams"></string> + <string id="language">Perl</string> + <string id="mpostparams"></string> + <string id="params"></string> + <string id="postparams"></string> + <string id="posttype">application/x-www-form-urlencoded</string> + <string id="request-method">GET</string> + <boolean id="show-dialog">1</boolean> + <boolean id="sim-cgi">0</boolean> + <boolean id="use-console">0</boolean> + <string id="userCGIEnvironment"></string> + <string id="userEnvironment"></string> + <string id="warnings">enabled</string> +</preference-set> +</preference-set> + <string id="lastInvocation">default</string> +</preference-set> +</project>