/DBIx-Class-Schema-Loader-0.07025/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm
Perl | 499 lines | 384 code | 111 blank | 4 comment | 46 complexity | f383edc1d13cc2f0899f2cc1a2d3c7cd MD5 | raw file
- package DBIx::Class::Schema::Loader::DBI::Sybase;
- use strict;
- use warnings;
- use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
- use mro 'c3';
- use List::MoreUtils 'any';
- use namespace::clean;
- use DBIx::Class::Schema::Loader::Table::Sybase ();
- our $VERSION = '0.07025';
- =head1 NAME
- DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI
- Sybase ASE Implementation.
- =head1 DESCRIPTION
- See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
- This class reblesses into the L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> class for connections to MSSQL.
- =cut
- sub _rebless {
- my $self = shift;
- my $dbh = $self->schema->storage->dbh;
- my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2];
- if ($DBMS_VERSION =~ /^Microsoft /i) {
- $DBMS_VERSION =~ s/\s/_/g;
- my $subclass = "DBIx::Class::Schema::Loader::DBI::Sybase::$DBMS_VERSION";
- if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
- bless $self, $subclass;
- $self->_rebless;
- }
- }
- }
- sub _system_databases {
- return (qw/
- master model sybsystemdb sybsystemprocs tempdb
- /);
- }
- sub _system_tables {
- return (qw/
- sysquerymetrics
- /);
- }
- sub _setup {
- my $self = shift;
- $self->next::method(@_);
- $self->preserve_case(1);
- my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
- if (ref $self->db_schema eq 'HASH') {
- if (keys %{ $self->db_schema } < 2) {
- my ($db) = keys %{ $self->db_schema };
- $db ||= $current_db;
- if ($db eq '%') {
- my $owners = $self->db_schema->{$db};
- my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
- SELECT name
- FROM master.dbo.sysdatabases
- EOF
- my @dbs;
- foreach my $db_name (@$db_names) {
- push @dbs, $db_name
- unless any { $_ eq $db_name } $self->_system_databases;
- }
- $self->db_schema({});
- DB: foreach my $db (@dbs) {
- if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
- my @owners;
- foreach my $owner (@$owners) {
- push @owners, $owner
- if defined $self->_uid($db, $owner);
- }
- next DB unless @owners;
- $self->db_schema->{$db} = \@owners;
- }
- else {
- # for post-processing below
- $self->db_schema->{$db} = '%';
- }
- }
- $self->qualify_objects(1);
- }
- else {
- if ($db ne $current_db) {
- $self->dbh->do("USE [$db]");
- $self->qualify_objects(1);
- }
- }
- }
- else {
- $self->qualify_objects(1);
- }
- }
- elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
- my $owners = $self->db_schema;
- $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ];
- $self->qualify_objects(1) if @$owners > 1;
- $self->db_schema({ $current_db => $owners });
- }
- foreach my $db (keys %{ $self->db_schema }) {
- if ($self->db_schema->{$db} eq '%') {
- my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
- SELECT name
- FROM [$db].dbo.sysusers
- WHERE uid <> gid
- EOF
- $self->db_schema->{$db} = $owners;
- $self->qualify_objects(1);
- }
- }
- }
- sub _tables_list {
- my ($self, $opts) = @_;
- my @tables;
- while (my ($db, $owners) = each %{ $self->db_schema }) {
- foreach my $owner (@$owners) {
- my ($uid) = $self->_uid($db, $owner);
- my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
- SELECT name
- FROM [$db].dbo.sysobjects
- WHERE uid = $uid
- AND type IN ('U', 'V')
- EOF
- TABLE: foreach my $table_name (@$table_names) {
- next TABLE if any { $_ eq $table_name } $self->_system_tables;
- push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
- loader => $self,
- name => $table_name,
- database => $db,
- schema => $owner,
- );
- }
- }
- }
- return $self->_filter_tables(\@tables, $opts);
- }
- sub _uid {
- my ($self, $db, $owner) = @_;
- my ($uid) = $self->dbh->selectrow_array(<<"EOF");
- SELECT uid
- FROM [$db].dbo.sysusers
- WHERE name = @{[ $self->dbh->quote($owner) ]}
- EOF
- return $uid;
- }
- sub _table_columns {
- my ($self, $table) = @_;
- my $db = $table->database;
- my $owner = $table->schema;
- my $columns = $self->dbh->selectcol_arrayref(<<"EOF");
- SELECT c.name
- FROM [$db].dbo.syscolumns c
- JOIN [$db].dbo.sysobjects o
- ON c.id = o.id
- WHERE o.name = @{[ $self->dbh->quote($table->name) ]}
- AND o.type IN ('U', 'V')
- AND o.uid = @{[ $self->_uid($db, $owner) ]}
- ORDER BY c.colid ASC
- EOF
- return $columns;
- }
- sub _table_pk_info {
- my ($self, $table) = @_;
- my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
- my $db = $table->database;
- $self->dbh->do("USE [$db]");
- local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
- my $sth = $self->dbh->prepare(<<"EOF");
- sp_pkeys @{[ $self->dbh->quote($table->name) ]},
- @{[ $self->dbh->quote($table->schema) ]},
- @{[ $self->dbh->quote($db) ]}
- EOF
- $sth->execute;
- my @keydata;
- while (my $row = $sth->fetchrow_hashref) {
- push @keydata, $row->{column_name};
- }
- $self->dbh->do("USE [$current_db]");
- return \@keydata;
- }
- sub _table_fk_info {
- my ($self, $table) = @_;
- my $db = $table->database;
- my $owner = $table->schema;
- my $sth = $self->dbh->prepare(<<"EOF");
- SELECT sr.reftabid, sd2.name, sr.keycnt,
- fokey1, fokey2, fokey3, fokey4, fokey5, fokey6, fokey7, fokey8,
- fokey9, fokey10, fokey11, fokey12, fokey13, fokey14, fokey15, fokey16,
- refkey1, refkey2, refkey3, refkey4, refkey5, refkey6, refkey7, refkey8,
- refkey9, refkey10, refkey11, refkey12, refkey13, refkey14, refkey15, refkey16
- FROM [$db].dbo.sysreferences sr
- JOIN [$db].dbo.sysobjects so1
- ON sr.tableid = so1.id
- JOIN [$db].dbo.sysusers su1
- ON so1.uid = su1.uid
- JOIN master.dbo.sysdatabases sd2
- ON sr.pmrydbid = sd2.dbid
- WHERE so1.name = @{[ $self->dbh->quote($table->name) ]}
- AND su1.name = @{[ $self->dbh->quote($table->schema) ]}
- EOF
- $sth->execute;
- my @rels;
- REL: while (my @rel = $sth->fetchrow_array) {
- my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3;
- my ($remote_tab_owner, $remote_tab_name) =
- $self->dbh->selectrow_array(<<"EOF");
- SELECT su.name, so.name
- FROM [$remote_db].dbo.sysusers su
- JOIN [$remote_db].dbo.sysobjects so
- ON su.uid = so.uid
- WHERE so.id = $remote_tab_id
- EOF
- next REL
- unless any { $_ eq $remote_tab_owner }
- @{ $self->db_schema->{$remote_db} || [] };
- my @local_col_ids = splice @rel, 0, 16;
- my @remote_col_ids = splice @rel, 0, 16;
- @local_col_ids = splice @local_col_ids, 0, $key_cnt;
- @remote_col_ids = splice @remote_col_ids, 0, $key_cnt;
- my $remote_table = DBIx::Class::Schema::Loader::Table::Sybase->new(
- loader => $self,
- name => $remote_tab_name,
- database => $remote_db,
- schema => $remote_tab_owner,
- );
- my $all_local_cols = $self->_table_columns($table);
- my $all_remote_cols = $self->_table_columns($remote_table);
- my @local_cols = map $all_local_cols->[$_-1], @local_col_ids;
- my @remote_cols = map $all_remote_cols->[$_-1], @remote_col_ids;
- next REL if (any { not defined $_ } @local_cols)
- || (any { not defined $_ } @remote_cols);
- push @rels, {
- local_columns => \@local_cols,
- remote_table => $remote_table,
- remote_columns => \@remote_cols,
- };
- };
- return \@rels;
- }
- sub _table_uniq_info {
- my ($self, $table) = @_;
- my $db = $table->database;
- my $owner = $table->schema;
- my $uid = $self->_uid($db, $owner);
- my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
- $self->dbh->do("USE [$db]");
- my $sth = $self->dbh->prepare(<<"EOF");
- SELECT si.name, si.indid, si.keycnt
- FROM [$db].dbo.sysindexes si
- JOIN [$db].dbo.sysobjects so
- ON si.id = so.id
- WHERE so.name = @{[ $self->dbh->quote($table->name) ]}
- AND so.uid = $uid
- AND si.indid > 0
- AND si.status & 2048 <> 2048
- AND si.status2 & 2 = 2
- EOF
- $sth->execute;
- my %uniqs;
- while (my ($ind_name, $ind_id, $key_cnt) = $sth->fetchrow_array) {
- COLS: foreach my $col_idx (1 .. ($key_cnt+1)) {
- my ($next_col) = $self->dbh->selectrow_array(<<"EOF");
- SELECT index_col(
- @{[ $self->dbh->quote($table->name) ]},
- $ind_id, $col_idx, $uid
- )
- EOF
- last COLS unless defined $next_col;
- push @{ $uniqs{$ind_name} }, $next_col;
- }
- }
- my @uniqs = map { [ $_ => $uniqs{$_} ] } keys %uniqs;
- $self->dbh->do("USE [$current_db]");
- return \@uniqs;
- }
- sub _columns_info_for {
- my $self = shift;
- my ($table) = @_;
- my $result = $self->next::method(@_);
- my $db = $table->database;
- my $owner = $table->schema;
- my $uid = $self->_uid($db, $owner);
- local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
- my $sth = $self->dbh->prepare(<<"EOF");
- 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
- FROM [$db].dbo.syscolumns c
- LEFT JOIN [$db].dbo.sysobjects o ON c.id = o.id
- LEFT JOIN [$db].dbo.systypes bt ON c.type = bt.type
- LEFT JOIN [$db].dbo.systypes ut ON c.usertype = ut.usertype
- WHERE o.name = @{[ $self->dbh->quote($table) ]}
- AND o.uid = $uid
- AND o.type IN ('U', 'V')
- EOF
- $sth->execute;
- my $info = $sth->fetchall_hashref('name');
- while (my ($col, $res) = each %$result) {
- $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type};
- if ($info->{$col}{is_id}) {
- $res->{is_auto_increment} = 1;
- }
- $sth->finish;
- # column has default value
- if (my $default_id = $info->{$col}{dflt_id}) {
- my $sth = $self->dbh->prepare(<<"EOF");
- SELECT cm.id, cm.text
- FROM [$db].dbo.syscomments cm
- WHERE cm.id = $default_id
- EOF
- $sth->execute;
- if (my ($d_id, $default) = $sth->fetchrow_array) {
- my $constant_default = ($default =~ /^DEFAULT \s+ (\S.*\S)/ix)
- ? $1
- : $default;
- $constant_default = substr($constant_default, 1, length($constant_default) - 2)
- if ( substr($constant_default, 0, 1) =~ m{['"\[]}
- && substr($constant_default, -1) =~ m{['"\]]});
- $res->{default_value} = $constant_default;
- }
- }
- # column is a computed value
- if (my $comp_id = $info->{$col}{comp_id}) {
- my $sth = $self->dbh->prepare(<<"EOF");
- SELECT cm.id, cm.text
- FROM [$db].dbo.syscomments cm
- WHERE cm.id = $comp_id
- EOF
- $sth->execute;
- if (my ($c_id, $comp) = $sth->fetchrow_array) {
- my $function = ($comp =~ /^AS \s+ (\S+)/ix) ? $1 : $comp;
- $res->{default_value} = \$function;
- if ($function =~ /^getdate\b/) {
- $res->{inflate_datetime} = 1;
- }
- delete $res->{size};
- $res->{data_type} = undef;
- }
- }
- if (my $data_type = $res->{data_type}) {
- if ($data_type eq 'int') {
- $data_type = $res->{data_type} = 'integer';
- }
- elsif ($data_type eq 'decimal') {
- $data_type = $res->{data_type} = 'numeric';
- }
- elsif ($data_type eq 'float') {
- $data_type = $res->{data_type}
- = ($info->{$col}{len} <= 4 ? 'real' : 'double precision');
- }
- if ($data_type eq 'timestamp') {
- $res->{inflate_datetime} = 0;
- }
- 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) {
- delete $res->{size};
- }
- elsif ($data_type eq 'numeric') {
- my ($prec, $scale) = @{$info->{$col}}{qw/prec scale/};
- if (!defined $prec && !defined $scale) {
- $data_type = $res->{data_type} = 'integer';
- delete $res->{size};
- }
- elsif ($prec == 18 && $scale == 0) {
- delete $res->{size};
- }
- else {
- $res->{size} = [ $prec, $scale ];
- }
- }
- elsif ($data_type =~ /char/) {
- $res->{size} = $info->{$col}{len};
- if ($data_type =~ /^(?:unichar|univarchar)\z/i) {
- $res->{size} /= 2;
- }
- elsif ($data_type =~ /^n(?:var)?char\z/i) {
- my ($nchar_size) = $self->dbh->selectrow_array('SELECT @@ncharsize');
- $res->{size} /= $nchar_size;
- }
- }
- }
- }
- return $result;
- }
- =head1 SEE ALSO
- L<DBIx::Class::Schema::Loader::DBI::Sybase::Common>,
- L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
- L<DBIx::Class::Schema::Loader::DBI>
- =head1 AUTHOR
- See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
- =head1 LICENSE
- This library is free software; you can redistribute it and/or modify it under
- the same terms as Perl itself.
- =cut
- 1;
- # vim:et sts=4 sw=4 tw=0: