# HG changeset patch # User Sergey # Date 1262868109 -10800 # Node ID 009aa9ca2e485909cb4e363be142bd1ffc65839a # Parent 4ff27cd051e34675221812f486bf92296d029882# Parent c442eb67fa22115f0e89c5f41a8bb20d4659f26d merge diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/DOM/Node.pm --- a/Lib/IMPL/DOM/Node.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/DOM/Node.pm Thu Jan 07 15:41:49 2010 +0300 @@ -208,7 +208,7 @@ # this method is called by the parent node on his children, so we need no to check parent $this->{$document} = $this->{$parentNode}->document; - # prevetn ciclyc + # prevent cyclic weaken($this->{$document}) if $this->{$document}; $_->_updateDocRefs foreach @{$this->{$childNodes}}; diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/DOM/Property.pm --- a/Lib/IMPL/DOM/Property.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/DOM/Property.pm Thu Jan 07 15:41:49 2010 +0300 @@ -25,21 +25,21 @@ die new IMPL::InvalidOperationException("Custom mutators are not allowed","${class}::$name") if ref $mutators; if (($mutators & prop_all) == prop_all) { *{"${class}::$name"} = sub { - $_[0]->Property($name,@_[1..$#_]); + $_[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]->Property($name); + $_[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]->Property($name,@_[1..$#_]); + $_[0]->nodeProperty($name,@_[1..$#_]); }; $propInfo->canGet(0); $propInfo->canSet(1); diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/DOM/Transform.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Transform.pm Thu Jan 07 15:41:49 2010 +0300 @@ -0,0 +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 diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/ORM/Object.pm --- a/Lib/IMPL/ORM/Object.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/ORM/Object.pm Thu Jan 07 15:41:49 2010 +0300 @@ -72,7 +72,7 @@ $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); } elsif (my $type = $dataSchema->isValueType($ormProp->Type,'IMPL::ORM::Object')) { # поле - $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$type) ); + $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$type->name) ); } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { # отношение ссылка $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/ORM/Schema.pm diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/ORM/Schema/Field.pm --- a/Lib/IMPL/ORM/Schema/Field.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/ORM/Schema/Field.pm Thu Jan 07 15:41:49 2010 +0300 @@ -8,6 +8,7 @@ BEGIN { public property fieldName => prop_get | owner_set; public property fieldType => prop_get | owner_set; + public property fieldNullbale => prop_get | owner_set; } our %CTOR = ( @@ -15,10 +16,11 @@ ); sub CTOR { - my ($this,$name,$type) = @_; + 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 { diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/ORM/Schema/TransformToSQL.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/ORM/Schema/TransformToSQL.pm Thu Jan 07 15:41:49 2010 +0300 @@ -0,0 +1,159 @@ +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 + } +); + +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->ReferenceTypes) { + $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 = map + $table->InsertColumn({ + Name => $prefix . $_->Name, + Type => $_->Type, + CanBeNull => 1 + }), + @{$tableForeign->PrimaryKey->Columns}; + + $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 = $table->Name . '_' . $relation->name; + + my @fkColumns = map + $tableForeign->InsertColumn({ + Name => $prefix . $_->Name, + Type => $_->Type, + CanBeNull => 1 + }), + @{$table->PrimaryKey->Columns}; + + $tableForeign->LinkTo($table,@fkColumns); +} + +sub SubclassTransform { + # actually this rlations has only ligical 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 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/ORM/Schema/ValueType.pm diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/SQL/Types.pm --- a/Lib/IMPL/SQL/Types.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/SQL/Types.pm Thu Jan 07 15:41:49 2010 +0300 @@ -4,7 +4,7 @@ require Exporter; our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary); +our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime); require IMPL::SQL::Schema::Type; @@ -32,4 +32,8 @@ return IMPL::SQL::Schema::Type->new(Name => 'BINARY'); } +sub DateTime() { + return IMPL::SQL::Schema::Type->new(Name => 'DATETIME'); +} + 1; diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/Text/Parser/Chunk.pm --- a/Lib/IMPL/Text/Parser/Chunk.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/Text/Parser/Chunk.pm Thu Jan 07 15:41:49 2010 +0300 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Object); +use base qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; use IMPL::Class::Property::Direct; @@ -12,8 +12,8 @@ OP_STRING => 2, OP_REFERENCE => 3, OP_CHUNK => 4, - OP_THROW => 5, - OP_TRYCATCH => 6 + OP_SWITCH => 5, + OP_REPEAT => 7 }; BEGIN { @@ -59,42 +59,35 @@ push @{$this->{$opStream}}, [OP_CHUNK, $chunk]; } -sub Throw { - my ($this, $msg) = @_; +sub Switch { + my $this = shift; - push @{$this->{$opStream}}, [OP_THROW, $msg]; -} - -sub TryCatch { - my ($this,$chunkTry,$chunkCatch) = @_; - - push @{$this->{$opStream}}, [OP_TRYCATCH, $chunkTry, $chunkCatch]; + push @{$this->{$opStream}}, [OP_SWITCH, @_]; } -sub compile { - my ($this) = @_; - - my $text = ''; +sub Repeat { + my ($this,$chunk,$min,$max) = @_; - if ($this->{$opStream}) { - foreach my $op (@{$this->{$opStream}}) { - my $code = shift @$op; - - if ($code == OP_REGEXP) { - - } elsif ($code == OP_STRING) { - - } elsif ($code == OP_REFERENCE) { - - } elsif ($code == OP_CHUNK) { - - } elsif ($code == OP_THROW) { - - } elsif ($code == OP_TRYCATCH) { - - } - } - } + 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 diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/Text/Parser/Player.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Text/Parser/Player.pm Thu Jan 07 15:41:49 2010 +0300 @@ -0,0 +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; diff -r 4ff27cd051e3 -r 009aa9ca2e48 Lib/IMPL/Transform.pm --- a/Lib/IMPL/Transform.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/Lib/IMPL/Transform.pm Thu Jan 07 15:41:49 2010 +0300 @@ -20,29 +20,35 @@ } sub Transform { - my ($this,$object) = @_; + 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); + 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); + return $this->$template($object,@args); } } sub MatchTemplate { my ($this,$object) = @_; - my $class = ref $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); @@ -76,7 +82,8 @@ my $result = $t->Transform($obj); -=head1 Summary -Преобразует данные содержащиеся в форме в реальные объекты используя специальное преобразование. +=head1 DESCRIPTION + +Преобразование одного объекта к другому, например даных к их представлению. =cut \ No newline at end of file diff -r 4ff27cd051e3 -r 009aa9ca2e48 _test/Test/ORM/Schema.pm --- a/_test/Test/ORM/Schema.pm Thu Jan 07 15:34:42 2010 +0300 +++ b/_test/Test/ORM/Schema.pm Thu Jan 07 15:41:49 2010 +0300 @@ -7,6 +7,8 @@ use IMPL::Test qw(test failed); +require IMPL::ORM::Schema::TransformToSQL; + test ExtractClassSchema => sub { my ($this) = @_; @@ -24,6 +26,12 @@ return 1; }; +test TransformDataSchema => sub { + my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Std->Transform(Test::ORM::Schema::Data->instance) + or failed("Failed to transform a schema"); + $sqlSchema->Dispose; +}; + package Test::ORM::Schema::Data::User; use base qw(IMPL::ORM::Object); @@ -59,11 +67,11 @@ 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' + 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__);