annotate Lib/IMPL/ORM/Schema/TransformToSQL.pm @ 39:4f5a6a1bfb0e

Text parser
author Sergey
date Tue, 08 Dec 2009 17:28:06 +0300
parents d660fb38b7cc
children 32d2350fccf9
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
38
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
1 package IMPL::ORM::Schema::TransformToSQL;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
2 use strict;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
3 use warnings;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
4
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
5 use base qw(IMPL::DOM::Transform);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
6 use IMPL::Class::Property;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
7 use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
8
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
9 require IMPL::SQL::Schema;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
10
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
11 BEGIN {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
12 public property Types => prop_get | owner_set;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
13 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
14
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
15 our %CTOR = (
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
16 'IMPL::DOM::Transform' => sub {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
17 ORMSchema => \&ORMSchemaTransform,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
18 Entity => \&EntityTransform,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
19 Field => \&FieldTransform,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
20 HasOne => \&HasOneTransform,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
21 HasMany => \&HasManyTransform,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
22 Subclass => \&SubclassTransform
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
23 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
24 );
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
25
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
26 sub CTOR {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
27 my ($this,$refTypeMap) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
28
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
29 $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required");
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
30 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
31
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
32 sub ORMSchemaTransform {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
33 my ($this,$node) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
34
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
35 my $schema = IMPL::SQL::Schema->new(Name => ref $node);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
36
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
37 my @constraints;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
38
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
39 my %ctx = (Schema => $schema);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
40
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
41 # all tables
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
42 foreach my $entity ($node->ReferenceTypes) {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
43 $schema->AddTable($this->Transform($entity,\%ctx));
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
44 push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')});
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
45 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
46
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
47 # establish relations
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
48 $this->Transform($_,\%ctx) foreach @constraints;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
49
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
50 return $schema;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
51 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
52
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
53 sub EntityTransform {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
54 my ($this,$node,$ctx) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
55
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
56 my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema});
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
57
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
58 $this->MakePrimaryKey($table);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
59
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
60 $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field');
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
61
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
62 return $table;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
63 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
64
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
65 sub FieldTransform {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
66 my ($this,$field,$ctx) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
67
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
68 return {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
69 Name => $field->fieldName,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
70 Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
71 CanBeNull => $field->fieldNullable
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
72 };
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
73 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
74
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
75 sub HasOneTransform {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
76 my ($this,$relation,$ctx) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
77
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
78 my $sqlSchema = $ctx->{Schema};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
79 my $table = $sqlSchema->Tables->{$relation->parentNode->entityName};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
80 my $tableForeign = $sqlSchema->Tables->{$relation->target};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
81 my $prefix = $relation->name;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
82
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
83 my @fkColumns = map
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
84 $table->InsertColumn({
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
85 Name => $prefix . $_->Name,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
86 Type => $_->Type,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
87 CanBeNull => 1
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
88 }),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
89 @{$tableForeign->PrimaryKey->Columns};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
90
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
91 $table->LinkTo($tableForeign,@fkColumns);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
92 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
93
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
94 sub HasManyTransform {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
95 my ($this,$relation,$ctx) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
96
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
97 #similar to HasOne
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
98
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
99 my $sqlSchema = $ctx->{Schema};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
100 my $table = $sqlSchema->Tables->{$relation->parentNode->entityName};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
101 my $tableForeign = $sqlSchema->Tables->{$relation->target};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
102 my $prefix = $table->Name . '_' . $relation->name;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
103
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
104 my @fkColumns = map
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
105 $tableForeign->InsertColumn({
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
106 Name => $prefix . $_->Name,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
107 Type => $_->Type,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
108 CanBeNull => 1
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
109 }),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
110 @{$table->PrimaryKey->Columns};
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
111
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
112 $tableForeign->LinkTo($table,@fkColumns);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
113 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
114
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
115 sub SubclassTransform {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
116 # actually this rlations has only ligical implementation
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
117 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
118
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
119 sub MapType {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
120 my ($this,$typeName) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
121
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
122 $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
123 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
124
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
125 sub MakePrimaryKey {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
126 my ($this,$table) = @_;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
127
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
128 $table->InsertColumn( {Name => '_Id', Type => Integer } );
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
129 $table->SetPrimaryKey('_Id');
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
130 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
131
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
132 {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
133 my $std;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
134 sub Std {
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
135 $std ||= __PACKAGE__->new({
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
136 String => Varchar(255),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
137 DateTime => DateTime,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
138 Integer => Integer,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
139 Float => Float(24),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
140 Decimal => Float(53),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
141 Real => Float(24),
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
142 Binary => Binary,
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
143 Text => Text
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
144 });
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
145 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
146 }
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
147
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
148 1;
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
149
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
150 __END__
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
151
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
152 =pod
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
153
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
154 =head1 SYNOPSIS
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
155
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
156 my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance);
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
157
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
158 =cut
d660fb38b7cc small fixes
Sergey
parents:
diff changeset
159