6069a75ebc9d1f9da9631da1db3fcdf3ae21e0ec
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Sybase.pm
1 package DBIx::Class::Schema::Loader::DBI::Sybase;
2
3 use strict;
4 use warnings;
5 use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
6 use mro 'c3';
7 use List::MoreUtils 'any';
8 use namespace::clean;
9
10 use DBIx::Class::Schema::Loader::Table::Sybase ();
11
12 our $VERSION = '0.07020';
13
14 =head1 NAME
15
16 DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI
17 Sybase ASE Implementation.
18
19 =head1 DESCRIPTION
20
21 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
22
23 This class reblesses into the L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> class for connections to MSSQL.
24
25 =cut
26
27 sub _rebless {
28     my $self = shift;
29
30     my $dbh = $self->schema->storage->dbh;
31     my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2];
32     if ($DBMS_VERSION =~ /^Microsoft /i) {
33         $DBMS_VERSION =~ s/\s/_/g;
34         my $subclass = "DBIx::Class::Schema::Loader::DBI::Sybase::$DBMS_VERSION";
35         if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
36             bless $self, $subclass;
37             $self->_rebless;
38       }
39     }
40 }
41
42 sub _system_databases {
43     return (qw/
44         master model sybsystemdb sybsystemprocs tempdb
45     /);
46 }
47
48 sub _system_tables {
49     return (qw/
50         sysquerymetrics
51     /);
52 }
53
54 sub _setup {
55     my $self = shift;
56
57     $self->next::method(@_);
58
59     $self->preserve_case(1);
60
61     my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
62
63     if (ref $self->db_schema eq 'HASH') {
64         if (keys %{ $self->db_schema } < 2) {
65             my ($db) = keys %{ $self->db_schema };
66
67             $db ||= $current_db;
68
69             if ($db eq '%') {
70                 my $owners = $self->db_schema->{$db};
71
72                 my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
73 SELECT name
74 FROM master.dbo.sysdatabases
75 EOF
76
77                 my @dbs;
78
79                 foreach my $db_name (@$db_names) {
80                     push @dbs, $db_name
81                         unless any { $_ eq $db_name } $self->_system_databases;
82                 }
83
84                 $self->db_schema({});
85
86                 DB: foreach my $db (@dbs) {
87                     if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
88                         my @owners;
89
90                         foreach my $owner (@$owners) {
91                             push @owners, $owner
92                                 if defined $self->_uid($db, $owner);
93                         }
94
95                         next DB unless @owners;
96
97                         $self->db_schema->{$db} = \@owners;
98                     }
99                     else {
100                         # for post-processing below
101                         $self->db_schema->{$db} = '%';
102                     }
103                 }
104
105                 $self->qualify_objects(1);
106             }
107             else {
108                 if ($db ne $current_db) {
109                     $self->dbh->do("USE [$db]");
110
111                     $self->qualify_objects(1);
112                 }
113             }
114         }
115         else {
116             $self->qualify_objects(1);
117         }
118     }
119     elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
120         my $owners = $self->db_schema;
121         $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ];
122
123         $self->qualify_objects(1) if @$owners > 1;
124
125         $self->db_schema({ $current_db => $owners });
126     }
127
128     foreach my $db (keys %{ $self->db_schema }) {
129         if ($self->db_schema->{$db} eq '%') {
130             my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
131 SELECT name
132 FROM [$db].dbo.sysusers
133 WHERE uid <> gid
134 EOF
135             $self->db_schema->{$db} = $owners;
136
137             $self->qualify_objects(1);
138         }
139     }
140 }
141
142 sub _tables_list {
143     my ($self, $opts) = @_;
144
145     my @tables;
146
147     while (my ($db, $owners) = each %{ $self->db_schema }) {
148         foreach my $owner (@$owners) {
149             my ($uid) = $self->_uid($db, $owner);
150
151             my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
152 SELECT name
153 FROM [$db].dbo.sysobjects
154 WHERE uid = $uid
155     AND type IN ('U', 'V')
156 EOF
157
158             TABLE: foreach my $table_name (@$table_names) {
159                 next TABLE if any { $_ eq $table_name } $self->_system_tables;
160
161                 push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
162                     loader   => $self,
163                     name     => $table_name,
164                     database => $db,
165                     schema   => $owner,
166                 );
167             }
168         }
169     }
170
171     return $self->_filter_tables(\@tables, $opts);
172 }
173
174 sub _uid {
175     my ($self, $db, $owner) = @_;
176
177     my ($uid) = $self->dbh->selectrow_array(<<"EOF");
178 SELECT uid
179 FROM [$db].dbo.sysusers
180 WHERE name = @{[ $self->dbh->quote($owner) ]}
181 EOF
182
183     return $uid;
184 }
185
186 sub _table_columns {
187     my ($self, $table) = @_;
188
189     my $db    = $table->database;
190     my $owner = $table->schema;
191
192     my $columns = $self->dbh->selectcol_arrayref(<<"EOF");
193 SELECT c.name
194 FROM [$db].dbo.syscolumns c
195 JOIN [$db].dbo.sysobjects o
196     ON c.id = o.id
197 WHERE o.name = @{[ $self->dbh->quote($table->name) ]}
198     AND o.type IN ('U', 'V')
199     AND o.uid  = @{[ $self->_uid($db, $owner) ]}
200 ORDER BY c.colid ASC
201 EOF
202
203     return $columns;
204 }
205
206 sub _table_pk_info {
207     my ($self, $table) = @_;
208
209     my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
210
211     my $db = $table->database;
212
213     $self->dbh->do("USE [$db]");
214
215     local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
216
217     my $sth = $self->dbh->prepare(<<"EOF");
218 sp_pkeys @{[ $self->dbh->quote($table->name) ]}, 
219     @{[ $self->dbh->quote($table->schema) ]},
220     @{[ $self->dbh->quote($db) ]}
221 EOF
222     $sth->execute;
223
224     my @keydata;
225
226     while (my $row = $sth->fetchrow_hashref) {
227         push @keydata, $row->{column_name};
228     }
229
230     $self->dbh->do("USE [$current_db]");
231
232     return \@keydata;
233 }
234
235 sub _table_fk_info {
236     my ($self, $table) = @_;
237
238     my $db    = $table->database;
239     my $owner = $table->schema;
240
241     my $sth = $self->dbh->prepare(<<"EOF");
242 SELECT sr.reftabid, sd2.name, sr.keycnt,
243     fokey1,  fokey2,   fokey3,   fokey4,   fokey5,   fokey6,   fokey7,   fokey8,
244     fokey9,  fokey10,  fokey11,  fokey12,  fokey13,  fokey14,  fokey15,  fokey16,
245     refkey1, refkey2,  refkey3,  refkey4,  refkey5,  refkey6,  refkey7,  refkey8,
246     refkey9, refkey10, refkey11, refkey12, refkey13, refkey14, refkey15, refkey16
247 FROM [$db].dbo.sysreferences sr
248 JOIN [$db].dbo.sysobjects so1
249     ON sr.tableid = so1.id
250 JOIN [$db].dbo.sysusers su1
251     ON so1.uid = su1.uid
252 JOIN master.dbo.sysdatabases sd2
253     ON sr.pmrydbid = sd2.dbid
254 WHERE so1.name = @{[ $self->dbh->quote($table->name) ]}
255     AND su1.name = @{[ $self->dbh->quote($table->schema) ]}
256 EOF
257     $sth->execute;
258
259     my @rels;
260
261     REL: while (my @rel = $sth->fetchrow_array) {
262         my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3;
263
264         my ($remote_tab_owner, $remote_tab_name) =
265             $self->dbh->selectrow_array(<<"EOF");
266 SELECT su.name, so.name
267 FROM [$remote_db].dbo.sysusers su
268 JOIN [$remote_db].dbo.sysobjects so
269     ON su.uid = so.uid
270 WHERE so.id = $remote_tab_id
271 EOF
272
273         next REL
274             unless any { $_ eq $remote_tab_owner }
275                 @{ $self->db_schema->{$remote_db} || [] };
276
277         my @local_col_ids  = splice @rel, 0, 16;
278         my @remote_col_ids = splice @rel, 0, 16;
279
280         @local_col_ids  = splice @local_col_ids,  0, $key_cnt;
281         @remote_col_ids = splice @remote_col_ids, 0, $key_cnt;
282
283         my $remote_table = DBIx::Class::Schema::Loader::Table::Sybase->new(
284             loader   => $self,
285             name     => $remote_tab_name,
286             database => $remote_db,
287             schema   => $remote_tab_owner,
288         );
289
290         my $all_local_cols  = $self->_table_columns($table);
291         my $all_remote_cols = $self->_table_columns($remote_table);
292
293         my @local_cols  = map $all_local_cols->[$_-1],  @local_col_ids;
294         my @remote_cols = map $all_remote_cols->[$_-1], @remote_col_ids;
295
296         next REL if    (any { not defined $_ } @local_cols)
297                     || (any { not defined $_ } @remote_cols);
298
299         push @rels, {
300             local_columns  => \@local_cols,
301             remote_table   => $remote_table,
302             remote_columns => \@remote_cols,
303         };
304     };
305
306     return \@rels;
307 }
308
309 sub _table_uniq_info {
310     my ($self, $table) = @_;
311
312     my $db    = $table->database;
313     my $owner = $table->schema;
314     my $uid   = $self->_uid($db, $owner);
315
316     my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
317
318     $self->dbh->do("USE [$db]");
319
320     my $sth = $self->dbh->prepare(<<"EOF");
321 SELECT si.name, si.indid, si.keycnt
322 FROM [$db].dbo.sysindexes si
323 JOIN [$db].dbo.sysobjects so
324     ON si.id = so.id
325 WHERE so.name = @{[ $self->dbh->quote($table->name) ]}
326     AND so.uid = $uid
327     AND si.indid > 0
328     AND si.status & 2048 <> 2048
329     AND si.status2 & 2 = 2
330 EOF
331     $sth->execute;
332
333     my %uniqs;
334
335     while (my ($ind_name, $ind_id, $key_cnt) = $sth->fetchrow_array) {
336         COLS: foreach my $col_idx (1 .. ($key_cnt+1)) {
337             my ($next_col) = $self->dbh->selectrow_array(<<"EOF");
338 SELECT index_col(
339     @{[ $self->dbh->quote($table->name) ]},
340     $ind_id, $col_idx, $uid
341 )
342 EOF
343             last COLS unless defined $next_col;
344
345             push @{ $uniqs{$ind_name} }, $next_col;
346         }
347     }
348
349     my @uniqs = map { [ $_ => $uniqs{$_} ] } keys %uniqs;
350
351     $self->dbh->do("USE [$current_db]");
352
353     return \@uniqs;
354 }
355
356 sub _columns_info_for {
357     my $self    = shift;
358     my ($table) = @_;
359     my $result  = $self->next::method(@_);
360
361     my $db    = $table->database;
362     my $owner = $table->schema;
363     my $uid   = $self->_uid($db, $owner);
364
365     local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
366     my $sth = $self->dbh->prepare(<<"EOF");
367 SELECT c.name name, bt.name base_type, ut.name user_type, cm.text deflt, c.prec prec, c.scale scale, c.length len
368 FROM [$db].dbo.syscolumns c
369 JOIN [$db].dbo.sysobjects o ON c.id = o.id
370 LEFT JOIN [$db].dbo.systypes bt ON c.type     = bt.type 
371 LEFT JOIN [$db].dbo.systypes ut ON c.usertype = ut.usertype
372 LEFT JOIN [$db].dbo.syscomments cm
373     ON cm.id = CASE WHEN c.cdefault = 0 THEN c.computedcol ELSE c.cdefault END
374 WHERE o.name = @{[ $self->dbh->quote($table) ]}
375     AND o.uid = $uid
376     AND o.type IN ('U', 'V')
377 EOF
378     $sth->execute;
379     my $info = $sth->fetchall_hashref('name');
380
381     while (my ($col, $res) = each %$result) {
382         my $data_type = $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type};
383  
384         # check if it's an IDENTITY column
385         my $sth = $self->dbh->prepare(<<"EOF");
386 SELECT name
387 FROM [$db].dbo.syscolumns
388 WHERE id = (
389     SELECT id
390     FROM [$db].dbo.sysobjects
391     WHERE name = @{[ $self->dbh->quote($table->name) ]}
392         AND uid = $uid
393 )
394     AND (status & 0x80) = 0x80
395     AND name = @{[ $self->dbh->quote($col) ]}
396 EOF
397         $sth->execute;
398
399         if ($sth->fetchrow_array) {
400             $res->{is_auto_increment} = 1;
401         }
402
403         if ($data_type && $data_type =~ /^timestamp\z/i) {
404             $res->{inflate_datetime} = 0;
405         }
406
407         if (my $default = $info->{$col}{deflt}) {
408             if ($default =~ /^AS \s+ (\S+)/ix) {
409                 my $function = $1;
410                 $res->{default_value} = \$function;
411
412                 if ($function =~ /^getdate\b/) {
413                     $res->{inflate_datetime} = 1;
414                 }
415
416                 delete $res->{size};
417                 $res->{data_type} = undef;
418             }
419             elsif ($default =~ /^DEFAULT \s+ (\S+)/ix) {
420                 my ($constant_default) = $1 =~ /^['"\[\]]?(.*?)['"\[\]]?\z/;
421                 $res->{default_value} = $constant_default;
422             }
423         }
424
425         if (my $data_type = $res->{data_type}) {
426             if ($data_type eq 'int') {
427                 $data_type = $res->{data_type} = 'integer';
428             }
429             elsif ($data_type eq 'decimal') {
430                 $data_type = $res->{data_type} = 'numeric';
431             }
432
433             if ($data_type =~ /^(?:text|unitext|image|bigint|integer|smallint|tinyint|real|double|double precision|float|date|time|datetime|smalldatetime|money|smallmoney|timestamp|bit)\z/i) {
434                 delete $res->{size};
435             }
436             elsif ($data_type eq 'numeric') {
437                 my ($prec, $scale) = @{$info->{$col}}{qw/prec scale/};
438
439                 if ($prec == 18 && $scale == 0) {
440                     delete $res->{size};
441                 }
442                 else {
443                     $res->{size} = [ $prec, $scale ];
444                 }
445             }
446             elsif ($data_type =~ /char/) {
447                 $res->{size} = $info->{$col}{len};
448
449                 if ($data_type =~ /^(?:unichar|univarchar)\z/i) {
450                     $res->{size} /= 2;
451                 }
452             }
453         }
454
455         if ($data_type eq 'float') {
456             $res->{data_type} = $info->{$col}{len} <= 4 ? 'real' : 'double precision';
457         }
458     }
459
460     return $result;
461 }
462
463 =head1 SEE ALSO
464
465 L<DBIx::Class::Schema::Loader::DBI::Sybase::Common>,
466 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
467 L<DBIx::Class::Schema::Loader::DBI>
468
469 =head1 AUTHOR
470
471 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
472
473 =head1 LICENSE
474
475 This library is free software; you can redistribute it and/or modify it under
476 the same terms as Perl itself.
477
478 =cut
479
480 1;
481 # vim:et sts=4 sw=4 tw=0: