Commit | Line | Data |
8793567f |
1 | package DBIx::Class::Schema::Loader::DBI::SQLAnywhere; |
2 | |
3 | use strict; |
4 | use warnings; |
383bd2a8 |
5 | use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault'; |
c4a69b87 |
6 | use mro 'c3'; |
7 | use List::MoreUtils 'any'; |
8 | use namespace::clean; |
2fa86d8b |
9 | use DBIx::Class::Schema::Loader::Table (); |
8793567f |
10 | |
802a1175 |
11 | our $VERSION = '0.07041'; |
8793567f |
12 | |
13 | =head1 NAME |
14 | |
15 | DBIx::Class::Schema::Loader::DBI::SQLAnywhere - DBIx::Class::Schema::Loader::DBI |
16 | SQL Anywhere Implementation. |
17 | |
18 | =head1 DESCRIPTION |
19 | |
bc5afe55 |
20 | See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. |
8793567f |
21 | |
22 | =cut |
23 | |
c4a69b87 |
24 | sub _system_schemas { |
25 | return (qw/dbo SYS diagnostics rs_systabgroup SA_DEBUG/); |
26 | } |
27 | |
d6a0cc27 |
28 | sub _setup { |
29 | my $self = shift; |
30 | |
bc1cb85e |
31 | $self->next::method(@_); |
32 | |
c4a69b87 |
33 | $self->preserve_case(1) |
34 | unless defined $self->preserve_case; |
35 | |
36 | $self->schema->storage->sql_maker->quote_char('"'); |
37 | $self->schema->storage->sql_maker->name_sep('.'); |
38 | |
39 | $self->db_schema([($self->dbh->selectrow_array('select user'))[0]]) |
40 | unless $self->db_schema; |
41 | |
42 | if (ref $self->db_schema eq 'ARRAY' && $self->db_schema->[0] eq '%') { |
43 | my @users = grep { my $uname = $_; not any { $_ eq $uname } $self->_system_schemas } |
44 | @{ $self->dbh->selectcol_arrayref('select user_name from sysuser') }; |
45 | |
46 | $self->db_schema(\@users); |
47 | } |
d6a0cc27 |
48 | } |
49 | |
50 | sub _tables_list { |
bfb43060 |
51 | my ($self, $opts) = @_; |
d6a0cc27 |
52 | |
c4a69b87 |
53 | my @tables; |
54 | |
55 | foreach my $schema (@{ $self->db_schema }) { |
56 | my $sth = $self->dbh->prepare(<<'EOF'); |
57 | SELECT t.table_name name |
58 | FROM systab t |
59 | JOIN sysuser u |
60 | ON t.creator = u.user_id |
61 | WHERE u.user_name = ? |
d6a0cc27 |
62 | EOF |
c4a69b87 |
63 | $sth->execute($schema); |
d6a0cc27 |
64 | |
c4a69b87 |
65 | my @table_names = map @$_, @{ $sth->fetchall_arrayref }; |
66 | |
67 | foreach my $table_name (@table_names) { |
68 | push @tables, DBIx::Class::Schema::Loader::Table->new( |
69 | loader => $self, |
70 | name => $table_name, |
71 | schema => $schema, |
72 | ); |
73 | } |
74 | } |
d6a0cc27 |
75 | |
bfb43060 |
76 | return $self->_filter_tables(\@tables, $opts); |
d6a0cc27 |
77 | } |
78 | |
8793567f |
79 | sub _columns_info_for { |
9dc968df |
80 | my $self = shift; |
81 | my ($table) = @_; |
82 | |
8793567f |
83 | my $result = $self->next::method(@_); |
84 | |
9dc968df |
85 | my $dbh = $self->schema->storage->dbh; |
86 | |
dd87d4c4 |
87 | while (my ($col, $info) = each %$result) { |
8793567f |
88 | my $def = $info->{default_value}; |
89 | if (ref $def eq 'SCALAR' && $$def eq 'autoincrement') { |
90 | delete $info->{default_value}; |
91 | $info->{is_auto_increment} = 1; |
92 | } |
9dc968df |
93 | |
116431d6 |
94 | my ($user_type) = $dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, lc($col)); |
9dc968df |
95 | SELECT ut.type_name |
96 | FROM systabcol tc |
c4a69b87 |
97 | JOIN systab t |
98 | ON tc.table_id = t.table_id |
99 | JOIN sysuser u |
100 | ON t.creator = u.user_id |
101 | JOIN sysusertype ut |
102 | ON tc.user_type = ut.type_id |
116431d6 |
103 | WHERE u.user_name = ? AND t.table_name = ? AND lower(tc.column_name) = ? |
9dc968df |
104 | EOF |
105 | $info->{data_type} = $user_type if defined $user_type; |
106 | |
107 | if ($info->{data_type} eq 'double') { |
108 | $info->{data_type} = 'double precision'; |
109 | } |
110 | |
111 | if ($info->{data_type} =~ /^(?:char|varchar|binary|varbinary)\z/ && ref($info->{size}) eq 'ARRAY') { |
112 | $info->{size} = $info->{size}[0]; |
113 | } |
114 | elsif ($info->{data_type} !~ /^(?:char|varchar|binary|varbinary|numeric|decimal)\z/) { |
115 | delete $info->{size}; |
116 | } |
117 | |
118 | my $sth = $dbh->prepare(<<'EOF'); |
119 | SELECT tc.width, tc.scale |
120 | FROM systabcol tc |
c4a69b87 |
121 | JOIN systab t |
122 | ON t.table_id = tc.table_id |
123 | JOIN sysuser u |
124 | ON t.creator = u.user_id |
116431d6 |
125 | WHERE u.user_name = ? AND t.table_name = ? AND lower(tc.column_name) = ? |
9dc968df |
126 | EOF |
116431d6 |
127 | $sth->execute($table->schema, $table->name, lc($col)); |
9dc968df |
128 | my ($width, $scale) = $sth->fetchrow_array; |
129 | $sth->finish; |
130 | |
131 | if ($info->{data_type} =~ /^(?:numeric|decimal)\z/) { |
132 | # We do not check for the default precision/scale, because they can be changed as PUBLIC database options. |
133 | $info->{size} = [$width, $scale]; |
134 | } |
135 | elsif ($info->{data_type} =~ /^(?:n(?:varchar|char) | varbit)\z/x) { |
136 | $info->{size} = $width; |
137 | } |
dd87d4c4 |
138 | elsif ($info->{data_type} eq 'float') { |
139 | $info->{data_type} = 'real'; |
140 | } |
9dc968df |
141 | |
268cc246 |
142 | if ((eval { lc ${ $info->{default_value} } }||'') eq 'current timestamp') { |
6e566cc4 |
143 | ${ $info->{default_value} } = 'current_timestamp'; |
701cd3e3 |
144 | |
145 | my $orig_deflt = 'current timestamp'; |
146 | $info->{original}{default_value} = \$orig_deflt; |
8a64178e |
147 | } |
8793567f |
148 | } |
149 | |
150 | return $result; |
151 | } |
152 | |
153 | sub _table_pk_info { |
154 | my ($self, $table) = @_; |
c4a69b87 |
155 | local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; |
156 | my $sth = $self->dbh->prepare(qq{sp_pkeys ?, ?}); |
157 | $sth->execute($table->name, $table->schema); |
8793567f |
158 | |
159 | my @keydata; |
160 | |
161 | while (my $row = $sth->fetchrow_hashref) { |
dd87d4c4 |
162 | push @keydata, $self->_lc($row->{column_name}); |
8793567f |
163 | } |
164 | |
165 | return \@keydata; |
166 | } |
167 | |
4b5eca90 |
168 | my %sqlany_rules = ( |
169 | C => 'CASCADE', |
170 | D => 'SET DEFAULT', |
171 | N => 'SET NULL', |
172 | R => 'RESTRICT', |
173 | ); |
174 | |
8793567f |
175 | sub _table_fk_info { |
176 | my ($self, $table) = @_; |
177 | |
4b5eca90 |
178 | my ($local_cols, $remote_cols, $remote_table, $attrs, @rels); |
c4a69b87 |
179 | my $sth = $self->dbh->prepare(<<'EOF'); |
4b5eca90 |
180 | SELECT fki.index_name fk_name, fktc.column_name local_column, pku.user_name remote_schema, pkt.table_name remote_table, pktc.column_name remote_column, on_delete.referential_action, on_update.referential_action |
c4a69b87 |
181 | FROM sysfkey fk |
4b5eca90 |
182 | JOIN ( |
183 | select foreign_table_id, foreign_index_id, |
184 | row_number() over (partition by foreign_table_id order by foreign_index_id) foreign_key_num |
185 | from sysfkey |
186 | ) fkid |
187 | ON fkid.foreign_table_id = fk.foreign_table_id and fkid.foreign_index_id = fk.foreign_index_id |
c4a69b87 |
188 | JOIN systab pkt |
189 | ON fk.primary_table_id = pkt.table_id |
190 | JOIN sysuser pku |
191 | ON pkt.creator = pku.user_id |
192 | JOIN systab fkt |
193 | ON fk.foreign_table_id = fkt.table_id |
194 | JOIN sysuser fku |
195 | ON fkt.creator = fku.user_id |
196 | JOIN sysidx pki |
197 | ON fk.primary_table_id = pki.table_id AND fk.primary_index_id = pki.index_id |
198 | JOIN sysidx fki |
199 | ON fk.foreign_table_id = fki.table_id AND fk.foreign_index_id = fki.index_id |
200 | JOIN sysidxcol fkic |
201 | ON fkt.table_id = fkic.table_id AND fki.index_id = fkic.index_id |
202 | JOIN systabcol pktc |
203 | ON pkt.table_id = pktc.table_id AND fkic.primary_column_id = pktc.column_id |
204 | JOIN systabcol fktc |
205 | ON fkt.table_id = fktc.table_id AND fkic.column_id = fktc.column_id |
4b5eca90 |
206 | LEFT JOIN systrigger on_delete |
207 | ON on_delete.foreign_table_id = fkt.table_id AND on_delete.foreign_key_id = fkid.foreign_key_num |
208 | AND on_delete.event = 'D' |
209 | LEFT JOIN systrigger on_update |
210 | ON on_update.foreign_table_id = fkt.table_id AND on_update.foreign_key_id = fkid.foreign_key_num |
211 | AND on_update.event = 'C' |
c4a69b87 |
212 | WHERE fku.user_name = ? AND fkt.table_name = ? |
4b5eca90 |
213 | ORDER BY fk.primary_table_id, pktc.column_id |
8793567f |
214 | EOF |
c4a69b87 |
215 | $sth->execute($table->schema, $table->name); |
8793567f |
216 | |
4b5eca90 |
217 | while (my ($fk, $local_col, $remote_schema, $remote_tab, $remote_col, $on_delete, $on_update) |
218 | = $sth->fetchrow_array) { |
219 | |
dd87d4c4 |
220 | push @{$local_cols->{$fk}}, $self->_lc($local_col); |
4b5eca90 |
221 | |
dd87d4c4 |
222 | push @{$remote_cols->{$fk}}, $self->_lc($remote_col); |
4b5eca90 |
223 | |
c4a69b87 |
224 | $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new( |
225 | loader => $self, |
226 | name => $remote_tab, |
227 | schema => $remote_schema, |
228 | ); |
4b5eca90 |
229 | |
230 | $attrs->{$fk} ||= { |
231 | on_delete => $sqlany_rules{$on_delete||''} || 'RESTRICT', |
232 | on_update => $sqlany_rules{$on_update||''} || 'RESTRICT', |
233 | # We may be able to use the value of the 'CHECK ON COMMIT' option, as it seems |
234 | # to be some sort of workaround for lack of deferred constraints. Unclear on |
235 | # how good of a substitute it is, and it requires the 'RESTRICT' rule. Also it |
236 | # only works for INSERT and UPDATE, not DELETE. Will get back to this. |
237 | is_deferrable => 1, |
238 | }; |
8793567f |
239 | } |
240 | |
241 | foreach my $fk (keys %$remote_table) { |
242 | push @rels, { |
ed577901 |
243 | local_columns => $local_cols->{$fk}, |
244 | remote_columns => $remote_cols->{$fk}, |
8793567f |
245 | remote_table => $remote_table->{$fk}, |
4b5eca90 |
246 | attrs => $attrs->{$fk}, |
8793567f |
247 | }; |
248 | } |
249 | return \@rels; |
250 | } |
251 | |
252 | sub _table_uniq_info { |
253 | my ($self, $table) = @_; |
254 | |
c4a69b87 |
255 | my $sth = $self->dbh->prepare(<<'EOF'); |
256 | SELECT c.constraint_name, tc.column_name |
257 | FROM sysconstraint c |
258 | JOIN systab t |
259 | ON c.table_object_id = t.object_id |
260 | JOIN sysuser u |
261 | ON t.creator = u.user_id |
262 | JOIN sysidx i |
263 | ON c.ref_object_id = i.object_id |
264 | JOIN sysidxcol ic |
265 | ON i.table_id = ic.table_id AND i.index_id = ic.index_id |
266 | JOIN systabcol tc |
267 | ON ic.table_id = tc.table_id AND ic.column_id = tc.column_id |
268 | WHERE c.constraint_type = 'U' AND u.user_name = ? AND t.table_name = ? |
8793567f |
269 | EOF |
c4a69b87 |
270 | $sth->execute($table->schema, $table->name); |
8793567f |
271 | |
272 | my $constraints; |
273 | while (my ($constraint_name, $column) = $sth->fetchrow_array) { |
dd87d4c4 |
274 | push @{$constraints->{$constraint_name}}, $self->_lc($column); |
8793567f |
275 | } |
276 | |
6c4f5a4a |
277 | return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ]; |
8793567f |
278 | } |
279 | |
280 | =head1 SEE ALSO |
281 | |
282 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
283 | L<DBIx::Class::Schema::Loader::DBI> |
284 | |
285 | =head1 AUTHOR |
286 | |
287 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
288 | |
289 | =head1 LICENSE |
290 | |
291 | This library is free software; you can redistribute it and/or modify it under |
292 | the same terms as Perl itself. |
293 | |
294 | =cut |
295 | |
296 | 1; |
9dc968df |
297 | # vim:et sw=4 sts=4 tw=0: |