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