# HG changeset patch # User wizard@linux-odin.local # Date 1267170561 -10800 # Node ID 16ada169ca7561efaa3e0fdfef19a15831339c66 # Parent 1c3c3e63a3142fe3a89178fc67f7bd10c1cb7dbc migrating to the Eclipse IDE diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/BNFCompiler.pm --- a/Lib/BNFCompiler.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/BNFCompiler.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,666 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/CDBI/Map.pm --- a/Lib/CDBI/Map.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/CDBI/Map.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,110 +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 +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 diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/CDBI/Meta.pm --- a/Lib/CDBI/Meta.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/CDBI/Meta.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,20 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/CDBI/Transform.pm --- a/Lib/CDBI/Transform.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/CDBI/Transform.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,105 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Common.pm --- a/Lib/Common.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Common.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,282 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Configuration.pm --- a/Lib/Configuration.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Configuration.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,37 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM.pm --- a/Lib/DOM.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,19 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Page.pm --- a/Lib/DOM/Page.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Page.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,241 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Providers/Form.pm --- a/Lib/DOM/Providers/Form.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Providers/Form.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,49 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Providers/Gallery.pm --- a/Lib/DOM/Providers/Gallery.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Providers/Gallery.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,200 +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>/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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Providers/Headlines.pm --- a/Lib/DOM/Providers/Headlines.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Providers/Headlines.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,128 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Providers/Page.pm --- a/Lib/DOM/Providers/Page.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Providers/Page.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,258 +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 +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 diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Providers/Perfomance.pm --- a/Lib/DOM/Providers/Perfomance.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Providers/Perfomance.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,15 +1,15 @@ -use strict; - -package DOM::Providers::Perfomance; -use PerfCounter; - -sub GetProviderInfo { - return { - Name => 'Perfomance', - Host => 'DOM::Site', - Objects => { - Counters => \%PerfCounter::Counters - } - } -} -1; +use strict; + +package DOM::Providers::Perfomance; +use PerfCounter; + +sub GetProviderInfo { + return { + Name => 'Perfomance', + Host => 'DOM::Site', + Objects => { + Counters => \%PerfCounter::Counters + } + } +} +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Providers/Security.pm --- a/Lib/DOM/Providers/Security.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Providers/Security.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,19 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DOM/Site.pm --- a/Lib/DOM/Site.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DOM/Site.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,80 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/DateTime.pm --- a/Lib/DateTime.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/DateTime.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,312 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment.pm --- a/Lib/Deployment.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,15 +1,15 @@ -package Deployment; -use strict; - -our %DeploymentScheme; -our %DeployMethod; - -sub isUpdateNeeded { - -} - -sub Update { - -} - -1; +package Deployment; +use strict; + +our %DeploymentScheme; +our %DeployMethod; + +sub isUpdateNeeded { + +} + +sub Update { + +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch.pm --- a/Lib/Deployment/Batch.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,129 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/Backup.pm --- a/Lib/Deployment/Batch/Backup.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/Backup.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,48 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/CDBIUpdate.pm --- a/Lib/Deployment/Batch/CDBIUpdate.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/CDBIUpdate.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,139 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/CopyFile.pm --- a/Lib/Deployment/Batch/CopyFile.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/CopyFile.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,45 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/CopyTree.pm --- a/Lib/Deployment/Batch/CopyTree.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/CopyTree.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,5 +1,5 @@ -package Deployment::Batch::CopyTree; -use base 'Deployment::Batch::Generic'; -use Common; - -1; +package Deployment::Batch::CopyTree; +use base 'Deployment::Batch::Generic'; +use Common; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/CustomAction.pm --- a/Lib/Deployment/Batch/CustomAction.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/CustomAction.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,32 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/Generic.pm --- a/Lib/Deployment/Batch/Generic.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/Generic.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,87 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/Batch/Temp.pm --- a/Lib/Deployment/Batch/Temp.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/Batch/Temp.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,52 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Deployment/CDBI.pm --- a/Lib/Deployment/CDBI.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Deployment/CDBI.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,101 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Action.pm --- a/Lib/Engine/Action.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Action.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,65 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Action/URICall.pm --- a/Lib/Engine/Action/URICall.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Action/URICall.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,42 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/CGI.pm --- a/Lib/Engine/CGI.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/CGI.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,67 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Output/JSON.pm --- a/Lib/Engine/Output/JSON.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Output/JSON.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,56 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Output/Page.pm --- a/Lib/Engine/Output/Page.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Output/Page.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,34 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Output/Template.pm --- a/Lib/Engine/Output/Template.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Output/Template.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,55 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Security.pm --- a/Lib/Engine/Security.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Security.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,36 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Security/AccessDeniedException.pm --- a/Lib/Engine/Security/AccessDeniedException.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Security/AccessDeniedException.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,13 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Security/Auth.pm --- a/Lib/Engine/Security/Auth.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Security/Auth.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,94 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Security/Cookies.pm --- a/Lib/Engine/Security/Cookies.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Security/Cookies.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,27 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Engine/Security/IPSession.pm --- a/Lib/Engine/Security/IPSession.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Engine/Security/IPSession.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,48 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form.pm --- a/Lib/Form.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,147 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Container.pm --- a/Lib/Form/Container.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Container.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,170 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Filter.pm --- a/Lib/Form/Filter.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Filter.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,67 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Filter/Depends.pm --- a/Lib/Form/Filter/Depends.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Filter/Depends.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,34 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Filter/Mandatory.pm --- a/Lib/Form/Filter/Mandatory.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Filter/Mandatory.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,34 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Filter/Regexp.pm --- a/Lib/Form/Filter/Regexp.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Filter/Regexp.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,38 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Item.pm --- a/Lib/Form/Item.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Item.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,79 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/ItemId.pm --- a/Lib/Form/ItemId.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/ItemId.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,46 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/Transform.pm --- a/Lib/Form/Transform.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/Transform.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,29 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/ValueItem.pm --- a/Lib/Form/ValueItem.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/ValueItem.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,47 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Form/ValueItem/List.pm --- a/Lib/Form/ValueItem/List.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Form/ValueItem/List.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,107 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Class/Member.pm --- a/Lib/IMPL/Class/Member.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/Member.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,37 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Class/MemberInfo.pm --- a/Lib/IMPL/Class/MemberInfo.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/MemberInfo.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,48 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Class/Meta.pm --- a/Lib/IMPL/Class/Meta.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/Meta.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,43 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Class/Property.pm --- a/Lib/IMPL/Class/Property.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/Property.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,35 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Class/Property/Direct.pm --- a/Lib/IMPL/Class/Property/Direct.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/Property/Direct.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,111 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Class/PropertyInfo.pm --- a/Lib/IMPL/Class/PropertyInfo.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/PropertyInfo.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,57 +1,57 @@ -package IMPL::Class::PropertyInfo; -use strict; - -use base qw(IMPL::Class::MemberInfo); - -__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet)); -__PACKAGE__->PassThroughArgs; - -my %LoadedModules; - -sub CTOR { - my $this = shift; - - if ( my $type = $this->Attributes ? delete $this->Attributes->{type} : undef ) { - $this->Type($type); - } - - $this->Mutators(0) unless defined $this->Mutators; -} - -sub Implementor { - my $this = shift; - - my $implementor; - - if (@_) { - $this->SUPER::Implementor(@_); - } else { - my $implementor = $this->SUPER::Implementor; - return $implementor if $implementor; - - $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->Implementor($implementor); - return $implementor; - } - -} - -sub SelectImplementor { - my ($this) = @_; - - if ($this->Class->can('_PropertyImplementor')) { - return $this->Class->_PropertyImplementor; - } - die new IMPL::Exception('Can\'t find a property implementor for the specified class',$this->Class); -} - -1; \ No newline at end of file +package IMPL::Class::PropertyInfo; +use strict; + +use base qw(IMPL::Class::MemberInfo); + +__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet)); +__PACKAGE__->PassThroughArgs; + +my %LoadedModules; + +sub CTOR { + my $this = shift; + + if ( my $type = $this->Attributes ? delete $this->Attributes->{type} : undef ) { + $this->Type($type); + } + + $this->Mutators(0) unless defined $this->Mutators; +} + +sub Implementor { + my $this = shift; + + my $implementor; + + if (@_) { + $this->SUPER::Implementor(@_); + } else { + my $implementor = $this->SUPER::Implementor; + return $implementor if $implementor; + + $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->Implementor($implementor); + return $implementor; + } + +} + +sub SelectImplementor { + my ($this) = @_; + + if ($this->Class->can('_PropertyImplementor')) { + return $this->Class->_PropertyImplementor; + } + die new IMPL::Exception('Can\'t find a property implementor for the specified class',$this->Class); +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Config.pm --- a/Lib/IMPL/Config.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Config.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,132 +1,132 @@ -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 - -=over - -=item static LoadXMLFile($fileName) -Создает из XML файла экземпляр приложения - -=item SaveXMLFile($fileName) -Сохраняет приложение в файл - -=item xml -Сохраняет конфигурацию приложения в XML строку - -=back - -=cut \ No newline at end of file +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 + +=over + +=item static LoadXMLFile($fileName) +Создает из XML файла экземпляр приложения + +=item SaveXMLFile($fileName) +Сохраняет приложение в файл + +=item xml +Сохраняет конфигурацию приложения в XML строку + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Config/Class.pm --- a/Lib/IMPL/Config/Class.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Config/Class.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,52 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Config/Container.pm --- a/Lib/IMPL/Config/Container.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Config/Container.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,40 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Document.pm --- a/Lib/IMPL/DOM/Document.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Document.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,51 +1,51 @@ -package IMPL::DOM::Document; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); - -__PACKAGE__->PassThroughArgs; - -sub document { - return $_[0]; -} - -sub Create { - my ($this,$nodeName,$class,$refProps) = @_; - - $refProps ||= {}; - - delete $refProps->{nodeName}; - - return $class->new( - nodeName => $nodeName, - document => $this, - %$refProps - ); -} - -{ - my $empty; - sub Empty() { - return $empty ? $empty : $empty = __PACKAGE__->new(nodeName => 'Empty'); - } -} - -1; -__END__ - -=pod - -=head1 DESCRIPTION - -=head1 METHODS - -=over - -=item C<<$doc->Create>> - -Создает узел определеннго типа с определенным именем и свойствами. - -=back - -=cut \ No newline at end of file +package IMPL::DOM::Document; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); + +__PACKAGE__->PassThroughArgs; + +sub document { + return $_[0]; +} + +sub Create { + my ($this,$nodeName,$class,$refProps) = @_; + + $refProps ||= {}; + + delete $refProps->{nodeName}; + + return $class->new( + nodeName => $nodeName, + document => $this, + %$refProps + ); +} + +{ + my $empty; + sub Empty() { + return $empty ? $empty : $empty = __PACKAGE__->new(nodeName => 'Empty'); + } +} + +1; +__END__ + +=pod + +=head1 DESCRIPTION + +=head1 METHODS + +=over + +=item C<<$doc->Create>> + +Создает узел определеннго типа с определенным именем и свойствами. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Navigator.pm --- a/Lib/IMPL/DOM/Navigator.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Navigator.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,274 +1,274 @@ -package IMPL::DOM::Navigator; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -BEGIN { - private _direct property _path => prop_all; - private _direct property _state => prop_all; - private _direct property _savedstates => prop_all; - public property Current => {get => \&_getCurrent}; -} - -sub CTOR { - my ($this,$CurrentNode) = @_; - - die IMPL::InvalidArgumentException("A starting node is a required paramater") unless $CurrentNode; - - $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; -} - -sub _initNavigator { - my ($this,$CurrentNode) = @_; - - die IMPL::InvalidArgumentException("A starting node is a required paramater") unless $CurrentNode; - - $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; - delete $this->{$_path}; - delete $this->{$_savedstates}; -} - -sub _getCurrent { - $_[0]->{$_state}{alternatives}[$_[0]->{$_state}{current}] -} - -sub Navigate { - my ($this,@path) = @_; - - return unless @path; - - my $node; - - foreach my $query (@path) { - if (my $current = $this->Current) { - - my @alternatives = $current->selectNodes($query); - - unless (@alternatives) { - $current = $this->advanceNavigator or return undef; - @alternatives = $current->selectNodes($query); - } - - push @{$this->{$_path}},$this->{$_state}; - $this->{$_state} = { - alternatives => \@alternatives, - current => 0, - query => $query - }; - - $node = $alternatives[0]; - } else { - return undef; - } - } - - $node; -} - -sub selectNodes { - my ($this,@path) = @_; - - return internalSelectNodes($this->Current,@path); -} - -sub internalSelectNodes { - my $node = shift; - my $query = shift; - - if (@_) { - return map internalSelectNodes($_,@_), $node->selectNodes($query); - } else { - return $node->selectNodes($query); - } -} - -sub internalNavigateNodeSet { - my ($this,@nodeSet) = @_; - - push @{$this->{$_path}}, $this->{$_state}; - - $this->{$_state} = { - alternatives => \@nodeSet, - current => 0 - }; - - $nodeSet[0]; -} - -sub fetch { - my ($this) = @_; - - my $result = $this->Current; - $this->advanceNavigator; - return $result; -} - -sub advanceNavigator { - my ($this) = @_; - - $this->{$_state}{current}++; - - if (@{$this->{$_state}{alternatives}} <= $this->{$_state}{current}) { - if ( exists $this->{$_state}{query} ) { - my $query = $this->{$_state}{query}; - - $this->Back or return undef; # that meams the end of the history - - undef while ( $this->advanceNavigator and not $this->Navigate($query)); - - return $this->Current; - } - return undef; - } - - return $this->Current; -} - -sub doeach { - my ($this,$code) = @_; - local $_; - - do { - for (my $i = $this->{$_state}{current}; $i < @{$this->{$_state}{alternatives}}; $i++) { - $_ = $this->{$_state}{alternatives}[$i]; - $code->(); - } - $this->{$_state}{current} = @{$this->{$_state}{alternatives}}; - } while ($this->advanceNavigator); -} - -sub Back { - my ($this,$steps) = @_; - if ($this->{$_path} and @{$this->{$_path}}) { - if ( (not $steps) || $steps == 1) { - $this->{$_state} = pop @{$this->{$_path}}; - } else { - $steps ||= 1; - - $steps = @{$this->{$_path}} - 1 if $steps >= @{$this->{$_path}}; - - $this->{$_state} = (splice @{$this->{$_path}},-$steps)[0]; - } - $this->Current if defined wantarray; - } else { - return undef; - } -} - -sub PathToString { - my ($this,$delim) = @_; - - $delim ||= '/'; - - join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); -} - -sub clone { - my ($this) = @_; - - my $newNavi = __PACKAGE__->surrogate; - - $newNavi->{$_path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; - $newNavi->{$_state} = { %{$this->{$_state}} }; - - return $newNavi; - -} - -sub saveState { - my ($this) = @_; - - my %state; - - $state{path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; - $state{state} = { %{$this->{$_state}} }; - - push @{$this->{$_savedstates}}, \%state; -} - -sub restoreState { - my ($this) = @_; - - if ( my $state = pop @{$this->{$_savedstates}||[]} ) { - $this->{$_path} = $state->{path}; - $this->{$_state} = $state->{state}; - } -} - -sub applyState { - my ($this) = @_; - - pop @{$this->{$_savedstates}||[]}; -} - -sub dosafe { - my ($this,$transaction) = @_; - - $this->saveState(); - - my $result; - - eval { - $result = $transaction->(); - }; - - if ($@) { - $this->restoreState(); - return undef; - } else { - $this->applyState(); - return $result; - } -} - -1; - -__END__ -=pod - -=head1 DESCRIPTION - -Объект для хождения по дереву DOM объектов. - -Результатом навигации является множество узлов (альтернатив). - -Состоянием навигатора является текущий набор узлов, позиция в данном наборе, -а также запрос по которому были получены данные результаты. - -Если при навигации указан путь сосящий из нескольких фильтров, то он разбивается -этапы простой навигации по кадой из частей пути. На каждом элементарном этапе -навигации образуется ряд альтернатив, и при каждом следующем этапе навигации -альтернативы предыдущих этапов могут перебираться, до получения положительного -результата навигации, в противном случае навигация считается невозможной. - -=head1 METHODS - -=over - -=item C<<$obj->new($nodeStart)>> - -Создает объект навигатора с указанной начальной позицией. - -=item C<<$obj->Navigate([$query,...])>> - -Перейти в новый узел используя запрос C<$query>. На данный момент запросом может -быть только имя узла и будет взят только первый узел. Если по запросу ничего не -найдено, переход не будет осуществлен. - -Возвращает либо новый узел в который перешли, либо C<undef>. - -=item C<<$obj->Back()>> - -Возвращается в предыдущий узел, если таковой есть. - -Возвращает либо узел в который перешли, либо C<undef>. - -=item C<<$obj->advanceNavigator()>> - -Переходит в следующую альтернативу, соответствующую текущему запросу. - -=back - -=cut \ No newline at end of file +package IMPL::DOM::Navigator; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +BEGIN { + private _direct property _path => prop_all; + private _direct property _state => prop_all; + private _direct property _savedstates => prop_all; + public property Current => {get => \&_getCurrent}; +} + +sub CTOR { + my ($this,$CurrentNode) = @_; + + die IMPL::InvalidArgumentException("A starting node is a required paramater") unless $CurrentNode; + + $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; +} + +sub _initNavigator { + my ($this,$CurrentNode) = @_; + + die IMPL::InvalidArgumentException("A starting node is a required paramater") unless $CurrentNode; + + $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; + delete $this->{$_path}; + delete $this->{$_savedstates}; +} + +sub _getCurrent { + $_[0]->{$_state}{alternatives}[$_[0]->{$_state}{current}] +} + +sub Navigate { + my ($this,@path) = @_; + + return unless @path; + + my $node; + + foreach my $query (@path) { + if (my $current = $this->Current) { + + my @alternatives = $current->selectNodes($query); + + unless (@alternatives) { + $current = $this->advanceNavigator or return undef; + @alternatives = $current->selectNodes($query); + } + + push @{$this->{$_path}},$this->{$_state}; + $this->{$_state} = { + alternatives => \@alternatives, + current => 0, + query => $query + }; + + $node = $alternatives[0]; + } else { + return undef; + } + } + + $node; +} + +sub selectNodes { + my ($this,@path) = @_; + + return internalSelectNodes($this->Current,@path); +} + +sub internalSelectNodes { + my $node = shift; + my $query = shift; + + if (@_) { + return map internalSelectNodes($_,@_), $node->selectNodes($query); + } else { + return $node->selectNodes($query); + } +} + +sub internalNavigateNodeSet { + my ($this,@nodeSet) = @_; + + push @{$this->{$_path}}, $this->{$_state}; + + $this->{$_state} = { + alternatives => \@nodeSet, + current => 0 + }; + + $nodeSet[0]; +} + +sub fetch { + my ($this) = @_; + + my $result = $this->Current; + $this->advanceNavigator; + return $result; +} + +sub advanceNavigator { + my ($this) = @_; + + $this->{$_state}{current}++; + + if (@{$this->{$_state}{alternatives}} <= $this->{$_state}{current}) { + if ( exists $this->{$_state}{query} ) { + my $query = $this->{$_state}{query}; + + $this->Back or return undef; # that meams the end of the history + + undef while ( $this->advanceNavigator and not $this->Navigate($query)); + + return $this->Current; + } + return undef; + } + + return $this->Current; +} + +sub doeach { + my ($this,$code) = @_; + local $_; + + do { + for (my $i = $this->{$_state}{current}; $i < @{$this->{$_state}{alternatives}}; $i++) { + $_ = $this->{$_state}{alternatives}[$i]; + $code->(); + } + $this->{$_state}{current} = @{$this->{$_state}{alternatives}}; + } while ($this->advanceNavigator); +} + +sub Back { + my ($this,$steps) = @_; + if ($this->{$_path} and @{$this->{$_path}}) { + if ( (not $steps) || $steps == 1) { + $this->{$_state} = pop @{$this->{$_path}}; + } else { + $steps ||= 1; + + $steps = @{$this->{$_path}} - 1 if $steps >= @{$this->{$_path}}; + + $this->{$_state} = (splice @{$this->{$_path}},-$steps)[0]; + } + $this->Current if defined wantarray; + } else { + return undef; + } +} + +sub PathToString { + my ($this,$delim) = @_; + + $delim ||= '/'; + + join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); +} + +sub clone { + my ($this) = @_; + + my $newNavi = __PACKAGE__->surrogate; + + $newNavi->{$_path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; + $newNavi->{$_state} = { %{$this->{$_state}} }; + + return $newNavi; + +} + +sub saveState { + my ($this) = @_; + + my %state; + + $state{path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; + $state{state} = { %{$this->{$_state}} }; + + push @{$this->{$_savedstates}}, \%state; +} + +sub restoreState { + my ($this) = @_; + + if ( my $state = pop @{$this->{$_savedstates}||[]} ) { + $this->{$_path} = $state->{path}; + $this->{$_state} = $state->{state}; + } +} + +sub applyState { + my ($this) = @_; + + pop @{$this->{$_savedstates}||[]}; +} + +sub dosafe { + my ($this,$transaction) = @_; + + $this->saveState(); + + my $result; + + eval { + $result = $transaction->(); + }; + + if ($@) { + $this->restoreState(); + return undef; + } else { + $this->applyState(); + return $result; + } +} + +1; + +__END__ +=pod + +=head1 DESCRIPTION + +Объект для хождения по дереву DOM объектов. + +Результатом навигации является множество узлов (альтернатив). + +Состоянием навигатора является текущий набор узлов, позиция в данном наборе, +а также запрос по которому были получены данные результаты. + +Если при навигации указан путь сосящий из нескольких фильтров, то он разбивается +этапы простой навигации по кадой из частей пути. На каждом элементарном этапе +навигации образуется ряд альтернатив, и при каждом следующем этапе навигации +альтернативы предыдущих этапов могут перебираться, до получения положительного +результата навигации, в противном случае навигация считается невозможной. + +=head1 METHODS + +=over + +=item C<<$obj->new($nodeStart)>> + +Создает объект навигатора с указанной начальной позицией. + +=item C<<$obj->Navigate([$query,...])>> + +Перейти в новый узел используя запрос C<$query>. На данный момент запросом может +быть только имя узла и будет взят только первый узел. Если по запросу ничего не +найдено, переход не будет осуществлен. + +Возвращает либо новый узел в который перешли, либо C<undef>. + +=item C<<$obj->Back()>> + +Возвращается в предыдущий узел, если таковой есть. + +Возвращает либо узел в который перешли, либо C<undef>. + +=item C<<$obj->advanceNavigator()>> + +Переходит в следующую альтернативу, соответствующую текущему запросу. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Navigator/Builder.pm --- a/Lib/IMPL/DOM/Navigator/Builder.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Navigator/Builder.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,97 +1,97 @@ -package IMPL::DOM::Navigator::Builder; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -require IMPL::DOM::Navigator::SchemaNavigator; - -BEGIN { - private _direct property _schemaNavi => prop_all; - private _direct property _nodesPath => prop_all; - private _direct property _nodeCurrent => prop_all; - private _direct property _docClass => prop_all - public _direct property Document => prop_get | owner_set; -} - -sub CTOR { - my ($this,$docClass,$schema) = @_; - - $this->{$_docClass} = $docClass; - $this->{$_schemaNavi} = $schema ? IMPL::DOM::Navigator::SchemaNavigator->new($schema) : undef; -} - -sub NavigateCreate { - my ($this,$nodeName,%props) = @_; - - if (my $schemaNode = $this->{$_schemaNavi}->NavigateName($nodeName)) { - my $class = $schemaNode->can('nativeType') ? $schemaNode->nativeType : 'IMPL::DOM::Node'; - - my $node; - if (! $this->{$Document}) { - $node = $this->{$Document} = $this->{$_docClass}->new(nodeName => $nodeName,%props); - } else { - die new IMPL::InvalidOperationException('Can\t create a second top level element') unless $this->{$_nodeCurrent}; - $node = $this->{$Document}->Create($nodeName,$class,\%props); - push @{$this->{$_nodesPath}}, $this->{$_nodeCurrent}; - $this->{$_nodeCurrent}->appendChild($node); - } - - $this->{$_nodeCurrent} = $node; - - return $node; - } else { - die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName); - } -} - -sub Back { - my ($this) = @_; - - $this->{$_schemaNavi}->SchemaBack(); - $this->{$_nodeCurrent} = pop @{$this->{$_nodesPath}}; -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -my $builder = new IMPL::DOM::Navigator::Builder(new MyApp::Document,$schema); -my $reader = new IMPL::DOM::XMLReader(Navigator => $builder); - -$reader->ParseFile("document.xml"); - -my @errors = $schema->Validate($builder->Document); - -=head1 DESCRIPTION - -Построитель DOM документов по указанной схеме. Обычно используется в связке -с объектами для чтения такими как C<IMPL::DOM::XMLReader>. - -=head1 METHODS - -=over - -=item C<CTOR($domDocument,$schema)> - -Создает новый объект, принимает на вход пустой (но не обязательно) документ и -схему. - -=item C<< $obj->NavigateCreate($nodeName) >> - -Создает новый узел с указанным именем и переходит в него. В случае если в схеме -подходящий узел не найден, то вызывается исключение. - -При этом по имени узла ищется его схема, после чего определяется класс для -создания экземпляра и созданный узел доавляется в документ. - -Также имя создаваемого узла НЕ может быть переопределено свойством nodeName, оно -будет проигнорировано. - -=back - -=cut \ No newline at end of file +package IMPL::DOM::Navigator::Builder; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +require IMPL::DOM::Navigator::SchemaNavigator; + +BEGIN { + private _direct property _schemaNavi => prop_all; + private _direct property _nodesPath => prop_all; + private _direct property _nodeCurrent => prop_all; + private _direct property _docClass => prop_all + public _direct property Document => prop_get | owner_set; +} + +sub CTOR { + my ($this,$docClass,$schema) = @_; + + $this->{$_docClass} = $docClass; + $this->{$_schemaNavi} = $schema ? IMPL::DOM::Navigator::SchemaNavigator->new($schema) : undef; +} + +sub NavigateCreate { + my ($this,$nodeName,%props) = @_; + + if (my $schemaNode = $this->{$_schemaNavi}->NavigateName($nodeName)) { + my $class = $schemaNode->can('nativeType') ? $schemaNode->nativeType : 'IMPL::DOM::Node'; + + my $node; + if (! $this->{$Document}) { + $node = $this->{$Document} = $this->{$_docClass}->new(nodeName => $nodeName,%props); + } else { + die new IMPL::InvalidOperationException('Can\t create a second top level element') unless $this->{$_nodeCurrent}; + $node = $this->{$Document}->Create($nodeName,$class,\%props); + push @{$this->{$_nodesPath}}, $this->{$_nodeCurrent}; + $this->{$_nodeCurrent}->appendChild($node); + } + + $this->{$_nodeCurrent} = $node; + + return $node; + } else { + die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName); + } +} + +sub Back { + my ($this) = @_; + + $this->{$_schemaNavi}->SchemaBack(); + $this->{$_nodeCurrent} = pop @{$this->{$_nodesPath}}; +} + +1; + +__END__ +=pod + +=head1 SYNOPSIS + +my $builder = new IMPL::DOM::Navigator::Builder(new MyApp::Document,$schema); +my $reader = new IMPL::DOM::XMLReader(Navigator => $builder); + +$reader->ParseFile("document.xml"); + +my @errors = $schema->Validate($builder->Document); + +=head1 DESCRIPTION + +Построитель DOM документов по указанной схеме. Обычно используется в связке +с объектами для чтения такими как C<IMPL::DOM::XMLReader>. + +=head1 METHODS + +=over + +=item C<CTOR($domDocument,$schema)> + +Создает новый объект, принимает на вход пустой (но не обязательно) документ и +схему. + +=item C<< $obj->NavigateCreate($nodeName) >> + +Создает новый узел с указанным именем и переходит в него. В случае если в схеме +подходящий узел не найден, то вызывается исключение. + +При этом по имени узла ищется его схема, после чего определяется класс для +создания экземпляра и созданный узел доавляется в документ. + +Также имя создаваемого узла НЕ может быть переопределено свойством nodeName, оно +будет проигнорировано. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Navigator/SchemaNavigator.pm --- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,124 +1,124 @@ -package IMPL::DOM::Navigator::SchemaNavigator; -use strict; -use warnings; - -use base qw(IMPL::DOM::Navigator); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -require IMPL::DOM::Schema::ComplexType; -require IMPL::DOM::Schema::NodeSet; -require IMPL::DOM::Schema::AnyNode; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public _direct property Schema => prop_get; - private _direct property _historySteps => prop_all; -} - -sub CTOR { - my ($this,$schema) = @_; - - $this->{$Schema} = $schema; - - die new IMPL::InvalidArgumentException("A schema object is required") unless $schema->isa('IMPL::DOM::Schema'); -} - -my $schemaAnyNode = IMPL::DOM::Schema::ComplexType->new(type => '::AnyNodeType', nativeType => 'IMPL::DOM::ComplexNode')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new() - ) -); - -sub NavigateName { - my ($this,$name) = @_; - - die new IMPL::InvalidArgumentException('name is required') unless defined $name; - - # perform a safe navigation - #return dosafe $this sub { - my $steps = 1; - # navigate to node - if ( - my $node = $this->Navigate( sub { - $_->isa('IMPL::DOM::Schema::Node') and ( - $_->name eq $name - or - $_->nodeName eq 'AnyNode' - or - ( $_->nodeName eq 'SwitchNode' and $_->selectNodes( sub { $_->name eq $name } ) ) - ) - }) - ) { - if ($node->nodeName eq 'AnyNode') { - # if we navigate to the anynode - # assume it to be ComplexType by default - $node = $node->type ? $this->{$Schema}->resolveType($node->type) : $schemaAnyNode; - } elsif ($node->nodeName eq 'SwitchNode') { - # if we are in the switchnode - # navigate to the target node - $node = $this->Navigate(sub { $_->name eq $name }); - $steps ++; - } - - if ($node->nodeName eq 'Node') { - # if we navigate to a reference - # resolve it - $node = $this->{$Schema}->resolveType($node->type); - $this->internalNavigateNodeSet($node); - $steps++; - } - - # if target node is a complex node - if ($node->isa('IMPL::DOM::Schema::ComplexNode')) { - # navigate to it's content - $this->internalNavigateNodeSet($node->content); - $steps ++; - } - - push @{$this->{$_historySteps}},$steps; - - # return found node schema - return $node; - } else { - return undef; # abort navigation - } - #} -} - -sub SchemaBack { - my ($this) = @_; - - $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; -} - -1; -__END__ - -=pod - -=head1 DESCRIPTION - -Помимо стандартных методов навигации позволяет переходить по элементам документа, -который данной схемой описывается. - -=head1 METHODS - -=over - -=item C<< $navi->NavigateName($name) >> - -Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>. -В данном случае всегда происходит безопасная навигация, тоесть в случае неудачи, -навигатор останется на прежней позиции. - -=item C<< $navi->SchemaBack >> - -Возвращается на позицию до последней операции C<NavigateName>. Данный метод нужен -посокольку операция навигации по элементам описываемым схемой может приводить к -нескольким операциям навигации по самой схеме. - -=back - -=cut \ No newline at end of file +package IMPL::DOM::Navigator::SchemaNavigator; +use strict; +use warnings; + +use base qw(IMPL::DOM::Navigator); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +require IMPL::DOM::Schema::ComplexType; +require IMPL::DOM::Schema::NodeSet; +require IMPL::DOM::Schema::AnyNode; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public _direct property Schema => prop_get; + private _direct property _historySteps => prop_all; +} + +sub CTOR { + my ($this,$schema) = @_; + + $this->{$Schema} = $schema; + + die new IMPL::InvalidArgumentException("A schema object is required") unless $schema->isa('IMPL::DOM::Schema'); +} + +my $schemaAnyNode = IMPL::DOM::Schema::ComplexType->new(type => '::AnyNodeType', nativeType => 'IMPL::DOM::ComplexNode')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new() + ) +); + +sub NavigateName { + my ($this,$name) = @_; + + die new IMPL::InvalidArgumentException('name is required') unless defined $name; + + # perform a safe navigation + #return dosafe $this sub { + my $steps = 1; + # navigate to node + if ( + my $node = $this->Navigate( sub { + $_->isa('IMPL::DOM::Schema::Node') and ( + $_->name eq $name + or + $_->nodeName eq 'AnyNode' + or + ( $_->nodeName eq 'SwitchNode' and $_->selectNodes( sub { $_->name eq $name } ) ) + ) + }) + ) { + if ($node->nodeName eq 'AnyNode') { + # if we navigate to the anynode + # assume it to be ComplexType by default + $node = $node->type ? $this->{$Schema}->resolveType($node->type) : $schemaAnyNode; + } elsif ($node->nodeName eq 'SwitchNode') { + # if we are in the switchnode + # navigate to the target node + $node = $this->Navigate(sub { $_->name eq $name }); + $steps ++; + } + + if ($node->nodeName eq 'Node') { + # if we navigate to a reference + # resolve it + $node = $this->{$Schema}->resolveType($node->type); + $this->internalNavigateNodeSet($node); + $steps++; + } + + # if target node is a complex node + if ($node->isa('IMPL::DOM::Schema::ComplexNode')) { + # navigate to it's content + $this->internalNavigateNodeSet($node->content); + $steps ++; + } + + push @{$this->{$_historySteps}},$steps; + + # return found node schema + return $node; + } else { + return undef; # abort navigation + } + #} +} + +sub SchemaBack { + my ($this) = @_; + + $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; +} + +1; +__END__ + +=pod + +=head1 DESCRIPTION + +Помимо стандартных методов навигации позволяет переходить по элементам документа, +который данной схемой описывается. + +=head1 METHODS + +=over + +=item C<< $navi->NavigateName($name) >> + +Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>. +В данном случае всегда происходит безопасная навигация, тоесть в случае неудачи, +навигатор останется на прежней позиции. + +=item C<< $navi->SchemaBack >> + +Возвращается на позицию до последней операции C<NavigateName>. Данный метод нужен +посокольку операция навигации по элементам описываемым схемой может приводить к +нескольким операциям навигации по самой схеме. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Navigator/SimpleBuilder.pm --- a/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,37 +1,37 @@ -package IMPL::DOM::Navigator::SimpleBuilder; -use strict; -use warnings; - -use base qw(IMPL::DOM::Navigator); - -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -require IMPL::DOM::Navigator::SchemaNavigator; -use IMPL::DOM::Document; - -BEGIN { - public _direct property Document => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document::Empty; } -); - -sub NavigateCreate { - my ($this,$nodeName,%props) = @_; - - my $node; - if (! $this->{$Document}) { - $node = $this->{$Document} = IMPL::DOM::Document->new(nodeName => $nodeName,%props); - $this->_initNavigator($node); - } else { - die new IMPL::InvalidOperationException('Can\t create a second top level element') unless $this->Current; - $node = $this->{$Document}->Create($nodeName,'IMPL::DOM::Node',\%props); - $this->Current->appendChild($node); - $this->internalNavigateNodeSet($node); - } - return $node; -} - -1; +package IMPL::DOM::Navigator::SimpleBuilder; +use strict; +use warnings; + +use base qw(IMPL::DOM::Navigator); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +require IMPL::DOM::Navigator::SchemaNavigator; +use IMPL::DOM::Document; + +BEGIN { + public _direct property Document => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Navigator' => sub { IMPL::DOM::Document::Empty; } +); + +sub NavigateCreate { + my ($this,$nodeName,%props) = @_; + + my $node; + if (! $this->{$Document}) { + $node = $this->{$Document} = IMPL::DOM::Document->new(nodeName => $nodeName,%props); + $this->_initNavigator($node); + } else { + die new IMPL::InvalidOperationException('Can\t create a second top level element') unless $this->Current; + $node = $this->{$Document}->Create($nodeName,'IMPL::DOM::Node',\%props); + $this->Current->appendChild($node); + $this->internalNavigateNodeSet($node); + } + return $node; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Node.pm --- a/Lib/IMPL/DOM/Node.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Node.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,275 +1,275 @@ -package IMPL::DOM::Node; -use strict; -use warnings; - -use base qw(IMPL::Object); - -use IMPL::Object::List; -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use Scalar::Util qw(weaken); - -use IMPL::Exception; - -BEGIN { - public _direct property nodeName => prop_get; - public _direct property document => prop_get; - public _direct property isComplex => { get => \&_getIsComplex } ; - public _direct property nodeValue => prop_all; - public _direct property childNodes => { get => \&_getChildNodes }; - public _direct property parentNode => prop_get ; - private _direct property _propertyMap => prop_all ; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); - $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; - if ( exists $args{document} ) { - $this->{$document} = delete $args{document}; - weaken($this->{$document}); - } - - $this->{$_propertyMap} = \%args; -} - -sub insertNode { - my ($this,$node,$pos) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - $this->childNodes->InsertAt($pos,$node); - - $node->_setParent( $this ); - - return $node; -} - -sub appendChild { - my ($this,$node) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - my $children = $this->childNodes; - $children->Append($node); - - $node->_setParent( $this ); - - return $node; -} - -sub appendNode { - goto &appendChild; -} - -sub appendRange { - my ($this,@range) = @_; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; - - foreach my $node (@range) { - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - $node->_setParent( $this ); - } - - $this->childNodes->Append(@range); - - return $this; -} - -sub _getChildNodes { - my ($this) = @_; - - $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; - return $this->{$childNodes}; -} - -sub removeNode { - my ($this,$node) = @_; - - if ($this == $node->{$parentNode}) { - $this->childNodes->RemoveItem($node); - $node->_setParent(undef); - return $node; - } else { - die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); - } -} - -sub replaceNodeAt { - my ($this,$index,$node) = @_; - - my $nodeOld = $this->childNodes->[$index]; - - die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; - - # unlink node from previous parent - $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - - # replace (or set) old node - $this->childNodes->[$index] = $node; - - # set new parent - $node->_setParent( $this ); - - # unlink old node if we have one - $nodeOld->_setParent(undef) if $nodeOld; - - # return old node - return $nodeOld; -} - -sub removeAt { - my ($this,$pos) = @_; - - if ( my $node = $this->childNodes->RemoveAt($pos) ) { - $node->_setParent(undef); - return $node; - } else { - return undef; - } -} - -sub removeLast { - my ($this) = @_; - - if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { - $node->_setParent(undef); - return $node; - } else { - return undef; - } -} - -sub removeSelected { - my ($this,$query) = @_; - - my @newSet; - my @result; - - if (ref $query eq 'CODE') { - &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; - } elsif (defined $query) { - $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; - } else { - my $children = $this->childNodes; - $_->_setParent(undef) foreach @$children; - delete $this->{$childNodes}; - return wantarray ? @$children : $children; - } - - $_->_setParent(undef) foreach @result; - - $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; - - return wantarray ? @result : \@result; -} - -sub selectNodes { - my ($this,$query) = @_; - - my @result; - - if (ref $query eq 'CODE') { - @result = grep &$query($_), @{$this->childNodes}; - } elsif (ref $query eq 'ARRAY' ) { - my %keys = map (($_,1),@$query); - @result = grep $keys{$_->nodeName}, @{$this->childNodes}; - } elsif (defined $query) { - @result = grep $_->nodeName eq $query, @{$this->childNodes}; - } else { - if (wantarray) { - return @{$this->childNodes}; - } else { - @result = $this->childNodes; - return \@result; - } - } - - return wantarray ? @result : \@result; -} - -sub firstChild { - @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; -} - -sub _getIsComplex { - $_[0]->childNodes->Count ? 1 : 0; -} - -sub _updateDocRefs { - my ($this) = @_; - - # this method is called by the parent node on his children, so we need no to check parent - $this->{$document} = $this->{$parentNode}->document; - - # prevent cyclic - weaken($this->{$document}) if $this->{$document}; - - $_->_updateDocRefs foreach @{$this->{$childNodes}}; -} - -sub _setParent { - my ($this,$node) = @_; - - - if (($node || 0) != ($this->{$parentNode} || 0)) { - my $newOwner; - if ($node) { - $this->{$parentNode} = $node; - $newOwner = $node->document || 0; - - # prevent from creating cyclicreferences - weaken($this->{$parentNode}); - - } else { - delete $this->{$parentNode}; - $newOwner = 0; - } - - if (($this->{$document}||0) != $newOwner) { - $this->{$document} = $newOwner; - weaken($this->{$document}) if $newOwner; - $_->_updateDocRefs foreach @{$this->childNodes}; - } - } -} - -sub text { - my ($this) = @_; - - join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes})); -} - -sub nodeProperty { - my $this = shift; - my $name = shift; - - if (@_) { - # set - return $this->{$_propertyMap}{$name} = shift; - } else { - return $this->{$_propertyMap}{$name}; - } -} - -sub qname { - $_[0]->{$nodeName}; -} - -sub path { - my ($this) = @_; - - if ($this->parentNode) { - return $this->parentNode->path.'.'.$this->qname; - } else { - return $this->qname; - } -} - -1; +package IMPL::DOM::Node; +use strict; +use warnings; + +use base qw(IMPL::Object); + +use IMPL::Object::List; +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use Scalar::Util qw(weaken); + +use IMPL::Exception; + +BEGIN { + public _direct property nodeName => prop_get; + public _direct property document => prop_get; + public _direct property isComplex => { get => \&_getIsComplex } ; + public _direct property nodeValue => prop_all; + public _direct property childNodes => { get => \&_getChildNodes }; + public _direct property parentNode => prop_get ; + private _direct property _propertyMap => prop_all ; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); + $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; + if ( exists $args{document} ) { + $this->{$document} = delete $args{document}; + weaken($this->{$document}); + } + + $this->{$_propertyMap} = \%args; +} + +sub insertNode { + my ($this,$node,$pos) = @_; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + $this->childNodes->InsertAt($pos,$node); + + $node->_setParent( $this ); + + return $node; +} + +sub appendChild { + my ($this,$node) = @_; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + my $children = $this->childNodes; + $children->Append($node); + + $node->_setParent( $this ); + + return $node; +} + +sub appendNode { + goto &appendChild; +} + +sub appendRange { + my ($this,@range) = @_; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; + + foreach my $node (@range) { + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + $node->_setParent( $this ); + } + + $this->childNodes->Append(@range); + + return $this; +} + +sub _getChildNodes { + my ($this) = @_; + + $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; + return $this->{$childNodes}; +} + +sub removeNode { + my ($this,$node) = @_; + + if ($this == $node->{$parentNode}) { + $this->childNodes->RemoveItem($node); + $node->_setParent(undef); + return $node; + } else { + die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); + } +} + +sub replaceNodeAt { + my ($this,$index,$node) = @_; + + my $nodeOld = $this->childNodes->[$index]; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + # unlink node from previous parent + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + # replace (or set) old node + $this->childNodes->[$index] = $node; + + # set new parent + $node->_setParent( $this ); + + # unlink old node if we have one + $nodeOld->_setParent(undef) if $nodeOld; + + # return old node + return $nodeOld; +} + +sub removeAt { + my ($this,$pos) = @_; + + if ( my $node = $this->childNodes->RemoveAt($pos) ) { + $node->_setParent(undef); + return $node; + } else { + return undef; + } +} + +sub removeLast { + my ($this) = @_; + + if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { + $node->_setParent(undef); + return $node; + } else { + return undef; + } +} + +sub removeSelected { + my ($this,$query) = @_; + + my @newSet; + my @result; + + if (ref $query eq 'CODE') { + &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; + } elsif (defined $query) { + $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; + } else { + my $children = $this->childNodes; + $_->_setParent(undef) foreach @$children; + delete $this->{$childNodes}; + return wantarray ? @$children : $children; + } + + $_->_setParent(undef) foreach @result; + + $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; + + return wantarray ? @result : \@result; +} + +sub selectNodes { + my ($this,$query) = @_; + + my @result; + + if (ref $query eq 'CODE') { + @result = grep &$query($_), @{$this->childNodes}; + } elsif (ref $query eq 'ARRAY' ) { + my %keys = map (($_,1),@$query); + @result = grep $keys{$_->nodeName}, @{$this->childNodes}; + } elsif (defined $query) { + @result = grep $_->nodeName eq $query, @{$this->childNodes}; + } else { + if (wantarray) { + return @{$this->childNodes}; + } else { + @result = $this->childNodes; + return \@result; + } + } + + return wantarray ? @result : \@result; +} + +sub firstChild { + @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; +} + +sub _getIsComplex { + $_[0]->childNodes->Count ? 1 : 0; +} + +sub _updateDocRefs { + my ($this) = @_; + + # this method is called by the parent node on his children, so we need no to check parent + $this->{$document} = $this->{$parentNode}->document; + + # prevent cyclic + weaken($this->{$document}) if $this->{$document}; + + $_->_updateDocRefs foreach @{$this->{$childNodes}}; +} + +sub _setParent { + my ($this,$node) = @_; + + + if (($node || 0) != ($this->{$parentNode} || 0)) { + my $newOwner; + if ($node) { + $this->{$parentNode} = $node; + $newOwner = $node->document || 0; + + # prevent from creating cyclicreferences + weaken($this->{$parentNode}); + + } else { + delete $this->{$parentNode}; + $newOwner = 0; + } + + if (($this->{$document}||0) != $newOwner) { + $this->{$document} = $newOwner; + weaken($this->{$document}) if $newOwner; + $_->_updateDocRefs foreach @{$this->childNodes}; + } + } +} + +sub text { + my ($this) = @_; + + join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes})); +} + +sub nodeProperty { + my $this = shift; + my $name = shift; + + if (@_) { + # set + return $this->{$_propertyMap}{$name} = shift; + } else { + return $this->{$_propertyMap}{$name}; + } +} + +sub qname { + $_[0]->{$nodeName}; +} + +sub path { + my ($this) = @_; + + if ($this->parentNode) { + return $this->parentNode->path.'.'.$this->qname; + } else { + return $this->qname; + } +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Property.pm --- a/Lib/IMPL/DOM/Property.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Property.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,73 +1,73 @@ -package IMPL::DOM::Property; -use strict; -use warnings; - -use IMPL::Class::Property; -require IMPL::Exception; - -use base qw(Exporter); -our @EXPORT_OK = qw(_dom); - -sub _dom($) { - my ($prop_info) = @_; - $prop_info->Implementor( 'IMPL::DOM::Property' ); - return $prop_info; -} - -sub Make { - my ($self,$propInfo) = @_; - - my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); - - die new IMPL::InvalidOperationException("DOM properties can be declared only for the DOM objects") unless $class->isa('IMPL::DOM::Node'); - - no strict 'refs'; - die new IMPL::InvalidOperationException("Custom mutators are not allowed","${class}::$name") if ref $mutators; - if (($mutators & prop_all) == prop_all) { - *{"${class}::$name"} = sub { - $_[0]->nodeProperty($name,@_[1..$#_]); - }; - $propInfo->canGet(1); - $propInfo->canSet(1); - } elsif( $mutators & prop_get ) { - *{"${class}::$name"} = sub { - die new IMPL::InvalidOperationException("This is a readonly property", "${class}::$name") if @_>1; - $_[0]->nodeProperty($name); - }; - $propInfo->canGet(1); - $propInfo->canSet(0); - } elsif( $mutators & prop_set ) { - *{"${class}::$name"} = sub { - die new IMPL::InvalidOperationException("This is a writeonly property", "${class}::$name") if @_<2; - $_[0]->nodeProperty($name,@_[1..$#_]); - }; - $propInfo->canGet(0); - $propInfo->canSet(1); - } else { - die new IMPL::InvalidOperationException("Invalid value for the property mutators","${class}::$name",$mutators); - } -} - -1; -__END__ -=pod - -=head1 SYNOPSIS - -package TypedNode; - -use base qw(IMPL::DOM::Node); -use IMPL::DOM::Property qw(_dom); - -BEGIN { - public _dom property Age => prop_all; - public _dom property Address => prop_all; - public property ServiceData => prop_all; -} - -=head1 DESCRIPTION - -Позволяет объявлять свойства, которые будут храниться в списке динамических -свойств. - -=cut \ No newline at end of file +package IMPL::DOM::Property; +use strict; +use warnings; + +use IMPL::Class::Property; +require IMPL::Exception; + +use base qw(Exporter); +our @EXPORT_OK = qw(_dom); + +sub _dom($) { + my ($prop_info) = @_; + $prop_info->Implementor( 'IMPL::DOM::Property' ); + return $prop_info; +} + +sub Make { + my ($self,$propInfo) = @_; + + my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); + + die new IMPL::InvalidOperationException("DOM properties can be declared only for the DOM objects") unless $class->isa('IMPL::DOM::Node'); + + no strict 'refs'; + die new IMPL::InvalidOperationException("Custom mutators are not allowed","${class}::$name") if ref $mutators; + if (($mutators & prop_all) == prop_all) { + *{"${class}::$name"} = sub { + $_[0]->nodeProperty($name,@_[1..$#_]); + }; + $propInfo->canGet(1); + $propInfo->canSet(1); + } elsif( $mutators & prop_get ) { + *{"${class}::$name"} = sub { + die new IMPL::InvalidOperationException("This is a readonly property", "${class}::$name") if @_>1; + $_[0]->nodeProperty($name); + }; + $propInfo->canGet(1); + $propInfo->canSet(0); + } elsif( $mutators & prop_set ) { + *{"${class}::$name"} = sub { + die new IMPL::InvalidOperationException("This is a writeonly property", "${class}::$name") if @_<2; + $_[0]->nodeProperty($name,@_[1..$#_]); + }; + $propInfo->canGet(0); + $propInfo->canSet(1); + } else { + die new IMPL::InvalidOperationException("Invalid value for the property mutators","${class}::$name",$mutators); + } +} + +1; +__END__ +=pod + +=head1 SYNOPSIS + +package TypedNode; + +use base qw(IMPL::DOM::Node); +use IMPL::DOM::Property qw(_dom); + +BEGIN { + public _dom property Age => prop_all; + public _dom property Address => prop_all; + public property ServiceData => prop_all; +} + +=head1 DESCRIPTION + +Позволяет объявлять свойства, которые будут храниться в списке динамических +свойств. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema.pm --- a/Lib/IMPL/DOM/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,240 +1,240 @@ -package IMPL::DOM::Schema; -use strict; -use warnings; - -require IMPL::DOM::Schema::ComplexNode; -require IMPL::DOM::Schema::ComplexType; -require IMPL::DOM::Schema::SimpleNode; -require IMPL::DOM::Schema::SimpleType; -require IMPL::DOM::Schema::Node; -require IMPL::DOM::Schema::AnyNode; -require IMPL::DOM::Schema::NodeList; -require IMPL::DOM::Schema::NodeSet; -require IMPL::DOM::Schema::Property; -require IMPL::DOM::Schema::SwitchNode; - -use base qw(IMPL::DOM::Document); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -our %CTOR = ( - 'IMPL::DOM::Document' => sub { nodeName => 'schema' } -); - -BEGIN { - private _direct property _TypesMap => prop_all; - public _direct property BaseSchemas => prop_get | owner_set; - private _direct property _Validators => prop_all; -} - -sub resolveType { - $_[0]->{$_TypesMap}->{$_[1]}; -} - -sub Create { - my ($this,$nodeName,$class,$refArgs) = @_; - - die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Schema::Node'); - - goto &SUPER::Create; -} - -sub Process { - my ($this) = @_; - - $this->{$_TypesMap} = { map { $_->type, $_ } $this->selectNodes(sub { $_[0]->nodeName eq 'ComplexType' || $_[0]->nodeName eq 'SimpleType' } ) }; -} - -sub Validate { - my ($this,$node) = @_; - - if ( my ($schemaNode) = $this->selectNodes(sub { $_[0]->name eq $node->nodeName })) { - $schemaNode->Validate($node); - } else { - return new IMPL::DOM::Schema::ValidationError(Message=> "A specified document doesn't match the schema"); - } -} - -my $schema; - -sub MetaSchema { - - return $schema if $schema; - - $schema = new IMPL::DOM::Schema; - - $schema->appendRange( - IMPL::DOM::Schema::ComplexNode->new(name => 'schema')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( - IMPL::DOM::Schema::Property->new(name => 'source') - ) - ), - ), - IMPL::DOM::Schema::ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange( - IMPL::DOM::Schema::SimpleNode->new(name => 'AnyNode'), - IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode') - ) - ) - ), - IMPL::DOM::Schema::ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), - ) - ), - IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), - ) - ), - IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( - IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::SwitchNode->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'), - IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'), - ), - IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - new IMPL::DOM::Schema::Property(name => 'type') - ), - IMPL::DOM::Schema::ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange( - IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::SwitchNode->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'), - IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'), - ), - IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - new IMPL::DOM::Schema::Property(name => 'name') - ), - IMPL::DOM::Schema::ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - new IMPL::DOM::Schema::Property(name => 'type') - ), - IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') - ), - new IMPL::DOM::Schema::Property(name => 'name') - ), - IMPL::DOM::Schema::ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange( - IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) - ), - new IMPL::DOM::Schema::Property(name => 'name') - ) - ); - - $schema->Process; - - return $schema; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Схема документа. Наследует C<IMPL::DOM::Document> - -=head1 METHODS - -=over - -=item C<< $obj->Process() >> - -Обновляет таблицу типов из содержимого. - -=item C<< $obj->ResolveType($typeName) >> - -Возвращает схему типа c именем C<$typeName>. - -=back - -=head1 DESCRIPTION - -DOM схема - это документ, состоящий из определенных узлов, описывающая структуру -других документов. - -=head1 META SCHEMA - -Схема для описания схемы, эта схема используется для постороения других схем - -<schema> - <ComplexNode name="schema"> - <NodeSet> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexType" type="ComplexType"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleType" type="SimpleType"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Include"/> - </NodeSet> - </ComplexNode> - - <ComplexType type="NodeContainer"> - <NodeSet> - <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> - <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> - <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> - </NodeSet> - </ComplexType> - - <ComplexType type="ComplexType"> - <NodeList> - <Node name="NodeSet" type="NodeContainer" minOcuur=0/> - <Node name="NodeList" type="NodeContainer" minOccur=0/> - <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> - </NodeList> - </ComplexType> - - <ComplexType type="ComplexNode"> - <NodeList> - <Node name="NodeSet" type="NodeContainer" minOcuur=0/> - <Node name="NodeList" type="NodeContainer" minOccur=0/> - <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> - </NodeList> - </ComplexType> - - <ComplexType type="SimpleNode"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> - </NodeSet> - </ComplexType> - - <ComplexType type="SimpleType"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> - </NodeSet> - </ComplexType> - - <ComplexType type="Validator"> - <NodeSet> - <AnyNode minOccur=0 maxOccur="unbounded"/> - </NodeSet> - </ComplexType> - -</schema> - -=cut +package IMPL::DOM::Schema; +use strict; +use warnings; + +require IMPL::DOM::Schema::ComplexNode; +require IMPL::DOM::Schema::ComplexType; +require IMPL::DOM::Schema::SimpleNode; +require IMPL::DOM::Schema::SimpleType; +require IMPL::DOM::Schema::Node; +require IMPL::DOM::Schema::AnyNode; +require IMPL::DOM::Schema::NodeList; +require IMPL::DOM::Schema::NodeSet; +require IMPL::DOM::Schema::Property; +require IMPL::DOM::Schema::SwitchNode; + +use base qw(IMPL::DOM::Document); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +our %CTOR = ( + 'IMPL::DOM::Document' => sub { nodeName => 'schema' } +); + +BEGIN { + private _direct property _TypesMap => prop_all; + public _direct property BaseSchemas => prop_get | owner_set; + private _direct property _Validators => prop_all; +} + +sub resolveType { + $_[0]->{$_TypesMap}->{$_[1]}; +} + +sub Create { + my ($this,$nodeName,$class,$refArgs) = @_; + + die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Schema::Node'); + + goto &SUPER::Create; +} + +sub Process { + my ($this) = @_; + + $this->{$_TypesMap} = { map { $_->type, $_ } $this->selectNodes(sub { $_[0]->nodeName eq 'ComplexType' || $_[0]->nodeName eq 'SimpleType' } ) }; +} + +sub Validate { + my ($this,$node) = @_; + + if ( my ($schemaNode) = $this->selectNodes(sub { $_[0]->name eq $node->nodeName })) { + $schemaNode->Validate($node); + } else { + return new IMPL::DOM::Schema::ValidationError(Message=> "A specified document doesn't match the schema"); + } +} + +my $schema; + +sub MetaSchema { + + return $schema if $schema; + + $schema = new IMPL::DOM::Schema; + + $schema->appendRange( + IMPL::DOM::Schema::ComplexNode->new(name => 'schema')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( + IMPL::DOM::Schema::Property->new(name => 'source') + ) + ), + ), + IMPL::DOM::Schema::ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange( + IMPL::DOM::Schema::SimpleNode->new(name => 'AnyNode'), + IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode') + ) + ) + ), + IMPL::DOM::Schema::ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), + ) + ), + IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), + ) + ), + IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( + IMPL::DOM::Schema::NodeList->new()->appendRange( + IMPL::DOM::Schema::SwitchNode->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'), + IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'), + ), + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + new IMPL::DOM::Schema::Property(name => 'type') + ), + IMPL::DOM::Schema::ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange( + IMPL::DOM::Schema::NodeList->new()->appendRange( + IMPL::DOM::Schema::SwitchNode->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'), + IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'), + ), + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + new IMPL::DOM::Schema::Property(name => 'name') + ), + IMPL::DOM::Schema::ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + new IMPL::DOM::Schema::Property(name => 'type') + ), + IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') + ), + new IMPL::DOM::Schema::Property(name => 'name') + ), + IMPL::DOM::Schema::ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange( + IMPL::DOM::Schema::NodeList->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) + ), + new IMPL::DOM::Schema::Property(name => 'name') + ) + ); + + $schema->Process; + + return $schema; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Схема документа. Наследует C<IMPL::DOM::Document> + +=head1 METHODS + +=over + +=item C<< $obj->Process() >> + +Обновляет таблицу типов из содержимого. + +=item C<< $obj->ResolveType($typeName) >> + +Возвращает схему типа c именем C<$typeName>. + +=back + +=head1 DESCRIPTION + +DOM схема - это документ, состоящий из определенных узлов, описывающая структуру +других документов. + +=head1 META SCHEMA + +Схема для описания схемы, эта схема используется для постороения других схем + +<schema> + <ComplexNode name="schema"> + <NodeSet> + <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> + <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> + <Node minOcuur="0" maxOccur="unbounded" name="ComplexType" type="ComplexType"/> + <Node minOcuur="0" maxOccur="unbounded" name="SimpleType" type="SimpleType"/> + <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> + <SimpleNode minOcuur="0" maxOccur="unbounded" name="Include"/> + </NodeSet> + </ComplexNode> + + <ComplexType type="NodeContainer"> + <NodeSet> + <Node minOcuur="0" maxOccur="unbounded" name="ComplexNode" type="ComplexNode"/> + <Node minOcuur="0" maxOccur="unbounded" name="SimpleNode" type="SimpleNode"/> + <SimpleNode minOcuur="0" maxOccur="unbounded" name="Node"/> + </NodeSet> + </ComplexType> + + <ComplexType type="ComplexType"> + <NodeList> + <Node name="NodeSet" type="NodeContainer" minOcuur=0/> + <Node name="NodeList" type="NodeContainer" minOccur=0/> + <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> + </NodeList> + </ComplexType> + + <ComplexType type="ComplexNode"> + <NodeList> + <Node name="NodeSet" type="NodeContainer" minOcuur=0/> + <Node name="NodeList" type="NodeContainer" minOccur=0/> + <AnyNode minOccur="0" maxOccur="unbounded" type="Validator"/> + </NodeList> + </ComplexType> + + <ComplexType type="SimpleNode"> + <NodeSet> + <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> + </NodeSet> + </ComplexType> + + <ComplexType type="SimpleType"> + <NodeSet> + <AnyNode minOccur=0 maxOccur="unbounded" type="Validator"/> + </NodeSet> + </ComplexType> + + <ComplexType type="Validator"> + <NodeSet> + <AnyNode minOccur=0 maxOccur="unbounded"/> + </NodeSet> + </ComplexType> + +</schema> + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/AnyNode.pm --- a/Lib/IMPL/DOM/Schema/AnyNode.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/AnyNode.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,42 +1,42 @@ -package IMPL::DOM::Schema::AnyNode; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::Node); - -our %CTOR = ( - 'IMPL::DOM::Schema::Node' => sub { - my %args = @_; - $args{nodeName} ||= 'AnyNode'; - $args{name} = '::any'; - - %args; - } -); - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Узел с произвольным именем, для этого узла предусмотрена специальная проверка -в контейнерах. - -В контейнерах типа C<IMPL::DOM::Schema::NodeSet> этот узел можно использовать только один раз -причем его использование исключает использование узла C<IMPL::DOM::Schema::SwitchNode>. - -В контейнерах типа С<IMPL::DOM::Schema::NodeList> данный узел может применяться несколько раз -для решения таких задачь как последовательности разноименных узлов с одним типом. - -<NodeList> - <SimpleNode name="firstName"/> - <SimpleNode name="age"/> - <AnyNode type="Notes" minOccur="0" maxOccur="unbounded"/> - <Node name="primaryAddress" type="Address"/> - <AnyNode/> -</NodeList> - -=cut \ No newline at end of file +package IMPL::DOM::Schema::AnyNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::Node); + +our %CTOR = ( + 'IMPL::DOM::Schema::Node' => sub { + my %args = @_; + $args{nodeName} ||= 'AnyNode'; + $args{name} = '::any'; + + %args; + } +); + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Узел с произвольным именем, для этого узла предусмотрена специальная проверка +в контейнерах. + +В контейнерах типа C<IMPL::DOM::Schema::NodeSet> этот узел можно использовать только один раз +причем его использование исключает использование узла C<IMPL::DOM::Schema::SwitchNode>. + +В контейнерах типа С<IMPL::DOM::Schema::NodeList> данный узел может применяться несколько раз +для решения таких задачь как последовательности разноименных узлов с одним типом. + +<NodeList> + <SimpleNode name="firstName"/> + <SimpleNode name="age"/> + <AnyNode type="Notes" minOccur="0" maxOccur="unbounded"/> + <Node name="primaryAddress" type="Address"/> + <AnyNode/> +</NodeList> + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/ComplexNode.pm --- a/Lib/IMPL/DOM/Schema/ComplexNode.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/ComplexNode.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,59 +1,59 @@ -package IMPL::DOM::Schema::ComplexNode; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::Node); -use IMPL::Class::Property; - -BEGIN { - public property content => { - get => \&_getContent, - set => \&_setContent - } -} - -our %CTOR = ( - 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'ComplexNode'; %args } -); - -sub _getContent { - $_[0]->firstChild; -} - -sub _setContent { - $_[0]->firstChild($_[1]); -} - -sub Validate { - my ($this,$node) = @_; - - map $_->Validate($node), @{$this->childNodes}; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Описывает сложный узел. Требует либо соответствие структуры, либо соответствия -типу. - -Дочерними элементами могут быть правила контроля свойств и т.п. -Первым дочерним элементом может быть только содержимое узла, см. C<content> - -=head2 PROPERTIES - -=over - -=item C<content> - -Содержимое узла, может быть либо C<IMPL::DOM::Schema::NodeSet> либо -C<IMPL::DOM::Schema::NodeList>, в зависимости от того важен порядок или нет. -Это свойство ссылается на первый дочерний элемент узла. - -=back - -=cut +package IMPL::DOM::Schema::ComplexNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::Node); +use IMPL::Class::Property; + +BEGIN { + public property content => { + get => \&_getContent, + set => \&_setContent + } +} + +our %CTOR = ( + 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'ComplexNode'; %args } +); + +sub _getContent { + $_[0]->firstChild; +} + +sub _setContent { + $_[0]->firstChild($_[1]); +} + +sub Validate { + my ($this,$node) = @_; + + map $_->Validate($node), @{$this->childNodes}; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Описывает сложный узел. Требует либо соответствие структуры, либо соответствия +типу. + +Дочерними элементами могут быть правила контроля свойств и т.п. +Первым дочерним элементом может быть только содержимое узла, см. C<content> + +=head2 PROPERTIES + +=over + +=item C<content> + +Содержимое узла, может быть либо C<IMPL::DOM::Schema::NodeSet> либо +C<IMPL::DOM::Schema::NodeList>, в зависимости от того важен порядок или нет. +Это свойство ссылается на первый дочерний элемент узла. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/ComplexType.pm --- a/Lib/IMPL/DOM/Schema/ComplexType.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/ComplexType.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,31 +1,31 @@ -package IMPL::DOM::Schema::ComplexType; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::ComplexNode); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property nativeType => prop_get; -} - -our %CTOR = ( - 'IMPL::DOM::Schema::ComplexNode' => sub { - my %args = @_; - $args{nodeName} ||= 'ComplexType'; - $args{minOccur} = 0; - $args{maxOccur} = 'unbounded'; - $args{name} ||= 'ComplexType'; - %args - } -); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nativeType} = $args{nativeType}; -} - - -1; +package IMPL::DOM::Schema::ComplexType; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::ComplexNode); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property nativeType => prop_get; +} + +our %CTOR = ( + 'IMPL::DOM::Schema::ComplexNode' => sub { + my %args = @_; + $args{nodeName} ||= 'ComplexType'; + $args{minOccur} = 0; + $args{maxOccur} = 'unbounded'; + $args{name} ||= 'ComplexType'; + %args + } +); + +sub CTOR { + my ($this,%args) = @_; + + $this->{$nativeType} = $args{nativeType}; +} + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/Node.pm --- a/Lib/IMPL/DOM/Schema/Node.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/Node.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,62 +1,62 @@ -package IMPL::DOM::Schema::Node; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); -use IMPL::Class::Property; -use IMPL::DOM::Property qw(_dom); -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property minOccur => prop_all; - public _direct property maxOccur => prop_all; - public _direct property type => prop_all; - public _direct property name => prop_all; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub {my %args = @_; $args{nodeName} ||= 'Node'; %args} -); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$minOccur} = defined $args{minOccur} ? $args{minOccur} : 1; - $this->{$maxOccur} = defined $args{maxOccur} ? $args{maxOccur} : 1; - $this->{$type} = $args{type}; - $this->{$name} = $args{name} or die new IMPL::InvalidArgumentException('Argument is required','name'); -} - -sub Validate { - my ($this,$node) = @_; - - if (my $schemaType = $this->{$type} ? $this->document->resolveType($this->{$type}) : undef ) { - return $schemaType->Validate($node); - } else { - return (); - } -} - -sub qname { - $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -package Restriction; -use base qw(IMPL::DOM::Schema::Item); - -sub Validate { - my ($this,$node) = @_; -} - -=head1 DESCRIPTION - -Базовый класс для элементов схемы. - -=cut +package IMPL::DOM::Schema::Node; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); +use IMPL::Class::Property; +use IMPL::DOM::Property qw(_dom); +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property minOccur => prop_all; + public _direct property maxOccur => prop_all; + public _direct property type => prop_all; + public _direct property name => prop_all; +} + +our %CTOR = ( + 'IMPL::DOM::Node' => sub {my %args = @_; $args{nodeName} ||= 'Node'; %args} +); + +sub CTOR { + my ($this,%args) = @_; + + $this->{$minOccur} = defined $args{minOccur} ? $args{minOccur} : 1; + $this->{$maxOccur} = defined $args{maxOccur} ? $args{maxOccur} : 1; + $this->{$type} = $args{type}; + $this->{$name} = $args{name} or die new IMPL::InvalidArgumentException('Argument is required','name'); +} + +sub Validate { + my ($this,$node) = @_; + + if (my $schemaType = $this->{$type} ? $this->document->resolveType($this->{$type}) : undef ) { + return $schemaType->Validate($node); + } else { + return (); + } +} + +sub qname { + $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; +} + +1; + +__END__ +=pod + +=head1 SYNOPSIS + +package Restriction; +use base qw(IMPL::DOM::Schema::Item); + +sub Validate { + my ($this,$node) = @_; +} + +=head1 DESCRIPTION + +Базовый класс для элементов схемы. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/NodeList.pm --- a/Lib/IMPL/DOM/Schema/NodeList.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/NodeList.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,104 +1,104 @@ -package IMPL::DOM::Schema::NodeList; -use strict; -use warnings; -use base qw(IMPL::DOM::Node); - -use IMPL::Class::Property; -require IMPL::DOM::Schema::ValidationError; - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'NodeList' } -); - -BEGIN { - public property messageUnexpected => prop_all; - public property messageNodesRequired => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->messageUnexpected($args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed in %Node.parentNode.path%'); - $this->messageNodesRequired($args{messageNodesRequired} || 'A %Schema.name% is required in the node %Node.path%'); -} - -sub Validate { - my ($this,$node) = @_; - - my @nodes = map { - {nodeName => $_->name, anyNode => $_->isa('IMPL::DOM::Schema::AnyNode') , Schema => $_, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur, Min => $_->minOccur, Seen => 0 } - } @{$this->childNodes}; - - my $info = shift @nodes; - - foreach my $child ( @{$node->childNodes} ) { - #skip schema elements - while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) { - # if possible of course :) - return new IMPL::DOM::Schema::ValidationError ( - Message => $this->messageUnexpected, - Node => $child, - Schema => $info->{Schema}, - Source => $this - ) if $info->{Min} > $info->{Seen}; - - $info = shift @nodes; - } - - # return error if no more children allowed - return new IMPL::DOM::Schema::ValidationError ( - Message => $this->messageUnexpected, - Node => $child, - Source => $this - ) unless $info; - - # it's ok, we found schema element for child - # but it may be any node or switching node wich would not satisfy current child - - # validate - while (my @errors = $info->{Schema}->Validate($child)) { - if( $info->{anyNode} and $info->{Seen} >= $info->{Min} ) { - # in case of any or switch node, skip it if possible - next if $info = shift @nodes; - } - return @errors; - } - - $info->{Seen}++; - - # check count limits - return new IMPL::DOM::Schema::ValidationError ( - Error => 1, - Message => $this->messageUnexpected, - Node => $child, - Source => $this, - ) if $info->{Max} and $info->{Seen} > $info->{Max}; - } - - # no more children left (but may be should :) - while ($info) { - return new IMPL::DOM::Schema::ValidationError ( - Error => 1, - Message => $this->messageNodesRequired, - Node => $node, - Source => $this, - Schema => $info->{Schema} - ) if $info->{Seen} < $info->{Min}; - - $info = shift @nodes; - } - return; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Содержимое для сложного узла. Порядок важен. Дочерними элементами могут быть -только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. - -=cut \ No newline at end of file +package IMPL::DOM::Schema::NodeList; +use strict; +use warnings; +use base qw(IMPL::DOM::Node); + +use IMPL::Class::Property; +require IMPL::DOM::Schema::ValidationError; + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'NodeList' } +); + +BEGIN { + public property messageUnexpected => prop_all; + public property messageNodesRequired => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->messageUnexpected($args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed in %Node.parentNode.path%'); + $this->messageNodesRequired($args{messageNodesRequired} || 'A %Schema.name% is required in the node %Node.path%'); +} + +sub Validate { + my ($this,$node) = @_; + + my @nodes = map { + {nodeName => $_->name, anyNode => $_->isa('IMPL::DOM::Schema::AnyNode') , Schema => $_, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur, Min => $_->minOccur, Seen => 0 } + } @{$this->childNodes}; + + my $info = shift @nodes; + + foreach my $child ( @{$node->childNodes} ) { + #skip schema elements + while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) { + # if possible of course :) + return new IMPL::DOM::Schema::ValidationError ( + Message => $this->messageUnexpected, + Node => $child, + Schema => $info->{Schema}, + Source => $this + ) if $info->{Min} > $info->{Seen}; + + $info = shift @nodes; + } + + # return error if no more children allowed + return new IMPL::DOM::Schema::ValidationError ( + Message => $this->messageUnexpected, + Node => $child, + Source => $this + ) unless $info; + + # it's ok, we found schema element for child + # but it may be any node or switching node wich would not satisfy current child + + # validate + while (my @errors = $info->{Schema}->Validate($child)) { + if( $info->{anyNode} and $info->{Seen} >= $info->{Min} ) { + # in case of any or switch node, skip it if possible + next if $info = shift @nodes; + } + return @errors; + } + + $info->{Seen}++; + + # check count limits + return new IMPL::DOM::Schema::ValidationError ( + Error => 1, + Message => $this->messageUnexpected, + Node => $child, + Source => $this, + ) if $info->{Max} and $info->{Seen} > $info->{Max}; + } + + # no more children left (but may be should :) + while ($info) { + return new IMPL::DOM::Schema::ValidationError ( + Error => 1, + Message => $this->messageNodesRequired, + Node => $node, + Source => $this, + Schema => $info->{Schema} + ) if $info->{Seen} < $info->{Min}; + + $info = shift @nodes; + } + return; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Содержимое для сложного узла. Порядок важен. Дочерними элементами могут быть +только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/NodeSet.pm --- a/Lib/IMPL/DOM/Schema/NodeSet.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/NodeSet.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,91 +1,91 @@ -package IMPL::DOM::Schema::NodeSet; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'NodeSet' } -); - -BEGIN { - public property messageUnexpected => prop_all; - public property messageMax => prop_all; - public property messageMin => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->messageMax( $args{messageMax} || 'Too many %Node.nodeName% nodes'); - $this->messageMin( $args{messageMin} || '%Schema.name% nodes expected'); - $this->messageUnexpected( $args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed in %Node.parentNode.path%'); -} - -sub Validate { - my ($this,$node) = @_; - - my @errors; - - my %nodes; - my $anyNode; - foreach (@{$this->childNodes}) { - if ($_->isa('IMPL::DOM::Schema::AnyNode')) { - $anyNode = {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , Seen => 0 }; - } else { - $nodes{$_->name} = {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , Seen => 0 }; - } - } - - foreach my $child ( @{$node->childNodes} ) { - if (my $info = $nodes{$child->nodeName} || $anyNode) { - $info->{Seen}++; - push @errors,new IMPL::DOM::Schema::ValidationError ( - Source => $this, - Node => $child, - Schema => $info->{Schema}, - Message => $this->messageMax - ) if ($info->{Max} and $info->{Seen} > $info->{Max}); - - if (my @localErrors = $info->{Schema}->Validate($child)) { - push @errors,@localErrors; - } - } else { - push @errors, new IMPL::DOM::Schema::ValidationError ( - Source => $this, - Node => $child, - Schema => $info->{Schema}, - Message => $this->messageUnexpected - ) - } - } - - foreach my $info (values %nodes) { - push @errors, new IMPL::DOM::Schema::ValidationError ( - Source => $this, - Schema => $info->{Schema}, - Node => $node, - Message => $this->messageMin - ) if $info->{Min} > $info->{Seen}; - } - - return @errors; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Содержимое для сложного узла. Порядок не важен. Дочерними элементами могут быть -только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. - -При проверке данного правила, проверяются имеющиеся элементы на соответсие схемы -и количества встречаемости, после чего проверяются количественные ограничения -для несуществующих элементов. - -=cut +package IMPL::DOM::Schema::NodeSet; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); +use IMPL::Class::Property; + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'NodeSet' } +); + +BEGIN { + public property messageUnexpected => prop_all; + public property messageMax => prop_all; + public property messageMin => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->messageMax( $args{messageMax} || 'Too many %Node.nodeName% nodes'); + $this->messageMin( $args{messageMin} || '%Schema.name% nodes expected'); + $this->messageUnexpected( $args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed in %Node.parentNode.path%'); +} + +sub Validate { + my ($this,$node) = @_; + + my @errors; + + my %nodes; + my $anyNode; + foreach (@{$this->childNodes}) { + if ($_->isa('IMPL::DOM::Schema::AnyNode')) { + $anyNode = {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , Seen => 0 }; + } else { + $nodes{$_->name} = {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , Seen => 0 }; + } + } + + foreach my $child ( @{$node->childNodes} ) { + if (my $info = $nodes{$child->nodeName} || $anyNode) { + $info->{Seen}++; + push @errors,new IMPL::DOM::Schema::ValidationError ( + Source => $this, + Node => $child, + Schema => $info->{Schema}, + Message => $this->messageMax + ) if ($info->{Max} and $info->{Seen} > $info->{Max}); + + if (my @localErrors = $info->{Schema}->Validate($child)) { + push @errors,@localErrors; + } + } else { + push @errors, new IMPL::DOM::Schema::ValidationError ( + Source => $this, + Node => $child, + Schema => $info->{Schema}, + Message => $this->messageUnexpected + ) + } + } + + foreach my $info (values %nodes) { + push @errors, new IMPL::DOM::Schema::ValidationError ( + Source => $this, + Schema => $info->{Schema}, + Node => $node, + Message => $this->messageMin + ) if $info->{Min} > $info->{Seen}; + } + + return @errors; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Содержимое для сложного узла. Порядок не важен. Дочерними элементами могут быть +только C<IMPL::DOM::Schema::ComplexNode> и C<IMPL::DOM::Schema::SimpleNode>. + +При проверке данного правила, проверяются имеющиеся элементы на соответсие схемы +и количества встречаемости, после чего проверяются количественные ограничения +для несуществующих элементов. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/Property.pm --- a/Lib/IMPL/DOM/Schema/Property.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/Property.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,54 +1,54 @@ -package IMPL::DOM::Schema::Property; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::SimpleNode); -require IMPL::DOM::Schema; -require IMPL::DOM::Node; -use IMPL::Class::Property; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public property RequiredMessage => prop_all; -} - -our %CTOR = ( - 'IMPL::DOM::Schema::SimpleNode' => sub { - my %args = @_; - - $args{maxOccur} = 1; - $args{minOccur} = delete $args{optional} ? 0 : 1; - $args{nodeName} ||= 'Property'; - - return %args; - } -); - -sub CTOR { - my ($this,%args) = @_; - - $this->RequiredMessage($args{RequiredMessage} || 'A property %Schema.name% is required in the %Node.qname%'); -} - -sub Validate { - my ($this,$node) = @_; - - if ($this->minOccur) { - my $prop = $this->name; - my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => $node->$prop() || $node->nodePropety($prop)); - - if (! $nodeProp->nodeValue) { - return new IMPL::DOM::Schema::ValidationError( - Message => $this->RequiredMessage, - Node => $node, - Schema => $this - ); - } - return $this->SUPER::Validate($nodeProp); - } else { - return (); - } -} - -1; +package IMPL::DOM::Schema::Property; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::SimpleNode); +require IMPL::DOM::Schema; +require IMPL::DOM::Node; +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property RequiredMessage => prop_all; +} + +our %CTOR = ( + 'IMPL::DOM::Schema::SimpleNode' => sub { + my %args = @_; + + $args{maxOccur} = 1; + $args{minOccur} = delete $args{optional} ? 0 : 1; + $args{nodeName} ||= 'Property'; + + return %args; + } +); + +sub CTOR { + my ($this,%args) = @_; + + $this->RequiredMessage($args{RequiredMessage} || 'A property %Schema.name% is required in the %Node.qname%'); +} + +sub Validate { + my ($this,$node) = @_; + + if ($this->minOccur) { + my $prop = $this->name; + my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => $node->$prop() || $node->nodePropety($prop)); + + if (! $nodeProp->nodeValue) { + return new IMPL::DOM::Schema::ValidationError( + Message => $this->RequiredMessage, + Node => $node, + Schema => $this + ); + } + return $this->SUPER::Validate($nodeProp); + } else { + return (); + } +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/SimpleNode.pm --- a/Lib/IMPL/DOM/Schema/SimpleNode.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,29 +1,29 @@ -package IMPL::DOM::Schema::SimpleNode; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::Node); - -our %CTOR = ( - 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'SimpleNode'; %args} -); - -sub Validate { - my ($this,$node) = @_; - - map $_->Validate($node), @{$this->childNodes}; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Узел имеющий простое значение. Данный узел может содержать ограничения -на простое значение. - - -=cut \ No newline at end of file +package IMPL::DOM::Schema::SimpleNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::Node); + +our %CTOR = ( + 'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'SimpleNode'; %args} +); + +sub Validate { + my ($this,$node) = @_; + + map $_->Validate($node), @{$this->childNodes}; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Узел имеющий простое значение. Данный узел может содержать ограничения +на простое значение. + + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/SimpleType.pm --- a/Lib/IMPL/DOM/Schema/SimpleType.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/SimpleType.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,31 +1,31 @@ -package IMPL::DOM::Schema::SimpleType; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::SimpleNode); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property nativeType => prop_get; -} - -our %CTOR = ( - 'IMPL::DOM::Schema::SimpleNode' => sub { - my %args = @_; - $args{nodeName} = 'SimpleType'; - $args{minOccur} = 0; - $args{maxOccur} = 'unbounded'; - $args{name} ||= 'SimpleType'; - %args - } -); - -sub CTOR { - my ($this,%args) = @_; - - $this->{$nativeType} = $args{nativeType}; -} - - -1; +package IMPL::DOM::Schema::SimpleType; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::SimpleNode); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property nativeType => prop_get; +} + +our %CTOR = ( + 'IMPL::DOM::Schema::SimpleNode' => sub { + my %args = @_; + $args{nodeName} = 'SimpleType'; + $args{minOccur} = 0; + $args{maxOccur} = 'unbounded'; + $args{name} ||= 'SimpleType'; + %args + } +); + +sub CTOR { + my ($this,%args) = @_; + + $this->{$nativeType} = $args{nativeType}; +} + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/SwitchNode.pm --- a/Lib/IMPL/DOM/Schema/SwitchNode.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/SwitchNode.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,54 +1,54 @@ -package IMPL::DOM::Schema::SwitchNode; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema::AnyNode); -use IMPL::Class::Property; -require IMPL::DOM::Schema::ValidationError; - -our %CTOR = ( - 'IMPL::DOM::Schema::AnyNode' => sub { - my %args = @_; - - $args{nodeName} ||= 'SwitchNode'; - - %args; - } -); - -BEGIN { - public property messageNoMatch => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->messageNoMatch($args{messageNoMatch} || 'A node %Node.nodeName% isn\'t expected in the %Node.parentNode.path%'); -} - -sub Validate { - my ($this,$node) = @_; - - if ( my ($schema) = $this->selectNodes(sub {$_[0]->name eq $node->nodeName} ) ) { - return $schema->Validate($node); - } else { - return new IMPL::DOM::Schema::ValidationError( - Node => $node, - Source => $this, - Message => $this->messageNoMatch - ); - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Представляет узел, который может быть одним из узлов, которые лежат внутри него. -Это более строгий вариант C<IMPL::DOM::Schema::AnyNode>. - -=cut +package IMPL::DOM::Schema::SwitchNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::AnyNode); +use IMPL::Class::Property; +require IMPL::DOM::Schema::ValidationError; + +our %CTOR = ( + 'IMPL::DOM::Schema::AnyNode' => sub { + my %args = @_; + + $args{nodeName} ||= 'SwitchNode'; + + %args; + } +); + +BEGIN { + public property messageNoMatch => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->messageNoMatch($args{messageNoMatch} || 'A node %Node.nodeName% isn\'t expected in the %Node.parentNode.path%'); +} + +sub Validate { + my ($this,$node) = @_; + + if ( my ($schema) = $this->selectNodes(sub {$_[0]->name eq $node->nodeName} ) ) { + return $schema->Validate($node); + } else { + return new IMPL::DOM::Schema::ValidationError( + Node => $node, + Source => $this, + Message => $this->messageNoMatch + ); + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Представляет узел, который может быть одним из узлов, которые лежат внутри него. +Это более строгий вариант C<IMPL::DOM::Schema::AnyNode>. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Schema/ValidationError.pm --- a/Lib/IMPL/DOM/Schema/ValidationError.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,26 +1,26 @@ -package IMPL::DOM::Schema::ValidationError; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use IMPL::Resources::Format qw(FormatMessage); - -BEGIN { - public _direct property Node => prop_get; - public _direct property Schema => prop_get; - public _direct property Source => prop_get; - public _direct property Message => prop_get; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Node} = $args{Node} or die new IMPL::InvalidArgumentException("Node is a required parameter"); - $this->{$Schema} = $args{Schema} if $args{Schema}; - $this->{$Source} = $args{Source} if $args{Source}; - $this->{$Message} = FormatMessage(delete $args{Message}, \%args) if $args{Message}; -} - -1; +package IMPL::DOM::Schema::ValidationError; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use IMPL::Resources::Format qw(FormatMessage); + +BEGIN { + public _direct property Node => prop_get; + public _direct property Schema => prop_get; + public _direct property Source => prop_get; + public _direct property Message => prop_get; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$Node} = $args{Node} or die new IMPL::InvalidArgumentException("Node is a required parameter"); + $this->{$Schema} = $args{Schema} if $args{Schema}; + $this->{$Source} = $args{Source} if $args{Source}; + $this->{$Message} = FormatMessage(delete $args{Message}, \%args) if $args{Message}; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Transform.pm --- a/Lib/IMPL/DOM/Transform.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Transform.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,33 +1,33 @@ -package IMPL::DOM::Transform; -use strict; -use warnings; - -use base qw(IMPL::Transform); - -__PACKAGE__->PassThroughArgs; - -sub GetClassForObject { - my ($this,$object) = @_; - - if (my $class = ref $object) { - if (UNIVERSAL::isa($object,'IMPL::DOM::Node')) { - return $object->nodeName; - } else { - return $class; - } - } else { - return undef; - } -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Преобразование для DOM документа - -=cut \ No newline at end of file +package IMPL::DOM::Transform; +use strict; +use warnings; + +use base qw(IMPL::Transform); + +__PACKAGE__->PassThroughArgs; + +sub GetClassForObject { + my ($this,$object) = @_; + + if (my $class = ref $object) { + if (UNIVERSAL::isa($object,'IMPL::DOM::Node')) { + return $object->nodeName; + } else { + return $class; + } + } else { + return undef; + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Преобразование для DOM документа + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/Transform/PostToDOM.pm --- a/Lib/IMPL/DOM/Transform/PostToDOM.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/Transform/PostToDOM.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,36 +1,36 @@ -package IMPL::DOM::Post2DOM; -use strict; -use warnings; - -use IMPL::DOM::Navigator; -use IMPL::Class::Property; - -use base qw(IMPL::Transform); - -BEGIN { - public property Navigator => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::Transform' => sub { - return ( - HASH => \&TransfromPostData - ); - } -); - -sub TransformPostData { - my ($this,$data) = @_; - - my $navi = $this->Navigator; - - while (my ($key,$value) = each %$data) { - my $node = $navi->Navigate($key); - $node->nodeValue($value); - } - - return $navi->Document; -} - - -1; +package IMPL::DOM::Post2DOM; +use strict; +use warnings; + +use IMPL::DOM::Navigator; +use IMPL::Class::Property; + +use base qw(IMPL::Transform); + +BEGIN { + public property Navigator => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::Transform' => sub { + return ( + HASH => \&TransfromPostData + ); + } +); + +sub TransformPostData { + my ($this,$data) = @_; + + my $navi = $this->Navigator; + + while (my ($key,$value) = each %$data) { + my $node = $navi->Navigate($key); + $node->nodeValue($value); + } + + return $navi->Document; +} + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/DOM/XMLReader.pm --- a/Lib/IMPL/DOM/XMLReader.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/DOM/XMLReader.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,105 +1,105 @@ -package IMPL::DOM::XMLReader; -use strict; -use warnings; - -use base qw(IMPL::Object IMPL::Object::Autofill); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; -use XML::Parser; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public _direct property Navigator => prop_get | owner_set; - private _direct property _current => prop_all; - private _direct property _text => prop_all; - private _direct property _textHistory => prop_all; -} - -sub Parse { - my ($this,$in) = @_; - - my $parser = new XML::Parser( - Handlers => { - Start => sub {shift; goto &OnStart($this,@_)}, - End => sub {shift; goto &OnEnd($this,@_)}, - Char => sub {shift; goto &OnChar($this,@_)} - } - ); - - $parser->parse($in); -} - -sub ParseFile { - my ($this,$in) = @_; - - my $parser = new XML::Parser( - Handlers => { - Start => sub {shift; unshift @_, $this; goto &_OnBegin;}, - End => sub {shift; unshift @_, $this; goto &_OnEnd;}, - Char => sub {shift; unshift @_, $this; goto &_OnChar;} - } - ); - - $parser->parsefile($in); -} - - -sub _OnBegin { - my ($this,$element,%attrs) = @_; - - push @{$this->{$_textHistory}},$this->{$_text}; - $this->{$_text} = ""; - $this->{$_current} = $this->Navigator->NavigateCreate($element,%attrs); -} - -sub _OnEnd { - my ($this,$element) = @_; - - $this->{$_current}->nodeValue($this->{$_text}) if length $this->{$_text}; - $this->{$_text} = pop @{$this->{$_textHistory}}; - $this->{$_current} = $this->Navigator->Back; -} - -sub _OnChar { - my ($this,$val) = @_; - $this->{$_text} .= $val; -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -my $reader = new IMPL::DOM::XMLReader(Navigator => $DomBuilder); -my $obj = $reader->parsefile("data.xml"); - -=head1 DESCRIPTION - -Простой класс, использующий навигатор для постороения документа. В зависимости от -используемого навигатора может быть получен различный результат. - -Навигатор должен поодерживать методы C<NavigateCreate> и C<Back> - -=head1 METHODS - -=over - -=item C<CTOR(Naviagtor => $builder)> - -Создает новый экземпляр парсера, с указанным навигатором для построения документа - -=item C<$obj->Parse($in)> - -Строит документ. На вход получает либо xml строку, либо HANDLE. - -=item C<$obj->ParseFile($fileName)> - -Строит документ из файла с именем C<$fileName>. - -=back - -=cut +package IMPL::DOM::XMLReader; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; +use XML::Parser; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public _direct property Navigator => prop_get | owner_set; + private _direct property _current => prop_all; + private _direct property _text => prop_all; + private _direct property _textHistory => prop_all; +} + +sub Parse { + my ($this,$in) = @_; + + my $parser = new XML::Parser( + Handlers => { + Start => sub {shift; goto &OnStart($this,@_)}, + End => sub {shift; goto &OnEnd($this,@_)}, + Char => sub {shift; goto &OnChar($this,@_)} + } + ); + + $parser->parse($in); +} + +sub ParseFile { + my ($this,$in) = @_; + + my $parser = new XML::Parser( + Handlers => { + Start => sub {shift; unshift @_, $this; goto &_OnBegin;}, + End => sub {shift; unshift @_, $this; goto &_OnEnd;}, + Char => sub {shift; unshift @_, $this; goto &_OnChar;} + } + ); + + $parser->parsefile($in); +} + + +sub _OnBegin { + my ($this,$element,%attrs) = @_; + + push @{$this->{$_textHistory}},$this->{$_text}; + $this->{$_text} = ""; + $this->{$_current} = $this->Navigator->NavigateCreate($element,%attrs); +} + +sub _OnEnd { + my ($this,$element) = @_; + + $this->{$_current}->nodeValue($this->{$_text}) if length $this->{$_text}; + $this->{$_text} = pop @{$this->{$_textHistory}}; + $this->{$_current} = $this->Navigator->Back; +} + +sub _OnChar { + my ($this,$val) = @_; + $this->{$_text} .= $val; +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +my $reader = new IMPL::DOM::XMLReader(Navigator => $DomBuilder); +my $obj = $reader->parsefile("data.xml"); + +=head1 DESCRIPTION + +Простой класс, использующий навигатор для постороения документа. В зависимости от +используемого навигатора может быть получен различный результат. + +Навигатор должен поодерживать методы C<NavigateCreate> и C<Back> + +=head1 METHODS + +=over + +=item C<CTOR(Naviagtor => $builder)> + +Создает новый экземпляр парсера, с указанным навигатором для построения документа + +=item C<$obj->Parse($in)> + +Строит документ. На вход получает либо xml строку, либо HANDLE. + +=item C<$obj->ParseFile($fileName)> + +Строит документ из файла с именем C<$fileName>. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Exception.pm --- a/Lib/IMPL/Exception.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Exception.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,113 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM.pm --- a/Lib/IMPL/ORM.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,123 +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 +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 diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Entity.pm --- a/Lib/IMPL/ORM/Entity.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Entity.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,48 +1,48 @@ -package IMPL::ORM::Entity; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Class => prop_get; - public _direct property Values => prop_get; - public _direct property Schema => prop_get; -} - -sub CTOR { - my ($this,$class,$schema) = @_; - - $this->{$Class} = $class; - (my $name = $class) =~ s/::/_/g; - $this->{$Name} = $name; - $this->Schema = $schema; - $this->{$Values} = { - map {$_->{name},{type => $_->{type}, virtual => $_->{virtual}}} @$schema - }; -} - -sub Store; -*Store = \&dbgStore; - -sub dbgStore { - my ($this,$prop,$value) = @_; - - if ( my $container = $this->{$Values}{$prop} ) { - $container->{oldValue} = $container->{value}; - $container->{value} = $value; - } else { - die new IMPL::InvalidOperationException("Property not found",$this->Name,$prop); - } -} - -sub Get { - my ($this,$prop) = @_; - - return $this->{$Values}{$prop}{value}; -} - -1; +package IMPL::ORM::Entity; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Class => prop_get; + public _direct property Values => prop_get; + public _direct property Schema => prop_get; +} + +sub CTOR { + my ($this,$class,$schema) = @_; + + $this->{$Class} = $class; + (my $name = $class) =~ s/::/_/g; + $this->{$Name} = $name; + $this->Schema = $schema; + $this->{$Values} = { + map {$_->{name},{type => $_->{type}, virtual => $_->{virtual}}} @$schema + }; +} + +sub Store; +*Store = \&dbgStore; + +sub dbgStore { + my ($this,$prop,$value) = @_; + + if ( my $container = $this->{$Values}{$prop} ) { + $container->{oldValue} = $container->{value}; + $container->{value} = $value; + } else { + die new IMPL::InvalidOperationException("Property not found",$this->Name,$prop); + } +} + +sub Get { + my ($this,$prop) = @_; + + return $this->{$Values}{$prop}{value}; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Helpers.pm --- a/Lib/IMPL/ORM/Helpers.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Helpers.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,24 +1,24 @@ -package IMPL::ORM::Helpers; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Map &Box); - -sub Map($$) { - my ($TKey,$TValue) = @_; - - $TKey =~ s/:://g; - $TValue =~ s/:://g; - - return "IMPL::ORM::Map::${TKey}${TValue}"; -} - -sub Box($) { - my ($TValue) = @_; - $TValue =~ s/:://g; - return "IMPL::ORM::Box::$TValue"; -} - -1; +package IMPL::ORM::Helpers; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&Map &Box); + +sub Map($$) { + my ($TKey,$TValue) = @_; + + $TKey =~ s/:://g; + $TValue =~ s/:://g; + + return "IMPL::ORM::Map::${TKey}${TValue}"; +} + +sub Box($) { + my ($TValue) = @_; + $TValue =~ s/:://g; + return "IMPL::ORM::Box::$TValue"; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Object.pm --- a/Lib/IMPL/ORM/Object.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Object.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,116 +1,116 @@ -package IMPL::ORM::Object; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -require IMPL::ORM::Entity; -require IMPL::ORM::Schema::Entity; -require IMPL::ORM::Schema::Field; -require IMPL::ORM::Schema::Relation::HasMany; -require IMPL::ORM::Schema::Relation::HasOne; -require IMPL::ORM::Schema::Relation::Subclass; - -BEGIN { - private _direct property _entities => prop_all; - public property objectType => prop_all, {type => 'String'}; - - sub _PropertyImplementor { - 'IMPL::ORM::PropertyImplementor' - } -} - -my %schemaCache; - -sub CTOR { - my ($this) = @_; - - while ( my ($class,$schema) = $this->ormGetSchema ) { - $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema); - } -} - -sub ormStore { - my ($this,$class,$prop,$value) = @_; - - die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class}; - - $this->{$_entities}{$class}->Store($prop,$value); -} - -sub ormGet { - my ($this,$class,$prop,$value) = @_; - - return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef; -} - -sub entityName { - (my $self = ref $_[0] || $_[0]) =~ s/^.*?(\w+)$/$1/; - return $self; -} - -sub ormGetSchema { - my ($self,$dataSchema,$surrogate) = @_; - - my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName); - - # для текущего класса, проходим по всем свойствам - foreach my $ormProp ( - $self->get_meta( - 'IMPL::Class::PropertyInfo', - sub { - UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' ) - }, - 0 - ) - ){ - if ($ormProp->Mutators & prop_list) { - # отношение 1 ко многим - my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name); - $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); - } elsif (my $type = $dataSchema->isValueType($ormProp->Type)) { - # поле - $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$ormProp->Type) ); - } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { - # отношение ссылка - $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); - } else { - # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле. - die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type); - } - } - - # Формируем отношения наследования - { - # локализуем прагму - no strict 'refs'; - - my $class = ref $self || $self; - - # по всем классам - foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) { - my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super); - $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type)); - } - } - - return $schema; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Базовый объект для реляционного отображения, -содержит в себе реляционные записи представляющие данный объект. - -Каждый класс отображается в определенную сущность. Сущности хранят -состояние объектов в том виде в котором удобно записывать в реляционную базу. - -=cut \ No newline at end of file +package IMPL::ORM::Object; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +require IMPL::ORM::Entity; +require IMPL::ORM::Schema::Entity; +require IMPL::ORM::Schema::Field; +require IMPL::ORM::Schema::Relation::HasMany; +require IMPL::ORM::Schema::Relation::HasOne; +require IMPL::ORM::Schema::Relation::Subclass; + +BEGIN { + private _direct property _entities => prop_all; + public property objectType => prop_all, {type => 'String'}; + + sub _PropertyImplementor { + 'IMPL::ORM::PropertyImplementor' + } +} + +my %schemaCache; + +sub CTOR { + my ($this) = @_; + + while ( my ($class,$schema) = $this->ormGetSchema ) { + $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema); + } +} + +sub ormStore { + my ($this,$class,$prop,$value) = @_; + + die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class}; + + $this->{$_entities}{$class}->Store($prop,$value); +} + +sub ormGet { + my ($this,$class,$prop,$value) = @_; + + return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef; +} + +sub entityName { + (my $self = ref $_[0] || $_[0]) =~ s/^.*?(\w+)$/$1/; + return $self; +} + +sub ormGetSchema { + my ($self,$dataSchema,$surrogate) = @_; + + my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName); + + # для текущего класса, проходим по всем свойствам + foreach my $ormProp ( + $self->get_meta( + 'IMPL::Class::PropertyInfo', + sub { + UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' ) + }, + 0 + ) + ){ + if ($ormProp->Mutators & prop_list) { + # отношение 1 ко многим + my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name); + $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); + } elsif (my $type = $dataSchema->isValueType($ormProp->Type)) { + # поле + $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$ormProp->Type) ); + } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { + # отношение ссылка + $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); + } else { + # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле. + die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type); + } + } + + # Формируем отношения наследования + { + # локализуем прагму + no strict 'refs'; + + my $class = ref $self || $self; + + # по всем классам + foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) { + my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super); + $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type)); + } + } + + return $schema; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Базовый объект для реляционного отображения, +содержит в себе реляционные записи представляющие данный объект. + +Каждый класс отображается в определенную сущность. Сущности хранят +состояние объектов в том виде в котором удобно записывать в реляционную базу. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/PropertyImplementor.pm --- a/Lib/IMPL/ORM/PropertyImplementor.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/PropertyImplementor.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,8 +1,8 @@ -package IMPL::ORM::PropertyImplementor; -use strict; -use warnings; - -use base qw(IMPL::Class::Property::Direct); - - -1; +package IMPL::ORM::PropertyImplementor; +use strict; +use warnings; + +use base qw(IMPL::Class::Property::Direct); + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema.pm --- a/Lib/IMPL/ORM/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,145 +1,145 @@ -package IMPL::ORM::Schema; -use strict; -use warnings; - -use base qw(IMPL::DOM::Document); -use IMPL::Class::Property; -require IMPL::ORM::Schema::Entity; -require IMPL::ORM::Schema::ValueType; - -our %CTOR = ( - 'IMPL::DOM::Document' => sub { nodeName => 'ORMSchema' } -); - -BEGIN { - public property mapValueTypes => prop_get | owner_set; - public property mapReferenceTypes => prop_get | owner_set; - public property mapPending => prop_get | owner_set; - public property prefix => prop_get | owner_set; -} - -sub CTOR { - my ($this ) = @_; - $this->mapValueTypes({}); - $this->mapReferenceTypes({}); - $this->mapPending({}); -} - -# return an entity for the specified typename -# makes forward declaration if nesessary -sub resolveType { - my ($this,$typeName) = @_; - - $this = ref $this ? $this : $this->instance; - - if (my $entity = $this->mapReferenceTypes->{$typeName}) { - return $entity; - } elsif (UNIVERSAL::isa($typeName,'IMPL::ORM::Object')) { - return $this->declareReferenceType($typeName); - } else { - return undef; - } -} - -sub declareReferenceType { - my ($this,$typeName) = @_; - - my $entity = new IMPL::ORM::Schema::Entity($typeName->entityName); - - $this->mapPending->{$typeName} = $entity; - - $this->appendChild($entity); - - return $this->mapReferenceTypes->{$typeName} = $entity; -} - -sub _addReferenceType { - my ($this,$className) = @_; - - if ( my $entity = delete $this->mapPending->{$className} ) { - $className->ormGetSchema($this,$entity); - } else { - return $this->appendChild( $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this) ); - } - -} - -# returns valuetype name -sub isValueType { - my ($this,$typeName) = @_; - - $this = ref $this ? $this : $this->instance; - - return $this->mapValueTypes->{$typeName}; -} - -my %instances; -sub instance { - my ($class) = @_; - - return ($instances{$class} || ($instances{$class} = $class->new)); -} - -sub ValueTypes { - my ($this,%classes) = @_; - - $this = ref $this ? $this : $this->instance; - - while ( my ($typeName,$typeReflected) = each %classes ) { - $this->mapValueTypes->{$typeName} = $typeReflected; - $this->appendChild(IMPL::ORM::Schema::ValueType->new($typeName,$typeReflected)); - } -} - -sub Classes { - my ($this,@classNames) = @_; - - $this = ref $this ? $this : $this->instance; - - $this->_addReferenceType($this->prefix . $_) foreach @classNames; -} - -sub usePrefix { - my ($this,$prefix) = @_; - - $prefix .= '::' if $prefix and $prefix !~ /::$/; - - (ref $this ? $this : $this->instance)->prefix($prefix); -} - -sub CompleteSchema { - my ($this) = @_; - - $this = ref $this ? $this : $this->instance; - - $_->ormGetSchema($this,delete $this->mapPending->{$_}) foreach (keys %{$this->mapPending}); -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION - -Схема данных, представляет собой DOM документ, элементами которой -являются сущности. - -Каждый узел - это описание сущности. - -<Schema> - <Entity entityName="My_Data_Foo"> - <Field fieldName="Doo" fieldType="String"/> - <HasMany name="Boxes" target="My_Data_Box"/> - </Entity> - <Entity entityName="My_Data_Bar"> - <Subclass base="My_Data_Foo"/> - <Field fieldName="Timestamp" fieldType="Integer"/> - </Entity> - <Entity entityName="My_Data_Box"> - <Field fieldName="Capacity" fieldType="Integer"/> - </Entity> -</Schema> - -=cut \ No newline at end of file +package IMPL::ORM::Schema; +use strict; +use warnings; + +use base qw(IMPL::DOM::Document); +use IMPL::Class::Property; +require IMPL::ORM::Schema::Entity; +require IMPL::ORM::Schema::ValueType; + +our %CTOR = ( + 'IMPL::DOM::Document' => sub { nodeName => 'ORMSchema' } +); + +BEGIN { + public property mapValueTypes => prop_get | owner_set; + public property mapReferenceTypes => prop_get | owner_set; + public property mapPending => prop_get | owner_set; + public property prefix => prop_get | owner_set; +} + +sub CTOR { + my ($this ) = @_; + $this->mapValueTypes({}); + $this->mapReferenceTypes({}); + $this->mapPending({}); +} + +# return an entity for the specified typename +# makes forward declaration if nesessary +sub resolveType { + my ($this,$typeName) = @_; + + $this = ref $this ? $this : $this->instance; + + if (my $entity = $this->mapReferenceTypes->{$typeName}) { + return $entity; + } elsif (UNIVERSAL::isa($typeName,'IMPL::ORM::Object')) { + return $this->declareReferenceType($typeName); + } else { + return undef; + } +} + +sub declareReferenceType { + my ($this,$typeName) = @_; + + my $entity = new IMPL::ORM::Schema::Entity($typeName->entityName); + + $this->mapPending->{$typeName} = $entity; + + $this->appendChild($entity); + + return $this->mapReferenceTypes->{$typeName} = $entity; +} + +sub _addReferenceType { + my ($this,$className) = @_; + + if ( my $entity = delete $this->mapPending->{$className} ) { + $className->ormGetSchema($this,$entity); + } else { + return $this->appendChild( $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this) ); + } + +} + +# returns valuetype name +sub isValueType { + my ($this,$typeName) = @_; + + $this = ref $this ? $this : $this->instance; + + return $this->mapValueTypes->{$typeName}; +} + +my %instances; +sub instance { + my ($class) = @_; + + return ($instances{$class} || ($instances{$class} = $class->new)); +} + +sub ValueTypes { + my ($this,%classes) = @_; + + $this = ref $this ? $this : $this->instance; + + while ( my ($typeName,$typeReflected) = each %classes ) { + $this->mapValueTypes->{$typeName} = $typeReflected; + $this->appendChild(IMPL::ORM::Schema::ValueType->new($typeName,$typeReflected)); + } +} + +sub Classes { + my ($this,@classNames) = @_; + + $this = ref $this ? $this : $this->instance; + + $this->_addReferenceType($this->prefix . $_) foreach @classNames; +} + +sub usePrefix { + my ($this,$prefix) = @_; + + $prefix .= '::' if $prefix and $prefix !~ /::$/; + + (ref $this ? $this : $this->instance)->prefix($prefix); +} + +sub CompleteSchema { + my ($this) = @_; + + $this = ref $this ? $this : $this->instance; + + $_->ormGetSchema($this,delete $this->mapPending->{$_}) foreach (keys %{$this->mapPending}); +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + +Схема данных, представляет собой DOM документ, элементами которой +являются сущности. + +Каждый узел - это описание сущности. + +<Schema> + <Entity entityName="My_Data_Foo"> + <Field fieldName="Doo" fieldType="String"/> + <HasMany name="Boxes" target="My_Data_Box"/> + </Entity> + <Entity entityName="My_Data_Bar"> + <Subclass base="My_Data_Foo"/> + <Field fieldName="Timestamp" fieldType="Integer"/> + </Entity> + <Entity entityName="My_Data_Box"> + <Field fieldName="Capacity" fieldType="Integer"/> + </Entity> +</Schema> + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/Entity.pm --- a/Lib/IMPL/ORM/Schema/Entity.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Entity.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,24 +1,24 @@ -package IMPL::ORM::Schema::Entity; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -BEGIN { - public property entityName => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { - nodeName => 'Entity' - } -); - -sub CTOR { - my ($this,$name) = @_; - - $this->entityName($name); -} - -1; +package IMPL::ORM::Schema::Entity; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); +use IMPL::Class::Property; + +BEGIN { + public property entityName => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { + nodeName => 'Entity' + } +); + +sub CTOR { + my ($this,$name) = @_; + + $this->entityName($name); +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/Field.pm --- a/Lib/IMPL/ORM/Schema/Field.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Field.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,30 +1,30 @@ -package IMPL::ORM::Schema::Field; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); -use IMPL::Class::Property; - -BEGIN { - public property fieldName => prop_get | owner_set; - public property fieldType => prop_get | owner_set; - public property fieldNullbale => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'Field' } -); - -sub CTOR { - my ($this,$name,$type,$nullable) = @_; - - $this->fieldName($name) or die new IMPL::InvalidArgumentException('A name is required for the field'); - $this->fieldType($type) or die new IMPL::InvalidArgumentException('A type is required for the field'); - $this->fieldNullbale(1) if $nullable; -} - -sub canHaveChildren { - 0; -} - -1; +package IMPL::ORM::Schema::Field; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); +use IMPL::Class::Property; + +BEGIN { + public property fieldName => prop_get | owner_set; + public property fieldType => prop_get | owner_set; + public property fieldNullbale => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'Field' } +); + +sub CTOR { + my ($this,$name,$type,$nullable) = @_; + + $this->fieldName($name) or die new IMPL::InvalidArgumentException('A name is required for the field'); + $this->fieldType($type) or die new IMPL::InvalidArgumentException('A type is required for the field'); + $this->fieldNullbale(1) if $nullable; +} + +sub canHaveChildren { + 0; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/Relation.pm --- a/Lib/IMPL/ORM/Schema/Relation.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Relation.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,12 +1,12 @@ -package IMPL::ORM::Schema::Relation; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); - -our %CTOR =( - 'IMPL::DOM::Node' => sub { nodeName => $_[0] } -); - - -1; +package IMPL::ORM::Schema::Relation; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); + +our %CTOR =( + 'IMPL::DOM::Node' => sub { nodeName => $_[0] } +); + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/Relation/HasMany.pm --- a/Lib/IMPL/ORM/Schema/Relation/HasMany.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Relation/HasMany.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,27 +1,27 @@ -package IMPL::ORM::Schema::Relation::HasMany; -use strict; -use warnings; - -use base qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property target => prop_get | owner_set; - public property name => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'HasMany' } -); - -sub CTOR { - my ($this,$name,$target) = @_; - $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); - $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); -} - -sub canHaveChildren { - 0; -} - -1; +package IMPL::ORM::Schema::Relation::HasMany; +use strict; +use warnings; + +use base qw(IMPL::ORM::Schema::Relation); +use IMPL::Class::Property; + +BEGIN { + public property target => prop_get | owner_set; + public property name => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::ORM::Schema::Relation' => sub { 'HasMany' } +); + +sub CTOR { + my ($this,$name,$target) = @_; + $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); + $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); +} + +sub canHaveChildren { + 0; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/Relation/HasOne.pm --- a/Lib/IMPL/ORM/Schema/Relation/HasOne.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Relation/HasOne.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,28 +1,28 @@ -package IMPL::ORM::Schema::Relation::HasOne; -use strict; -use warnings; - -use base qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property target => prop_get | owner_set; - public property name => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'HasOne' } -); - -sub CTOR { - my ($this,$name,$target) = @_; - $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); - $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); -} - -sub canHaveChildren { - 0; -} - - -1; +package IMPL::ORM::Schema::Relation::HasOne; +use strict; +use warnings; + +use base qw(IMPL::ORM::Schema::Relation); +use IMPL::Class::Property; + +BEGIN { + public property target => prop_get | owner_set; + public property name => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::ORM::Schema::Relation' => sub { 'HasOne' } +); + +sub CTOR { + my ($this,$name,$target) = @_; + $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation'); + $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name); +} + +sub canHaveChildren { + 0; +} + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/Relation/Subclass.pm --- a/Lib/IMPL/ORM/Schema/Relation/Subclass.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Relation/Subclass.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,26 +1,26 @@ -package IMPL::ORM::Schema::Relation::Subclass; -use strict; -use warnings; - -use base qw(IMPL::ORM::Schema::Relation); -use IMPL::Class::Property; - -BEGIN { - public property base => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::ORM::Schema::Relation' => sub { 'Subclass' } -); - -sub CTOR { - my ($this,$base) = @_; - - $this->base($base) or die new IMPL::InvalidArgumentException('A base is required for this relation'); -} - -sub canHaveChildren { - 0; -} - -1; +package IMPL::ORM::Schema::Relation::Subclass; +use strict; +use warnings; + +use base qw(IMPL::ORM::Schema::Relation); +use IMPL::Class::Property; + +BEGIN { + public property base => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::ORM::Schema::Relation' => sub { 'Subclass' } +); + +sub CTOR { + my ($this,$base) = @_; + + $this->base($base) or die new IMPL::InvalidArgumentException('A base is required for this relation'); +} + +sub canHaveChildren { + 0; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/TransformToSQL.pm --- a/Lib/IMPL/ORM/Schema/TransformToSQL.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/TransformToSQL.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,177 +1,177 @@ -package IMPL::ORM::Schema::TransformToSQL; -use strict; -use warnings; - -use base qw(IMPL::DOM::Transform); -use IMPL::Class::Property; -use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary); - -require IMPL::SQL::Schema; - -BEGIN { - public property Types => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Transform' => sub { - ORMSchema => \&ORMSchemaTransform, - Entity => \&EntityTransform, - Field => \&FieldTransform, - HasOne => \&HasOneTransform, - HasMany => \&HasManyTransform, - Subclass => \&SubclassTransform, - ValueType => sub {} - } -); - -sub CTOR { - my ($this,$refTypeMap) = @_; - - $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required"); -} - -sub ORMSchemaTransform { - my ($this,$node) = @_; - - my $schema = IMPL::SQL::Schema->new(Name => ref $node); - - my @constraints; - - my %ctx = (Schema => $schema); - - # all tables - foreach my $entity ($node->selectNodes('Entity')) { - $schema->AddTable($this->Transform($entity,\%ctx)); - push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')}); - } - - # establish relations - $this->Transform($_,\%ctx) foreach @constraints; - - return $schema; -} - -sub EntityTransform { - my ($this,$node,$ctx) = @_; - - my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema}); - - $this->MakePrimaryKey($table); - - $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field'); - - return $table; -} - -sub FieldTransform { - my ($this,$field,$ctx) = @_; - - return { - Name => $field->fieldName, - Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType), - CanBeNull => $field->fieldNullable - }; -} - -sub HasOneTransform { - my ($this,$relation,$ctx) = @_; - - my $sqlSchema = $ctx->{Schema}; - my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; - my $tableForeign = $sqlSchema->Tables->{$relation->target}; - my $prefix = $relation->name; - - my @fkColumns = @{$tableForeign->PrimaryKey->Columns}; - - if (@fkColumns > 1) { - @fkColumns = map - $table->InsertColumn({ - Name => $prefix . $_->Name, - Type => $_->Type, - CanBeNull => 1 - }), @fkColumns; - } else { - @fkColumns = $table->InsertColumn({ - Name => $prefix, - Type => $fkColumns[0]->Type, - CanBeNull => 1 - }); - } - - $table->LinkTo($tableForeign,@fkColumns); -} - -sub HasManyTransform { - my ($this,$relation,$ctx) = @_; - - #similar to HasOne - - my $sqlSchema = $ctx->{Schema}; - my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; - my $tableForeign = $sqlSchema->Tables->{$relation->target}; - my $prefix = $relation->name; - - my @fkColumns = @{$table->PrimaryKey->Columns}; - - if (@fkColumns > 1 ) { - @fkColumns = map $tableForeign->InsertColumn({ - Name => $prefix . $_->Name, - Type => $_->Type, - CanBeNull => 1 - }), @fkColumns; - } else { - @fkColumns = $tableForeign->InsertColumn({ - Name => $prefix, - Type => $fkColumns[0]->Type, - CanBeNull => 1 - }); - } - - $tableForeign->LinkTo($table,@fkColumns); -} - -sub SubclassTransform { - # actually this rlations has only logical implementation -} - -sub MapType { - my ($this,$typeName) = @_; - - $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName); -} - -sub MakePrimaryKey { - my ($this,$table) = @_; - - $table->InsertColumn( {Name => '_Id', Type => Integer } ); - $table->SetPrimaryKey('_Id'); -} - -{ - my $std; - sub Std { - $std ||= __PACKAGE__->new({ - String => Varchar(255), - DateTime => DateTime, - Integer => Integer, - Float => Float(24), - Decimal => Float(53), - Real => Float(24), - Binary => Binary, - Text => Text - }); - } -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance); - -=cut - +package IMPL::ORM::Schema::TransformToSQL; +use strict; +use warnings; + +use base qw(IMPL::DOM::Transform); +use IMPL::Class::Property; +use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary); + +require IMPL::SQL::Schema; + +BEGIN { + public property Types => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Transform' => sub { + ORMSchema => \&ORMSchemaTransform, + Entity => \&EntityTransform, + Field => \&FieldTransform, + HasOne => \&HasOneTransform, + HasMany => \&HasManyTransform, + Subclass => \&SubclassTransform, + ValueType => sub {} + } +); + +sub CTOR { + my ($this,$refTypeMap) = @_; + + $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required"); +} + +sub ORMSchemaTransform { + my ($this,$node) = @_; + + my $schema = IMPL::SQL::Schema->new(Name => ref $node); + + my @constraints; + + my %ctx = (Schema => $schema); + + # all tables + foreach my $entity ($node->selectNodes('Entity')) { + $schema->AddTable($this->Transform($entity,\%ctx)); + push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')}); + } + + # establish relations + $this->Transform($_,\%ctx) foreach @constraints; + + return $schema; +} + +sub EntityTransform { + my ($this,$node,$ctx) = @_; + + my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema}); + + $this->MakePrimaryKey($table); + + $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field'); + + return $table; +} + +sub FieldTransform { + my ($this,$field,$ctx) = @_; + + return { + Name => $field->fieldName, + Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType), + CanBeNull => $field->fieldNullable + }; +} + +sub HasOneTransform { + my ($this,$relation,$ctx) = @_; + + my $sqlSchema = $ctx->{Schema}; + my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; + my $tableForeign = $sqlSchema->Tables->{$relation->target}; + my $prefix = $relation->name; + + my @fkColumns = @{$tableForeign->PrimaryKey->Columns}; + + if (@fkColumns > 1) { + @fkColumns = map + $table->InsertColumn({ + Name => $prefix . $_->Name, + Type => $_->Type, + CanBeNull => 1 + }), @fkColumns; + } else { + @fkColumns = $table->InsertColumn({ + Name => $prefix, + Type => $fkColumns[0]->Type, + CanBeNull => 1 + }); + } + + $table->LinkTo($tableForeign,@fkColumns); +} + +sub HasManyTransform { + my ($this,$relation,$ctx) = @_; + + #similar to HasOne + + my $sqlSchema = $ctx->{Schema}; + my $table = $sqlSchema->Tables->{$relation->parentNode->entityName}; + my $tableForeign = $sqlSchema->Tables->{$relation->target}; + my $prefix = $relation->name; + + my @fkColumns = @{$table->PrimaryKey->Columns}; + + if (@fkColumns > 1 ) { + @fkColumns = map $tableForeign->InsertColumn({ + Name => $prefix . $_->Name, + Type => $_->Type, + CanBeNull => 1 + }), @fkColumns; + } else { + @fkColumns = $tableForeign->InsertColumn({ + Name => $prefix, + Type => $fkColumns[0]->Type, + CanBeNull => 1 + }); + } + + $tableForeign->LinkTo($table,@fkColumns); +} + +sub SubclassTransform { + # actually this rlations has only logical implementation +} + +sub MapType { + my ($this,$typeName) = @_; + + $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName); +} + +sub MakePrimaryKey { + my ($this,$table) = @_; + + $table->InsertColumn( {Name => '_Id', Type => Integer } ); + $table->SetPrimaryKey('_Id'); +} + +{ + my $std; + sub Std { + $std ||= __PACKAGE__->new({ + String => Varchar(255), + DateTime => DateTime, + Integer => Integer, + Float => Float(24), + Decimal => Float(53), + Real => Float(24), + Binary => Binary, + Text => Text + }); + } +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance); + +=cut + diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Schema/ValueType.pm --- a/Lib/IMPL/ORM/Schema/ValueType.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/ValueType.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,31 +1,31 @@ -package IMPL::ORM::Schema::ValueType; - -use strict; - -use base qw(IMPL::DOM::Node); - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'ValueType' } -); - -use IMPL::Class::Property; - -BEGIN { - public property typeName => prop_all; - public property typeReflected => prop_all; -} - -sub CTOR { - my ($this,$typeName,$typeReflected) = @_; - - $this->typeName($typeName); - $this->typeReflected($typeReflected); -} - -1; - -__END__ - -=pod - -=cut \ No newline at end of file +package IMPL::ORM::Schema::ValueType; + +use strict; + +use base qw(IMPL::DOM::Node); + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'ValueType' } +); + +use IMPL::Class::Property; + +BEGIN { + public property typeName => prop_all; + public property typeReflected => prop_all; +} + +sub CTOR { + my ($this,$typeName,$typeReflected) = @_; + + $this->typeName($typeName); + $this->typeReflected($typeReflected); +} + +1; + +__END__ + +=pod + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/ORM/Store/SQL.pm --- a/Lib/IMPL/ORM/Store/SQL.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/ORM/Store/SQL.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,30 +1,30 @@ -package IMPL::ORM::Store::SQL; -use strict; -use warnings; - -use base qw(IMPL::Object); - -use IMPL::Class::Property; - -BEGIN { - public property Connection => prop_all; -} - -sub loadObjects { - my ($this,$rObjects) = @_; -} - -sub search { - my ($this,$query) = @_; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION -Драйвер для SQL баз данных. - -=cut \ No newline at end of file +package IMPL::ORM::Store::SQL; +use strict; +use warnings; + +use base qw(IMPL::Object); + +use IMPL::Class::Property; + +BEGIN { + public property Connection => prop_all; +} + +sub loadObjects { + my ($this,$rObjects) = @_; +} + +sub search { + my ($this,$query) = @_; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION +Драйвер для SQL баз данных. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object.pm --- a/Lib/IMPL/Object.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,103 +1,103 @@ -package IMPL::Object; -use strict; - -use base qw(IMPL::Object::Abstract); - -sub surrogate { - bless {}, ref $_[0] || $_[0]; -} - -sub new { - my $class = shift; - my $self = bless {}, ref($class) || $class; - $self->callCTOR(@_); - - $self; -} - -sub _PropertyImplementor { - 'IMPL::Class::Property::Direct' -} - -=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 -# Bar: -# Composite: Hello World! - -=h1 Description -Базовый класс для объектов, основанных на хеше. - -=h1 Members - -=level 4 - -=item operator C<new>(@args) - -Создает экземпляр объекта и вызывает конструктор с параметрами @args. - -=item operator C<surrogate>() - -Создает неинициализированный экземпляр объекта. - -=back - -=р1 Cavearts - -Нужно заметить, что директива C<use base> работает не совсем прозрачно, если в нашем примере -класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от -C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:) - -=cut - -1; \ No newline at end of file +package IMPL::Object; +use strict; + +use base qw(IMPL::Object::Abstract); + +sub surrogate { + bless {}, ref $_[0] || $_[0]; +} + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + $self->callCTOR(@_); + + $self; +} + +sub _PropertyImplementor { + 'IMPL::Class::Property::Direct' +} + +=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 +# Bar: +# Composite: Hello World! + +=h1 Description +Базовый класс для объектов, основанных на хеше. + +=h1 Members + +=level 4 + +=item operator C<new>(@args) + +Создает экземпляр объекта и вызывает конструктор с параметрами @args. + +=item operator C<surrogate>() + +Создает неинициализированный экземпляр объекта. + +=back + +=р1 Cavearts + +Нужно заметить, что директива C<use base> работает не совсем прозрачно, если в нашем примере +класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от +C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:) + +=cut + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Abstract.pm --- a/Lib/IMPL/Object/Abstract.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Abstract.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,136 +1,136 @@ -package IMPL::Object::Abstract; -use strict; -use warnings; - -use base qw(IMPL::Class::Meta); - -our $MemoryLeakProtection; -my $Cleanup = 0; - -my %cacheCTOR; - -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 superCTOR { - my $this = shift; - - warn "The mehod is deprecated, at " . caller; -} - -sub toString { - my $self = shift; - - return (ref $self || $self); -} - -sub isDisposed { - 0; -} - -#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; -} - -sub _pass_throgh_mapper { - @_; -} - -sub PassArgs { - \&_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 MyBaseObject; -use base qw(IMPL::Object::Abstract); - -sub new { - # own implementation of the new opeator -} - -sub surrogate { - # own implementation of the surrogate operator -} - -=h1 DESCRIPTION - -Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов -создания экземпляров. -=cut - -1; +package IMPL::Object::Abstract; +use strict; +use warnings; + +use base qw(IMPL::Class::Meta); + +our $MemoryLeakProtection; +my $Cleanup = 0; + +my %cacheCTOR; + +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 superCTOR { + my $this = shift; + + warn "The mehod is deprecated, at " . caller; +} + +sub toString { + my $self = shift; + + return (ref $self || $self); +} + +sub isDisposed { + 0; +} + +#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; +} + +sub _pass_throgh_mapper { + @_; +} + +sub PassArgs { + \&_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 MyBaseObject; +use base qw(IMPL::Object::Abstract); + +sub new { + # own implementation of the new opeator +} + +sub surrogate { + # own implementation of the surrogate operator +} + +=h1 DESCRIPTION + +Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов +создания экземпляров. +=cut + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Accessor.pm --- a/Lib/IMPL/Object/Accessor.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Accessor.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,15 +1,15 @@ -package IMPL::Object::Accessor; -use strict; -use base qw(IMPL::Object::Abstract 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; +package IMPL::Object::Accessor; +use strict; +use base qw(IMPL::Object::Abstract 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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/ArrayObject.pm --- a/Lib/IMPL/Object/ArrayObject.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/ArrayObject.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,19 +1,19 @@ -package IMPL::Object::ArrayObject; -use strict; -use warnings; - -use base qw(IMPL::Object::Abstract); - -sub new { - my $class = shift; - my $self = bless [], ref $class || $class; - $self->callCTOR(@_); - return $self; -} - -sub surrogate { - return bless [], ref $_[0] || $_; -} - -1; - +package IMPL::Object::ArrayObject; +use strict; +use warnings; + +use base qw(IMPL::Object::Abstract); + +sub new { + my $class = shift; + my $self = bless [], ref $class || $class; + $self->callCTOR(@_); + return $self; +} + +sub surrogate { + return bless [], ref $_[0] || $_; +} + +1; + diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Autofill.pm --- a/Lib/IMPL/Object/Autofill.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Autofill.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,110 +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 +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 diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Disposable.pm --- a/Lib/IMPL/Object/Disposable.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Disposable.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,39 +1,39 @@ -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); -} - -sub isDisposed { - 1; -} - -1; +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); +} + +sub isDisposed { + 1; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/EventSource.pm --- a/Lib/IMPL/Object/EventSource.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/EventSource.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,193 +1,192 @@ -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 { - shift; - if (not @_) { - if (not defined wantarray and caller(1) eq $class) { - $globalEventTable->Invoke($class); - } else { - return $globalEventTable; - } - } else { - $globalEventTable->Invoke($class,@_); - } - }; -} - -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; - -__END__ -=pod -=head1 SYNOPSIS -package Foo; -use base qw(IMPL::Object IMPL::Object::EventSource); - -# declare events -__PACKAGE__->CreateEvent('OnUpdate'); -__PACKAGE__->CreateStaticEvent('OnNewObject'); - -sub CTOR { - my $this = shift; - // rise static event - $this->OnNewObject(); -} - -sub Update { - my ($this,$val) = @_; - - // rise object event - $this->OnUpdate($val); -} - -package Bar; - -// subscribe static event -Foo->OnNewObject->Subscribe(sub { warn "New $_[0] created" } ); - -sub LookForFoo { - my ($this,$foo) = @_; - - // subscribe object event - $foo->OnUpdate->Subscribe($this,'OnFooUpdate'); -} - -// event handler -sub OnFooUpdate { - my ($this,$sender,$value) = @_; -} - -=head1 DESCRIPTION -Позволяет объявлять и инициировать события. События делятся на статические и -локальные. Статические события объявляются для класса и при возникновении -данного события вызываются всегда все подписчики. Статические события могут быть -вызваны как для класса, так и для объекта, что приведет к одинаковым результатам. - -Локальные события состоят из статической (как статические события) и локальной -части. Если подписываться на события класса, то обработчики будут вызываться при -любых вариантах инициации данного события (как у статических событий). При -подписке на события объекта, обработчик будет вызван только при возникновении -событий у данного объекта. - -=head1 METHODS -=level 4 -=back - -=head1 EventTable - -=cut \ No newline at end of file +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 { + shift; + if (not @_) { + if (not defined wantarray and caller(1) eq $class) { + $globalEventTable->Invoke($class); + } else { + return $globalEventTable; + } + } else { + $globalEventTable->Invoke($class,@_); + } + }; +} + +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->{$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; + +__END__ +=pod +=head1 SYNOPSIS +package Foo; +use base qw(IMPL::Object IMPL::Object::EventSource); + +# declare events +__PACKAGE__->CreateEvent('OnUpdate'); +__PACKAGE__->CreateStaticEvent('OnNewObject'); + +sub CTOR { + my $this = shift; + // rise static event + $this->OnNewObject(); +} + +sub Update { + my ($this,$val) = @_; + + // rise object event + $this->OnUpdate($val); +} + +package Bar; + +// subscribe static event +Foo->OnNewObject->Subscribe(sub { warn "New $_[0] created" } ); + +sub LookForFoo { + my ($this,$foo) = @_; + + // subscribe object event + $foo->OnUpdate->Subscribe($this,'OnFooUpdate'); +} + +// event handler +sub OnFooUpdate { + my ($this,$sender,$value) = @_; +} + +=head1 DESCRIPTION +Позволяет объявлять и инициировать события. События делятся на статические и +локальные. Статические события объявляются для класса и при возникновении +данного события вызываются всегда все подписчики. Статические события могут быть +вызваны как для класса, так и для объекта, что приведет к одинаковым результатам. + +Локальные события состоят из статической (как статические события) и локальной +части. Если подписываться на события класса, то обработчики будут вызываться при +любых вариантах инициации данного события (как у статических событий). При +подписке на события объекта, обработчик будет вызван только при возникновении +событий у данного объекта. + +=head1 METHODS +=level 4 +=back + +=head1 EventTable + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/List.pm --- a/Lib/IMPL/Object/List.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/List.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,72 +1,72 @@ -package IMPL::Object::List; -use strict; -use warnings; - -use base qw(IMPL::Object::ArrayObject); -use IMPL::Exception; - -sub as_list { - return wantarray ? @{$_[0]} : $_[0]; -} - -sub CTOR { - my ($this,$data) = @_; - - if ($data) { - die new IMPL::InvalidArgumentException("The parameter should be a reference to an array") unless UNIVERSAL::isa($data,"ARRAY"); - @$this = @$data; - } -} - -sub Append { - push @{$_[0]}, @_[1 .. $#_]; -} - -sub RemoveLast { - return pop @{$_[0]}; -} - -sub AddFirst { - return unshift @{$_[0]}, $_[1]; -} - -sub RemoveFirst { - return shift @{$_[0]}; -} - -sub Count { - return scalar @{$_[0]}; -} - -sub InsertAt { - my ($this,$index,@val) = @_; - - splice @$this,($index||0),0,@val; -} - -sub RemoveAt { - my ($this,$index,$count) = @_; - - $count ||= 1; - - return splice @$this,$index,$count; -} - -sub RemoveItem { - my ($this,$item) = @_; - - @$this = grep $_ != $item, @$this; - - return $this; -} - -sub RemoveItemStr { - my ($this,$item) = @_; - - @$this = grep $_ ne $item, @$this; - - return $this; -} - - -1; +package IMPL::Object::List; +use strict; +use warnings; + +use base qw(IMPL::Object::ArrayObject); +use IMPL::Exception; + +sub as_list { + return wantarray ? @{$_[0]} : $_[0]; +} + +sub CTOR { + my ($this,$data) = @_; + + if ($data) { + die new IMPL::InvalidArgumentException("The parameter should be a reference to an array") unless UNIVERSAL::isa($data,"ARRAY"); + @$this = @$data; + } +} + +sub Append { + push @{$_[0]}, @_[1 .. $#_]; +} + +sub RemoveLast { + return pop @{$_[0]}; +} + +sub AddFirst { + return unshift @{$_[0]}, $_[1]; +} + +sub RemoveFirst { + return shift @{$_[0]}; +} + +sub Count { + return scalar @{$_[0]}; +} + +sub InsertAt { + my ($this,$index,@val) = @_; + + splice @$this,($index||0),0,@val; +} + +sub RemoveAt { + my ($this,$index,$count) = @_; + + $count ||= 1; + + return splice @$this,$index,$count; +} + +sub RemoveItem { + my ($this,$item) = @_; + + @$this = grep $_ != $item, @$this; + + return $this; +} + +sub RemoveItemStr { + my ($this,$item) = @_; + + @$this = grep $_ ne $item, @$this; + + return $this; +} + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Meta.pm --- a/Lib/IMPL/Object/Meta.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Meta.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,23 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Serializable.pm --- a/Lib/IMPL/Object/Serializable.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Serializable.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,54 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Singleton.pm --- a/Lib/IMPL/Object/Singleton.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Singleton.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,47 +1,47 @@ -package IMPL::Object::Singleton; -use strict; -use warnings; - -my %instances; - -sub instance { - my $self = shift; - - $instances{$self} || ($instances{$self} = $self->new(@_)); -} - -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -package Foo; - -use base qw(IMPL::Object IMPL::Object::Singleton); - -#.... - -Foo->isnatnce->some_work(); - -Foo->isnatnce->get_result(); - -=head1 DESCRIPTION - -Реализует шаблон Singleton - -=head1 MEMBERS - -=head2 OPERATORS - -=list - -=item C<instance CLASS(@params)> - -Создает или возвращает экземпляр класса, если экземляр не существует, то он создается с параметрами C<@params>. - -=over - -=cut \ No newline at end of file +package IMPL::Object::Singleton; +use strict; +use warnings; + +my %instances; + +sub instance { + my $self = shift; + + $instances{$self} || ($instances{$self} = $self->new(@_)); +} + +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +package Foo; + +use base qw(IMPL::Object IMPL::Object::Singleton); + +#.... + +Foo->isnatnce->some_work(); + +Foo->isnatnce->get_result(); + +=head1 DESCRIPTION + +Реализует шаблон Singleton + +=head1 MEMBERS + +=head2 OPERATORS + +=list + +=item C<instance CLASS(@params)> + +Создает или возвращает экземпляр класса, если экземляр не существует, то он создается с параметрами C<@params>. + +=over + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Object/Verify.pm --- a/Lib/IMPL/Object/Verify.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Object/Verify.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,7 +1,7 @@ -package IMPL::Object::Verify; -use strict; -use warnings; - - - -1; +package IMPL::Object::Verify; +use strict; +use warnings; + + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Profiler.pm --- a/Lib/IMPL/Profiler.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Profiler.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,139 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Profiler/Memory.pm --- a/Lib/IMPL/Profiler/Memory.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Profiler/Memory.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,57 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Resources.pm --- a/Lib/IMPL/Resources.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Resources.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,59 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Resources/Format.pm --- a/Lib/IMPL/Resources/Format.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Resources/Format.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,32 +1,32 @@ -package IMPL::Resources::Format; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&FormatMessage); - -sub FormatMessage { - my ($string,$args) = @_; - - $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]")/ge; - - return $string; -} - -sub _getvalue { - my ($obj,$path,$default) = @_; - - foreach my $chunk (split /\./,$path) { - if (eval { $obj->can( $chunk ) } ) { - $obj = $obj->$chunk(); - } elsif (UNIVERSAL::isa($obj,'HASH')) { - $obj = $obj->{$chunk}; - } else { - return $default; - } - } - return $obj; -} - -1; +package IMPL::Resources::Format; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&FormatMessage); + +sub FormatMessage { + my ($string,$args) = @_; + + $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]")/ge; + + return $string; +} + +sub _getvalue { + my ($obj,$path,$default) = @_; + + foreach my $chunk (split /\./,$path) { + if (eval { $obj->can( $chunk ) } ) { + $obj = $obj->$chunk(); + } elsif (UNIVERSAL::isa($obj,'HASH')) { + $obj = $obj->{$chunk}; + } else { + return $default; + } + } + return $obj; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Resources/Strings.pm --- a/Lib/IMPL/Resources/Strings.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Resources/Strings.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,100 +1,100 @@ -use strict; -use warnings; - -package IMPL::Resources::Strings::Storage; -package IMPL::Resources::Strings; -use File::Spec; - -our $Locale ||= 'default'; -our $Base ||='locale'; -our $Encoding ||= 'utf-8'; -our @Locations; - -@Locations = ('.') unless @Locations; - -sub import { - my ($self,$refStrings,%options) = @_; - - my ($class,$pathModule) = caller; - - my ($vol,$dir,$file) = File::Spec->splitpath($pathModule); - my $baseDir = File::Spec->catpath($vol,$dir,''); - - my @pathClass = split /::/,$class; - my $fileClass = pop @pathClass; - - my @ways = map { - my @path = ($_); - push @path,$Base; - push @path,$Locale; - - File::Spec->catfile(@path,@pathClass,$fileClass); - } @Locations; - - push @ways, File::Spec->catfile($baseDir,'locale',$Locale,$fileClass); - - - - my $stringsStorage = findResource(@Locations,$Base,$Locale,) - -} - -sub findResource { - my (@locations,$file,%options) = @_; - - -} - - - -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; -} - -package IMPL::Resources::Strings::Storage; -use base qw(IMPL::Object); - -sub get { - my ($this,$msg_name) = @_; -} -1; - -__END__ - -=pod - -=head1 SYNOPSIS - -package Foo; - -use IMPL::Resources::Strings { - msg_say_hello => "Hello, %name!", - msg_module_name => "Simple Foo class" -}, auto => 1, locale => 'en-us'; - -sub InviteUser { - my ($this,$uname) = @_; - - print msg_say_hello(name => $uname); - -} - -=cut \ No newline at end of file +use strict; +use warnings; + +package IMPL::Resources::Strings::Storage; +package IMPL::Resources::Strings; +use File::Spec; + +our $Locale ||= 'default'; +our $Base ||='locale'; +our $Encoding ||= 'utf-8'; +our @Locations; + +@Locations = ('.') unless @Locations; + +sub import { + my ($self,$refStrings,%options) = @_; + + my ($class,$pathModule) = caller; + + my ($vol,$dir,$file) = File::Spec->splitpath($pathModule); + my $baseDir = File::Spec->catpath($vol,$dir,''); + + my @pathClass = split /::/,$class; + my $fileClass = pop @pathClass; + + my @ways = map { + my @path = ($_); + push @path,$Base; + push @path,$Locale; + + File::Spec->catfile(@path,@pathClass,$fileClass); + } @Locations; + + push @ways, File::Spec->catfile($baseDir,'locale',$Locale,$fileClass); + + + + my $stringsStorage = findResource(@Locations,$Base,$Locale,) + +} + +sub findResource { + my (@locations,$file,%options) = @_; + + +} + + + +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; +} + +package IMPL::Resources::Strings::Storage; +use base qw(IMPL::Object); + +sub get { + my ($this,$msg_name) = @_; +} +1; + +__END__ + +=pod + +=head1 SYNOPSIS + +package Foo; + +use IMPL::Resources::Strings { + msg_say_hello => "Hello, %name!", + msg_module_name => "Simple Foo class" +}, auto => 1, locale => 'en-us'; + +sub InviteUser { + my ($this,$uname) = @_; + + print msg_say_hello(name => $uname); + +} + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema.pm --- a/Lib/IMPL/SQL/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,96 +1,96 @@ -use strict; -package IMPL::SQL::Schema; - -use base qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -require IMPL::SQL::Schema::Table; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public _direct property Version => prop_get; - public _direct property Name => prop_get; - public _direct property Tables => prop_get; -} - -sub AddTable { - my ($this,$table) = @_; - - if (UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table')) { - $table->Schema == $this or die new IMPL::InvalidOperationException('The specified table must belong to the database'); - not exists $this->{$Tables}->{$table->Name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); - } elsif (UNIVERSAL::isa($table,'HASH')) { - not exists $this->{$Tables}->{$table->{'Name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); - $table->{'Schema'} = $this; - $table = new IMPL::SQL::Schema::Table(%{$table}); - } else { - die new IMPL::InvalidArgumentException('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,'IMPL::SQL::Schema::Table') ? $table->Name : $table; - $table = delete $this->{$Tables}{$tn} or die new IMPL::InvalidArgumentException('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; - -__END__ -=pod - -=head1 SINOPSYS - -require IMPL::SQL::Schema; -use IMPL::SQL::Types qw(Varchar Integer); - -my $dbSchema = new IMPL::SQL::Schema; - -my $tbl = $dbSchema->AddTable({Name => 'Person' }); -$tbl->AddColumn({ - Name => 'FirstName', - CanBeNull => 1, - Type => Varchar(255) -}); -$tbl->AddColumn({ - Name => 'Age', - Type => Integer -}); - -# so on - -# and finally don't forget to - -$dbSchema->Dispoce(); - -=head1 DESCRIPTION - -Схема реляциоонной базы данных, орентированная на язык SQL, содержит описания таблиц -которые являются частью базы. Позволяет создавать и удалать таблицы. - -Имея две схемы можно создавать скрипты для примениения изменений схемы данных C<<IMPL::SQL::Traits>> - -=cut +use strict; +package IMPL::SQL::Schema; + +use base qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +require IMPL::SQL::Schema::Table; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public _direct property Version => prop_get; + public _direct property Name => prop_get; + public _direct property Tables => prop_get; +} + +sub AddTable { + my ($this,$table) = @_; + + if (UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table')) { + $table->Schema == $this or die new IMPL::InvalidOperationException('The specified table must belong to the database'); + not exists $this->{$Tables}->{$table->Name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + } elsif (UNIVERSAL::isa($table,'HASH')) { + not exists $this->{$Tables}->{$table->{'Name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + $table->{'Schema'} = $this; + $table = new IMPL::SQL::Schema::Table(%{$table}); + } else { + die new IMPL::InvalidArgumentException('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,'IMPL::SQL::Schema::Table') ? $table->Name : $table; + $table = delete $this->{$Tables}{$tn} or die new IMPL::InvalidArgumentException('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; + +__END__ +=pod + +=head1 SINOPSYS + +require IMPL::SQL::Schema; +use IMPL::SQL::Types qw(Varchar Integer); + +my $dbSchema = new IMPL::SQL::Schema; + +my $tbl = $dbSchema->AddTable({Name => 'Person' }); +$tbl->AddColumn({ + Name => 'FirstName', + CanBeNull => 1, + Type => Varchar(255) +}); +$tbl->AddColumn({ + Name => 'Age', + Type => Integer +}); + +# so on + +# and finally don't forget to + +$dbSchema->Dispoce(); + +=head1 DESCRIPTION + +Схема реляциоонной базы данных, орентированная на язык SQL, содержит описания таблиц +которые являются частью базы. Позволяет создавать и удалать таблицы. + +Имея две схемы можно создавать скрипты для примениения изменений схемы данных C<<IMPL::SQL::Traits>> + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Column.pm --- a/Lib/IMPL/SQL/Schema/Column.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Column.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,60 +1,60 @@ -use strict; -package IMPL::SQL::Schema::Column; -use base qw(IMPL::Object IMPL::Object::Autofill); - -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Type => prop_get; - public _direct property CanBeNull => prop_get; - public _direct property DefaultValue => prop_get; - public _direct property Tag => prop_get; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - $this->{$Name} or die new IMPL::InvalidArgumentException('a column name is required'); - $this->{$CanBeNull} = 0 if not exists $this->{$CanBeNull}; - UNIVERSAL::isa($this->{$Type},'IMPL::SQL::Schema::Type') or die new IMPL::InvalidArgumentException('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; +use strict; +package IMPL::SQL::Schema::Column; +use base qw(IMPL::Object IMPL::Object::Autofill); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Type => prop_get; + public _direct property CanBeNull => prop_get; + public _direct property DefaultValue => prop_get; + public _direct property Tag => prop_get; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + $this->{$Name} or die new IMPL::InvalidArgumentException('a column name is required'); + $this->{$CanBeNull} = 0 if not exists $this->{$CanBeNull}; + UNIVERSAL::isa($this->{$Type},'IMPL::SQL::Schema::Type') or die new IMPL::InvalidArgumentException('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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Constraint.pm --- a/Lib/IMPL/SQL/Schema/Constraint.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Constraint.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,51 +1,51 @@ -use strict; -package IMPL::SQL::Schema::Constraint; -use base qw(IMPL::Object IMPL::Object::Disposable); - -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Table => prop_get; - public _direct property Columns => prop_get; -} - -sub CTOR { - my ($this,%args) = @_; - die new IMPL::InvalidArgumentException("The table argument must be an instance of a table object") if not UNIVERSAL::isa($args{'Table'},'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::Column') ? $Column->Name : $Column; - - my $resolved = $Table->Column($cn); - die new IMPL::InvalidOperationException("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 +use strict; +package IMPL::SQL::Schema::Constraint; +use base qw(IMPL::Object IMPL::Object::Disposable); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Table => prop_get; + public _direct property Columns => prop_get; +} + +sub CTOR { + my ($this,%args) = @_; + die new IMPL::InvalidArgumentException("The table argument must be an instance of a table object") if not UNIVERSAL::isa($args{'Table'},'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::Column') ? $Column->Name : $Column; + + my $resolved = $Table->Column($cn); + die new IMPL::InvalidOperationException("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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm --- a/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,58 +1,58 @@ -package IMPL::SQL::Schema::Constraint::ForeignKey; -use strict; -use base qw(IMPL::SQL::Schema::Constraint); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property ReferencedPrimaryKey => prop_get; - public _direct property OnDelete => prop_get; - public _direct property OnUpdate => prop_get; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my ($this,%args) = @_; - - die new Eexception("Referenced table must be an instance of a table object") if not UNIVERSAL::isa($args{'ReferencedTable'},'IMPL::SQL::Schema::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 {IMPL::SQL::Schema::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}->isDisposed; - 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 +package IMPL::SQL::Schema::Constraint::ForeignKey; +use strict; +use base qw(IMPL::SQL::Schema::Constraint); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property ReferencedPrimaryKey => prop_get; + public _direct property OnDelete => prop_get; + public _direct property OnUpdate => prop_get; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my ($this,%args) = @_; + + die new Eexception("Referenced table must be an instance of a table object") if not UNIVERSAL::isa($args{'ReferencedTable'},'IMPL::SQL::Schema::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 {IMPL::SQL::Schema::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}->isDisposed; + 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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Constraint/Index.pm --- a/Lib/IMPL/SQL/Schema/Constraint/Index.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Constraint/Index.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,14 +1,14 @@ -package IMPL::SQL::Schema::Constraint::Index; -use strict; -use base qw(IMPL::SQL::Schema::Constraint); - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - my %colnames; - not grep { $colnames{$_}++ } @{$this->Columns} or die new Exception('Each column in the index can occur only once'); -} - -1; +package IMPL::SQL::Schema::Constraint::Index; +use strict; +use base qw(IMPL::SQL::Schema::Constraint); + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + my %colnames; + not grep { $colnames{$_}++ } @{$this->Columns} or die new Exception('Each column in the index can occur only once'); +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm --- a/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,43 +1,43 @@ -package IMPL::SQL::Schema::Constraint::PrimaryKey; -use strict; -use base qw(IMPL::SQL::Schema::Constraint::Index); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public _direct property ConnectedFK => prop_get; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->SUPER::CTOR(%args); - - $this->{$ConnectedFK} = {}; -} - -sub ConnectFK { - my ($this,$FK) = @_; - - UNIVERSAL::isa($FK,'IMPL::SQL::Schema::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 +package IMPL::SQL::Schema::Constraint::PrimaryKey; +use strict; +use base qw(IMPL::SQL::Schema::Constraint::Index); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public _direct property ConnectedFK => prop_get; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->SUPER::CTOR(%args); + + $this->{$ConnectedFK} = {}; +} + +sub ConnectFK { + my ($this,$FK) = @_; + + UNIVERSAL::isa($FK,'IMPL::SQL::Schema::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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Constraint/Unique.pm --- a/Lib/IMPL/SQL/Schema/Constraint/Unique.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Constraint/Unique.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,7 +1,7 @@ -package IMPL::SQL::Schema::Constraint::Unique; -use strict; -use base qw(IMPL::SQL::Schema::Constraint::Index); - -__PACKAGE__->PassThroughArgs; - -1; \ No newline at end of file +package IMPL::SQL::Schema::Constraint::Unique; +use strict; +use base qw(IMPL::SQL::Schema::Constraint::Index); + +__PACKAGE__->PassThroughArgs; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Table.pm --- a/Lib/IMPL/SQL/Schema/Table.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Table.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,168 +1,168 @@ -use strict; -package IMPL::SQL::Schema::Table; - -use IMPL::SQL::Schema::Column; -use IMPL::SQL::Schema::Constraint; -use IMPL::SQL::Schema::Constraint::PrimaryKey; -use IMPL::SQL::Schema::Constraint::ForeignKey; - -use base qw(IMPL::Object IMPL::Object::Disposable); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -srand time; - -BEGIN { - public _direct property Name => prop_get; - public _direct property Schema => prop_get; - public _direct property Columns => prop_get; - public _direct property Constraints => prop_get; - public _direct property ColumnsByName => prop_none; - public _direct property PrimaryKey => prop_get; - public _direct property Tag => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Name} = $args{'Name'} or die new IMPL::InvalidArgumentException('a table name is required'); - $this->{$Schema} = $args{'Schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); -} - -sub InsertColumn { - my ($this,$column,$index) = @_; - - $index = ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0) if not defined $index; - - die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0)); - - if (UNIVERSAL::isa($column,'IMPL::SQL::Schema::Column')) { - - } elsif (UNIVERSAL::isa($column,'HASH')) { - $column = new IMPL::SQL::Schema::Column(%{$column}); - } else { - die new IMPL::InvalidArgumentException("The invalid column parameter"); - } - - if (exists $this->{$ColumnsByName}->{$column->Name}) { - die new IMPL::InvalidOperationException("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,'IMPL::SQL::Schema::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 IMPL::InvalidOperationException('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 IMPL::InvalidOperationException("The column not found",$NameOrColumn->Name); - } -} - -sub Column { - my ($this,$name) = @_; - - return $this->{$ColumnsByName}->{$name}; -} - -sub ColumnAt { - my ($this,$index) = @_; - - die new IMPL::InvalidArgumentException("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 IMPL::InvalidArgumentException('The invalid parameter') if not UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint'); - - $Constraint->Table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); - - if (exists $this->{$Constraints}->{$Constraint->Name}) { - die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->Name); - } else { - if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not $this->{$PrimaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); - $this->{$PrimaryKey} = $Constraint; - } - - $this->{$Constraints}->{$Constraint->Name} = $Constraint; - } -} - -sub RemoveConstraint { - my ($this,$Constraint,$Force) = @_; - - my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->Name : $Constraint; - $Constraint = $this->{$Constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); - - if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not scalar keys %{$this->{$PrimaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('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($_ ,'IMPL::SQL::Schema::Column') ? $_ ->Name : $_ } @Columns; - exists $this->{$ColumnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; - - return grep {$_->HasColumn(@cn)} values %{$this->{$Constraints}}; -} - -sub SetPrimaryKey { - my ($this,@ColumnList) = @_; - - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(Name => $this->{$Name}.'_PK', Table => $this,Columns => \@ColumnList)); -} - -sub LinkTo { - my ($this,$table,@ColumnList) = @_; - $table->PrimaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); - my $constraintName = $this->{$Name}.'_'.$table->Name.'_FK_'.join('_',map {ref $_ ? $_->Name : $_} @ColumnList); - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(Name => $constraintName, Table => $this,Columns => \@ColumnList, ReferencedTable => $table, ReferencedColumns => $table->PrimaryKey->Columns)); -} - -sub Dispose { - my ($this) = @_; - - $_->Dispose() foreach values %{$this->{$Constraints}}; - - undef %{$this}; - $this->SUPER::Dispose(); -} - -1; +use strict; +package IMPL::SQL::Schema::Table; + +use IMPL::SQL::Schema::Column; +use IMPL::SQL::Schema::Constraint; +use IMPL::SQL::Schema::Constraint::PrimaryKey; +use IMPL::SQL::Schema::Constraint::ForeignKey; + +use base qw(IMPL::Object IMPL::Object::Disposable); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +srand time; + +BEGIN { + public _direct property Name => prop_get; + public _direct property Schema => prop_get; + public _direct property Columns => prop_get; + public _direct property Constraints => prop_get; + public _direct property ColumnsByName => prop_none; + public _direct property PrimaryKey => prop_get; + public _direct property Tag => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$Name} = $args{'Name'} or die new IMPL::InvalidArgumentException('a table name is required'); + $this->{$Schema} = $args{'Schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); +} + +sub InsertColumn { + my ($this,$column,$index) = @_; + + $index = ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0) if not defined $index; + + die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0)); + + if (UNIVERSAL::isa($column,'IMPL::SQL::Schema::Column')) { + + } elsif (UNIVERSAL::isa($column,'HASH')) { + $column = new IMPL::SQL::Schema::Column(%{$column}); + } else { + die new IMPL::InvalidArgumentException("The invalid column parameter"); + } + + if (exists $this->{$ColumnsByName}->{$column->Name}) { + die new IMPL::InvalidOperationException("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,'IMPL::SQL::Schema::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 IMPL::InvalidOperationException('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 IMPL::InvalidOperationException("The column not found",$NameOrColumn->Name); + } +} + +sub Column { + my ($this,$name) = @_; + + return $this->{$ColumnsByName}->{$name}; +} + +sub ColumnAt { + my ($this,$index) = @_; + + die new IMPL::InvalidArgumentException("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 IMPL::InvalidArgumentException('The invalid parameter') if not UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint'); + + $Constraint->Table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); + + if (exists $this->{$Constraints}->{$Constraint->Name}) { + die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->Name); + } else { + if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { + not $this->{$PrimaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); + $this->{$PrimaryKey} = $Constraint; + } + + $this->{$Constraints}->{$Constraint->Name} = $Constraint; + } +} + +sub RemoveConstraint { + my ($this,$Constraint,$Force) = @_; + + my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->Name : $Constraint; + $Constraint = $this->{$Constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); + + if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { + not scalar keys %{$this->{$PrimaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('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($_ ,'IMPL::SQL::Schema::Column') ? $_ ->Name : $_ } @Columns; + exists $this->{$ColumnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; + + return grep {$_->HasColumn(@cn)} values %{$this->{$Constraints}}; +} + +sub SetPrimaryKey { + my ($this,@ColumnList) = @_; + + $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(Name => $this->{$Name}.'_PK', Table => $this,Columns => \@ColumnList)); +} + +sub LinkTo { + my ($this,$table,@ColumnList) = @_; + $table->PrimaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); + my $constraintName = $this->{$Name}.'_'.$table->Name.'_FK_'.join('_',map {ref $_ ? $_->Name : $_} @ColumnList); + $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(Name => $constraintName, Table => $this,Columns => \@ColumnList, ReferencedTable => $table, ReferencedColumns => $table->PrimaryKey->Columns)); +} + +sub Dispose { + my ($this) = @_; + + $_->Dispose() foreach values %{$this->{$Constraints}}; + + undef %{$this}; + $this->SUPER::Dispose(); +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Traits.pm --- a/Lib/IMPL/SQL/Schema/Traits.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Traits.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,275 +1,275 @@ -package IMPL::SQL::Schema::Traits; -use strict; -use base qw(IMPL::Object IMPL::Object::Autofill); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -use constant { - STATE_NORMAL => 0, - STATE_UPDATED => 1, - STATE_CREATED => 2, - STATE_REMOVED => 3, - STATE_PENDING => 4 -} ; - -BEGIN { - public _direct property SrcSchema => prop_all; - public _direct property DstSchema => prop_all; - public _direct property PendingActions => prop_get; - public _direct property TableInfo => prop_get; - public _direct property Handler => prop_get; - public _direct property TableMap => prop_none; - public _direct property KeepTables => prop_all; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - $this->{$SrcSchema} or die new IMPL::InvalidArgumentException('A source schema is required'); - $this->{$DstSchema} or die new IMPL::InvalidArgumentException('A destination schema is required'); - $this->{$Handler} or die new IMPL::InvalidArgumentException('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,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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($_,'IMPL::SQL::Schema::Constraint::ForeignKey') } values %{$tbl->Constraints}}; - - $this->AddConstraint($_) foreach grep { UNIVERSAL::isa($_,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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; +package IMPL::SQL::Schema::Traits; +use strict; +use base qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +use constant { + STATE_NORMAL => 0, + STATE_UPDATED => 1, + STATE_CREATED => 2, + STATE_REMOVED => 3, + STATE_PENDING => 4 +} ; + +BEGIN { + public _direct property SrcSchema => prop_all; + public _direct property DstSchema => prop_all; + public _direct property PendingActions => prop_get; + public _direct property TableInfo => prop_get; + public _direct property Handler => prop_get; + public _direct property TableMap => prop_none; + public _direct property KeepTables => prop_all; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + $this->{$SrcSchema} or die new IMPL::InvalidArgumentException('A source schema is required'); + $this->{$DstSchema} or die new IMPL::InvalidArgumentException('A destination schema is required'); + $this->{$Handler} or die new IMPL::InvalidArgumentException('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,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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($_,'IMPL::SQL::Schema::Constraint::ForeignKey') } values %{$tbl->Constraints}}; + + $this->AddConstraint($_) foreach grep { UNIVERSAL::isa($_,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Traits/mysql.pm --- a/Lib/IMPL/SQL/Schema/Traits/mysql.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Traits/mysql.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,555 +1,555 @@ -package IMPL::SQL::Schema::Traits::mysql::Handler; -use strict; -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property SqlBatch => prop_all; -} - -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 IMPL::InvalidArgumentException('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,'IMPL::SQL::Schema::Type::mysql::CHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameVarChar { - my ($type) = @_; - - return ( - $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::VARCHAR') ? $type->Encoding : '') - ); -} - -sub formatTypeNameEnum { - my ($type) = @_; - die new Exception('Enum must be a type of either IMPL::SQL::Schema::Type::mysql::ENUM or IMPL::SQL::Schema::Type::mysql::SET') if not (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::ENUM') or UNIVERSAL::isa($type,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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($_,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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 'IMPL::SQL::Schema::Constraint::PrimaryKey') { - return "\t"x$level."PRIMARY KEY ($columns)"; - } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Unique') { - return "\t"x$level."UNIQUE $name ($columns)"; - } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Index') { - return "\t"x$level."INDEX $name ($columns)"; - } else { - die new IMPL::InvalidArgumentException('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 IMPL::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 IMPL::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 'IMPL::SQL::Schema::Constraint::PrimaryKey') { - $constraintName = 'PRIMARY KEY'; - } elsif (ref $constraint eq 'IMPL::SQL::Schema::Constraint::ForeignKey') { - $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name); - } elsif (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { - $constraintName = 'INDEX '.quote_names($constraint->Name); - } else { - die new IMPL::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 IMPL::SQL::Schema::Traits::mysql; -use Common; -use base qw(IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property PendingConstraints => prop_none; -} - -our %CTOR = ( - 'IMPL::SQL::Schema::Traits' => sub { - my %args = @_; - $args{'Handler'} = new IMPL::SQL::Schema::Traits::mysql::Handler; - %args; - } -); - -sub DropConstraint { - my ($this,$constraint) = @_; - - if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { - return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED} $constraint->Columns; - my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns); - if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'IMPL::SQL::Schema::Constraint::ForeignKey')) { - my $fk = shift @constraints; - if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED) { - push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]}; - $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++; - - die new IMPL::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 IMPL::SQL::Schema::Traits::mysql::MetaTable->new( DBHandle => $dbh); -} - -package IMPL::SQL::Schema::Traits::mysql::MetaTable; -use Common; -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property DBHandle => prop_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 IMPL::Exception("Failed to create table","_Meta"); - - $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val); - } -} - -1; +package IMPL::SQL::Schema::Traits::mysql::Handler; +use strict; +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property SqlBatch => prop_all; +} + +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 IMPL::InvalidArgumentException('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,'IMPL::SQL::Schema::Type::mysql::CHAR') ? $type->Encoding : '') + ); +} + +sub formatTypeNameVarChar { + my ($type) = @_; + + return ( + $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::VARCHAR') ? $type->Encoding : '') + ); +} + +sub formatTypeNameEnum { + my ($type) = @_; + die new Exception('Enum must be a type of either IMPL::SQL::Schema::Type::mysql::ENUM or IMPL::SQL::Schema::Type::mysql::SET') if not (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::ENUM') or UNIVERSAL::isa($type,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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($_,'IMPL::SQL::Schema::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,'IMPL::SQL::Schema::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 'IMPL::SQL::Schema::Constraint::PrimaryKey') { + return "\t"x$level."PRIMARY KEY ($columns)"; + } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Unique') { + return "\t"x$level."UNIQUE $name ($columns)"; + } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Index') { + return "\t"x$level."INDEX $name ($columns)"; + } else { + die new IMPL::InvalidArgumentException('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 IMPL::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 IMPL::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 'IMPL::SQL::Schema::Constraint::PrimaryKey') { + $constraintName = 'PRIMARY KEY'; + } elsif (ref $constraint eq 'IMPL::SQL::Schema::Constraint::ForeignKey') { + $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name); + } elsif (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { + $constraintName = 'INDEX '.quote_names($constraint->Name); + } else { + die new IMPL::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 IMPL::SQL::Schema::Traits::mysql; +use Common; +use base qw(IMPL::SQL::Schema::Traits); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property PendingConstraints => prop_none; +} + +our %CTOR = ( + 'IMPL::SQL::Schema::Traits' => sub { + my %args = @_; + $args{'Handler'} = new IMPL::SQL::Schema::Traits::mysql::Handler; + %args; + } +); + +sub DropConstraint { + my ($this,$constraint) = @_; + + if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) { + return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED} $constraint->Columns; + my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns); + if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'IMPL::SQL::Schema::Constraint::ForeignKey')) { + my $fk = shift @constraints; + if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED) { + push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]}; + $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++; + + die new IMPL::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 IMPL::SQL::Schema::Traits::mysql::MetaTable->new( DBHandle => $dbh); +} + +package IMPL::SQL::Schema::Traits::mysql::MetaTable; +use Common; +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property DBHandle => prop_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 IMPL::Exception("Failed to create table","_Meta"); + + $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val); + } +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Schema/Type.pm --- a/Lib/IMPL/SQL/Schema/Type.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Schema/Type.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,44 +1,44 @@ -use strict; -package IMPL::SQL::Schema::Type; -use base qw(IMPL::Object IMPL::Object::Autofill); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -BEGIN { - public _direct property Name => prop_get; - public _direct property MaxLength => prop_get; - public _direct property Scale => prop_get; - public _direct property Unsigned => prop_get; - public _direct property Zerofill => prop_get; - public _direct property Tag => prop_get; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - $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; +use strict; +package IMPL::SQL::Schema::Type; +use base qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +BEGIN { + public _direct property Name => prop_get; + public _direct property MaxLength => prop_get; + public _direct property Scale => prop_get; + public _direct property Unsigned => prop_get; + public _direct property Zerofill => prop_get; + public _direct property Tag => prop_get; +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my $this = shift; + + $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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/SQL/Types.pm --- a/Lib/IMPL/SQL/Types.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/SQL/Types.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,39 +1,39 @@ -package IMPL::SQL::Types; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime); - -require IMPL::SQL::Schema::Type; - -sub Integer() { - return IMPL::SQL::Schema::Type->new(Name => 'INTEGER'); -} - -sub Varchar($) { - return IMPL::SQL::Schema::Type->new(Name => 'VARCHAR', MaxLength => shift); -} - -sub Float($) { - return IMPL::SQL::Schema::Type->new(Name => 'FLOAT', Scale => shift); -} - -sub Real() { - return IMPL::SQL::Schema::Type->new(Name => 'REAL'); -} - -sub Text() { - return IMPL::SQL::Schema::Type->new(Name => 'TEXT'); -} - -sub Binary() { - return IMPL::SQL::Schema::Type->new(Name => 'BINARY'); -} - -sub DateTime() { - return IMPL::SQL::Schema::Type->new(Name => 'DATETIME'); -} - -1; +package IMPL::SQL::Types; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime); + +require IMPL::SQL::Schema::Type; + +sub Integer() { + return IMPL::SQL::Schema::Type->new(Name => 'INTEGER'); +} + +sub Varchar($) { + return IMPL::SQL::Schema::Type->new(Name => 'VARCHAR', MaxLength => shift); +} + +sub Float($) { + return IMPL::SQL::Schema::Type->new(Name => 'FLOAT', Scale => shift); +} + +sub Real() { + return IMPL::SQL::Schema::Type->new(Name => 'REAL'); +} + +sub Text() { + return IMPL::SQL::Schema::Type->new(Name => 'TEXT'); +} + +sub Binary() { + return IMPL::SQL::Schema::Type->new(Name => 'BINARY'); +} + +sub DateTime() { + return IMPL::SQL::Schema::Type->new(Name => 'DATETIME'); +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Security.pm --- a/Lib/IMPL/Security.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Security.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,3 +1,3 @@ -package IMPL::Security; - -1; \ No newline at end of file +package IMPL::Security; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Security/AuthResult.pm --- a/Lib/IMPL/Security/AuthResult.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Security/AuthResult.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,16 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Security/Context.pm --- a/Lib/IMPL/Security/Context.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Security/Context.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,42 +1,42 @@ -package IMPL::Security::Context; -use strict; -use warnings; - -use base qw(IMPL::Object); - -use IMPL::Class::Property; - -require IMPL::Security::Principal; - -my $current = __PACKAGE__->nobody; -my $nobody; - -BEGIN { - public property Principal => prop_get; - public property AssignedRoles => prop_all; -} - -sub Impersonate { - my ($this,$code) = @_; - - my $old = $current; - my $result; - local $@; - eval { - $result = $code->(); - }; - $current = $old; - if($@) { - die $@; - } else { - return $result; - } -} - -sub nobody { - my ($self) = @_; - $nobody = $self->new(Principal => IMPL::Security::Principal->nobody, AssignedRoles => undef) unless $nobody; - $nobody; -} - -1; +package IMPL::Security::Context; +use strict; +use warnings; + +use base qw(IMPL::Object); + +use IMPL::Class::Property; + +require IMPL::Security::Principal; + +my $current = __PACKAGE__->nobody; +my $nobody; + +BEGIN { + public property Principal => prop_get; + public property AssignedRoles => prop_all; +} + +sub Impersonate { + my ($this,$code) = @_; + + my $old = $current; + my $result; + local $@; + eval { + $result = $code->(); + }; + $current = $old; + if($@) { + die $@; + } else { + return $result; + } +} + +sub nobody { + my ($self) = @_; + $nobody = $self->new(Principal => IMPL::Security::Principal->nobody, AssignedRoles => undef) unless $nobody; + $nobody; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Security/Principal.pm --- a/Lib/IMPL/Security/Principal.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Security/Principal.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,20 +1,20 @@ -package IMPL::Security::Principal; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; - -BEGIN { - public property Name => prop_get; - public property Description => prop_get; -} - -my $nobody; - -sub nobody { - $nobody = $_[0]->new(Name => 'nobody', Description => '') unless $nobody; - return $nobody; -} - -1; +package IMPL::Security::Principal; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; + +BEGIN { + public property Name => prop_get; + public property Description => prop_get; +} + +my $nobody; + +sub nobody { + $nobody = $_[0]->new(Name => 'nobody', Description => '') unless $nobody; + return $nobody; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Serialization.pm --- a/Lib/IMPL/Serialization.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Serialization.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,13 +1,12 @@ +package IMPL::Serialization; +use strict; # 20060222 -# Модуль для сериализации структур данных -# (ц) Sourcer, cin.sourcer@gmail.com +# пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ +# (пїЅ) Sourcer, cin.sourcer@gmail.com # revision 3 (20090517) -package IMPL::Serialization; -use strict; - package IMPL::Serialization::Context; use base qw(IMPL::Object); @@ -17,24 +16,24 @@ use Scalar::Util qw(refaddr); BEGIN { - private _direct property ObjectWriter => prop_all; # объект, записывающий данные в поток - private _direct property Context => prop_all; # контекст (объекты которые уже сериализованы, их идентификаторы) - private _direct property NextID => prop_all;# следующий идентификатор для объекта + private _direct property ObjectWriter => prop_all; # пїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅ + private _direct property Context => prop_all; # пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ (пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ) + private _direct property NextID => prop_all;# пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ - # процедура, которая знает, как сериализовывать определенные типы. Первым параметром - # получаем ссылку на IMPL::Serialization::Context, вторым параметром ссылку на объект + # пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅ. пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ + # пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ IMPL::Serialization::Context, пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ public _direct property Serializer => prop_all; - private _direct property State => 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 { @@ -55,8 +54,8 @@ 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'); @@ -149,10 +148,10 @@ use IMPL::Exception; BEGIN { - # уже десериализованные объекты, хеш, ключ - идентификатор, значение - ссылка. + # пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅ, пїЅпїЅпїЅпїЅ - пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ - пїЅпїЅпїЅпїЅпїЅпїЅ. private _direct property Context => prop_all; - # текущий объект. информация для десериализации + # пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ. пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ # { # Type => 'typename', # Name => 'object_name', @@ -161,24 +160,24 @@ # } 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 + # $Type - пїЅпїЅпїЅ пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ + # $DeserializationData - пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, + # пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ. + # $refSurogate - пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ. + # пїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ undef private _direct property ObjectFactory => prop_all; - # Создает неинициализированные объекты. + # пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ. # SurogateHelper($Type) - # $Type имя типпа, чей сурогат нужно создать. + # $Type пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ. private _direct property SurogateHelper => prop_all; } @@ -208,7 +207,7 @@ $rhCurrentObj->{'Data'} = [$name,$refObj]; } - # это затем, что будет вызван OnObjectEnd для объекта, который был простой ссылкой. т.о. мы не нарушим стек + # пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ OnObjectEnd пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ. пїЅ.пїЅ. пїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅ push @{$this->{$ObjectsPath}},$rhCurrentObj; $this->{$CurrentObject} = undef; @@ -248,8 +247,8 @@ my $rhObject = $this->{$CurrentObject}; my $rhPrevObject = pop @{$this->{$ObjectsPath}}; - # если текущий объект не определен, а предыдущий - определен, значит текущий - это ссылка - # просто восстанавливаем предыдущий в текущий и ничего более не делаем + # пїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ - пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ, пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ - пїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ + # пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅпїЅ пїЅ пїЅпїЅпїЅпїЅпїЅпїЅ пїЅпїЅпїЅпїЅпїЅ пїЅпїЅ пїЅпїЅпїЅпїЅпїЅпїЅ if ((not defined($rhObject)) && $rhPrevObject) { $this->{$CurrentObject} = $rhPrevObject; return 1; @@ -406,4 +405,4 @@ return $Context->Root(); } -1; \ No newline at end of file +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Serialization/XmlFormatter.pm --- a/Lib/IMPL/Serialization/XmlFormatter.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Serialization/XmlFormatter.pm Fri Feb 26 10:49:21 2010 +0300 @@ -199,4 +199,4 @@ return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace()); } -1; \ No newline at end of file +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test.pm --- a/Lib/IMPL/Test.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,48 +1,48 @@ -package IMPL::Test; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&test &shared &failed &cmparray); - -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)); -} - -sub failed($;@) { - die new IMPL::Test::FailException(@_); -} - -sub cmparray { - my ($a,$b) = @_; - - return 0 unless @$a == @$b; - - for (my $i=0; $i < @$a; $i++ ) { - return 0 unless $a->[$i] eq $b->[$i]; - } - - return 1; -} -1; +package IMPL::Test; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&test &shared &failed &cmparray); + +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)); +} + +sub failed($;@) { + die new IMPL::Test::FailException(@_); +} + +sub cmparray { + my ($a,$b) = @_; + + return 0 unless @$a == @$b; + + for (my $i=0; $i < @$a; $i++ ) { + return 0 unless $a->[$i] eq $b->[$i]; + } + + return 1; +} +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/BadUnit.pm --- a/Lib/IMPL/Test/BadUnit.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/BadUnit.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,65 +1,65 @@ -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 { - if (@_>1) { - # Unit construction - 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) - } - ); - } else { - # test construction - return @_; - } - } -); - -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)}); -} - -sub List { - my ($this) = @_; - my $error = $this->Error; - return new IMPL::Test::Unit::TestInfo( - BadUnitTest => sub { - die new IMPL::Test::FailException($this->Message,$this->UnitName,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) - } - ); -} - - -1; +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 { + if (@_>1) { + # Unit construction + 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) + } + ); + } else { + # test construction + return @_; + } + } +); + +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)}); +} + +sub List { + my ($this) = @_; + my $error = $this->Error; + return new IMPL::Test::Unit::TestInfo( + BadUnitTest => sub { + die new IMPL::Test::FailException($this->Message,$this->UnitName,eval {$error->isa('IMPL::Exception')} ? $error->toString(1) : $error) + } + ); +} + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/FailException.pm --- a/Lib/IMPL/Test/FailException.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/FailException.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,22 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/HarnessRunner.pm --- a/Lib/IMPL/Test/HarnessRunner.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/HarnessRunner.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,37 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/Plan.pm --- a/Lib/IMPL/Test/Plan.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/Plan.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,208 +1,208 @@ -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; - - # preload module - undef $@; - - eval "require $Unit" unless (ref $Unit); - - # handle loading errors - $Unit = new IMPL::Test::BadUnit($Unit,"Failed to load unit",$@) if $@; - - $info{Unit} = $Unit; - try { - $info{Tests} = [map $Unit->new($_), $Unit->List]; - } otherwise { - $info{Tests} = [$info{Unit} = new IMPL::Test::BadUnit($Unit->can('UnitName') ? $Unit->UnitName : $Unit,"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; +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; + + # preload module + undef $@; + + eval "require $Unit" unless (ref $Unit); + + # handle loading errors + $Unit = new IMPL::Test::BadUnit($Unit,"Failed to load unit",$@) if $@; + + $info{Unit} = $Unit; + try { + $info{Tests} = [map $Unit->new($_), $Unit->List]; + } otherwise { + $info{Tests} = [$info{Unit} = new IMPL::Test::BadUnit($Unit->can('UnitName') ? $Unit->UnitName : $Unit,"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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/Result.pm --- a/Lib/IMPL/Test/Result.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/Result.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,32 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/SkipException.pm --- a/Lib/IMPL/Test/SkipException.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/SkipException.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,8 +1,8 @@ -package IMPL::Test::SkipException; - -use base qw(IMPL::Test::FailException); - -__PACKAGE__->PassThroughArgs; - -1; - +package IMPL::Test::SkipException; + +use base qw(IMPL::Test::FailException); + +__PACKAGE__->PassThroughArgs; + +1; + diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/Straps.pm --- a/Lib/IMPL/Test/Straps.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/Straps.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,90 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/Straps/ShellExecutor.pm --- a/Lib/IMPL/Test/Straps/ShellExecutor.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/Straps/ShellExecutor.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,32 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/TAPListener.pm --- a/Lib/IMPL/Test/TAPListener.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/TAPListener.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,70 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Test/Unit.pm --- a/Lib/IMPL/Test/Unit.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Test/Unit.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,147 +1,147 @@ -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 { - my ($this,$session) = @_; - - $session->{$_} = $this->$_() foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData'); - - 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($session); - }; - - 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; +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 { + my ($this,$session) = @_; + + $session->{$_} = $this->$_() foreach map $_->DataList, $this->get_meta('IMPL::Test::Unit::SharedData'); + + 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($session); + }; + + 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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Text/Parser/Builder.pm --- a/Lib/IMPL/Text/Parser/Builder.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Text/Parser/Builder.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,7 +1,7 @@ -package IMPL::Text::Parser::Builder; -use strict; -use warnings; - - - -1; +package IMPL::Text::Parser::Builder; +use strict; +use warnings; + + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Text/Parser/Chunk.pm --- a/Lib/IMPL/Text/Parser/Chunk.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Text/Parser/Chunk.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,93 +1,93 @@ -package IMPL::Text::Parser::Chunk; -use strict; -use warnings; - -use base qw(IMPL::Object IMPL::Object::Autofill); - -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -use constant { - OP_REGEXP => 1, - OP_STRING => 2, - OP_REFERENCE => 3, - OP_CHUNK => 4, - OP_SWITCH => 5, - OP_REPEAT => 7 -}; - -BEGIN { - public _direct property chunkName => prop_get; - public _direct property opStream => prop_get; -} - -sub Regexp { - my ($this,$rx) = @_; - - if (ref $rx eq 'Regexp') { - - } elsif (not ref $rx) { - $rx = q/$rx/; - } else { - die new IMPL::InvalidArgumentException('A regular expression required'); - } - - push @{$this->{$opStream}}, [OP_REGEXP, $rx]; -} - -sub String { - my ($this,$str) = @_; - - die new IMPL::InvalidArgumentException("A simple value is required") if ref $str; - - push @{$this->{$opStream}}, [OP_STRING, $str]; -} - -sub Reference { - my ($this,$ref) = @_; - - die new IMPL::InvalidArgumentException("A simple value is reqiured") if ref $ref; - - push @{$this->{$opStream}}, [OP_REFERENCE, $ref]; -} - -sub Chunk { - my ($this,$chunk) = @_; - - die new IMPL::InvalidArgumentException unless UNIVERSAL::isa($chunk,'IMPL::Text::Parser::Chunk'); - - push @{$this->{$opStream}}, [OP_CHUNK, $chunk]; -} - -sub Switch { - my $this = shift; - - push @{$this->{$opStream}}, [OP_SWITCH, @_]; -} - -sub Repeat { - my ($this,$chunk,$min,$max) = @_; - - die new IMPL::InvalidArgumentException unless UNIVERSAL::isa($chunk,'IMPL::Text::Parser::Chunk'); - - push @{$this->{$opStream}}, [OP_REPEAT, $chunk, $min, $max ]; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION -Именованный поток операций - -=head1 MEMBERS - -=level - -=item C<<$obj->>> - -=back - -=cut \ No newline at end of file +package IMPL::Text::Parser::Chunk; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Autofill); + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +use constant { + OP_REGEXP => 1, + OP_STRING => 2, + OP_REFERENCE => 3, + OP_CHUNK => 4, + OP_SWITCH => 5, + OP_REPEAT => 7 +}; + +BEGIN { + public _direct property chunkName => prop_get; + public _direct property opStream => prop_get; +} + +sub Regexp { + my ($this,$rx) = @_; + + if (ref $rx eq 'Regexp') { + + } elsif (not ref $rx) { + $rx = q/$rx/; + } else { + die new IMPL::InvalidArgumentException('A regular expression required'); + } + + push @{$this->{$opStream}}, [OP_REGEXP, $rx]; +} + +sub String { + my ($this,$str) = @_; + + die new IMPL::InvalidArgumentException("A simple value is required") if ref $str; + + push @{$this->{$opStream}}, [OP_STRING, $str]; +} + +sub Reference { + my ($this,$ref) = @_; + + die new IMPL::InvalidArgumentException("A simple value is reqiured") if ref $ref; + + push @{$this->{$opStream}}, [OP_REFERENCE, $ref]; +} + +sub Chunk { + my ($this,$chunk) = @_; + + die new IMPL::InvalidArgumentException unless UNIVERSAL::isa($chunk,'IMPL::Text::Parser::Chunk'); + + push @{$this->{$opStream}}, [OP_CHUNK, $chunk]; +} + +sub Switch { + my $this = shift; + + push @{$this->{$opStream}}, [OP_SWITCH, @_]; +} + +sub Repeat { + my ($this,$chunk,$min,$max) = @_; + + die new IMPL::InvalidArgumentException unless UNIVERSAL::isa($chunk,'IMPL::Text::Parser::Chunk'); + + push @{$this->{$opStream}}, [OP_REPEAT, $chunk, $min, $max ]; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION +Именованный поток операций + +=head1 MEMBERS + +=level + +=item C<<$obj->>> + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Text/Parser/Player.pm --- a/Lib/IMPL/Text/Parser/Player.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Text/Parser/Player.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,217 +1,217 @@ -package IMPL::Text::Parser::Player; -use strict; -use warnings; - -use base qw(IMPL::Object); -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -use IMPL::Text::Parser::Chunk; - -my %opCodesMap = ( - IMPL::Text::Parser::Chunk::OP_REGEXP , &MatchRegexp , - IMPL::Text::Parser::Chunk::OP_STRING , &MatchString , - IMPL::Text::Parser::Chunk::OP_REFERENCE , &MatchReference , - IMPL::Text::Parser::Chunk::OP_CHUNK , &PlayChunk , - IMPL::Text::Parser::Chunk::OP_SWITCH , &MatchSwitch , - IMPL::Text::Parser::Chunk::OP_REPEAT , &MatchRepeat -); - -BEGIN { - private _direct property _data => prop_all; - private _direct property _current => prop_all; - private _direct property _states => prop_all; - private _direct property _document => prop_all; - - public _direct property errorLast => prop_all; - public _direct property Punctuation => prop_all; - public _direct property Delimier => prop_all; -} - -sub CTOR { - my ($this,$document) = @_; - - $this->{$_document} = $document or die new IMPL::InvalidArgumentException("The first parameter must be a document"); -} - -sub LoadString { - my ($this,$string) = @_; - - my $rxDelim = /(\s+|[.,;!-+*~$^&|%()`@\\\/])/; - - my $line = 0; - - $this->{$_data} = [ - map { - $line++; - map { - [$line,$_] - } split $rxDelim, $_ - } split /\n/, $string - ] -} - -sub Play { - my ($this) = @_; -} - -sub PlayChunk { - my ($this,$chunk) = @_; - - my $end = 0; - - my $name = $chunk->chunkName; - - $this->enter($name) if $name; - - foreach my $op ( @{$chunk->opStream} ) { - $this->leave(0) and return $this->error("no more data") if $end; - - $opCodesMap{shift @$op}->(@$op) || return $this->leave(0) ; - $this->moveNext or $end = 1; - } - - return $this->leave(1); -} - -sub MatchRegexp { - my ($this,$rx) = @_; - - $this->{$_current}{token} =~ $rx ? ($this->data() and return 1) : return $this->error("Expected: $rx"); -} - -sub MatchString { - my ($this,$string) = @_; - - $this->{$_current}{token} eq $string ? ($this->data() and return 1) : return $this->error("Expected: $string"); -} - -sub MatchReference { - my ($this,$name) = @_; - - my $chunk = $this->ResolveChunk($name) || return $this->error("Invalid reference: $name"); - return $this->PlayChunk($chunk); -} - -sub MatchSwitch { - my ($this,@chunks) = @_; - - foreach my $chunk (@chunks) { - $this->save; - if ( $this->PlayChunk($chunk) ) { - $this->apply; - return 1; - } else { - $this->restore; - } - } - - return 0; # passthrough last error -} - -sub MatchRepeat { - my ($this,$chunk, $min, $max) = @_; - - my $count = 0; - - $this->save; - while (1) { - $this->save; - if ($this->PlayChunk($chunk)) { - $count ++; - $this->apply; - $this->apply and return 1 if ($count >= $max) - } else { - $this->restore; - $count >= $min ? - ($this->apply() and return 1) : - ($this->restore() and return $this->error("Expected at least $min occurances, got only $count")); - } - } - - # we should never get here - die new IMPL::InvalidOperationException("unexpected error"); -} - -sub moveNext { - my ($this) = @_; - - my $pos = $this->{$_current}{pos}; - - $pos ++; - - if ($pos < @{$this->{$_data}}) { - - $this->{$_current} = { - pos => $pos, - token => $this->{$_data}[$pos][1], - line => $this->{$_data} - }; - - } else { - $this->{$_current} = {}; - return undef; - } -} - -sub ResolveChunk { - my ($this,$name) = @_; -} - -sub save { - my ($this) = @_; - - push @{$this->{$_states}}, $this->{$_current}; -} - -sub restore { - my ($this) = @_; - - $this->{$_current} = pop @{$this->{$_states}}; -} - -sub apply { - my ($this) = @_; - - pop @{$this->{$_states}}; -} - -sub error { - my ($this,$message) = @_; - - $this->{$errorLast} = { - message => $message, - line => $this->{$_current}{line}, - token => $this->{$_current}{token} - }; - - return 0; -} - -sub __debug { - -} -sub enter { - my ($this,$name) = @_; - - #always return true; - return 1; -} - -sub leave { - my ($this,$isEmpty) = @_; - - #always return true; - return 1; -} - -sub data { - my ($this) = @_; - - my $data = $this->{$_current}{token}; - - # always return true; - return 1; -} - -1; +package IMPL::Text::Parser::Player; +use strict; +use warnings; + +use base qw(IMPL::Object); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +use IMPL::Text::Parser::Chunk; + +my %opCodesMap = ( + IMPL::Text::Parser::Chunk::OP_REGEXP , &MatchRegexp , + IMPL::Text::Parser::Chunk::OP_STRING , &MatchString , + IMPL::Text::Parser::Chunk::OP_REFERENCE , &MatchReference , + IMPL::Text::Parser::Chunk::OP_CHUNK , &PlayChunk , + IMPL::Text::Parser::Chunk::OP_SWITCH , &MatchSwitch , + IMPL::Text::Parser::Chunk::OP_REPEAT , &MatchRepeat +); + +BEGIN { + private _direct property _data => prop_all; + private _direct property _current => prop_all; + private _direct property _states => prop_all; + private _direct property _document => prop_all; + + public _direct property errorLast => prop_all; + public _direct property Punctuation => prop_all; + public _direct property Delimier => prop_all; +} + +sub CTOR { + my ($this,$document) = @_; + + $this->{$_document} = $document or die new IMPL::InvalidArgumentException("The first parameter must be a document"); +} + +sub LoadString { + my ($this,$string) = @_; + + my $rxDelim = /(\s+|[.,;!-+*~$^&|%()`@\\\/])/; + + my $line = 0; + + $this->{$_data} = [ + map { + $line++; + map { + [$line,$_] + } split $rxDelim, $_ + } split /\n/, $string + ] +} + +sub Play { + my ($this) = @_; +} + +sub PlayChunk { + my ($this,$chunk) = @_; + + my $end = 0; + + my $name = $chunk->chunkName; + + $this->enter($name) if $name; + + foreach my $op ( @{$chunk->opStream} ) { + $this->leave(0) and return $this->error("no more data") if $end; + + $opCodesMap{shift @$op}->(@$op) || return $this->leave(0) ; + $this->moveNext or $end = 1; + } + + return $this->leave(1); +} + +sub MatchRegexp { + my ($this,$rx) = @_; + + $this->{$_current}{token} =~ $rx ? ($this->data() and return 1) : return $this->error("Expected: $rx"); +} + +sub MatchString { + my ($this,$string) = @_; + + $this->{$_current}{token} eq $string ? ($this->data() and return 1) : return $this->error("Expected: $string"); +} + +sub MatchReference { + my ($this,$name) = @_; + + my $chunk = $this->ResolveChunk($name) || return $this->error("Invalid reference: $name"); + return $this->PlayChunk($chunk); +} + +sub MatchSwitch { + my ($this,@chunks) = @_; + + foreach my $chunk (@chunks) { + $this->save; + if ( $this->PlayChunk($chunk) ) { + $this->apply; + return 1; + } else { + $this->restore; + } + } + + return 0; # passthrough last error +} + +sub MatchRepeat { + my ($this,$chunk, $min, $max) = @_; + + my $count = 0; + + $this->save; + while (1) { + $this->save; + if ($this->PlayChunk($chunk)) { + $count ++; + $this->apply; + $this->apply and return 1 if ($count >= $max) + } else { + $this->restore; + $count >= $min ? + ($this->apply() and return 1) : + ($this->restore() and return $this->error("Expected at least $min occurances, got only $count")); + } + } + + # we should never get here + die new IMPL::InvalidOperationException("unexpected error"); +} + +sub moveNext { + my ($this) = @_; + + my $pos = $this->{$_current}{pos}; + + $pos ++; + + if ($pos < @{$this->{$_data}}) { + + $this->{$_current} = { + pos => $pos, + token => $this->{$_data}[$pos][1], + line => $this->{$_data} + }; + + } else { + $this->{$_current} = {}; + return undef; + } +} + +sub ResolveChunk { + my ($this,$name) = @_; +} + +sub save { + my ($this) = @_; + + push @{$this->{$_states}}, $this->{$_current}; +} + +sub restore { + my ($this) = @_; + + $this->{$_current} = pop @{$this->{$_states}}; +} + +sub apply { + my ($this) = @_; + + pop @{$this->{$_states}}; +} + +sub error { + my ($this,$message) = @_; + + $this->{$errorLast} = { + message => $message, + line => $this->{$_current}{line}, + token => $this->{$_current}{token} + }; + + return 0; +} + +sub __debug { + +} +sub enter { + my ($this,$name) = @_; + + #always return true; + return 1; +} + +sub leave { + my ($this,$isEmpty) = @_; + + #always return true; + return 1; +} + +sub data { + my ($this) = @_; + + my $data = $this->{$_current}{token}; + + # always return true; + return 1; +} + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Text/Schema.pm --- a/Lib/IMPL/Text/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Text/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,87 +1,87 @@ -package IMPL::Text::Schema; -use strict; -use warnings; - -use base qw(IMPL::DOM::Schema); - -__PACKAGE__->PassThroughArgs; - -1; - -__END__ - -=pod - -=head1 SINOPSYS - -<schema> - <ComplexNode name="syntax"> - <Node name="Define" type="Statement" minOccur="1" maxOccur="unbounded"> - <Property name="name" type="Word"/> - </Node> - </ComplexNode> - <ComplexType type="Statement" nativeType="IMPL::Text::Schema::Statement"> - <NodeList> - <SwitchNode minOccur="1" maxOccur="unbounded"> - <Node name="Word" type="Word"/> - <Node name="Statement" type="Word"/> - <Node name="Regexp" type="Regexp"/> - <Node name="Switch" type="Switch"/> - <Node name="Repeat" type="List"/> - </SwitchNode> - </NodeList> - </ComplexType> - <SimpleType type="Word" nativeType="IMPL::Text::Schema::Word"/> - <SimpleType type="Regexp" nativeType="IMPL::Text::Schema::Regexp"/> - <ComplexType type="Switch" nativeType="IMPL::Text::Schema::Switch"> - <NodeList> - <SwitchNode minOccur="1" maxOccur="unbounded"> - <Node name="Word" type="Word"/> - <Node name="Statement" type="Word"/> - <Node name="Regexp" type="Regexp"/> - <Node name="Switch" type="Switch"/> - <Node name="Repeat" type="List"/> - </SwitchNode> - </NodeList> - </ComplexType> - <ComplexType type="Repeat" nativeType="IMPL::Text::Schema::Repeat"> - <NodeList> - <SwitchNode minOccur="1" maxOccur="unbounded"> - <Node name="Word" type="Word"/> - <Node name="Statement" type="Word"/> - <Node name="Regexp" type="Regexp"/> - <Node name="Switch" type="Switch"/> - <Node name="Repeat" type="List"/> - </SwitchNode> - </NodeList> - </CoomplexType> -</schema> - -=head1 DESCRIPTION - -Схема текстового файла, которую можно использовать для разбора содержимого -текстового файла. - -Схема текстового файла состоит из выражений. -1. Регулярное выражение является выражением -2. Строковое значение является выражением. -3. Выражения объединенные логическими операторами также выражение. - -Допускаются следующие операторы -1. Повтор -2. Ветвление - -=head1 METHODS - -=over - -=item C<<$schema->compile()>> - -Возвращает объект для разбора текста. - -=back - -=head1 INTERNALS - - -=cut +package IMPL::Text::Schema; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema); + +__PACKAGE__->PassThroughArgs; + +1; + +__END__ + +=pod + +=head1 SINOPSYS + +<schema> + <ComplexNode name="syntax"> + <Node name="Define" type="Statement" minOccur="1" maxOccur="unbounded"> + <Property name="name" type="Word"/> + </Node> + </ComplexNode> + <ComplexType type="Statement" nativeType="IMPL::Text::Schema::Statement"> + <NodeList> + <SwitchNode minOccur="1" maxOccur="unbounded"> + <Node name="Word" type="Word"/> + <Node name="Statement" type="Word"/> + <Node name="Regexp" type="Regexp"/> + <Node name="Switch" type="Switch"/> + <Node name="Repeat" type="List"/> + </SwitchNode> + </NodeList> + </ComplexType> + <SimpleType type="Word" nativeType="IMPL::Text::Schema::Word"/> + <SimpleType type="Regexp" nativeType="IMPL::Text::Schema::Regexp"/> + <ComplexType type="Switch" nativeType="IMPL::Text::Schema::Switch"> + <NodeList> + <SwitchNode minOccur="1" maxOccur="unbounded"> + <Node name="Word" type="Word"/> + <Node name="Statement" type="Word"/> + <Node name="Regexp" type="Regexp"/> + <Node name="Switch" type="Switch"/> + <Node name="Repeat" type="List"/> + </SwitchNode> + </NodeList> + </ComplexType> + <ComplexType type="Repeat" nativeType="IMPL::Text::Schema::Repeat"> + <NodeList> + <SwitchNode minOccur="1" maxOccur="unbounded"> + <Node name="Word" type="Word"/> + <Node name="Statement" type="Word"/> + <Node name="Regexp" type="Regexp"/> + <Node name="Switch" type="Switch"/> + <Node name="Repeat" type="List"/> + </SwitchNode> + </NodeList> + </CoomplexType> +</schema> + +=head1 DESCRIPTION + +Схема текстового файла, которую можно использовать для разбора содержимого +текстового файла. + +Схема текстового файла состоит из выражений. +1. Регулярное выражение является выражением +2. Строковое значение является выражением. +3. Выражения объединенные логическими операторами также выражение. + +Допускаются следующие операторы +1. Повтор +2. Ветвление + +=head1 METHODS + +=over + +=item C<<$schema->compile()>> + +Возвращает объект для разбора текста. + +=back + +=head1 INTERNALS + + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Transform.pm --- a/Lib/IMPL/Transform.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Transform.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,93 +1,93 @@ -package IMPL::Transform; -use base qw(IMPL::Object); - -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; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->{$Plain} = delete $args{-plain}; - $this->{$Default} = delete $args{-default}; - - $this->{$Templates} = \%args; -} - -sub Transform { - my ($this,$object,@args) = @_; - - 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,@args); - } else { - - my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object); - - return $this->$template($object,@args); - } -} - -sub MatchTemplate { - my ($this,$object) = @_; - my $class = $this->GetClassForObject( $object ); - - foreach my $tClass ( keys %{$this->Templates || {}} ) { - return $this->Templates->{$tClass} if ($tClass eq $class); - } -} - -sub GetClassForObject { - my ($this,$object) = @_; - - return ref $object; -} - -package IMPL::Transform::NoTransformException; -use base qw(IMPL::Exception); - -our %CTOR = ( - 'IMPL::Exception' => sub { 'No transformation', @_ } -); - -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); - }, - -default => sub { - my ($this,$object) = @_; - return $object; - }, - -plain => sub { - my ($this,$object) = @_; - return $object; - } -); - -my $result = $t->Transform($obj); - -=head1 DESCRIPTION - -Преобразование одного объекта к другому, например даных к их представлению. - -=cut \ No newline at end of file +package IMPL::Transform; +use base qw(IMPL::Object); + +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; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->{$Plain} = delete $args{-plain}; + $this->{$Default} = delete $args{-default}; + + $this->{$Templates} = \%args; +} + +sub Transform { + my ($this,$object,@args) = @_; + + 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,@args); + } else { + + my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object); + + return $this->$template($object,@args); + } +} + +sub MatchTemplate { + my ($this,$object) = @_; + my $class = $this->GetClassForObject( $object ); + + foreach my $tClass ( keys %{$this->Templates || {}} ) { + return $this->Templates->{$tClass} if ($tClass eq $class); + } +} + +sub GetClassForObject { + my ($this,$object) = @_; + + return ref $object; +} + +package IMPL::Transform::NoTransformException; +use base qw(IMPL::Exception); + +our %CTOR = ( + 'IMPL::Exception' => sub { 'No transformation', @_ } +); + +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); + }, + -default => sub { + my ($this,$object) = @_; + return $object; + }, + -plain => sub { + my ($this,$object) = @_; + return $object; + } +); + +my $result = $t->Transform($obj); + +=head1 DESCRIPTION + +Преобразование одного объекта к другому, например даных к их представлению. + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Web/Application.pm --- a/Lib/IMPL/Web/Application.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Web/Application.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,47 +1,47 @@ -package IMPL::Web::Application; -use strict; -use warnings; - -use base qw(IMPL::Object IMPL::Object::Singleton); -use IMPL::Class::Property; - -BEGIN { - public property RequestFactory => prop_all; - public property ContextInitializers => prop_all; -} - -# custom factory -sub new { - my ($self,$file) = @_; - - return $self->LoadXMLFile($file); -} - -sub Run { - my ($this) = @_; - - while (my $request = $this->fetch_request()) { - my $context = $this->prepare_context($request); - $context->invoke($request); - } -} - -1; - -=pod - -=head1 SYNOPSIS - -require MyApp; -MyApp->instance('app.config')->Run(); - -=head1 DESCRIPTION - -Зкземпляр приложения содержит в себе глобальные настройки, реализует контроллер запросов, - -Получая запрос из источника запросов, создает контекст выполнения запроса -затем выполняет запрос в указанном контексте. - -Контекст формируется сначала из запроса, а затем посредством набора инициализаторов - -=cut \ No newline at end of file +package IMPL::Web::Application; +use strict; +use warnings; + +use base qw(IMPL::Object IMPL::Object::Singleton); +use IMPL::Class::Property; + +BEGIN { + public property RequestFactory => prop_all; + public property ContextInitializers => prop_all; +} + +# custom factory +sub new { + my ($self,$file) = @_; + + return $self->LoadXMLFile($file); +} + +sub Run { + my ($this) = @_; + + while (my $request = $this->fetch_request()) { + my $context = $this->prepare_context($request); + $context->invoke($request); + } +} + +1; + +=pod + +=head1 SYNOPSIS + +require MyApp; +MyApp->instance('app.config')->Run(); + +=head1 DESCRIPTION + +Зкземпляр приложения содержит в себе глобальные настройки, реализует контроллер запросов, + +Получая запрос из источника запросов, создает контекст выполнения запроса +затем выполняет запрос в указанном контексте. + +Контекст формируется сначала из запроса, а затем посредством набора инициализаторов + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/IMPL/Web/TDocument.pm --- a/Lib/IMPL/Web/TDocument.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Web/TDocument.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,145 +1,145 @@ -package IMPL::Web::TDocument; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node IMPL::Object::Disposable); -use Template::Context; -use Template::Provider; -use IMPL::Class::Property; -use File::Spec; - -BEGIN { - private property _Provider => prop_all; - private property _Context => prop_all; - public property Template => prop_get | owner_set; -} - -our %CTOR = ( - 'IMPL::DOM::Node' => sub { nodeName => 'document' } -); - -sub Provider { - my ($this,%args) = @_; - - if (my $provider = $this->_Provider) { - return $provider; - } else { - return $this->_Provider(new Template::Provider( - \%args - )); - } -} - -sub Context { - my ($this) = @_; - - if (my $ctx = $this->_Context) { - return $ctx; - } else { - return $this->_Context ( - new Template::Context( - VARIABLES => { - document => $this - }, - TRIM => 1, - RECURSION => 1, - LOAD_TEMPLATES => [$this->Provider] - ) - ) - } -} - -sub loadFile { - my ($this,$filePath,$encoding) = @_; - - die new IMPL::InvalidArgumentException("A filePath parameter is required") unless $filePath; - - $encoding ||= 'utf8'; - - $this->_Context(undef); - $this->_Provider(undef); - - my ($vol,$dir,$fileName) = File::Spec->splitpath($filePath); - - my $inc = File::Spec->catpath($vol,$dir,''); - - $this->Provider( - ENCODING => $encoding, - INTERPOLATE => 1, - PRE_CHOMP => 1, - POST_CHOMP => 1, - INCLUDE_PATH => $inc - ); - - $this->Template($this->Context->template($fileName)); -} - -sub Title { - $_[0]->Template->Title; -} - -sub Render { - my ($this) = @_; - - return $this->Template->process($this->Context); -} - -sub Dispose { - my ($this) = @_; - - $this->Template(undef); - $this->_Context(undef); - $this->_Provider(undef); - - $this->SUPER::Dispose(); -} - -1; -__END__ -=pod - -=head1 SYNOPSIS - -// create new document -my $doc = new IMPL::Web::TDocument; - -// load template -$doc->loadFile('Templates/index.tt'); - -// render file -print $doc->Render(); - -=head1 DESCRIPTION - -Документ, основанный на шаблоне Template::Toolkit. Позволяет загрузить шаблон, -и сформировать окончательный документ. Является наследником C<IMPL::DOM::Node>, -т.о. может быть использован для реализации DOM модели. - -Внутри шаблона переменная C<document> ссылается на объект документа. По этой -причине образуется циклическая ссылка между объектами шаблона и документом, что -требует вызова метода C<Dispose> для освобождения документа. - -=head1 METHODS - -=level 4 - -=item C<new()> - -Создает новый экземпляр документа - -=item C<$doc->loadFile($fileName,$encoding)> - -Загружает шаблон из файла C<$fileName>, используя кодировку C<$encoding>. Если -кодировка не указана, использует utf-8. - -=item C<$doc->Render()> - -Возвращает данные построенные на основе загруженного шаблона. - -=item C<$doc->Dispose()> - -Освобождает ресурсы и помечает объект как освобожденный. - -=back - -=cut \ No newline at end of file +package IMPL::Web::TDocument; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node IMPL::Object::Disposable); +use Template::Context; +use Template::Provider; +use IMPL::Class::Property; +use File::Spec; + +BEGIN { + private property _Provider => prop_all; + private property _Context => prop_all; + public property Template => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::DOM::Node' => sub { nodeName => 'document' } +); + +sub Provider { + my ($this,%args) = @_; + + if (my $provider = $this->_Provider) { + return $provider; + } else { + return $this->_Provider(new Template::Provider( + \%args + )); + } +} + +sub Context { + my ($this) = @_; + + if (my $ctx = $this->_Context) { + return $ctx; + } else { + return $this->_Context ( + new Template::Context( + VARIABLES => { + document => $this + }, + TRIM => 1, + RECURSION => 1, + LOAD_TEMPLATES => [$this->Provider] + ) + ) + } +} + +sub loadFile { + my ($this,$filePath,$encoding) = @_; + + die new IMPL::InvalidArgumentException("A filePath parameter is required") unless $filePath; + + $encoding ||= 'utf8'; + + $this->_Context(undef); + $this->_Provider(undef); + + my ($vol,$dir,$fileName) = File::Spec->splitpath($filePath); + + my $inc = File::Spec->catpath($vol,$dir,''); + + $this->Provider( + ENCODING => $encoding, + INTERPOLATE => 1, + PRE_CHOMP => 1, + POST_CHOMP => 1, + INCLUDE_PATH => $inc + ); + + $this->Template($this->Context->template($fileName)); +} + +sub Title { + $_[0]->Template->Title; +} + +sub Render { + my ($this) = @_; + + return $this->Template->process($this->Context); +} + +sub Dispose { + my ($this) = @_; + + $this->Template(undef); + $this->_Context(undef); + $this->_Provider(undef); + + $this->SUPER::Dispose(); +} + +1; +__END__ +=pod + +=head1 SYNOPSIS + +// create new document +my $doc = new IMPL::Web::TDocument; + +// load template +$doc->loadFile('Templates/index.tt'); + +// render file +print $doc->Render(); + +=head1 DESCRIPTION + +Документ, основанный на шаблоне Template::Toolkit. Позволяет загрузить шаблон, +и сформировать окончательный документ. Является наследником C<IMPL::DOM::Node>, +т.о. может быть использован для реализации DOM модели. + +Внутри шаблона переменная C<document> ссылается на объект документа. По этой +причине образуется циклическая ссылка между объектами шаблона и документом, что +требует вызова метода C<Dispose> для освобождения документа. + +=head1 METHODS + +=level 4 + +=item C<new()> + +Создает новый экземпляр документа + +=item C<$doc->loadFile($fileName,$encoding)> + +Загружает шаблон из файла C<$fileName>, используя кодировку C<$encoding>. Если +кодировка не указана, использует utf-8. + +=item C<$doc->Render()> + +Возвращает данные построенные на основе загруженного шаблона. + +=item C<$doc->Dispose()> + +Освобождает ресурсы и помечает объект как освобожденный. + +=back + +=cut diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Mailer.pm --- a/Lib/Mailer.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Mailer.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,69 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/ObjectStore/CDBI/Users.pm --- a/Lib/ObjectStore/CDBI/Users.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/ObjectStore/CDBI/Users.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,100 +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 +#!/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); +} diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/PerfCounter.pm --- a/Lib/PerfCounter.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/PerfCounter.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,161 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema.pm --- a/Lib/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,748 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB.pm --- a/Lib/Schema/DB.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,57 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Column.pm --- a/Lib/Schema/DB/Column.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Column.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,56 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Constraint.pm --- a/Lib/Schema/DB/Constraint.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Constraint.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,48 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Constraint/ForeignKey.pm --- a/Lib/Schema/DB/Constraint/ForeignKey.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Constraint/ForeignKey.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,58 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Constraint/Index.pm --- a/Lib/Schema/DB/Constraint/Index.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Constraint/Index.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,14 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Constraint/PrimaryKey.pm --- a/Lib/Schema/DB/Constraint/PrimaryKey.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Constraint/PrimaryKey.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,40 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Constraint/Unique.pm --- a/Lib/Schema/DB/Constraint/Unique.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Constraint/Unique.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,6 +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 +package Schema::DB::Constraint::PrimaryKey; +use strict; +use Common; +use base qw(Schema::DB::Constraint::Index); + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Table.pm --- a/Lib/Schema/DB/Table.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Table.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,168 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Traits.pm --- a/Lib/Schema/DB/Traits.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Traits.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,268 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Traits/mysql.pm --- a/Lib/Schema/DB/Traits/mysql.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Traits/mysql.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,549 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DB/Type.pm --- a/Lib/Schema/DB/Type.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DB/Type.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,42 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DataSource.pm --- a/Lib/Schema/DataSource.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DataSource.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,138 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DataSource/CDBIBuilder.pm --- a/Lib/Schema/DataSource/CDBIBuilder.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DataSource/CDBIBuilder.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,326 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/DataSource/TypeMapping.pm --- a/Lib/Schema/DataSource/TypeMapping.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/DataSource/TypeMapping.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,46 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/Form.pm --- a/Lib/Schema/Form.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/Form.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,252 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/Form/Container.pm --- a/Lib/Schema/Form/Container.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/Form/Container.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,41 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/Form/Field.pm --- a/Lib/Schema/Form/Field.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/Form/Field.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,33 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/Form/Filter.pm --- a/Lib/Schema/Form/Filter.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/Form/Filter.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,46 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/Form/Format.pm --- a/Lib/Schema/Form/Format.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/Form/Format.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,26 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Schema/Form/Item.pm --- a/Lib/Schema/Form/Item.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Schema/Form/Item.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,41 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Security.pm --- a/Lib/Security.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Security.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,21 +1,21 @@ -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; -} - -1; - +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; +} + +1; + diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Security/Auth.pm --- a/Lib/Security/Auth.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Security/Auth.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,108 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Security/Auth/Simple.pm --- a/Lib/Security/Auth/Simple.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Security/Auth/Simple.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,73 +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; +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Lib/Security/Authz.pm --- a/Lib/Security/Authz.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/Security/Authz.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,33 +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 +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; +} diff -r 1c3c3e63a314 -r 16ada169ca75 Schema/form.def --- a/Schema/form.def Fri Feb 26 01:43:42 2010 +0300 +++ b/Schema/form.def Fri Feb 26 10:49:21 2010 +0300 @@ -1,39 +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 +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; diff -r 1c3c3e63a314 -r 16ada169ca75 Schema/query.def --- a/Schema/query.def Fri Feb 26 01:43:42 2010 +0300 +++ b/Schema/query.def Fri Feb 26 10:49:21 2010 +0300 @@ -1,27 +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 +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 ...] diff -r 1c3c3e63a314 -r 16ada169ca75 Schema/schema.def --- a/Schema/schema.def Fri Feb 26 01:43:42 2010 +0300 +++ b/Schema/schema.def Fri Feb 26 10:49:21 2010 +0300 @@ -1,43 +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 +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} ...] diff -r 1c3c3e63a314 -r 16ada169ca75 Schema/type.def --- a/Schema/type.def Fri Feb 26 01:43:42 2010 +0300 +++ b/Schema/type.def Fri Feb 26 10:49:21 2010 +0300 @@ -1,3 +1,3 @@ -syntax ::= name [<\<>syntax [, syntax ...]<\>>] - -name ::= <\w>+ \ No newline at end of file +syntax ::= name [<\<>syntax [, syntax ...]<\>>] + +name ::= <\w>+ diff -r 1c3c3e63a314 -r 16ada169ca75 _test/DOM.t --- a/_test/DOM.t Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/DOM.t Fri Feb 26 10:49:21 2010 +0300 @@ -1,18 +1,18 @@ -#!/usr/bin/perl -w -use strict; -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; - -my $plan = new IMPL::Test::Plan qw( - Test::DOM::Node - Test::DOM::Navigator - Test::DOM::Schema - Test::DOM::Builder -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); \ No newline at end of file +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::DOM::Node + Test::DOM::Navigator + Test::DOM::Schema + Test::DOM::Builder +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); diff -r 1c3c3e63a314 -r 16ada169ca75 _test/ORM.t --- a/_test/ORM.t Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/ORM.t Fri Feb 26 10:49:21 2010 +0300 @@ -1,17 +1,17 @@ -#!/usr/bin/perl -w -use strict; -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; - -my $plan = new IMPL::Test::Plan qw( - Test::ORM::Schema -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); - -1; \ No newline at end of file +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::ORM::Schema +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Resources.t --- a/_test/Resources.t Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Resources.t Fri Feb 26 10:49:21 2010 +0300 @@ -1,15 +1,15 @@ -#!/usr/bin/perl -w -use strict; -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; - -my $plan = new IMPL::Test::Plan qw( - Test::Resources::Format -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); \ No newline at end of file +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::Resources::Format +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Resources/form.schema --- a/_test/Resources/form.schema Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Resources/form.schema Fri Feb 26 10:49:21 2010 +0300 @@ -1,58 +1,58 @@ -<?xml version="1.0" encoding="UTF-8"?> -<schema> - <Include src="forms.schema"/> - <Form - type="Form" - dataPolicy="AddOrUpdate" - dataType="App::Data::User" - messageMin="Р’С‹ РЅРµ заполнили %Node.formLabel_blame%" - > - <Name - formLabel="РРјСЏ" - formLabel_blame="РёРјСЏ" - formLabel_no="имени" - type="EditBox" - /> - <!-- Опциональный элемент --> - <Nick - formLabel="Прозвище" - formLabel_no="прозвища" - minOccur="0" - type="EditBox" - > - <RegExp>\w{4,10}</RegExp> - </Nick> - <Role - dataType="App::Data::Role" - dataSource="roles" - formLabel="Роль" - formLabel_blame="роль" - type="MultiSelect" - maxOccur="unbounded" - /> - <Contacts - minOccur="0" - maxOccur="unbounded" - formLabel="Контакты" - dataType="App::Data::Contacts" - type="Container" - > - <NodeSet> - <EMail - type="EditBox" - minOccur="0" - formLabel="Р­Р». почта" - formLabel_no="СЌР». почты" - /> - <Phone - type="EditBox" - minOccur="0" - formLabel="Телефон" - formLabel_no="телефона" - /> - </NodeSet> - </Contacts> - </Form> - -</schema> - +<?xml version="1.0" encoding="UTF-8"?> +<schema> + <Include src="forms.schema"/> + <Form + type="Form" + dataPolicy="AddOrUpdate" + dataType="App::Data::User" + messageMin="Р’С‹ РЅРµ заполнили %Node.formLabel_blame%" + > + <Name + formLabel="РРјСЏ" + formLabel_blame="РёРјСЏ" + formLabel_no="имени" + type="EditBox" + /> + <!-- Опциональный элемент --> + <Nick + formLabel="Прозвище" + formLabel_no="прозвища" + minOccur="0" + type="EditBox" + > + <RegExp>\w{4,10}</RegExp> + </Nick> + <Role + dataType="App::Data::Role" + dataSource="roles" + formLabel="Роль" + formLabel_blame="роль" + type="MultiSelect" + maxOccur="unbounded" + /> + <Contacts + minOccur="0" + maxOccur="unbounded" + formLabel="Контакты" + dataType="App::Data::Contacts" + type="Container" + > + <NodeSet> + <EMail + type="EditBox" + minOccur="0" + formLabel="Р­Р». почта" + formLabel_no="СЌР». почты" + /> + <Phone + type="EditBox" + minOccur="0" + formLabel="Телефон" + formLabel_no="телефона" + /> + </NodeSet> + </Contacts> + </Form> + +</schema> + diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Resources/large.xml --- a/_test/Resources/large.xml Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Resources/large.xml Fri Feb 26 10:49:21 2010 +0300 @@ -1,2 +1,2 @@ -<?xml version="1.0" encoding="utf-8"?> -<CIM CIMVERSION="2.0" DTDVERSION="2.0"><DECLARATION><DECLGROUP.WITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">268435456</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">268435456</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3758096384</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3758096384</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4026531840</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4026531840</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4027056128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4027056128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4030726144</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4030726144</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034920448</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034920448</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034936832</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034936832</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">2</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">2</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">4</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">4</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">1</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">1</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">10</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">10</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">11</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">11</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">12</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0F03\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">12</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0F03\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">14</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">14</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">15</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">15</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">5</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">5</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">6</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">6</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI_HAL\PNP0C08\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI_HAL\PNP0C08\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">100</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">100</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1008</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1008</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1014</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1014</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1015</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1015</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1912</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1912</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">192</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">192</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">2681</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">2681</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3328</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3328</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">368</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">368</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">496</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">496</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53248</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_269E&SUBSYS_00000000&REV_00\3&267A616A&0&09]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53248</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_269E&SUBSYS_00000000&REV_00\3&267A616A&0&09]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53280</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53280</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53312</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53312</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53504</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53504</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53760</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53760</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">628</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">628</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">633</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">633</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">886</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">886</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">888</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">888</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">944</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">944</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">96</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">96</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">960</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">960</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH></DECLGROUP.WITHPATH></DECLARATION></CIM> +<?xml version="1.0" encoding="utf-8"?> +<CIM CIMVERSION="2.0" DTDVERSION="2.0"><DECLARATION><DECLGROUP.WITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">268435456</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">268435456</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3758096384</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3758096384</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4026531840</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4026531840</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4027056128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4027056128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4030726144</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4030726144</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034920448</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034920448</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034936832</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">4034936832</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DeviceMemoryAddress"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">655360</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">2</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">2</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">4</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_DMAChannel"><KEYBINDING NAME="DMAChannel"><KEYVALUE VALUETYPE="numeric">4</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">1</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">1</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">10</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">10</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">11</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">11</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">12</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0F03\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">12</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0F03\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">14</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">14</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">15</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">15</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">5</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">5</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_106B&DEV_003F&SUBSYS_00000000&REV_00\3&267A616A&0&30]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">6</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">6</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI_HAL\PNP0C08\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI_HAL\PNP0C08\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_IRQResource"><KEYBINDING NAME="IRQNumber"><KEYVALUE VALUETYPE="numeric">9</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">100</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">100</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1008</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1008</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1014</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1014</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1015</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1015</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0700\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">128</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1912</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">1912</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">192</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">192</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0200\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">2681</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">2681</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3328</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">3328</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ACPI\PNP0A03\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">368</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">368</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">496</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">496</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53248</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_269E&SUBSYS_00000000&REV_00\3&267A616A&0&09]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53248</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_269E&SUBSYS_00000000&REV_00\3&267A616A&0&09]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53280</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53280</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_1022&DEV_2000&SUBSYS_20001022&REV_40\3&267A616A&0&18]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53312</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53312</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_CAFE&SUBSYS_00000000&REV_00\3&267A616A&0&20]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53504</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53504</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53760</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">53760</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_8086&DEV_2415&SUBSYS_00008086&REV_01\3&267A616A&0&28]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">628</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">628</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">633</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">633</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string">ISAPNP\READDATAPORT\0</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">886</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">886</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCIIDE\IDECHANNEL\4&30B164C9&0&1]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">888</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">888</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0400\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">944</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">944</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">96</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">96</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[ACPI\PNP0303\4&1D401FB5&0]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH><VALUE.OBJECTWITHPATH><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PNPAllocatedResource"><KEYBINDING NAME="Antecedent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">960</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING><KEYBINDING NAME="Dependent"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></KEYBINDING></INSTANCENAME></INSTANCEPATH><INSTANCE CLASSNAME="Win32_PNPAllocatedResource"><PROPERTY.REFERENCE NAME="Antecedent" REFERENCECLASS="CIM_SystemResource"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PortResource"><KEYBINDING NAME="StartingAddress"><KEYVALUE VALUETYPE="string">960</KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE><PROPERTY.REFERENCE NAME="Dependent" REFERENCECLASS="Win32_PNPEntity"><VALUE.REFERENCE><INSTANCEPATH><NAMESPACEPATH><HOST>WEB-DEV</HOST><LOCALNAMESPACEPATH><NAMESPACE NAME="root"/><NAMESPACE NAME="cimv2"/></LOCALNAMESPACEPATH></NAMESPACEPATH><INSTANCENAME CLASSNAME="Win32_PnPEntity"><KEYBINDING NAME="DeviceID"><KEYVALUE VALUETYPE="string"><![CDATA[PCI\VEN_80EE&DEV_BEEF&SUBSYS_00000000&REV_00\3&267A616A&0&10]]></KEYVALUE></KEYBINDING></INSTANCENAME></INSTANCEPATH></VALUE.REFERENCE></PROPERTY.REFERENCE></INSTANCE></VALUE.OBJECTWITHPATH></DECLGROUP.WITHPATH></DECLARATION></CIM> diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Resources/person_info.xml --- a/_test/Resources/person_info.xml Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Resources/person_info.xml Fri Feb 26 10:49:21 2010 +0300 @@ -1,10 +1,10 @@ -<?xml version="1.0" encoding="UTF-8"?> -<personInfo> - <firstName>Norman</firstName> - <lastName>Freeman</lastName> - <address> - <street>hellroad</street> - <line>1</line> - </address> -</personInfo> - +<?xml version="1.0" encoding="UTF-8"?> +<personInfo> + <firstName>Norman</firstName> + <lastName>Freeman</lastName> + <address> + <street>hellroad</street> + <line>1</line> + </address> +</personInfo> + diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Resources/test.schema --- a/_test/Resources/test.schema Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Resources/test.schema Fri Feb 26 10:49:21 2010 +0300 @@ -1,41 +1,41 @@ -<?xml version="1.0" encoding="utf-8"?> -<schema> - <!-- Директивы --> - <!-- Загрузка фрагмента схемы --> - <Include src="basic.types.schema"/> - - <!-- Определения типов --> - <SimpleType type="DateTime"> - <Regexp>\d{4}-\d{2}-\d{2}((T|\s)\d{2}\:\d{2}:\d{2})?</Regexp> - </SimpleType> - <ComplexType type="Person"> - <NodeSet> - <SimpleNode nodeName="FirstName"/> - <SimpleNode nodeName="LastName"/> - <ComplexNode maxOccur="unbounded" nodeName="Passport" type="Passport"> - <Node nodeName="DateExpire" type="DateTime"/> - <SimpleNode nodeName="Code"/> - </ComplexNode> - </NodeSet> - </ComplexType> - - <!-- Содержимое возможные варианты для документов--> - <ComplexNode nodeName="Form"> - <NodeSet> - <SimpleNode nodeName="FirstName"> - <Regexp>\w+</Regexp> - </SimpleNode> - <SimpleNode nodeName="LastName"> - <Regexp>\w+</Regexp> - </SimpleNode> - <Node nodeName="BirthDate" type="DateTime" /> - <Node nodeName="Email" type="Email" minOccur="0" maxOccur="unbounded" /> - <ComplexNode nodeName="AviaTicket" minOccur="0"> - <Node nodeName="From" type="Airport" control="ListBox" datasource="Airports"/> - <Node nodeName="To" type="Airport" > - <Check op='!=' LVal='nodeValue' RVal="From.nodeValue"/> - </Node> - </ComplexNode> - </NodeSet> - </ComplexNode> -</schema> \ No newline at end of file +<?xml version="1.0" encoding="utf-8"?> +<schema> + <!-- Директивы --> + <!-- Загрузка фрагмента схемы --> + <Include src="basic.types.schema"/> + + <!-- Определения типов --> + <SimpleType type="DateTime"> + <Regexp>\d{4}-\d{2}-\d{2}((T|\s)\d{2}\:\d{2}:\d{2})?</Regexp> + </SimpleType> + <ComplexType type="Person"> + <NodeSet> + <SimpleNode nodeName="FirstName"/> + <SimpleNode nodeName="LastName"/> + <ComplexNode maxOccur="unbounded" nodeName="Passport" type="Passport"> + <Node nodeName="DateExpire" type="DateTime"/> + <SimpleNode nodeName="Code"/> + </ComplexNode> + </NodeSet> + </ComplexType> + + <!-- Содержимое возможные варианты для документов--> + <ComplexNode nodeName="Form"> + <NodeSet> + <SimpleNode nodeName="FirstName"> + <Regexp>\w+</Regexp> + </SimpleNode> + <SimpleNode nodeName="LastName"> + <Regexp>\w+</Regexp> + </SimpleNode> + <Node nodeName="BirthDate" type="DateTime" /> + <Node nodeName="Email" type="Email" minOccur="0" maxOccur="unbounded" /> + <ComplexNode nodeName="AviaTicket" minOccur="0"> + <Node nodeName="From" type="Airport" control="ListBox" datasource="Airports"/> + <Node nodeName="To" type="Airport" > + <Check op='!=' LVal='nodeValue' RVal="From.nodeValue"/> + </Node> + </ComplexNode> + </NodeSet> + </ComplexNode> +</schema> diff -r 1c3c3e63a314 -r 16ada169ca75 _test/SQL.t --- a/_test/SQL.t Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/SQL.t Fri Feb 26 10:49:21 2010 +0300 @@ -1,17 +1,17 @@ -#!/usr/bin/perl -w -use strict; -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; - -my $plan = new IMPL::Test::Plan qw( - Test::SQL::Schema -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); - -1; \ No newline at end of file +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::SQL::Schema +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/DOM/Builder.pm --- a/_test/Test/DOM/Builder.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/DOM/Builder.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,125 +1,125 @@ -package Test::DOM::Builder; -use strict; -use warnings; - -use base qw(IMPL::Test::Unit); -__PACKAGE__->PassThroughArgs; - -use IMPL::Class::Property; -use IMPL::Test qw(test failed shared); - -require IMPL::DOM::Schema; -require IMPL::DOM::Navigator::Builder; -require IMPL::DOM::Navigator::SimpleBuilder; -require IMPL::DOM::Document; -require IMPL::DOM::XMLReader; - -BEGIN { - public property schemaDoc => prop_all; -} - -sub CTOR { - my ($this) = @_; - - my $schema = new IMPL::DOM::Schema; - $schema->appendRange( - IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - new IMPL::DOM::Schema::SimpleNode( name => 'firstName' ), - new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), - new IMPL::DOM::Schema::ComplexNode( name => 'address', maxOccur => 'unbounded' )->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - new IMPL::DOM::Schema::SimpleNode( name => 'street' ), - new IMPL::DOM::Schema::SimpleNode( name => 'line', minOccur => 0 ) - ) - ) - ) - ) - ); - - $this->schemaDoc( $schema ); -} - -test CreateBuilder => sub { - my ($this) = @_; - - my $builder = IMPL::DOM::Navigator::Builder->new( - new IMPL::DOM::Document(nodeName => 'personInfo'), - $this->schemaDoc - ); -}; - -test BuildDocument => sub { - my ($this) = @_; - - my $builder = IMPL::DOM::Navigator::Builder->new( - 'IMPL::DOM::Document', - $this->schemaDoc - ); - - $builder->NavigateCreate('personInfo', version => '1'); - $builder->NavigateCreate('firstName')->nodeValue('Nemo'); - $builder->Back(); - $builder->NavigateCreate('lastName')->nodeValue('Nobel'); - $builder->Back(); - for(1..10) { - $builder->NavigateCreate('address', local => 1); - $builder->NavigateCreate('street')->nodeValue('Hellroad'); - $builder->Back(); - $builder->NavigateCreate('line')->nodeValue($_); - $builder->Back(); - $builder->Back(); - } - $builder->Back(); - - my @errors = $this->schemaDoc->Validate($builder->Document); - failed ("The built document doesn't pass a validation",@errors) if @errors; - - return 1; -}; - -test BuildSimpleDocument => sub { - my ($this) = @_; - - my $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); - - $builder->NavigateCreate('personInfo', version => '1'); - $builder->NavigateCreate('firstName')->nodeValue('Nemo'); - $builder->Back(); - $builder->NavigateCreate('lastName')->nodeValue('Nobel'); - $builder->Back(); - for(1..10) { - $builder->NavigateCreate('address', local => 1); - $builder->NavigateCreate('street')->nodeValue('Hellroad'); - $builder->Back(); - $builder->NavigateCreate('line')->nodeValue($_); - $builder->Back(); - $builder->Back(); - } - $builder->Back(); - - my @errors = $this->schemaDoc->Validate($builder->Document); - failed ("The built document doesn't pass a validation",@errors) if @errors; - - return 1; -}; - -test BuildDocumentFromXml => sub { - my ($this) = @_; - - my $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); - my $reader = IMPL::DOM::XMLReader->new( Navigator => $builder ); - - $reader->ParseFile("Resources/person_info.xml"); - - my $doc = $builder->Document() or failed("No document was constrcuted"); - - my @errors = $this->schemaDoc->Validate($doc); - failed("The document isn't correct", @errors) if @errors; - my $name = ($doc->selectNodes("firstName"))[0]->nodeValue; - failed("The firstName has a wrong value", "Expected: Norman", "Got: $name") unless $name eq "Norman"; - -}; - - -1; +package Test::DOM::Builder; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +__PACKAGE__->PassThroughArgs; + +use IMPL::Class::Property; +use IMPL::Test qw(test failed shared); + +require IMPL::DOM::Schema; +require IMPL::DOM::Navigator::Builder; +require IMPL::DOM::Navigator::SimpleBuilder; +require IMPL::DOM::Document; +require IMPL::DOM::XMLReader; + +BEGIN { + public property schemaDoc => prop_all; +} + +sub CTOR { + my ($this) = @_; + + my $schema = new IMPL::DOM::Schema; + $schema->appendRange( + IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'firstName' ), + new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), + new IMPL::DOM::Schema::ComplexNode( name => 'address', maxOccur => 'unbounded' )->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'street' ), + new IMPL::DOM::Schema::SimpleNode( name => 'line', minOccur => 0 ) + ) + ) + ) + ) + ); + + $this->schemaDoc( $schema ); +} + +test CreateBuilder => sub { + my ($this) = @_; + + my $builder = IMPL::DOM::Navigator::Builder->new( + new IMPL::DOM::Document(nodeName => 'personInfo'), + $this->schemaDoc + ); +}; + +test BuildDocument => sub { + my ($this) = @_; + + my $builder = IMPL::DOM::Navigator::Builder->new( + 'IMPL::DOM::Document', + $this->schemaDoc + ); + + $builder->NavigateCreate('personInfo', version => '1'); + $builder->NavigateCreate('firstName')->nodeValue('Nemo'); + $builder->Back(); + $builder->NavigateCreate('lastName')->nodeValue('Nobel'); + $builder->Back(); + for(1..10) { + $builder->NavigateCreate('address', local => 1); + $builder->NavigateCreate('street')->nodeValue('Hellroad'); + $builder->Back(); + $builder->NavigateCreate('line')->nodeValue($_); + $builder->Back(); + $builder->Back(); + } + $builder->Back(); + + my @errors = $this->schemaDoc->Validate($builder->Document); + failed ("The built document doesn't pass a validation",@errors) if @errors; + + return 1; +}; + +test BuildSimpleDocument => sub { + my ($this) = @_; + + my $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); + + $builder->NavigateCreate('personInfo', version => '1'); + $builder->NavigateCreate('firstName')->nodeValue('Nemo'); + $builder->Back(); + $builder->NavigateCreate('lastName')->nodeValue('Nobel'); + $builder->Back(); + for(1..10) { + $builder->NavigateCreate('address', local => 1); + $builder->NavigateCreate('street')->nodeValue('Hellroad'); + $builder->Back(); + $builder->NavigateCreate('line')->nodeValue($_); + $builder->Back(); + $builder->Back(); + } + $builder->Back(); + + my @errors = $this->schemaDoc->Validate($builder->Document); + failed ("The built document doesn't pass a validation",@errors) if @errors; + + return 1; +}; + +test BuildDocumentFromXml => sub { + my ($this) = @_; + + my $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); + my $reader = IMPL::DOM::XMLReader->new( Navigator => $builder ); + + $reader->ParseFile("Resources/person_info.xml"); + + my $doc = $builder->Document() or failed("No document was constrcuted"); + + my @errors = $this->schemaDoc->Validate($doc); + failed("The document isn't correct", @errors) if @errors; + my $name = ($doc->selectNodes("firstName"))[0]->nodeValue; + failed("The firstName has a wrong value", "Expected: Norman", "Got: $name") unless $name eq "Norman"; + +}; + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/DOM/Navigator.pm --- a/_test/Test/DOM/Navigator.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/DOM/Navigator.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,161 +1,161 @@ -package Test::DOM::Navigator; -use base qw(IMPL::Test::Unit); - -__PACKAGE__->PassThroughArgs; - -use IMPL::Test qw(test failed); -use IMPL::DOM::Navigator; -use IMPL::DOM::Navigator::SchemaNavigator; -use IMPL::DOM::Node; -use IMPL::DOM::Schema; -use IMPL::Class::Property; - -BEGIN { - public property doc => prop_all; -} - -sub CTOR { - my ($this) = @_; - - $this->doc( - IMPL::DOM::Node->new(nodeName => 'root')->appendRange( - IMPL::DOM::Node->new(nodeName=> 'age', nodeValue => 21), - IMPL::DOM::Node->new(nodeName=> 'address')->appendRange( - IMPL::DOM::Node->new(nodeName=>'city', nodeValue=>'moscow'), - IMPL::DOM::Node->new(nodeName=>'street', nodeValue=>'main'), - IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'123-456'), - ), - IMPL::DOM::Node->new(nodeName=> 'address')->appendRange( - IMPL::DOM::Node->new(nodeName=>'city', nodeValue=>'San Francisco'), - IMPL::DOM::Node->new(nodeName=>'street', nodeValue=>'Libertador'), - ), - IMPL::DOM::Node->new(nodeName=> 'contacts')->appendRange( - IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'123-123'), - IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'1-233-434-34-54'), - IMPL::DOM::Node->new(nodeName=>'email',nodeValue=>'some@mail.none') - ) - - ) - ); -} - -test Creation => sub { - my ($this) = @_; - - my $doc = new IMPL::DOM::Node(nodeName => 'root'); - - my $obj = new IMPL::DOM::Navigator($doc) or failed "Failed to create instance" ; -}; - -test Navigate => sub { - my $doc = new IMPL::DOM::Node(nodeName => 'root'); - my $child = $doc->insertNode( - new IMPL::DOM::Node( - nodeName => 'Child' - ) - ); - - my $navi = new IMPL::DOM::Navigator($doc); - my $navresult = $navi->Navigate("Child"); - - failed ("Navigate retuned unexpected result", "Recieved: $navresult", "Expected: $child") if $child != $navresult; - my $curr = $navi->Current; - failed ("Current node has a wrong value","Current: $curr","Expected: $child") if $child != $curr; -}; - -test PathToString => sub { - my $doc = new IMPL::DOM::Node(nodeName => 'root'); - my $child = $doc->insertNode( - new IMPL::DOM::Node( - nodeName => 'Child' - ) - ); - - my $navi = new IMPL::DOM::Navigator($doc); - $navi->Navigate("Child"); - - my $expected = "root/Child"; - my $res = $navi->PathToString; - failed("Unexpected PathToString result","Recieved: $res","Expected: $expected") if $res ne $expected; -}; - -test Back => sub { - my $doc = new IMPL::DOM::Node(nodeName => 'root'); - my $child = $doc->insertNode( - new IMPL::DOM::Node( - nodeName => 'Child' - ) - ); - - my $navi = new IMPL::DOM::Navigator($doc); - $navi->Navigate("Child"); - my $navresult = $navi->Back; - - failed ("Back() retuned unexpected result", "Recieved: $navresult", "Expected: $doc") if $doc != $navresult; - my $curr = $navi->Current; - failed ("Current node has a wrong value","Current: $curr","Expected: $doc") if $doc != $curr; -}; - -test selectNodes1 => sub { - my ($this) = @_; - - my $navi = new IMPL::DOM::Navigator($this->doc); - my @result = $navi->selectNodes('contacts','phone'); - failed "Expected to get two entries, but got:",map($_->nodeName,@result) unless @result == 2; -}; - -test selectNodes2 => sub { - my ($this) = @_; - - my $navi = new IMPL::DOM::Navigator($this->doc); - my @result = $navi->selectNodes(undef,'phone'); - failed "Expected to get three entries, but got:",map($_->nodeName,@result) unless @result == 3; -}; - -test FetchDoeachState => sub { - my ($this) = @_; - - my $navi = new IMPL::DOM::Navigator($this->doc); - - $navi->Navigate(undef,'phone'); - - $navi->saveState(); - - my @result; - doeach $navi sub { - push @result,$_; - }; - - failed "Expected to get three nodes, but got: ", map($_->nodeName,@result) unless @result == 3; - - $navi->restoreState(); - @result = (); - - push @result, $_ while fetch $navi; - - failed "Expected to get three nodes, but got: ", map($_->nodeName,@result) unless @result == 3; -}; - -test NavigateSchema => sub { - my $navi = new IMPL::DOM::Navigator::SchemaNavigator(IMPL::DOM::Schema->MetaSchema); - - my $root = $navi->NavigateName('schema') or failed "Failed to navigate to the root element"; - - $navi->saveState; - $navi->NavigateName('Node') or failed "Failed to navigate to a simple node"; - $navi->restoreState; - - failed "Can't navigate from simple node" if $navi->dosafe(sub { $navi->NavigateName('Property') || die } ); - - $navi->NavigateName('ComplexType') or failed "Failed to navigate to a complex node"; - $navi->NavigateName('NodeSet') or failed "Failed to navigate to NodeSet"; - $navi->SchemaBack(); - $navi->NavigateName('NodeList') or failed "Failed to navigate to NodeList"; - $navi->NavigateName('SimpleNode') or failed "Failed to navigate to SimpleNode"; - $navi->NavigateName('Enum') or failed "Failed to navigate to Enum"; - $navi->NavigateName('Item') or failed "Failed to navigate to Item"; - -}; - - -1; +package Test::DOM::Navigator; +use base qw(IMPL::Test::Unit); + +__PACKAGE__->PassThroughArgs; + +use IMPL::Test qw(test failed); +use IMPL::DOM::Navigator; +use IMPL::DOM::Navigator::SchemaNavigator; +use IMPL::DOM::Node; +use IMPL::DOM::Schema; +use IMPL::Class::Property; + +BEGIN { + public property doc => prop_all; +} + +sub CTOR { + my ($this) = @_; + + $this->doc( + IMPL::DOM::Node->new(nodeName => 'root')->appendRange( + IMPL::DOM::Node->new(nodeName=> 'age', nodeValue => 21), + IMPL::DOM::Node->new(nodeName=> 'address')->appendRange( + IMPL::DOM::Node->new(nodeName=>'city', nodeValue=>'moscow'), + IMPL::DOM::Node->new(nodeName=>'street', nodeValue=>'main'), + IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'123-456'), + ), + IMPL::DOM::Node->new(nodeName=> 'address')->appendRange( + IMPL::DOM::Node->new(nodeName=>'city', nodeValue=>'San Francisco'), + IMPL::DOM::Node->new(nodeName=>'street', nodeValue=>'Libertador'), + ), + IMPL::DOM::Node->new(nodeName=> 'contacts')->appendRange( + IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'123-123'), + IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'1-233-434-34-54'), + IMPL::DOM::Node->new(nodeName=>'email',nodeValue=>'some@mail.none') + ) + + ) + ); +} + +test Creation => sub { + my ($this) = @_; + + my $doc = new IMPL::DOM::Node(nodeName => 'root'); + + my $obj = new IMPL::DOM::Navigator($doc) or failed "Failed to create instance" ; +}; + +test Navigate => sub { + my $doc = new IMPL::DOM::Node(nodeName => 'root'); + my $child = $doc->insertNode( + new IMPL::DOM::Node( + nodeName => 'Child' + ) + ); + + my $navi = new IMPL::DOM::Navigator($doc); + my $navresult = $navi->Navigate("Child"); + + failed ("Navigate retuned unexpected result", "Recieved: $navresult", "Expected: $child") if $child != $navresult; + my $curr = $navi->Current; + failed ("Current node has a wrong value","Current: $curr","Expected: $child") if $child != $curr; +}; + +test PathToString => sub { + my $doc = new IMPL::DOM::Node(nodeName => 'root'); + my $child = $doc->insertNode( + new IMPL::DOM::Node( + nodeName => 'Child' + ) + ); + + my $navi = new IMPL::DOM::Navigator($doc); + $navi->Navigate("Child"); + + my $expected = "root/Child"; + my $res = $navi->PathToString; + failed("Unexpected PathToString result","Recieved: $res","Expected: $expected") if $res ne $expected; +}; + +test Back => sub { + my $doc = new IMPL::DOM::Node(nodeName => 'root'); + my $child = $doc->insertNode( + new IMPL::DOM::Node( + nodeName => 'Child' + ) + ); + + my $navi = new IMPL::DOM::Navigator($doc); + $navi->Navigate("Child"); + my $navresult = $navi->Back; + + failed ("Back() retuned unexpected result", "Recieved: $navresult", "Expected: $doc") if $doc != $navresult; + my $curr = $navi->Current; + failed ("Current node has a wrong value","Current: $curr","Expected: $doc") if $doc != $curr; +}; + +test selectNodes1 => sub { + my ($this) = @_; + + my $navi = new IMPL::DOM::Navigator($this->doc); + my @result = $navi->selectNodes('contacts','phone'); + failed "Expected to get two entries, but got:",map($_->nodeName,@result) unless @result == 2; +}; + +test selectNodes2 => sub { + my ($this) = @_; + + my $navi = new IMPL::DOM::Navigator($this->doc); + my @result = $navi->selectNodes(undef,'phone'); + failed "Expected to get three entries, but got:",map($_->nodeName,@result) unless @result == 3; +}; + +test FetchDoeachState => sub { + my ($this) = @_; + + my $navi = new IMPL::DOM::Navigator($this->doc); + + $navi->Navigate(undef,'phone'); + + $navi->saveState(); + + my @result; + doeach $navi sub { + push @result,$_; + }; + + failed "Expected to get three nodes, but got: ", map($_->nodeName,@result) unless @result == 3; + + $navi->restoreState(); + @result = (); + + push @result, $_ while fetch $navi; + + failed "Expected to get three nodes, but got: ", map($_->nodeName,@result) unless @result == 3; +}; + +test NavigateSchema => sub { + my $navi = new IMPL::DOM::Navigator::SchemaNavigator(IMPL::DOM::Schema->MetaSchema); + + my $root = $navi->NavigateName('schema') or failed "Failed to navigate to the root element"; + + $navi->saveState; + $navi->NavigateName('Node') or failed "Failed to navigate to a simple node"; + $navi->restoreState; + + failed "Can't navigate from simple node" if $navi->dosafe(sub { $navi->NavigateName('Property') || die } ); + + $navi->NavigateName('ComplexType') or failed "Failed to navigate to a complex node"; + $navi->NavigateName('NodeSet') or failed "Failed to navigate to NodeSet"; + $navi->SchemaBack(); + $navi->NavigateName('NodeList') or failed "Failed to navigate to NodeList"; + $navi->NavigateName('SimpleNode') or failed "Failed to navigate to SimpleNode"; + $navi->NavigateName('Enum') or failed "Failed to navigate to Enum"; + $navi->NavigateName('Item') or failed "Failed to navigate to Item"; + +}; + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/DOM/Node.pm --- a/_test/Test/DOM/Node.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/DOM/Node.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,124 +1,124 @@ -package Test::DOM::Node; -use strict; -use warnings; - -use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test shared failed cmparray); -use IMPL::Class::Property; - -require IMPL::DOM::Node; - -__PACKAGE__->PassThroughArgs; - -BEGIN { - shared public property Root => prop_all; -} - -test Create => sub { - my ($this) = @_; - - $this->Root(new IMPL::DOM::Document(nodeName => 'Root')) or failed "Failed to create a document"; -}; - -test InsertNode => sub { - my ($this) = @_; - my $child = $this->Root->insertNode(new IMPL::DOM::Node(nodeName => 'Child')) or failed "Failed to insert a child node"; - failed "fiestChild returned incorrect results" unless ($this->Root->firstChild || 0) == $child; -}; - -test AppendNode => sub { - my ($this) = @_; - - my $child = $this->Root->appendNode(new IMPL::DOM::Node(nodeName => 'Child')) or failed "Failed to append a child node"; - - my $lastChild = $this->Root->removeLast; - - failed "removeLast returned incorrect results" unless $lastChild == $child; -}; - -test GetDocumentNode => sub { - my ($this) = @_; - - my $child = $this->Root->firstChild->appendNode(new IMPL::DOM::Node(nodeName => 'GrandChild')) or failed "Failed to append a child node"; - - failed "document property is undef" unless $child->document; - failed "document property returned incorrect value" unless $child->document == $this->Root; -}; - -test MoveNode => sub { - my ($this) = @_; - - my $grandChild = $this->Root->firstChild->firstChild; - $this->Root->appendNode($grandChild); - - failed "incorrect new parentNode value" unless ($grandChild->parentNode || 0) == $this->Root; - failed "incorrect new document value" unless ($grandChild->document || 0) == $this->Root; -}; - -test AppendRange => sub { - my ($this) = @_; - - my $count = $this->Root->childNodes->Count; - - $this->Root->appendRange( - map IMPL::DOM::Node->new(nodeName => "Item", nodeValue => $_),1..10 - ); - - failed - "Wrong number of a child nodes", - "Expected: ".($count+10), - "Actual: ".$this->Root->childNodes->Count - unless $count + 10 == $this->Root->childNodes->Count; -}; - -test SelectNodes => sub { - my ($this) = @_; - - my @result = $this->Root->selectNodes("Item"); - - failed - "Wrong number of a selected nodes", - "Expected: 10", - "Actual: ".scalar(@result) - unless @result == 10; -}; - -test SelectNodesByQuery => sub { - my ($this) = @_; - - my @result = $this->Root->selectNodes(sub { $_->nodeName =~ /child/i } ); - failed - "Wrong number of a selected nodes", - "Expected: 2", - "Actual: ".scalar(@result) - unless @result == 2; -}; - -test CheckNodesValues => sub { - my ($this) = @_; - - my @expected = (1..10); - - my @result = map $_->nodeValue, grep $_->nodeValue, $this->Root->selectNodes("Item"); - - failed - "Some nodes returned wrong node values or in a wrong order", - "Expected: ".join(', ',@expected), - "Recieved: ".join(', ',@result) - unless cmparray(\@expected,\@result); - - failed - "a text property of a root node returned a wrong value", - "Expected: @expected", - "Recieved: ". $this->Root->text - unless $this->Root->text eq join '',@expected; -}; - -test isComplex => sub { - my ($this) = @_; - - failed "property isComplex returned false for the root node" unless $this->Root->isComplex; - failed "property isComplex returned true for a simple node", $this->Root->firstChild->nodeName if $this->Root->firstChild->isComplex; -}; - -1; +package Test::DOM::Node; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test shared failed cmparray); +use IMPL::Class::Property; + +require IMPL::DOM::Node; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + shared public property Root => prop_all; +} + +test Create => sub { + my ($this) = @_; + + $this->Root(new IMPL::DOM::Document(nodeName => 'Root')) or failed "Failed to create a document"; +}; + +test InsertNode => sub { + my ($this) = @_; + my $child = $this->Root->insertNode(new IMPL::DOM::Node(nodeName => 'Child')) or failed "Failed to insert a child node"; + failed "fiestChild returned incorrect results" unless ($this->Root->firstChild || 0) == $child; +}; + +test AppendNode => sub { + my ($this) = @_; + + my $child = $this->Root->appendNode(new IMPL::DOM::Node(nodeName => 'Child')) or failed "Failed to append a child node"; + + my $lastChild = $this->Root->removeLast; + + failed "removeLast returned incorrect results" unless $lastChild == $child; +}; + +test GetDocumentNode => sub { + my ($this) = @_; + + my $child = $this->Root->firstChild->appendNode(new IMPL::DOM::Node(nodeName => 'GrandChild')) or failed "Failed to append a child node"; + + failed "document property is undef" unless $child->document; + failed "document property returned incorrect value" unless $child->document == $this->Root; +}; + +test MoveNode => sub { + my ($this) = @_; + + my $grandChild = $this->Root->firstChild->firstChild; + $this->Root->appendNode($grandChild); + + failed "incorrect new parentNode value" unless ($grandChild->parentNode || 0) == $this->Root; + failed "incorrect new document value" unless ($grandChild->document || 0) == $this->Root; +}; + +test AppendRange => sub { + my ($this) = @_; + + my $count = $this->Root->childNodes->Count; + + $this->Root->appendRange( + map IMPL::DOM::Node->new(nodeName => "Item", nodeValue => $_),1..10 + ); + + failed + "Wrong number of a child nodes", + "Expected: ".($count+10), + "Actual: ".$this->Root->childNodes->Count + unless $count + 10 == $this->Root->childNodes->Count; +}; + +test SelectNodes => sub { + my ($this) = @_; + + my @result = $this->Root->selectNodes("Item"); + + failed + "Wrong number of a selected nodes", + "Expected: 10", + "Actual: ".scalar(@result) + unless @result == 10; +}; + +test SelectNodesByQuery => sub { + my ($this) = @_; + + my @result = $this->Root->selectNodes(sub { $_->nodeName =~ /child/i } ); + failed + "Wrong number of a selected nodes", + "Expected: 2", + "Actual: ".scalar(@result) + unless @result == 2; +}; + +test CheckNodesValues => sub { + my ($this) = @_; + + my @expected = (1..10); + + my @result = map $_->nodeValue, grep $_->nodeValue, $this->Root->selectNodes("Item"); + + failed + "Some nodes returned wrong node values or in a wrong order", + "Expected: ".join(', ',@expected), + "Recieved: ".join(', ',@result) + unless cmparray(\@expected,\@result); + + failed + "a text property of a root node returned a wrong value", + "Expected: @expected", + "Recieved: ". $this->Root->text + unless $this->Root->text eq join '',@expected; +}; + +test isComplex => sub { + my ($this) = @_; + + failed "property isComplex returned false for the root node" unless $this->Root->isComplex; + failed "property isComplex returned true for a simple node", $this->Root->firstChild->nodeName if $this->Root->firstChild->isComplex; +}; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/DOM/Schema.pm --- a/_test/Test/DOM/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/DOM/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,104 +1,104 @@ -package Test::DOM::Schema; -use strict; -use warnings; - -use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test failed shared); -use IMPL::Class::Property; - -__PACKAGE__->PassThroughArgs; - -require IMPL::DOM::Schema; - -BEGIN { - shared public property SampleSchema => prop_all; -} - -test GetMetaSchema => sub { - my $metaSchema = IMPL::DOM::Schema->MetaSchema(); -}; - -test AutoverifyMetaSchema => sub { - my $metaSchema = IMPL::DOM::Schema->MetaSchema(); - - if (my @errors = $metaSchema->Validate($metaSchema)) { - failed "Self verification failed", map $_ ? $_->Message : 'unknown', @errors; - } -}; - -test VerifyCorrectSchema => sub { - my ($this) = @_; - my $metaSchema = IMPL::DOM::Schema->MetaSchema(); - - my $schema = new IMPL::DOM::Schema; - $schema->appendRange( - IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - new IMPL::DOM::Schema::SimpleNode( name => 'firstName' ), - new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), - new IMPL::DOM::Schema::ComplexNode( name => 'address' )->appendRange( - IMPL::DOM::Schema::NodeSet->new()->appendRange( - new IMPL::DOM::Schema::SimpleNode( name => 'street' ), - new IMPL::DOM::Schema::SimpleNode( name => 'line', minOccur => 0 ) - ) - ) - ) - ) - ); - - $this->SampleSchema($schema); - - my @errors = $metaSchema->Validate($schema); - failed "Failed to validate a wellformed schema", map $_->Message, @errors if @errors; -}; - -test VerifyWrongSchema => sub { - my $metaSchema = IMPL::DOM::Schema->MetaSchema(); - - my $schema = new IMPL::DOM::Schema; - $schema->appendRange( - IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( - new IMPL::DOM::Schema::ComplexType( type => 'someType' ), - new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), - new IMPL::DOM::Schema::ComplexNode( name => 'address' )->appendRange( - new IMPL::DOM::Schema::SimpleNode( name => 'street' ), - new IMPL::DOM::Schema::SimpleNode( name => 'line' ) - ) - ) - ); - - my @errors = $metaSchema->Validate($schema); - failed "A not wellformed schema validated correctly" unless @errors; -}; - -test ValidateCorrectData => sub { - my ($this) = @_; - - my $data = IMPL::DOM::Node->new(nodeName => 'personInfo')->appendRange( - IMPL::DOM::Node->new(nodeName => 'firstName', nodeValue => 'John'), - IMPL::DOM::Node->new(nodeName => 'lastName', nodeValue => 'Smith'), - IMPL::DOM::Node->new(nodeName => 'address')->appendRange( - IMPL::DOM::Node->new(nodeName => 'street', nodeValue => 'main road') - ) - ); - - if (my @errors = $this->SampleSchema->Validate($data)) { - failed "Failed to validate a correct data", map $_->Message , @errors; - } -}; - -test ValidateWrongData => sub { - my ($this) = @_; - - my $data = IMPL::DOM::Node->new(nodeName => 'personInfo')->appendRange( - IMPL::DOM::Node->new(nodeName => 'firstName', nodeValue => 'John'), - IMPL::DOM::Node->new(nodeName => 'address')->appendRange( - IMPL::DOM::Node->new(nodeName => 'street', nodeValue => 'main road') - ) - ); - - failed "A wrong data validated corretly" unless $this->SampleSchema->Validate($data); -}; - - -1; +package Test::DOM::Schema; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test failed shared); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +require IMPL::DOM::Schema; + +BEGIN { + shared public property SampleSchema => prop_all; +} + +test GetMetaSchema => sub { + my $metaSchema = IMPL::DOM::Schema->MetaSchema(); +}; + +test AutoverifyMetaSchema => sub { + my $metaSchema = IMPL::DOM::Schema->MetaSchema(); + + if (my @errors = $metaSchema->Validate($metaSchema)) { + failed "Self verification failed", map $_ ? $_->Message : 'unknown', @errors; + } +}; + +test VerifyCorrectSchema => sub { + my ($this) = @_; + my $metaSchema = IMPL::DOM::Schema->MetaSchema(); + + my $schema = new IMPL::DOM::Schema; + $schema->appendRange( + IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'firstName' ), + new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), + new IMPL::DOM::Schema::ComplexNode( name => 'address' )->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'street' ), + new IMPL::DOM::Schema::SimpleNode( name => 'line', minOccur => 0 ) + ) + ) + ) + ) + ); + + $this->SampleSchema($schema); + + my @errors = $metaSchema->Validate($schema); + failed "Failed to validate a wellformed schema", map $_->Message, @errors if @errors; +}; + +test VerifyWrongSchema => sub { + my $metaSchema = IMPL::DOM::Schema->MetaSchema(); + + my $schema = new IMPL::DOM::Schema; + $schema->appendRange( + IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( + new IMPL::DOM::Schema::ComplexType( type => 'someType' ), + new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), + new IMPL::DOM::Schema::ComplexNode( name => 'address' )->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'street' ), + new IMPL::DOM::Schema::SimpleNode( name => 'line' ) + ) + ) + ); + + my @errors = $metaSchema->Validate($schema); + failed "A not wellformed schema validated correctly" unless @errors; +}; + +test ValidateCorrectData => sub { + my ($this) = @_; + + my $data = IMPL::DOM::Node->new(nodeName => 'personInfo')->appendRange( + IMPL::DOM::Node->new(nodeName => 'firstName', nodeValue => 'John'), + IMPL::DOM::Node->new(nodeName => 'lastName', nodeValue => 'Smith'), + IMPL::DOM::Node->new(nodeName => 'address')->appendRange( + IMPL::DOM::Node->new(nodeName => 'street', nodeValue => 'main road') + ) + ); + + if (my @errors = $this->SampleSchema->Validate($data)) { + failed "Failed to validate a correct data", map $_->Message , @errors; + } +}; + +test ValidateWrongData => sub { + my ($this) = @_; + + my $data = IMPL::DOM::Node->new(nodeName => 'personInfo')->appendRange( + IMPL::DOM::Node->new(nodeName => 'firstName', nodeValue => 'John'), + IMPL::DOM::Node->new(nodeName => 'address')->appendRange( + IMPL::DOM::Node->new(nodeName => 'street', nodeValue => 'main road') + ) + ); + + failed "A wrong data validated corretly" unless $this->SampleSchema->Validate($data); +}; + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/ORM/Schema.pm --- a/_test/Test/ORM/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/ORM/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,101 +1,101 @@ -package Test::ORM::Schema; -use strict; -use warnings; -use base qw(IMPL::Test::Unit); - -require IMPL::SQL::Schema::Traits::mysql; - -__PACKAGE__->PassThroughArgs; - -use IMPL::Test qw(test failed); - -require IMPL::ORM::Schema::TransformToSQL; - -test ExtractClassSchema => sub { - my ($this) = @_; - - my $schema = Test::ORM::Schema::Data::User->ormGetSchema('Test::ORM::Schema::Data'); - failed "Wrong number of the elements","expected: 4","got: ".$schema->childNodes->Count unless $schema->childNodes->Count == 4; - - return 1; -}; - -test StaticSchema => sub { - my ($this) = @_; - - my $schema = Test::ORM::Schema::Data->instance; - - return 1; -}; - -test GenerateSQL => sub { - my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Std->Transform(Test::ORM::Schema::Data->instance) - or failed("Failed to transform a schema"); - - my $sqlEmpty = new IMPL::SQL::Schema(Name => 'empty'); - - my $traits = IMPL::SQL::Schema::Traits::mysql->new( - SrcSchema => $sqlEmpty, - DstSchema => $sqlSchema - ); - - $traits->UpdateSchema(); - - print "$_\n" foreach $traits->Handler->Sql; - - $sqlEmpty->Dispose; - $sqlSchema->Dispose; -}; - - -package Test::ORM::Schema::Data::User; -use base qw(IMPL::ORM::Object); -use IMPL::Class::Property; - -BEGIN { - public property Name => prop_all, { type => 'String' }; # Field - public property Id => prop_all, { type => 'String' }; # Field - public property Roles => prop_all | prop_list, { type=> 'Test::ORM::Schema::Data::Role'}; # HasMany -} - -package Test::ORM::Schema::Data::Role; -use base qw(IMPL::ORM::Object); -use IMPL::Class::Property; - -BEGIN { - public property Name => prop_all, { type => 'String' }; # Field -} - -package Test::ORM::Schema::Data::Session; -use base qw(IMPL::ORM::Object); -use IMPL::Class::Property; -use IMPL::ORM::Helpers qw(Map); - -BEGIN { - public property Id => prop_get, { type => 'String' }; # Field - public property User => prop_get, { type => 'Test::ORM::Schema::Data::User' }; # HasOne - #public property Data => prop_all, { type => Map( 'String','String' ) }; # HasOne - public property AccessTime => prop_get, { type => 'DateTime' }; # Field -} - -package Test::ORM::Schema::Data; -use base qw(IMPL::ORM::Schema); - -__PACKAGE__->ValueTypes ( - String => 'IMPL::ORM::Value::String', - DateTime => 'IMPL::ORM::Value::DateTime', - Integer => 'IMPL::ORM::Value::Inetger', - Float => 'IMPL::ORM::Value::Float', - Decimal => 'IMPL::ORM::Value::Decimal' -); - -__PACKAGE__->usePrefix(__PACKAGE__); -__PACKAGE__->Classes qw( - User - Role - Session -); - -__PACKAGE__->CompleteSchema; - -1; +package Test::ORM::Schema; +use strict; +use warnings; +use base qw(IMPL::Test::Unit); + +require IMPL::SQL::Schema::Traits::mysql; + +__PACKAGE__->PassThroughArgs; + +use IMPL::Test qw(test failed); + +require IMPL::ORM::Schema::TransformToSQL; + +test ExtractClassSchema => sub { + my ($this) = @_; + + my $schema = Test::ORM::Schema::Data::User->ormGetSchema('Test::ORM::Schema::Data'); + failed "Wrong number of the elements","expected: 4","got: ".$schema->childNodes->Count unless $schema->childNodes->Count == 4; + + return 1; +}; + +test StaticSchema => sub { + my ($this) = @_; + + my $schema = Test::ORM::Schema::Data->instance; + + return 1; +}; + +test GenerateSQL => sub { + my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Std->Transform(Test::ORM::Schema::Data->instance) + or failed("Failed to transform a schema"); + + my $sqlEmpty = new IMPL::SQL::Schema(Name => 'empty'); + + my $traits = IMPL::SQL::Schema::Traits::mysql->new( + SrcSchema => $sqlEmpty, + DstSchema => $sqlSchema + ); + + $traits->UpdateSchema(); + + print "$_\n" foreach $traits->Handler->Sql; + + $sqlEmpty->Dispose; + $sqlSchema->Dispose; +}; + + +package Test::ORM::Schema::Data::User; +use base qw(IMPL::ORM::Object); +use IMPL::Class::Property; + +BEGIN { + public property Name => prop_all, { type => 'String' }; # Field + public property Id => prop_all, { type => 'String' }; # Field + public property Roles => prop_all | prop_list, { type=> 'Test::ORM::Schema::Data::Role'}; # HasMany +} + +package Test::ORM::Schema::Data::Role; +use base qw(IMPL::ORM::Object); +use IMPL::Class::Property; + +BEGIN { + public property Name => prop_all, { type => 'String' }; # Field +} + +package Test::ORM::Schema::Data::Session; +use base qw(IMPL::ORM::Object); +use IMPL::Class::Property; +use IMPL::ORM::Helpers qw(Map); + +BEGIN { + public property Id => prop_get, { type => 'String' }; # Field + public property User => prop_get, { type => 'Test::ORM::Schema::Data::User' }; # HasOne + #public property Data => prop_all, { type => Map( 'String','String' ) }; # HasOne + public property AccessTime => prop_get, { type => 'DateTime' }; # Field +} + +package Test::ORM::Schema::Data; +use base qw(IMPL::ORM::Schema); + +__PACKAGE__->ValueTypes ( + String => 'IMPL::ORM::Value::String', + DateTime => 'IMPL::ORM::Value::DateTime', + Integer => 'IMPL::ORM::Value::Inetger', + Float => 'IMPL::ORM::Value::Float', + Decimal => 'IMPL::ORM::Value::Decimal' +); + +__PACKAGE__->usePrefix(__PACKAGE__); +__PACKAGE__->Classes qw( + User + Role + Session +); + +__PACKAGE__->CompleteSchema; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/Object/Common.pm --- a/_test/Test/Object/Common.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/Object/Common.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,106 +1,106 @@ -package Test::Object::Common; -use strict; -use warnings; - -use base qw( IMPL::Test::Unit ); -use IMPL::Test qw(test failed cmparray); - -__PACKAGE__->PassThroughArgs; - -{ - package Foo; - use base qw(IMPL::Object); - - sub CTOR { - my ($this,$refarg) = @_; - $$refarg = 1; - } - - package Bar; - use base qw(Foo); - - __PACKAGE__->PassThroughArgs; - - sub CTOR { - my ($this,$ref,$array) = @_; - - push @$array,__PACKAGE__; - } - - package Baz; - use base qw(Bar); - - our %CTOR = ( - Bar => sub { - my $t; - (\$t,$_[0]); - } - ); - - sub CTOR { - my ($this,$array) = @_; - push @$array,__PACKAGE__; - } - - package Zoo; - use base qw(Bar); - - __PACKAGE__->PassThroughArgs; - - sub CTOR { - my ($this,$ref,$array) = @_; - - push @$array,__PACKAGE__; - }; - - package Complex; - use base qw(Baz Zoo); - - our %CTOR = ( - Baz => sub { @_ }, - Zoo => sub { - my $t; - (\$t,$_[0]); - } - ); - -} - -test Creation => sub { - my $flag = 0; - - my $obj = new Foo(\$flag); - - die new IMPL::Test::FailException("Object is undef") unless $obj; - die new IMPL::Test::FailException("Contructor doesn't run") unless $obj; -}; - -test SimpleInheritance => sub { - my $sequence = []; - my $flag = 0; - my $obj = new Bar(\$flag,$sequence); - - failed "Object is undef" unless $obj; - failed "Base class constructor isn't called" unless $flag; - failed "Class constructor isn't called" unless @$sequence; -}; - -test SimpleInheritance2 => sub { - my $sequence = []; - my $expected = [qw(Bar Baz)]; - my $obj = new Baz($sequence); - - failed "Object is undef" unless $obj; - failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected; -}; - -test MultipleInheritance => sub { - my $sequence = []; - my $expected = [qw(Bar Baz Bar Zoo)]; - my $obj = new Complex($sequence); - - failed "Object is undef" unless $obj; - failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected; -}; - -1; +package Test::Object::Common; +use strict; +use warnings; + +use base qw( IMPL::Test::Unit ); +use IMPL::Test qw(test failed cmparray); + +__PACKAGE__->PassThroughArgs; + +{ + package Foo; + use base qw(IMPL::Object); + + sub CTOR { + my ($this,$refarg) = @_; + $$refarg = 1; + } + + package Bar; + use base qw(Foo); + + __PACKAGE__->PassThroughArgs; + + sub CTOR { + my ($this,$ref,$array) = @_; + + push @$array,__PACKAGE__; + } + + package Baz; + use base qw(Bar); + + our %CTOR = ( + Bar => sub { + my $t; + (\$t,$_[0]); + } + ); + + sub CTOR { + my ($this,$array) = @_; + push @$array,__PACKAGE__; + } + + package Zoo; + use base qw(Bar); + + __PACKAGE__->PassThroughArgs; + + sub CTOR { + my ($this,$ref,$array) = @_; + + push @$array,__PACKAGE__; + }; + + package Complex; + use base qw(Baz Zoo); + + our %CTOR = ( + Baz => sub { @_ }, + Zoo => sub { + my $t; + (\$t,$_[0]); + } + ); + +} + +test Creation => sub { + my $flag = 0; + + my $obj = new Foo(\$flag); + + die new IMPL::Test::FailException("Object is undef") unless $obj; + die new IMPL::Test::FailException("Contructor doesn't run") unless $obj; +}; + +test SimpleInheritance => sub { + my $sequence = []; + my $flag = 0; + my $obj = new Bar(\$flag,$sequence); + + failed "Object is undef" unless $obj; + failed "Base class constructor isn't called" unless $flag; + failed "Class constructor isn't called" unless @$sequence; +}; + +test SimpleInheritance2 => sub { + my $sequence = []; + my $expected = [qw(Bar Baz)]; + my $obj = new Baz($sequence); + + failed "Object is undef" unless $obj; + failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected; +}; + +test MultipleInheritance => sub { + my $sequence = []; + my $expected = [qw(Bar Baz Bar Zoo)]; + my $obj = new Complex($sequence); + + failed "Object is undef" unless $obj; + failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected; +}; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/Object/List.pm --- a/_test/Test/Object/List.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/Object/List.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,32 +1,32 @@ -package Test::Object::List; -use strict; -use warnings; - -use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test cmparray failed); -use IMPL::Object::List; -__PACKAGE__->PassThroughArgs; - -test Creation => sub { - my $list = new IMPL::Object::List(); - - failed "Failed to create an empty list" unless $list; -}; - -test FilledByRef => sub { - my $data = [map rand 100, 1 .. 300]; - my $list = new IMPL::Object::List($data); - - failed("List filled incorrectlty") unless cmparray($data,$list); -}; - -test FilledByWrongRef => sub { - eval { - my $list = new IMPL::Object::List({}); - }; - unless ($@) { - failed("List can be initialized only by an ARRAY reference"); - } -}; - -1; +package Test::Object::List; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test cmparray failed); +use IMPL::Object::List; +__PACKAGE__->PassThroughArgs; + +test Creation => sub { + my $list = new IMPL::Object::List(); + + failed "Failed to create an empty list" unless $list; +}; + +test FilledByRef => sub { + my $data = [map rand 100, 1 .. 300]; + my $list = new IMPL::Object::List($data); + + failed("List filled incorrectlty") unless cmparray($data,$list); +}; + +test FilledByWrongRef => sub { + eval { + my $list = new IMPL::Object::List({}); + }; + unless ($@) { + failed("List can be initialized only by an ARRAY reference"); + } +}; + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/Resources/Format.pm --- a/_test/Test/Resources/Format.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/Resources/Format.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,39 +1,39 @@ -package Test::Resources::Format; -use strict; -use warnings; - -use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test failed); -use IMPL::Resources::Format qw(FormatMessage); - -__PACKAGE__->PassThroughArgs; - -{ - package Args; - use base qw(IMPL::Object); - - sub foo { - return { name => 'Args::foo', value => 'some value'} - } -} - -test FormatMessage => sub { - my $format = 'This is a %name% message. %args.foo.name% has %args.foo.value% and %some.unknown.param%'; - - my $args = { - name => 'Test', - args => new Args() - }; - - my $result = FormatMessage($format,$args); - my $expected = 'This is a Test message. Args::foo has some value and [some.unknown.param]'; - - failed - "Format message returned unexpected results", - "Expected: $expected", - "Recieved: $result" - unless $result eq $expected; -}; - - -1; +package Test::Resources::Format; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test failed); +use IMPL::Resources::Format qw(FormatMessage); + +__PACKAGE__->PassThroughArgs; + +{ + package Args; + use base qw(IMPL::Object); + + sub foo { + return { name => 'Args::foo', value => 'some value'} + } +} + +test FormatMessage => sub { + my $format = 'This is a %name% message. %args.foo.name% has %args.foo.value% and %some.unknown.param%'; + + my $args = { + name => 'Test', + args => new Args() + }; + + my $result = FormatMessage($format,$args); + my $expected = 'This is a Test message. Args::foo has some value and [some.unknown.param]'; + + failed + "Format message returned unexpected results", + "Expected: $expected", + "Recieved: $result" + unless $result eq $expected; +}; + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/SQL/Schema.pm --- a/_test/Test/SQL/Schema.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/SQL/Schema.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,110 +1,110 @@ -package Test::SQL::Schema; -use strict; -use warnings; - -use base qw(IMPL::Test::Unit); -__PACKAGE__->PassThroughArgs; - -use IMPL::Class::Property; -use IMPL::Class::Property::Direct; - -use IMPL::Test qw(test shared failed); - -BEGIN { - shared public property schemaDB => prop_all; -} - -require IMPL::SQL::Schema; -require IMPL::SQL::Schema::Constraint::Unique; - -use IMPL::SQL::Types qw(Integer Varchar); - -test CreateSchema => sub { - my ($this) = @_; - - my $schema = new IMPL::SQL::Schema(Name => 'dbTest', Version => 1) or failed "Failed to create schema"; - - failed "Failed to set a schema name" unless $schema->Name eq 'dbTest'; - failed "Failed to set a schema version" unless $schema->Version == 1; - - $this->schemaDB($schema); -}; - -test AddTable => sub { - my ($this) = @_; - - my $table = $this->schemaDB->AddTable({Name => 'User'}) or failed "Failed to add a table to the schema"; - $table->InsertColumn({ - Name => 'Id', - Type => Integer - }); - $table->InsertColumn({ - Name => 'Login', - Type => Varchar(255) - }); - $table->InsertColumn({ - Name => 'DisplayName', - CanBeNull => 1, - Type => Varchar(255) - }); - $table->InsertColumn({ - Name => 'RoleId', - CanBeNull => 1, - Type => Integer - }); - - $table->SetPrimaryKey('Id'); - - my $colCount = @{$table->Columns}; - - failed "Failed to add columns", "Expected: 4", "Got: ".$colCount unless $colCount == 4; - failed "Failed to set a primary key" unless $table->PrimaryKey; - - my $table2 = $this->schemaDB->AddTable({Name => 'Role'}); - $table2->InsertColumn({ - Name => 'Id', - Type => Integer - }); - $table2->InsertColumn({ - Name => 'Description', - Type => Varchar(255) - }); - $table2->InsertColumn({ - Name => 'ObsoleteId', - Type => Integer - }); - - $table2->SetPrimaryKey('Id'); - - $table->LinkTo($table2,'RoleId'); -}; - -test Constraints => sub { - my ($this) = @_; - - my $table = $this->schemaDB->Tables->{Role} or failed "Failed to get a table"; - - my $constraint = $table->AddConstraint( - new IMPL::SQL::Schema::Constraint::Unique( - Name => 'Role_ObsoleteId_Uniq', - Table => $table, - Columns => ['ObsoleteId'] - ) - ) or failed "Failed to add constraint"; - - failed "Failed to retrieve a constraint" unless ($table->GetColumnConstraints('ObsoleteId'))[0] == $constraint; - - $table->RemoveColumn('ObsoleteId',1); - - failed "A constraint remains alive after column deletion" unless $constraint->isDisposed; - -}; - -test Dispose => sub { - my ($this) = @_; - - $this->schemaDB->Dispose(); -}; - - -1; +package Test::SQL::Schema; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +__PACKAGE__->PassThroughArgs; + +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +use IMPL::Test qw(test shared failed); + +BEGIN { + shared public property schemaDB => prop_all; +} + +require IMPL::SQL::Schema; +require IMPL::SQL::Schema::Constraint::Unique; + +use IMPL::SQL::Types qw(Integer Varchar); + +test CreateSchema => sub { + my ($this) = @_; + + my $schema = new IMPL::SQL::Schema(Name => 'dbTest', Version => 1) or failed "Failed to create schema"; + + failed "Failed to set a schema name" unless $schema->Name eq 'dbTest'; + failed "Failed to set a schema version" unless $schema->Version == 1; + + $this->schemaDB($schema); +}; + +test AddTable => sub { + my ($this) = @_; + + my $table = $this->schemaDB->AddTable({Name => 'User'}) or failed "Failed to add a table to the schema"; + $table->InsertColumn({ + Name => 'Id', + Type => Integer + }); + $table->InsertColumn({ + Name => 'Login', + Type => Varchar(255) + }); + $table->InsertColumn({ + Name => 'DisplayName', + CanBeNull => 1, + Type => Varchar(255) + }); + $table->InsertColumn({ + Name => 'RoleId', + CanBeNull => 1, + Type => Integer + }); + + $table->SetPrimaryKey('Id'); + + my $colCount = @{$table->Columns}; + + failed "Failed to add columns", "Expected: 4", "Got: ".$colCount unless $colCount == 4; + failed "Failed to set a primary key" unless $table->PrimaryKey; + + my $table2 = $this->schemaDB->AddTable({Name => 'Role'}); + $table2->InsertColumn({ + Name => 'Id', + Type => Integer + }); + $table2->InsertColumn({ + Name => 'Description', + Type => Varchar(255) + }); + $table2->InsertColumn({ + Name => 'ObsoleteId', + Type => Integer + }); + + $table2->SetPrimaryKey('Id'); + + $table->LinkTo($table2,'RoleId'); +}; + +test Constraints => sub { + my ($this) = @_; + + my $table = $this->schemaDB->Tables->{Role} or failed "Failed to get a table"; + + my $constraint = $table->AddConstraint( + new IMPL::SQL::Schema::Constraint::Unique( + Name => 'Role_ObsoleteId_Uniq', + Table => $table, + Columns => ['ObsoleteId'] + ) + ) or failed "Failed to add constraint"; + + failed "Failed to retrieve a constraint" unless ($table->GetColumnConstraints('ObsoleteId'))[0] == $constraint; + + $table->RemoveColumn('ObsoleteId',1); + + failed "A constraint remains alive after column deletion" unless $constraint->isDisposed; + +}; + +test Dispose => sub { + my ($this) = @_; + + $this->schemaDB->Dispose(); +}; + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Test/Web/TDocument.pm --- a/_test/Test/Web/TDocument.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Test/Web/TDocument.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,34 +1,34 @@ -package Test::Web::TDocument; -use strict; -use warnings; -use encoding 'cp1251'; - -use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test failed); -use IMPL::Web::TDocument; -__PACKAGE__->PassThroughArgs; - -test Creation => sub { - my $document = new IMPL::Web::TDocument(); - - failed "Failed to create document" unless $document; -}; - -test SimpleTemplate => sub { - my $document = new IMPL::Web::TDocument(); - - failed "Failed to create document" unless $document; - - $document->loadFile('Resources/simple.tt','cp1251'); - - my $out = $document->Render; - - open my $hFile,'<:encoding(cp1251)',"Resources/simple.txt" or die "Failed to open etalon file: $!"; - local $/; - my $eta = <$hFile>; - - failed "Rendered data doesn't match the etalon data","Expected:\n$eta","Actual:\n$out" if $out ne $eta; -}; - - -1; +package Test::Web::TDocument; +use strict; +use warnings; +use encoding 'cp1251'; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test failed); +use IMPL::Web::TDocument; +__PACKAGE__->PassThroughArgs; + +test Creation => sub { + my $document = new IMPL::Web::TDocument(); + + failed "Failed to create document" unless $document; +}; + +test SimpleTemplate => sub { + my $document = new IMPL::Web::TDocument(); + + failed "Failed to create document" unless $document; + + $document->loadFile('Resources/simple.tt','cp1251'); + + my $out = $document->Render; + + open my $hFile,'<:encoding(cp1251)',"Resources/simple.txt" or die "Failed to open etalon file: $!"; + local $/; + my $eta = <$hFile>; + + failed "Rendered data doesn't match the etalon data","Expected:\n$eta","Actual:\n$out" if $out ne $eta; +}; + + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/Web.t --- a/_test/Web.t Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/Web.t Fri Feb 26 10:49:21 2010 +0300 @@ -1,15 +1,15 @@ -#!/usr/bin/perl -w -use strict; -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; - -my $plan = new IMPL::Test::Plan qw( - Test::Web::TDocument -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::Web::TDocument +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); diff -r 1c3c3e63a314 -r 16ada169ca75 _test/any.pl --- a/_test/any.pl Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/any.pl Fri Feb 26 10:49:21 2010 +0300 @@ -1,65 +1,65 @@ -#!/usr/bin/perl -w -use strict; -use lib '..\Lib'; - -require IMPL::DOM::Navigator::SimpleBuilder; -require IMPL::DOM::XMLReader; - -my $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); - - use Time::HiRes qw(gettimeofday tv_interval); - - my $t = [gettimeofday]; - - $builder->NavigateCreate('personInfo', version => '1'); - $builder->NavigateCreate('firstName')->nodeValue('Nemo'); - $builder->Back(); - $builder->NavigateCreate('lastName')->nodeValue('Nobel'); - $builder->Back(); - $builder->NavigateCreate('lastName')->nodeValue('Gardum'); - $builder->Back(); - for(my $i = 0 ; $i < 10000; $i++) { - $builder->NavigateCreate('address', local => 1); - $builder->NavigateCreate('street')->nodeValue('Hellroad'); - $builder->Back(); - $builder->NavigateCreate('line')->nodeValue($_); - $builder->Back(); - $builder->Back(); - } - $builder->Back(); - - print "Build: ",tv_interval($t,[gettimeofday]),"\n"; - - $t = [gettimeofday]; - - my $doc = new IMPL::DOM::Document(nodeName => 'doc'); - for(my $i = 0 ; $i < 30000; $i++) { - my $node = new IMPL::DOM::Node(nodeName => 'test'); - $node->nodeValue(100); - $doc->appendChild($node); - } - - print "Create 30000 nodes: ",tv_interval($t,[gettimeofday]),"\n"; - - $t = [gettimeofday]; - $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); - my $reader = IMPL::DOM::XMLReader->new( Navigator => $builder ); - - $reader->ParseFile("Resources/large.xml"); - print "Parsing large Xml file: ",tv_interval($t,[gettimeofday]),"\n"; - - my $count = selectAll($builder->Document); - my $len = length $builder->Document->text; - print "Total nodes loaded: $count, data length: $len\n"; - - $t = [gettimeofday]; - $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); - my $reader2 = IMPL::DOM::XMLReader->new( Navigator => $builder ); - - $reader2->ParseFile("Resources/person_info.xml"); - print "Parsing small Xml file: ",tv_interval($t,[gettimeofday]),"\n"; - -sub selectAll { - my $node = shift; - $node,map selectAll($_),@{$node->childNodes}; -} \ No newline at end of file +#!/usr/bin/perl -w +use strict; +use lib '..\Lib'; + +require IMPL::DOM::Navigator::SimpleBuilder; +require IMPL::DOM::XMLReader; + +my $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); + + use Time::HiRes qw(gettimeofday tv_interval); + + my $t = [gettimeofday]; + + $builder->NavigateCreate('personInfo', version => '1'); + $builder->NavigateCreate('firstName')->nodeValue('Nemo'); + $builder->Back(); + $builder->NavigateCreate('lastName')->nodeValue('Nobel'); + $builder->Back(); + $builder->NavigateCreate('lastName')->nodeValue('Gardum'); + $builder->Back(); + for(my $i = 0 ; $i < 10000; $i++) { + $builder->NavigateCreate('address', local => 1); + $builder->NavigateCreate('street')->nodeValue('Hellroad'); + $builder->Back(); + $builder->NavigateCreate('line')->nodeValue($_); + $builder->Back(); + $builder->Back(); + } + $builder->Back(); + + print "Build: ",tv_interval($t,[gettimeofday]),"\n"; + + $t = [gettimeofday]; + + my $doc = new IMPL::DOM::Document(nodeName => 'doc'); + for(my $i = 0 ; $i < 30000; $i++) { + my $node = new IMPL::DOM::Node(nodeName => 'test'); + $node->nodeValue(100); + $doc->appendChild($node); + } + + print "Create 30000 nodes: ",tv_interval($t,[gettimeofday]),"\n"; + + $t = [gettimeofday]; + $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); + my $reader = IMPL::DOM::XMLReader->new( Navigator => $builder ); + + $reader->ParseFile("Resources/large.xml"); + print "Parsing large Xml file: ",tv_interval($t,[gettimeofday]),"\n"; + + my $count = selectAll($builder->Document); + my $len = length $builder->Document->text; + print "Total nodes loaded: $count, data length: $len\n"; + + $t = [gettimeofday]; + $builder = IMPL::DOM::Navigator::SimpleBuilder->new(); + my $reader2 = IMPL::DOM::XMLReader->new( Navigator => $builder ); + + $reader2->ParseFile("Resources/person_info.xml"); + print "Parsing small Xml file: ",tv_interval($t,[gettimeofday]),"\n"; + +sub selectAll { + my $node = shift; + $node,map selectAll($_),@{$node->childNodes}; +} diff -r 1c3c3e63a314 -r 16ada169ca75 _test/object.t --- a/_test/object.t Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/object.t Fri Feb 26 10:49:21 2010 +0300 @@ -1,16 +1,16 @@ -#!/usr/bin/perl -w -use strict; -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; - -my $plan = new IMPL::Test::Plan qw( - Test::Object::Common - Test::Object::List -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::Object::Common + Test::Object::List +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); diff -r 1c3c3e63a314 -r 16ada169ca75 _test/run_tests.pl --- a/_test/run_tests.pl Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/run_tests.pl Fri Feb 26 10:49:21 2010 +0300 @@ -1,24 +1,24 @@ -#!/usr/bin/perl -use strict; -use warnings; - -use lib '../Lib'; -use lib '.'; - -use IMPL::Test::HarnessRunner; -use IMPL::Test::Straps; - -my $runner = new IMPL::Test::HarnessRunner( - Strap => new IMPL::Test::Straps () -); - -$runner->Strap->Executors( - { - Re => '.*', - Executor => $runner->Strap - } -); - -$runner->RunTests(<*.t>); - -1; +#!/usr/bin/perl +use strict; +use warnings; + +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::HarnessRunner; +use IMPL::Test::Straps; + +my $runner = new IMPL::Test::HarnessRunner( + Strap => new IMPL::Test::Straps () +); + +$runner->Strap->Executors( + { + Re => '.*', + Executor => $runner->Strap + } +); + +$runner->RunTests(<*.t>); + +1; diff -r 1c3c3e63a314 -r 16ada169ca75 _test/wmi.pl --- a/_test/wmi.pl Fri Feb 26 01:43:42 2010 +0300 +++ b/_test/wmi.pl Fri Feb 26 10:49:21 2010 +0300 @@ -1,12 +1,12 @@ -#!/usr/bin/perl -w -use strict; - -use Win32::OLE; - -my $wmi = Win32::OLE->GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\.\\root\\cimv2"); - -my $colServices = $wmi->ExecQuery("select * from Win32_NetworkAdapterSetting"); - -print $_->Element,"\t",$_->Setting,"\n" foreach in $colServices; - - +#!/usr/bin/perl -w +use strict; + +use Win32::OLE; + +my $wmi = Win32::OLE->GetObject("winmgmts:{impersonationLevel=impersonate}!\\\\.\\root\\cimv2"); + +my $colServices = $wmi->ExecQuery("select * from Win32_NetworkAdapterSetting"); + +print $_->Element,"\t",$_->Setting,"\n" foreach in $colServices; + +