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