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.07019';
  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: