lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm

   1 package DBIx::Class::Schema::Loader::DBI::SQLAnywhere;
   2
   3 use strict;
   4 use warnings;
   5 use namespace::autoclean;
   6 use Class::C3;
   7 use base qw/
   8     DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
   9     DBIx::Class::Schema::Loader::DBI
  10 /;
  11 use Carp::Clan qw/^DBIx::Class/;
  12 use List::MoreUtils 'uniq';
  13
  14 our $VERSION = '0.05003';
  15
  16 =head1 NAME
  17
  18 DBIx::Class::Schema::Loader::DBI::SQLAnywhere - DBIx::Class::Schema::Loader::DBI
  19 SQL Anywhere Implementation.
  20
  21 =head1 DESCRIPTION
  22
  23 See L<DBIx::Class::Schema::Loader::Base>.
  24
  25 =cut
  26
  27 sub _setup {
  28     my $self = shift;
  29
  30     $self->{db_schema} ||=
  31         ($self->schema->storage->dbh->selectrow_array('select user'))[0];
  32 }
  33
  34 sub _tables_list {
  35     my $self = shift;
  36
  37     my $dbh = $self->schema->storage->dbh;
  38     my $sth = $dbh->prepare(<<'EOF');
  39 select t.table_name from systab t
  40 join sysuser u on u.user_id = t.creator
  41 where u.user_name = ?
  42 EOF
  43     $sth->execute($self->db_schema);
  44
  45     my @tables = map @$_, @{ $sth->fetchall_arrayref };
  46
  47     return $self->_filter_tables(@tables);
  48 }
  49
  50 # check for IDENTITY columns
  51 sub _columns_info_for {
  52     my $self   = shift;
  53     my $result = $self->next::method(@_);
  54
  55     while (my ($col, $info) = each %$result) {
  56         my $def = $info->{default_value};
  57         if (ref $def eq 'SCALAR' && $$def eq 'autoincrement') {
  58             delete $info->{default_value};
  59             $info->{is_auto_increment} = 1;
  60         }
  61     }
  62
  63     return $result;
  64 }
  65
  66 sub _table_pk_info {
  67     my ($self, $table) = @_;
  68     my $dbh = $self->schema->storage->dbh;
  69     local $dbh->{FetchHashKeyName} = 'NAME_lc';
  70     my $sth = $dbh->prepare(qq{sp_pkeys ?});
  71     $sth->execute($table);
  72
  73     my @keydata;
  74
  75     while (my $row = $sth->fetchrow_hashref) {
  76         push @keydata, lc $row->{column_name};
  77     }
  78
  79     return \@keydata;
  80 }
  81
  82 sub _table_fk_info {
  83     my ($self, $table) = @_;
  84
  85     my ($local_cols, $remote_cols, $remote_table, @rels);
  86     my $dbh = $self->schema->storage->dbh;
  87     my $sth = $dbh->prepare(<<'EOF');
  88 select fki.index_name fk_name, fktc.column_name local_column, pkt.table_name remote_table, pktc.column_name remote_column
  89 from sysfkey fk
  90 join sysidx    pki  on fk.primary_table_id = pki.table_id  and fk.primary_index_id = pki.index_id
  91 join sysidx    fki  on fk.foreign_table_id = fki.table_id  and fk.foreign_index_id = fki.index_id
  92 join systab    pkt  on fk.primary_table_id = pkt.table_id
  93 join systab    fkt  on fk.foreign_table_id = fkt.table_id
  94 join sysidxcol pkic on pki.table_id        = pkic.table_id and pki.index_id        = pkic.index_id
  95 join sysidxcol fkic on fki.table_id        = fkic.table_id and fki.index_id        = fkic.index_id
  96 join systabcol pktc on pkic.table_id       = pktc.table_id and pkic.column_id      = pktc.column_id
  97 join systabcol fktc on fkic.table_id       = fktc.table_id and fkic.column_id      = fktc.column_id
  98 where fkt.table_name = ?
  99 EOF
 100     $sth->execute($table);
 101
 102     while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
 103         push @{$local_cols->{$fk}},  lc $local_col;
 104         push @{$remote_cols->{$fk}}, lc $remote_col;
 105         $remote_table->{$fk} = lc $remote_tab;
 106     }
 107
 108     foreach my $fk (keys %$remote_table) {
 109         push @rels, {
 110             local_columns => [ uniq @{ $local_cols->{$fk} } ],
 111             remote_columns => [ uniq @{ $remote_cols->{$fk} } ],
 112             remote_table => $remote_table->{$fk},
 113         };
 114     }
 115     return \@rels;
 116 }
 117
 118 sub _table_uniq_info {
 119     my ($self, $table) = @_;
 120
 121     my $dbh = $self->schema->storage->dbh;
 122     my $sth = $dbh->prepare(<<'EOF');
 123 select c.constraint_name, tc.column_name
 124 from sysconstraint c
 125 join systab t on c.table_object_id = t.object_id
 126 join sysidx i on c.ref_object_id = i.object_id
 127 join sysidxcol ic on i.table_id = ic.table_id and i.index_id = ic.index_id
 128 join systabcol tc on ic.table_id = tc.table_id and ic.column_id = tc.column_id
 129 where c.constraint_type = 'U' and t.table_name = ?
 130 EOF
 131     $sth->execute($table);
 132
 133     my $constraints;
 134     while (my ($constraint_name, $column) = $sth->fetchrow_array) {
 135         push @{$constraints->{$constraint_name}}, lc $column;
 136     }
 137
 138     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 139     return \@uniqs;
 140 }
 141
 142 =head1 SEE ALSO
 143
 144 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 145 L<DBIx::Class::Schema::Loader::DBI>
 146
 147 =head1 AUTHOR
 148
 149 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 150
 151 =head1 LICENSE
 152
 153 This library is free software; you can redistribute it and/or modify it under
 154 the same terms as Perl itself.
 155
 156 =cut
 157
 158 1;