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::Util 'any';
   8 use namespace::clean;
   9
  10 use DBIx::Class::Schema::Loader::Table::Sybase ();
  11
  12 our $VERSION = '0.07047';
  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) = @_;
 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);
 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     $self->dbh->do("USE [$current_db]");
 350
 351     return [ map { [ $_ => $uniqs{$_} ] } sort keys %uniqs ];
 352 }
 353
 354 sub _columns_info_for {
 355     my $self    = shift;
 356     my ($table) = @_;
 357     my $result  = $self->next::method(@_);
 358
 359     my $db    = $table->database;
 360     my $owner = $table->schema;
 361     my $uid   = $self->_uid($db, $owner);
 362
 363     local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
 364     my $sth = $self->dbh->prepare(<<"EOF");
 365 SELECT c.name, bt.name base_type, ut.name user_type, c.prec prec, c.scale scale, c.length len, c.cdefault dflt_id, c.computedcol comp_id, (c.status & 0x80) is_id
 366 FROM [$db].dbo.syscolumns c
 367 LEFT JOIN [$db].dbo.sysobjects o  ON c.id       = o.id
 368 LEFT JOIN [$db].dbo.systypes   bt ON c.type     = bt.type
 369 LEFT JOIN [$db].dbo.systypes   ut ON c.usertype = ut.usertype
 370 WHERE o.name = @{[ $self->dbh->quote($table) ]}
 371     AND o.uid = $uid
 372     AND o.type IN ('U', 'V')
 373 EOF
 374     $sth->execute;
 375     my $info = $sth->fetchall_hashref('name');
 376
 377     while (my ($col, $res) = each %$result) {
 378         $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type};
 379
 380         if ($info->{$col}{is_id}) {
 381             $res->{is_auto_increment} = 1;
 382         }
 383         $sth->finish;
 384
 385         # column has default value
 386         if (my $default_id = $info->{$col}{dflt_id}) {
 387             my $sth = $self->dbh->prepare(<<"EOF");
 388 SELECT cm.id, cm.text
 389 FROM [$db].dbo.syscomments cm
 390 WHERE cm.id = $default_id
 391 EOF
 392             $sth->execute;
 393
 394             if (my ($d_id, $default) = $sth->fetchrow_array) {
 395                 my $constant_default = ($default =~ /^DEFAULT \s+ (\S.*\S)/ix)
 396                     ? $1
 397                     : $default;
 398
 399                 $constant_default = substr($constant_default, 1, length($constant_default) - 2)
 400                     if (   substr($constant_default, 0, 1) =~ m{['"\[]}
 401                         && substr($constant_default, -1)   =~ m{['"\]]});
 402
 403                 $res->{default_value} = $constant_default;
 404             }
 405         }
 406
 407         # column is a computed value
 408         if (my $comp_id = $info->{$col}{comp_id}) {
 409             my $sth = $self->dbh->prepare(<<"EOF");
 410 SELECT cm.id, cm.text
 411 FROM [$db].dbo.syscomments cm
 412 WHERE cm.id = $comp_id
 413 EOF
 414             $sth->execute;
 415             if (my ($c_id, $comp) = $sth->fetchrow_array) {
 416                 my $function = ($comp =~ /^AS \s+ (\S+)/ix) ? $1 : $comp;
 417                 $res->{default_value} = \$function;
 418
 419                 if ($function =~ /^getdate\b/) {
 420                     $res->{inflate_datetime} = 1;
 421                 }
 422
 423                 delete $res->{size};
 424                 $res->{data_type} = undef;
 425             }
 426         }
 427
 428         if (my $data_type = $res->{data_type}) {
 429             if ($data_type eq 'int') {
 430                 $data_type = $res->{data_type} = 'integer';
 431             }
 432             elsif ($data_type eq 'decimal') {
 433                 $data_type = $res->{data_type} = 'numeric';
 434             }
 435             elsif ($data_type eq 'float') {
 436                 $data_type = $res->{data_type}
 437                     = ($info->{$col}{len} <= 4 ? 'real' : 'double precision');
 438             }
 439
 440             if ($data_type eq 'timestamp') {
 441                 $res->{inflate_datetime} = 0;
 442             }
 443
 444             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) {
 445                 delete $res->{size};
 446             }
 447             elsif ($data_type eq 'numeric') {
 448                 my ($prec, $scale) = @{$info->{$col}}{qw/prec scale/};
 449
 450                 if (!defined $prec && !defined $scale) {
 451                     $data_type = $res->{data_type} = 'integer';
 452                     delete $res->{size};
 453                 }
 454                 elsif ($prec == 18 && $scale == 0) {
 455                     delete $res->{size};
 456                 }
 457                 else {
 458                     $res->{size} = [ $prec, $scale ];
 459                 }
 460             }
 461             elsif ($data_type =~ /char/) {
 462                 $res->{size} = $info->{$col}{len};
 463
 464                 if ($data_type =~ /^(?:unichar|univarchar)\z/i) {
 465                     $res->{size} /= 2;
 466                 }
 467                 elsif ($data_type =~ /^n(?:var)?char\z/i) {
 468                     my ($nchar_size) = $self->dbh->selectrow_array('SELECT @@ncharsize');
 469
 470                     $res->{size} /= $nchar_size;
 471                 }
 472             }
 473         }
 474     }
 475
 476     return $result;
 477 }
 478
 479 =head1 SEE ALSO
 480
 481 L<DBIx::Class::Schema::Loader::DBI::Sybase::Common>,
 482 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 483 L<DBIx::Class::Schema::Loader::DBI>
 484
 485 =head1 AUTHORS
 486
 487 See L<DBIx::Class::Schema::Loader/AUTHORS>.
 488
 489 =head1 LICENSE
 490
 491 This library is free software; you can redistribute it and/or modify it under
 492 the same terms as Perl itself.
 493
 494 =cut
 495
 496 1;
 497 # vim:et sts=4 sw=4 tw=0: