Commit | Line | Data |
7a0ceaa1 |
1 | package SQL::Translator::Producer::SQLServer; |
2 | |
7a0ceaa1 |
3 | use strict; |
f27f9229 |
4 | use warnings; |
0c04c5a2 |
5 | our ( $DEBUG, $WARN ); |
6 | our $VERSION = '1.59'; |
7a0ceaa1 |
7 | $DEBUG = 1 unless defined $DEBUG; |
8 | |
7a0ceaa1 |
9 | use SQL::Translator::Schema::Constants; |
10 | use SQL::Translator::Utils qw(debug header_comment); |
c661b77d |
11 | use SQL::Translator::Generator::DDL::SQLServer; |
0a6e5a56 |
12 | |
7a0ceaa1 |
13 | sub produce { |
9a6c1bf9 |
14 | my $translator = shift; |
15 | SQL::Translator::Generator::DDL::SQLServer->new( |
16 | add_comments => !$translator->no_comments, |
17 | add_drop_tables => $translator->add_drop_table, |
18 | )->schema($translator->schema) |
871f55d4 |
19 | } |
20 | |
2402c3ea |
21 | sub rename_table { |
22 | my ($old, $new) = @_;; |
23 | |
24 | q(sp_rename ') . $old->name . q(', ') . $new->name . q(') |
25 | } |
26 | |
27 | sub alter_drop_constraint { |
28 | my ($constraint, $options) = @_; |
29 | my $table_name_q= $constraint->table->name; |
30 | my $ct_name_q= $constraint->name; |
31 | return "ALTER TABLE $table_name_q DROP CONSTRAINT $ct_name_q;"; |
32 | } |
33 | |
34 | sub alter_drop_index { |
35 | my ($index, $options) = @_; |
36 | my $table_name_q= $index->table->name; |
37 | my $index_name_q= $index->name; |
38 | return "ALTER TABLE $table_name_q DROP $index_name_q"; |
39 | } |
40 | |
41 | sub alter_field { |
42 | my ($from_field, $to_field, $options) = @_; |
43 | |
44 | my $field_clause= build_field_clause($to_field, $options); |
45 | my $table_name_q= $to_field->table->name; |
46 | |
47 | my @sql; |
48 | if (lc($from_field->data_type) eq 'enum') { |
49 | push @sql, build_drop_enum_constraint($from_field, $options).';'; |
50 | } |
51 | |
52 | push @sql, "ALTER TABLE $table_name_q ALTER COLUMN $field_clause;"; |
53 | |
54 | if ($from_field->name ne $to_field->name) { |
55 | push @sql, rename_field(@_); |
56 | } |
57 | |
58 | if (lc($to_field->data_type) eq 'enum') { |
59 | push @sql, build_add_enum_constraint($to_field, $options).';'; |
60 | } |
61 | |
62 | return join("\n", @sql); |
63 | } |
64 | |
65 | sub rename_field { |
66 | 'lol' |
67 | } |
68 | |
69 | sub alter_create_index { |
70 | my ($index, $options) = @_; |
71 | my ($stmt, $clause)= build_index_stmt(@_); |
72 | return $stmt.';'; |
73 | } |
74 | |
75 | sub build_index_stmt { |
76 | my ($index, $options)= @_; |
77 | my $table_name_q = $index->table->name; |
78 | my $idx_name_q = $index->name; |
79 | my $field_list = join(', ', $index->fields ); |
80 | |
81 | my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $idx_name_q" . |
82 | " ON $table_name_q ($field_list)"; |
83 | return $stmt, undef; |
84 | } |
85 | |
86 | sub build_constraint_stmt { |
87 | my $c = shift; |
88 | |
89 | if ($c->type eq PRIMARY_KEY ) { |
90 | return SQL::Translator::Generator::DDL::SQLServer->new->primary_key_constraint($c) |
91 | } elsif ($c->type eq UNIQUE ) { |
92 | return SQL::Translator::Generator::DDL::SQLServer->new->unique_constraint_single($c) |
93 | } |
94 | } |
95 | |
96 | sub drop_table { 'DROP TABLE ' . $_[0]->name } |
97 | |
98 | sub alter_create_constraint { |
99 | my ($constraint, $options) = @_; |
100 | my ($stmt, $clause)= build_constraint_stmt(@_); |
101 | return $stmt.';'; |
102 | } |
103 | |
104 | sub build_enum_constraint { |
105 | my ($field, $options)= @_; |
106 | my %extra = $field->extra; |
107 | my $list = $extra{'list'} || []; |
108 | # \todo deal with embedded quotes |
109 | my $commalist = join( ', ', map { qq['$_'] } @$list ); |
110 | my $field_name_q = $field->name; |
111 | my $check_name_q = $field->table->name . '_' . $field->name . '_chk'; |
112 | return "CONSTRAINT $check_name_q CHECK ($field_name_q IN ($commalist))"; |
113 | } |
114 | sub build_drop_enum_constraint { |
115 | my ($field, $options)= @_; |
116 | my $table_name_q = $field->table->name; |
117 | my $check_name_q = $field->table->name . '_' . $field->name . '_chk'; |
118 | return "ALTER TABLE $table_name_q DROP $check_name_q"; |
119 | } |
120 | |
121 | sub build_add_enum_constraint { |
122 | my ($field, $options)= @_; |
123 | my $table_name_q = $field->table->name; |
124 | return "ALTER TABLE $table_name_q ADD ".build_enum_constraint(@_); |
125 | } |
126 | |
127 | sub build_field_clause { |
128 | SQL::Translator::Generator::DDL::SQLServer->new->field(shift) |
129 | } |
130 | |
131 | sub add_field { |
132 | my ($new_field, $options) = @_; |
133 | |
134 | my $field_clause = build_field_clause($new_field); |
135 | my $table_name_q= $new_field->table->name; |
136 | |
137 | my @sql= "ALTER TABLE $table_name_q ADD COLUMN $field_clause;"; |
138 | if (lc($new_field->data_type) eq 'enum') { |
139 | push @sql, build_add_enum_constraint($new_field, $options).';'; |
140 | } |
141 | |
142 | return join("\n", @sql); |
143 | } |
144 | |
145 | sub drop_field { |
146 | my ($old_field, $options) = @_; |
147 | |
148 | my $table_name_q= $old_field->table->name; |
149 | my $field_name_q= $old_field->name; |
150 | |
151 | my @sql; |
152 | if (lc($old_field->data_type) eq 'enum') { |
153 | push @sql, build_drop_enum_constraint($old_field, $options).';'; |
154 | } |
155 | |
156 | push @sql, "ALTER TABLE $table_name_q DROP COLUMN $field_name_q;"; |
157 | |
158 | return join("\n", @sql); |
159 | } |
160 | |
056238d8 |
161 | 1; |
162 | |
056238d8 |
163 | =head1 NAME |
164 | |
165 | SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator |
166 | |
167 | =head1 SYNOPSIS |
168 | |
169 | use SQL::Translator; |
170 | |
171 | my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' ); |
172 | $t->translate; |
173 | |
174 | =head1 DESCRIPTION |
175 | |
22c0c10f |
176 | This is currently a thin wrapper around the nextgen |
177 | L<SQL::Translator::Generator::DDL::SQLServer> DDL maker. |
056238d8 |
178 | |
179 | =head1 Extra Attributes |
180 | |
181 | =over 4 |
182 | |
183 | =item field.list |
184 | |
185 | List of values for an enum field. |
186 | |
187 | =back |
188 | |
189 | =head1 TODO |
190 | |
191 | * !! Write some tests !! |
192 | * Reserved words list needs updating to SQLServer. |
193 | * Triggers, Procedures and Views DO NOT WORK |
194 | |
195 | |
7a0ceaa1 |
196 | # Text of view is already a 'create view' statement so no need to |
197 | # be fancy |
198 | foreach ( $schema->get_views ) { |
199 | my $name = $_->name(); |
200 | $output .= "\n\n"; |
5c5997ef |
201 | $output .= "--\n-- View: $name\n--\n\n" unless $no_comments; |
3e0bcbfd |
202 | my $text = $_->sql(); |
e2fb9ad3 |
203 | $text =~ s/\r//g; |
5bb0a4ee |
204 | $output .= "$text\nGO\n"; |
7a0ceaa1 |
205 | } |
206 | |
207 | # Text of procedure already has the 'create procedure' stuff |
208 | # so there is no need to do anything fancy. However, we should |
209 | # think about doing fancy stuff with granting permissions and |
210 | # so on. |
211 | foreach ( $schema->get_procedures ) { |
212 | my $name = $_->name(); |
213 | $output .= "\n\n"; |
5c5997ef |
214 | $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments; |
3e0bcbfd |
215 | my $text = $_->sql(); |
028386aa |
216 | $text =~ s/\r//g; |
5bb0a4ee |
217 | $output .= "$text\nGO\n"; |
7a0ceaa1 |
218 | } |
7a0ceaa1 |
219 | |
220 | =head1 SEE ALSO |
221 | |
22c0c10f |
222 | L<SQL::Translator> |
7a0ceaa1 |
223 | |
224 | =head1 AUTHORS |
225 | |
22c0c10f |
226 | See the included AUTHORS file: |
227 | L<http://search.cpan.org/dist/SQL-Translator/AUTHORS> |
228 | |
229 | =head1 COPYRIGHT |
230 | |
231 | Copyright (c) 2012 the SQL::Translator L</AUTHORS> as listed above. |
232 | |
233 | =head1 LICENSE |
234 | |
235 | This code is free software and may be distributed under the same terms as Perl |
236 | itself. |
7a0ceaa1 |
237 | |
238 | =cut |