annotate Lib/IMPL/SQL/Schema/Traits/mysql.pm @ 44:32d2350fccf9

ORM *Minor fixes *Working tarnsform to sql *Fixes to the sql traits
author Sergey
date Mon, 11 Jan 2010 01:42:00 +0300
parents 56cef8e3cda6
children 16ada169ca75
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
32
Sergey
parents:
diff changeset
1 package IMPL::SQL::Schema::Traits::mysql::Handler;
Sergey
parents:
diff changeset
2 use strict;
Sergey
parents:
diff changeset
3 use base qw(IMPL::Object);
Sergey
parents:
diff changeset
4 use IMPL::Class::Property;
Sergey
parents:
diff changeset
5 use IMPL::Class::Property::Direct;
Sergey
parents:
diff changeset
6
Sergey
parents:
diff changeset
7 BEGIN {
44
Sergey
parents: 32
diff changeset
8 public _direct property SqlBatch => prop_all;
32
Sergey
parents:
diff changeset
9 }
Sergey
parents:
diff changeset
10
Sergey
parents:
diff changeset
11 sub formatTypeNameInteger {
Sergey
parents:
diff changeset
12 my ($type) = @_;
Sergey
parents:
diff changeset
13
Sergey
parents:
diff changeset
14 return $type->Name.($type->MaxLength ? '('.$type->MaxLength.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : '');
Sergey
parents:
diff changeset
15 }
Sergey
parents:
diff changeset
16
Sergey
parents:
diff changeset
17 sub formatTypeNameReal {
Sergey
parents:
diff changeset
18 my ($type) = @_;
Sergey
parents:
diff changeset
19
Sergey
parents:
diff changeset
20 return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : '');
Sergey
parents:
diff changeset
21 }
Sergey
parents:
diff changeset
22
Sergey
parents:
diff changeset
23 sub formatTypeNameNumeric {
Sergey
parents:
diff changeset
24 my ($type) = @_;
Sergey
parents:
diff changeset
25 $type->MaxLength or die new IMPL::InvalidArgumentException('The length and precission must be specified',$type->Name);
Sergey
parents:
diff changeset
26 return $type->Name.($type->MaxLength ? '('.$type->MaxLength.', '.$type->Scale.')' : '').($type->Unsigned ? ' UNSIGNED': '').($type->Zerofill ? ' ZEROFILL' : '');
Sergey
parents:
diff changeset
27 }
Sergey
parents:
diff changeset
28
Sergey
parents:
diff changeset
29 sub formatTypeName {
Sergey
parents:
diff changeset
30 my ($type) = @_;
Sergey
parents:
diff changeset
31 return $type->Name;
Sergey
parents:
diff changeset
32 }
Sergey
parents:
diff changeset
33
Sergey
parents:
diff changeset
34 sub formatTypeNameChar {
Sergey
parents:
diff changeset
35 my ($type) = @_;
Sergey
parents:
diff changeset
36
Sergey
parents:
diff changeset
37 return (
Sergey
parents:
diff changeset
38 $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::CHAR') ? $type->Encoding : '')
Sergey
parents:
diff changeset
39 );
Sergey
parents:
diff changeset
40 }
Sergey
parents:
diff changeset
41
Sergey
parents:
diff changeset
42 sub formatTypeNameVarChar {
Sergey
parents:
diff changeset
43 my ($type) = @_;
Sergey
parents:
diff changeset
44
Sergey
parents:
diff changeset
45 return (
Sergey
parents:
diff changeset
46 $type->Name.'('.$type->MaxLength.')'. (UNIVERSAL::isa($type,'IMPL::SQL::Schema::Type::mysql::VARCHAR') ? $type->Encoding : '')
Sergey
parents:
diff changeset
47 );
Sergey
parents:
diff changeset
48 }
Sergey
parents:
diff changeset
49
Sergey
parents:
diff changeset
50 sub formatTypeNameEnum {
Sergey
parents:
diff changeset
51 my ($type) = @_;
Sergey
parents:
diff changeset
52 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'));
Sergey
parents:
diff changeset
53 return (
Sergey
parents:
diff changeset
54 $type->Name.'('.join(',',map {quote($_)} $type->Values).')'
Sergey
parents:
diff changeset
55 );
Sergey
parents:
diff changeset
56 }
Sergey
parents:
diff changeset
57
Sergey
parents:
diff changeset
58 sub quote{
Sergey
parents:
diff changeset
59 if (wantarray) {
Sergey
parents:
diff changeset
60 return map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_;
Sergey
parents:
diff changeset
61 } else {
Sergey
parents:
diff changeset
62 return join '',map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_;
Sergey
parents:
diff changeset
63 }
Sergey
parents:
diff changeset
64 }
Sergey
parents:
diff changeset
65
Sergey
parents:
diff changeset
66 sub quote_names {
Sergey
parents:
diff changeset
67 if (wantarray) {
Sergey
parents:
diff changeset
68 return map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_;
Sergey
parents:
diff changeset
69 } else {
Sergey
parents:
diff changeset
70 return join '',map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_;
Sergey
parents:
diff changeset
71 }
Sergey
parents:
diff changeset
72 }
Sergey
parents:
diff changeset
73
Sergey
parents:
diff changeset
74 sub formatStringValue {
Sergey
parents:
diff changeset
75 my ($value) = @_;
Sergey
parents:
diff changeset
76
Sergey
parents:
diff changeset
77 if (ref $value) {
Sergey
parents:
diff changeset
78 if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) {
Sergey
parents:
diff changeset
79 return $value->as_string;
Sergey
parents:
diff changeset
80 } else {
Sergey
parents:
diff changeset
81 die new Exception('Can\'t format the object as a value',ref $value);
Sergey
parents:
diff changeset
82 }
Sergey
parents:
diff changeset
83 } else {
Sergey
parents:
diff changeset
84 return quote($value);
Sergey
parents:
diff changeset
85 }
Sergey
parents:
diff changeset
86 }
Sergey
parents:
diff changeset
87
Sergey
parents:
diff changeset
88
Sergey
parents:
diff changeset
89 sub formatNumberValue {
Sergey
parents:
diff changeset
90 my ($value) = @_;
Sergey
parents:
diff changeset
91
Sergey
parents:
diff changeset
92 if (ref $value) {
Sergey
parents:
diff changeset
93 if (UNIVERSAL::isa($value,'IMPL::SQL::Schema::mysql::Expression')) {
Sergey
parents:
diff changeset
94 return $value->as_string;
Sergey
parents:
diff changeset
95 } else {
Sergey
parents:
diff changeset
96 die new Exception('Can\'t format the object as a value',ref $value);
Sergey
parents:
diff changeset
97 }
Sergey
parents:
diff changeset
98 } else {
Sergey
parents:
diff changeset
99 $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ or die new Exception('The specified value isn\'t a valid number',$value);
Sergey
parents:
diff changeset
100 return $value;
Sergey
parents:
diff changeset
101 }
Sergey
parents:
diff changeset
102 }
Sergey
parents:
diff changeset
103
Sergey
parents:
diff changeset
104
Sergey
parents:
diff changeset
105 my %TypesFormat = (
Sergey
parents:
diff changeset
106 TINYINT => {
Sergey
parents:
diff changeset
107 formatType => \&formatTypeNameInteger,
Sergey
parents:
diff changeset
108 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
109 },
Sergey
parents:
diff changeset
110 SMALLINT => {
Sergey
parents:
diff changeset
111 formatType => \&formatTypeNameInteger,
Sergey
parents:
diff changeset
112 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
113 },
Sergey
parents:
diff changeset
114 MEDIUMINT => {
Sergey
parents:
diff changeset
115 formatType => \&formatTypeNameInteger,
Sergey
parents:
diff changeset
116 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
117 },
Sergey
parents:
diff changeset
118 INT => {
Sergey
parents:
diff changeset
119 formatType => \&formatTypeNameInteger,
Sergey
parents:
diff changeset
120 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
121 },
Sergey
parents:
diff changeset
122 INTEGER => {
Sergey
parents:
diff changeset
123 formatType => \&formatTypeNameInteger,
Sergey
parents:
diff changeset
124 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
125 },
Sergey
parents:
diff changeset
126 BIGINT => {
Sergey
parents:
diff changeset
127 formatType => \&formatTypeNameInteger,
Sergey
parents:
diff changeset
128 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
129 },
Sergey
parents:
diff changeset
130 REAL => {
Sergey
parents:
diff changeset
131 formatType => \&formatTypeNameReal,
Sergey
parents:
diff changeset
132 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
133 },
Sergey
parents:
diff changeset
134 DOUBLE => {
Sergey
parents:
diff changeset
135 formatType => \&formatTypeNameReal,
Sergey
parents:
diff changeset
136 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
137 },
Sergey
parents:
diff changeset
138 FLOAT => {
Sergey
parents:
diff changeset
139 formatType => \&formatTypeNameReal,
Sergey
parents:
diff changeset
140 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
141 },
Sergey
parents:
diff changeset
142 DECIMAL => {
Sergey
parents:
diff changeset
143 formatType => \&formatTypeNameNumeric,
Sergey
parents:
diff changeset
144 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
145 },
Sergey
parents:
diff changeset
146 NUMERIC => {
Sergey
parents:
diff changeset
147 formatType => \&formatTypeNameNumeric,
Sergey
parents:
diff changeset
148 formatValue => \&formatNumberValue
Sergey
parents:
diff changeset
149 },
Sergey
parents:
diff changeset
150 DATE => {
Sergey
parents:
diff changeset
151 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
152 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
153 },
Sergey
parents:
diff changeset
154 TIME => {
Sergey
parents:
diff changeset
155 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
156 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
157 },
Sergey
parents:
diff changeset
158 TIMESTAMP => {
Sergey
parents:
diff changeset
159 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
160 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
161 },
Sergey
parents:
diff changeset
162 DATETIME => {
Sergey
parents:
diff changeset
163 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
164 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
165 },
Sergey
parents:
diff changeset
166 CHAR => {
Sergey
parents:
diff changeset
167 formatType => \&formatTypeNameChar,
Sergey
parents:
diff changeset
168 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
169 },
Sergey
parents:
diff changeset
170 VARCHAR => {
Sergey
parents:
diff changeset
171 formatType => \&formatTypeNameVarChar,
Sergey
parents:
diff changeset
172 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
173 },
Sergey
parents:
diff changeset
174 TINYBLOB => {
Sergey
parents:
diff changeset
175 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
176 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
177 },
Sergey
parents:
diff changeset
178 BLOB => {
Sergey
parents:
diff changeset
179 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
180 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
181 },
Sergey
parents:
diff changeset
182 MEDIUMBLOB => {
Sergey
parents:
diff changeset
183 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
184 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
185 },
Sergey
parents:
diff changeset
186 LONGBLOB => {
Sergey
parents:
diff changeset
187 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
188 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
189 },
Sergey
parents:
diff changeset
190 TINYTEXT => {
Sergey
parents:
diff changeset
191 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
192 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
193 },
Sergey
parents:
diff changeset
194 TEXT => {
Sergey
parents:
diff changeset
195 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
196 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
197 },
Sergey
parents:
diff changeset
198 MEDIUMTEXT => {
Sergey
parents:
diff changeset
199 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
200 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
201 },
Sergey
parents:
diff changeset
202 LONGTEXT => {
Sergey
parents:
diff changeset
203 formatType => \&formatTypeName,
Sergey
parents:
diff changeset
204 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
205 },
Sergey
parents:
diff changeset
206 ENUM => {
Sergey
parents:
diff changeset
207 formatType => \&formatTypeNameEnum,
Sergey
parents:
diff changeset
208 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
209 },
Sergey
parents:
diff changeset
210 SET => {
Sergey
parents:
diff changeset
211 formatType => \&formatTypeNameEnum,
Sergey
parents:
diff changeset
212 formatValue => \&formatStringValue
Sergey
parents:
diff changeset
213 }
Sergey
parents:
diff changeset
214 );
Sergey
parents:
diff changeset
215
Sergey
parents:
diff changeset
216
Sergey
parents:
diff changeset
217 =pod
Sergey
parents:
diff changeset
218 CREATE TABLE 'test'.'New Table' (
Sergey
parents:
diff changeset
219 'dd' INTEGER UNSIGNED NOT NULL AUTO_INCREMENT,
Sergey
parents:
diff changeset
220 `ff` VARCHAR(45) NOT NULL,
Sergey
parents:
diff changeset
221 `ffg` VARCHAR(45) NOT NULL DEFAULT 'aaa',
Sergey
parents:
diff changeset
222 `ddf` INTEGER UNSIGNED NOT NULL,
Sergey
parents:
diff changeset
223 PRIMARY KEY(`dd`),
Sergey
parents:
diff changeset
224 UNIQUE `Index_2`(`ffg`),
Sergey
parents:
diff changeset
225 CONSTRAINT `FK_New Table_1` FOREIGN KEY `FK_New Table_1` (`ddf`)
Sergey
parents:
diff changeset
226 REFERENCES `user` (`id`)
Sergey
parents:
diff changeset
227 ON DELETE RESTRICT
Sergey
parents:
diff changeset
228 ON UPDATE RESTRICT
Sergey
parents:
diff changeset
229 )
Sergey
parents:
diff changeset
230 ENGINE = InnoDB;
Sergey
parents:
diff changeset
231 =cut
Sergey
parents:
diff changeset
232 sub formatCreateTable {
Sergey
parents:
diff changeset
233 my ($table,$level,%options) = @_;
Sergey
parents:
diff changeset
234
Sergey
parents:
diff changeset
235 my @sql;
Sergey
parents:
diff changeset
236
Sergey
parents:
diff changeset
237 # table body
44
Sergey
parents: 32
diff changeset
238 push @sql, map { formatColumn($_,$level+1) } @{$table->Columns} ;
32
Sergey
parents:
diff changeset
239 if ($options{'skip_foreign_keys'}) {
Sergey
parents:
diff changeset
240 push @sql, map { formatConstraint($_,$level+1) } grep {not UNIVERSAL::isa($_,'IMPL::SQL::Schema::Constraint::ForeignKey')} values %{$table->Constraints};
Sergey
parents:
diff changeset
241 } else {
Sergey
parents:
diff changeset
242 push @sql, map { formatConstraint($_,$level+1) } values %{$table->Constraints};
Sergey
parents:
diff changeset
243 }
Sergey
parents:
diff changeset
244
Sergey
parents:
diff changeset
245 for(my $i = 0 ; $i < @sql -1; $i++) {
Sergey
parents:
diff changeset
246 $sql[$i] .= ',';
Sergey
parents:
diff changeset
247 }
Sergey
parents:
diff changeset
248
Sergey
parents:
diff changeset
249 unshift @sql, "CREATE TABLE ".quote_names($table->Name)."(";
Sergey
parents:
diff changeset
250
Sergey
parents:
diff changeset
251 if ($table->Tag) {
Sergey
parents:
diff changeset
252 push @sql, ")";
Sergey
parents:
diff changeset
253 push @sql, formatTableTag($table->Tag,$level);
Sergey
parents:
diff changeset
254 $sql[$#sql].=';';
Sergey
parents:
diff changeset
255 } else {
Sergey
parents:
diff changeset
256 push @sql, ');';
Sergey
parents:
diff changeset
257 }
Sergey
parents:
diff changeset
258
Sergey
parents:
diff changeset
259 return map { ("\t" x $level) . $_ } @sql;
Sergey
parents:
diff changeset
260 }
Sergey
parents:
diff changeset
261
Sergey
parents:
diff changeset
262 sub formatDropTable {
Sergey
parents:
diff changeset
263 my ($tableName,$level) = @_;
Sergey
parents:
diff changeset
264
Sergey
parents:
diff changeset
265 return "\t"x$level."DROP TABLE ".quote_names($tableName).";";
Sergey
parents:
diff changeset
266 }
Sergey
parents:
diff changeset
267
Sergey
parents:
diff changeset
268 sub formatTableTag {
Sergey
parents:
diff changeset
269 my ($tag,$level) = @_;
Sergey
parents:
diff changeset
270 return map { "\t"x$level . "$_ = ".$tag->{$_} } grep {/^(ENGINE)$/i} keys %{$tag};
Sergey
parents:
diff changeset
271 }
Sergey
parents:
diff changeset
272
Sergey
parents:
diff changeset
273 sub formatColumn {
Sergey
parents:
diff changeset
274 my ($column,$level) = @_;
Sergey
parents:
diff changeset
275 $level ||= 0;
Sergey
parents:
diff changeset
276 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) : '');
Sergey
parents:
diff changeset
277 }
Sergey
parents:
diff changeset
278
Sergey
parents:
diff changeset
279 sub formatType {
Sergey
parents:
diff changeset
280 my ($type) = @_;
Sergey
parents:
diff changeset
281 my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name);
Sergey
parents:
diff changeset
282 $format->{formatType}->($type);
Sergey
parents:
diff changeset
283 }
Sergey
parents:
diff changeset
284
Sergey
parents:
diff changeset
285 sub formatValueToType {
Sergey
parents:
diff changeset
286 my ($value,$type) = @_;
Sergey
parents:
diff changeset
287
Sergey
parents:
diff changeset
288 my $format = $TypesFormat{uc $type->Name} or die new Exception('The unknown type name',$type->Name);
Sergey
parents:
diff changeset
289 $format->{formatValue}->($value);
Sergey
parents:
diff changeset
290 }
Sergey
parents:
diff changeset
291
Sergey
parents:
diff changeset
292 sub formatConstraint {
Sergey
parents:
diff changeset
293 my ($constraint,$level) = @_;
Sergey
parents:
diff changeset
294
Sergey
parents:
diff changeset
295 if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::ForeignKey')) {
Sergey
parents:
diff changeset
296 return formatForeignKey($constraint,$level);
Sergey
parents:
diff changeset
297 } else {
Sergey
parents:
diff changeset
298 return formatIndex($constraint, $level);
Sergey
parents:
diff changeset
299 }
Sergey
parents:
diff changeset
300 }
Sergey
parents:
diff changeset
301
Sergey
parents:
diff changeset
302 sub formatIndex {
Sergey
parents:
diff changeset
303 my ($constraint,$level) = @_;
Sergey
parents:
diff changeset
304
Sergey
parents:
diff changeset
305 my $name = quote_names($constraint->Name);
44
Sergey
parents: 32
diff changeset
306 my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns});
32
Sergey
parents:
diff changeset
307
Sergey
parents:
diff changeset
308 if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') {
Sergey
parents:
diff changeset
309 return "\t"x$level."PRIMARY KEY ($columns)";
Sergey
parents:
diff changeset
310 } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Unique') {
Sergey
parents:
diff changeset
311 return "\t"x$level."UNIQUE $name ($columns)";
Sergey
parents:
diff changeset
312 } elsif ($constraint eq 'IMPL::SQL::Schema::Constraint::Index') {
Sergey
parents:
diff changeset
313 return "\t"x$level."INDEX $name ($columns)";
Sergey
parents:
diff changeset
314 } else {
Sergey
parents:
diff changeset
315 die new IMPL::InvalidArgumentException('The unknown constraint', ref $constraint);
Sergey
parents:
diff changeset
316 }
Sergey
parents:
diff changeset
317
Sergey
parents:
diff changeset
318 }
Sergey
parents:
diff changeset
319
Sergey
parents:
diff changeset
320 sub formatForeignKey {
Sergey
parents:
diff changeset
321 my ($constraint,$level) = @_;
Sergey
parents:
diff changeset
322
Sergey
parents:
diff changeset
323 my $name = quote_names($constraint->Name);
44
Sergey
parents: 32
diff changeset
324 my $columns = join(',',map quote_names($_->Name),@{$constraint->Columns});
32
Sergey
parents:
diff changeset
325
Sergey
parents:
diff changeset
326 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);
Sergey
parents:
diff changeset
327 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);
Sergey
parents:
diff changeset
328
Sergey
parents:
diff changeset
329 my $refname = quote_names($constraint->ReferencedPrimaryKey->Table->Name);
44
Sergey
parents: 32
diff changeset
330 my $refcolumns = join(',',map quote_names($_->Name),@{$constraint->ReferencedPrimaryKey->Columns});
32
Sergey
parents:
diff changeset
331 return (
Sergey
parents:
diff changeset
332 "\t"x$level.
Sergey
parents:
diff changeset
333 "CONSTRAINT $name FOREIGN KEY $name ($columns) REFERENCES $refname ($refcolumns)".
Sergey
parents:
diff changeset
334 ($constraint->OnUpdate ? 'ON UPDATE'.$constraint->OnUpdate : '').
Sergey
parents:
diff changeset
335 ($constraint->OnDelete ? 'ON DELETE'.$constraint->OnDelete : '')
Sergey
parents:
diff changeset
336 );
Sergey
parents:
diff changeset
337 }
Sergey
parents:
diff changeset
338
Sergey
parents:
diff changeset
339 sub formatAlterTableRename {
Sergey
parents:
diff changeset
340 my ($oldName,$newName,$level) = @_;
Sergey
parents:
diff changeset
341
Sergey
parents:
diff changeset
342 return "\t"x$level."ALTER TABLE ".quote_names($oldName)." RENAME TO ".quote_names($newName).";";
Sergey
parents:
diff changeset
343 }
Sergey
parents:
diff changeset
344
Sergey
parents:
diff changeset
345 sub formatAlterTableDropColumn {
Sergey
parents:
diff changeset
346 my ($tableName, $columnName,$level) = @_;
Sergey
parents:
diff changeset
347
Sergey
parents:
diff changeset
348 return "\t"x$level."ALTER TABLE ".quote_names($tableName)." DROP COLUMN ".quote_names($columnName).";";
Sergey
parents:
diff changeset
349 }
Sergey
parents:
diff changeset
350
Sergey
parents:
diff changeset
351 =pod
Sergey
parents:
diff changeset
352 ALTER TABLE `test`.`user` ADD COLUMN `my_col` VARCHAR(45) NOT NULL AFTER `name2`
Sergey
parents:
diff changeset
353 =cut
Sergey
parents:
diff changeset
354 sub formatAlterTableAddColumn {
Sergey
parents:
diff changeset
355 my ($tableName, $column, $table, $pos, $level) = @_;
Sergey
parents:
diff changeset
356
Sergey
parents:
diff changeset
357 my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name);
Sergey
parents:
diff changeset
358
Sergey
parents:
diff changeset
359 return "\t"x$level."ALTER TABLE ".quote_names($tableName)." ADD COLUMN ".formatColumn($column) .' '. $posSpec.";";
Sergey
parents:
diff changeset
360 }
Sergey
parents:
diff changeset
361
Sergey
parents:
diff changeset
362 =pod
Sergey
parents:
diff changeset
363 ALTER TABLE `test`.`manager` MODIFY COLUMN `description` VARCHAR(256) NOT NULL DEFAULT NULL;
Sergey
parents:
diff changeset
364 =cut
Sergey
parents:
diff changeset
365 sub formatAlterTableChangeColumn {
Sergey
parents:
diff changeset
366 my ($tableName,$column,$table,$pos,$level) = @_;
Sergey
parents:
diff changeset
367 my $posSpec = $pos == 0 ? 'FIRST' : 'AFTER '.quote_names($table->ColumnAt($pos-1)->Name);
Sergey
parents:
diff changeset
368 return "\t"x$level."ALTER TABLE ".quote_names($tableName)." MODIFY COLUMN ".formatColumn($column).' '. $posSpec.";";
Sergey
parents:
diff changeset
369 }
Sergey
parents:
diff changeset
370
Sergey
parents:
diff changeset
371 =pod
Sergey
parents:
diff changeset
372 ALTER TABLE `test`.`manager` DROP INDEX `Index_2`;
Sergey
parents:
diff changeset
373 =cut
Sergey
parents:
diff changeset
374 sub formatAlterTableDropConstraint {
Sergey
parents:
diff changeset
375 my ($tableName,$constraint,$level) = @_;
Sergey
parents:
diff changeset
376 my $constraintName;
Sergey
parents:
diff changeset
377 if (ref $constraint eq 'IMPL::SQL::Schema::Constraint::PrimaryKey') {
Sergey
parents:
diff changeset
378 $constraintName = 'PRIMARY KEY';
Sergey
parents:
diff changeset
379 } elsif (ref $constraint eq 'IMPL::SQL::Schema::Constraint::ForeignKey') {
Sergey
parents:
diff changeset
380 $constraintName = 'FOREIGN KEY '.quote_names($constraint->Name);
Sergey
parents:
diff changeset
381 } elsif (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) {
Sergey
parents:
diff changeset
382 $constraintName = 'INDEX '.quote_names($constraint->Name);
Sergey
parents:
diff changeset
383 } else {
Sergey
parents:
diff changeset
384 die new IMPL::Exception("The unknow type of the constraint",ref $constraint);
Sergey
parents:
diff changeset
385 }
Sergey
parents:
diff changeset
386 return "\t"x$level."ALTER TABLE ".quote_names($tableName)." DROP $constraintName;";
Sergey
parents:
diff changeset
387 }
Sergey
parents:
diff changeset
388
Sergey
parents:
diff changeset
389 =pod
Sergey
parents:
diff changeset
390 ALTER TABLE `test`.`session` ADD INDEX `Index_2`(`id`, `name`);
Sergey
parents:
diff changeset
391 =cut
Sergey
parents:
diff changeset
392 sub formatAlterTableAddConstraint {
Sergey
parents:
diff changeset
393 my ($tableName,$constraint,$level) = @_;
Sergey
parents:
diff changeset
394
Sergey
parents:
diff changeset
395 return "\t"x$level."ALTER TABLE ".quote_names($tableName)." ADD ".formatConstraint($constraint,0).';';
Sergey
parents:
diff changeset
396 }
Sergey
parents:
diff changeset
397
Sergey
parents:
diff changeset
398 sub CreateTable {
Sergey
parents:
diff changeset
399 my ($this,$tbl,%option) = @_;
Sergey
parents:
diff changeset
400
Sergey
parents:
diff changeset
401 push @{$this->{$SqlBatch}},join("\n",formatCreateTable($tbl,0,%option));
Sergey
parents:
diff changeset
402
Sergey
parents:
diff changeset
403 return 1;
Sergey
parents:
diff changeset
404 }
Sergey
parents:
diff changeset
405
Sergey
parents:
diff changeset
406 sub DropTable {
Sergey
parents:
diff changeset
407 my ($this,$tbl) = @_;
Sergey
parents:
diff changeset
408
Sergey
parents:
diff changeset
409 push @{$this->{$SqlBatch}},join("\n",formatDropTable($tbl,0));
Sergey
parents:
diff changeset
410
Sergey
parents:
diff changeset
411 return 1;
Sergey
parents:
diff changeset
412 }
Sergey
parents:
diff changeset
413
Sergey
parents:
diff changeset
414 sub RenameTable {
Sergey
parents:
diff changeset
415 my ($this,$oldName,$newName) = @_;
Sergey
parents:
diff changeset
416
Sergey
parents:
diff changeset
417 push @{$this->{$SqlBatch}},join("\n",formatAlterTableRename($oldName,$newName,0));
Sergey
parents:
diff changeset
418
Sergey
parents:
diff changeset
419 return 1;
Sergey
parents:
diff changeset
420 }
Sergey
parents:
diff changeset
421
Sergey
parents:
diff changeset
422 sub AlterTableAddColumn {
Sergey
parents:
diff changeset
423 my ($this,$tblName,$column,$table,$pos) = @_;
Sergey
parents:
diff changeset
424
Sergey
parents:
diff changeset
425 push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddColumn($tblName,$column,$table,$pos,0));
Sergey
parents:
diff changeset
426
Sergey
parents:
diff changeset
427 return 1;
Sergey
parents:
diff changeset
428 }
Sergey
parents:
diff changeset
429 sub AlterTableDropColumn {
Sergey
parents:
diff changeset
430 my ($this,$tblName,$columnName) = @_;
Sergey
parents:
diff changeset
431
Sergey
parents:
diff changeset
432 push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropColumn($tblName,$columnName,0));
Sergey
parents:
diff changeset
433
Sergey
parents:
diff changeset
434 return 1;
Sergey
parents:
diff changeset
435 }
Sergey
parents:
diff changeset
436
Sergey
parents:
diff changeset
437 sub AlterTableChangeColumn {
Sergey
parents:
diff changeset
438 my ($this,$tblName,$column,$table,$pos) = @_;
Sergey
parents:
diff changeset
439
Sergey
parents:
diff changeset
440 push @{$this->{$SqlBatch}},join("\n",formatAlterTableChangeColumn($tblName,$column,$table,$pos,0));
Sergey
parents:
diff changeset
441
Sergey
parents:
diff changeset
442 return 1;
Sergey
parents:
diff changeset
443 }
Sergey
parents:
diff changeset
444
Sergey
parents:
diff changeset
445 sub AlterTableAddConstraint {
Sergey
parents:
diff changeset
446 my ($this,$tblName,$constraint) = @_;
Sergey
parents:
diff changeset
447
Sergey
parents:
diff changeset
448 push @{$this->{$SqlBatch}},join("\n",formatAlterTableAddConstraint($tblName,$constraint,0));
Sergey
parents:
diff changeset
449
Sergey
parents:
diff changeset
450 return 1;
Sergey
parents:
diff changeset
451 }
Sergey
parents:
diff changeset
452
Sergey
parents:
diff changeset
453 sub AlterTableDropConstraint {
Sergey
parents:
diff changeset
454 my ($this,$tblName,$constraint) = @_;
Sergey
parents:
diff changeset
455
Sergey
parents:
diff changeset
456 push @{$this->{$SqlBatch}},join("\n",formatAlterTableDropConstraint($tblName,$constraint,0));
Sergey
parents:
diff changeset
457
Sergey
parents:
diff changeset
458 return 1;
Sergey
parents:
diff changeset
459 }
Sergey
parents:
diff changeset
460
Sergey
parents:
diff changeset
461 sub Sql {
Sergey
parents:
diff changeset
462 my ($this) = @_;
Sergey
parents:
diff changeset
463 if (wantarray) {
44
Sergey
parents: 32
diff changeset
464 @{$this->SqlBatch || []};
32
Sergey
parents:
diff changeset
465 } else {
Sergey
parents:
diff changeset
466 return join("\n",$this->SqlBatch);
Sergey
parents:
diff changeset
467 }
Sergey
parents:
diff changeset
468 }
Sergey
parents:
diff changeset
469
Sergey
parents:
diff changeset
470 package IMPL::SQL::Schema::Traits::mysql;
Sergey
parents:
diff changeset
471 use Common;
Sergey
parents:
diff changeset
472 use base qw(IMPL::SQL::Schema::Traits);
Sergey
parents:
diff changeset
473 use IMPL::Class::Property;
Sergey
parents:
diff changeset
474 use IMPL::Class::Property::Direct;
Sergey
parents:
diff changeset
475
Sergey
parents:
diff changeset
476 BEGIN {
Sergey
parents:
diff changeset
477 public _direct property PendingConstraints => prop_none;
Sergey
parents:
diff changeset
478 }
Sergey
parents:
diff changeset
479
44
Sergey
parents: 32
diff changeset
480 our %CTOR = (
Sergey
parents: 32
diff changeset
481 'IMPL::SQL::Schema::Traits' => sub {
Sergey
parents: 32
diff changeset
482 my %args = @_;
Sergey
parents: 32
diff changeset
483 $args{'Handler'} = new IMPL::SQL::Schema::Traits::mysql::Handler;
Sergey
parents: 32
diff changeset
484 %args;
Sergey
parents: 32
diff changeset
485 }
Sergey
parents: 32
diff changeset
486 );
32
Sergey
parents:
diff changeset
487
Sergey
parents:
diff changeset
488 sub DropConstraint {
Sergey
parents:
diff changeset
489 my ($this,$constraint) = @_;
Sergey
parents:
diff changeset
490
Sergey
parents:
diff changeset
491 if (UNIVERSAL::isa($constraint,'IMPL::SQL::Schema::Constraint::Index')) {
Sergey
parents:
diff changeset
492 return 1 if not grep { $this->TableInfo->{$this->MapTableName($constraint->Table->Name)}->{'Columns'}->{$_->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED} $constraint->Columns;
Sergey
parents:
diff changeset
493 my @constraints = grep {$_ != $constraint } $constraint->Table->GetColumnConstraints($constraint->Columns);
Sergey
parents:
diff changeset
494 if (scalar @constraints == 1 and UNIVERSAL::isa($constraints[0],'IMPL::SQL::Schema::Constraint::ForeignKey')) {
Sergey
parents:
diff changeset
495 my $fk = shift @constraints;
Sergey
parents:
diff changeset
496 if ($this->TableInfo->{$this->MapTableName($fk->Table->Name)}->{'Constraints'}->{$fk->Name} != IMPL::SQL::Schema::Traits::STATE_REMOVED) {
Sergey
parents:
diff changeset
497 push @{$this->PendingActions}, {Action => \&DropConstraint, Args => [$constraint]};
Sergey
parents:
diff changeset
498 $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} ++;
Sergey
parents:
diff changeset
499
Sergey
parents:
diff changeset
500 die new IMPL::Exception('Can\'t drop the primary key becouse of the foreing key',$fk->UniqName) if $this->{$PendingConstraints}->{$constraint->UniqName}->{'attempts'} > 2;
Sergey
parents:
diff changeset
501 return 2;
Sergey
parents:
diff changeset
502 }
Sergey
parents:
diff changeset
503 }
Sergey
parents:
diff changeset
504 }
Sergey
parents:
diff changeset
505 $this->SUPER::DropConstraint($constraint);
Sergey
parents:
diff changeset
506 }
Sergey
parents:
diff changeset
507
Sergey
parents:
diff changeset
508 sub GetMetaTable {
Sergey
parents:
diff changeset
509 my ($class,$dbh) = @_;
Sergey
parents:
diff changeset
510
Sergey
parents:
diff changeset
511 return IMPL::SQL::Schema::Traits::mysql::MetaTable->new( DBHandle => $dbh);
Sergey
parents:
diff changeset
512 }
Sergey
parents:
diff changeset
513
Sergey
parents:
diff changeset
514 package IMPL::SQL::Schema::Traits::mysql::MetaTable;
Sergey
parents:
diff changeset
515 use Common;
Sergey
parents:
diff changeset
516 use base qw(IMPL::Object);
Sergey
parents:
diff changeset
517 use IMPL::Class::Property;
Sergey
parents:
diff changeset
518 use IMPL::Class::Property::Direct;
Sergey
parents:
diff changeset
519
Sergey
parents:
diff changeset
520 BEGIN {
Sergey
parents:
diff changeset
521 public _direct property DBHandle => prop_none;
Sergey
parents:
diff changeset
522 }
Sergey
parents:
diff changeset
523
Sergey
parents:
diff changeset
524 sub ReadProperty {
Sergey
parents:
diff changeset
525 my ($this,$name) = @_;
Sergey
parents:
diff changeset
526
Sergey
parents:
diff changeset
527 local $this->{$DBHandle}->{PrintError};
Sergey
parents:
diff changeset
528 $this->{$DBHandle}->{PrintError} = 0;
Sergey
parents:
diff changeset
529 my ($val) = $this->{$DBHandle}->selectrow_array("SELECT value FROM _Meta WHERE name like ?", undef, $name);
Sergey
parents:
diff changeset
530 return $val;
Sergey
parents:
diff changeset
531 }
Sergey
parents:
diff changeset
532
Sergey
parents:
diff changeset
533 sub SetProperty {
Sergey
parents:
diff changeset
534 my ($this,$name,$val) = @_;
Sergey
parents:
diff changeset
535
Sergey
parents:
diff changeset
536 if ( $this->{$DBHandle}->selectrow_arrayref("SELECT TABLE_NAME FROM information_schema.`TABLES` T where TABLE_SCHEMA like DATABASE() and TABLE_NAME like '_Meta'")) {
Sergey
parents:
diff changeset
537 if ($this->{$DBHandle}->selectrow_arrayref("SELECT name FROM _Meta WHERE name like ?", undef, $name)) {
Sergey
parents:
diff changeset
538 $this->{$DBHandle}->do("UPDATE _Meta SET value = ? WHERE name like ?",undef,$val,$name);
Sergey
parents:
diff changeset
539 } else {
Sergey
parents:
diff changeset
540 $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES ('$name',?)",undef,$val);
Sergey
parents:
diff changeset
541 }
Sergey
parents:
diff changeset
542 } else {
Sergey
parents:
diff changeset
543 $this->{$DBHandle}->do(q{
Sergey
parents:
diff changeset
544 CREATE TABLE `_Meta` (
Sergey
parents:
diff changeset
545 `name` VARCHAR(255) NOT NULL,
Sergey
parents:
diff changeset
546 `value` LONGTEXT NULL,
Sergey
parents:
diff changeset
547 PRIMARY KEY(`name`)
Sergey
parents:
diff changeset
548 );
Sergey
parents:
diff changeset
549 }) or die new IMPL::Exception("Failed to create table","_Meta");
Sergey
parents:
diff changeset
550
Sergey
parents:
diff changeset
551 $this->{$DBHandle}->do("INSERT INTO _Meta(name,value) VALUES (?,?)",undef,$name,$val);
Sergey
parents:
diff changeset
552 }
Sergey
parents:
diff changeset
553 }
Sergey
parents:
diff changeset
554
Sergey
parents:
diff changeset
555 1;