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 | |
8990a2b2 |
11 | our $VERSION = '0.07028'; |
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 | |
168 | sub _table_fk_info { |
169 | my ($self, $table) = @_; |
170 | |
171 | my ($local_cols, $remote_cols, $remote_table, @rels); |
c4a69b87 |
172 | my $sth = $self->dbh->prepare(<<'EOF'); |
173 | 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 |
174 | FROM sysfkey fk |
175 | JOIN systab pkt |
176 | ON fk.primary_table_id = pkt.table_id |
177 | JOIN sysuser pku |
178 | ON pkt.creator = pku.user_id |
179 | JOIN systab fkt |
180 | ON fk.foreign_table_id = fkt.table_id |
181 | JOIN sysuser fku |
182 | ON fkt.creator = fku.user_id |
183 | JOIN sysidx pki |
184 | ON fk.primary_table_id = pki.table_id AND fk.primary_index_id = pki.index_id |
185 | JOIN sysidx fki |
186 | ON fk.foreign_table_id = fki.table_id AND fk.foreign_index_id = fki.index_id |
187 | JOIN sysidxcol fkic |
188 | ON fkt.table_id = fkic.table_id AND fki.index_id = fkic.index_id |
189 | JOIN systabcol pktc |
190 | ON pkt.table_id = pktc.table_id AND fkic.primary_column_id = pktc.column_id |
191 | JOIN systabcol fktc |
192 | ON fkt.table_id = fktc.table_id AND fkic.column_id = fktc.column_id |
193 | WHERE fku.user_name = ? AND fkt.table_name = ? |
8793567f |
194 | EOF |
c4a69b87 |
195 | $sth->execute($table->schema, $table->name); |
8793567f |
196 | |
c4a69b87 |
197 | while (my ($fk, $local_col, $remote_schema, $remote_tab, $remote_col) = $sth->fetchrow_array) { |
dd87d4c4 |
198 | push @{$local_cols->{$fk}}, $self->_lc($local_col); |
199 | push @{$remote_cols->{$fk}}, $self->_lc($remote_col); |
c4a69b87 |
200 | $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new( |
201 | loader => $self, |
202 | name => $remote_tab, |
203 | schema => $remote_schema, |
204 | ); |
8793567f |
205 | } |
206 | |
207 | foreach my $fk (keys %$remote_table) { |
208 | push @rels, { |
ed577901 |
209 | local_columns => $local_cols->{$fk}, |
210 | remote_columns => $remote_cols->{$fk}, |
8793567f |
211 | remote_table => $remote_table->{$fk}, |
212 | }; |
213 | } |
214 | return \@rels; |
215 | } |
216 | |
217 | sub _table_uniq_info { |
218 | my ($self, $table) = @_; |
219 | |
c4a69b87 |
220 | my $sth = $self->dbh->prepare(<<'EOF'); |
221 | SELECT c.constraint_name, tc.column_name |
222 | FROM sysconstraint c |
223 | JOIN systab t |
224 | ON c.table_object_id = t.object_id |
225 | JOIN sysuser u |
226 | ON t.creator = u.user_id |
227 | JOIN sysidx i |
228 | ON c.ref_object_id = i.object_id |
229 | JOIN sysidxcol ic |
230 | ON i.table_id = ic.table_id AND i.index_id = ic.index_id |
231 | JOIN systabcol tc |
232 | ON ic.table_id = tc.table_id AND ic.column_id = tc.column_id |
233 | WHERE c.constraint_type = 'U' AND u.user_name = ? AND t.table_name = ? |
8793567f |
234 | EOF |
c4a69b87 |
235 | $sth->execute($table->schema, $table->name); |
8793567f |
236 | |
237 | my $constraints; |
238 | while (my ($constraint_name, $column) = $sth->fetchrow_array) { |
dd87d4c4 |
239 | push @{$constraints->{$constraint_name}}, $self->_lc($column); |
8793567f |
240 | } |
241 | |
242 | my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; |
243 | return \@uniqs; |
244 | } |
245 | |
246 | =head1 SEE ALSO |
247 | |
248 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
249 | L<DBIx::Class::Schema::Loader::DBI> |
250 | |
251 | =head1 AUTHOR |
252 | |
253 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
254 | |
255 | =head1 LICENSE |
256 | |
257 | This library is free software; you can redistribute it and/or modify it under |
258 | the same terms as Perl itself. |
259 | |
260 | =cut |
261 | |
262 | 1; |
9dc968df |
263 | # vim:et sw=4 sts=4 tw=0: |