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

   1 package DBIx::Class::Schema::Loader::DBI::Oracle;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/
   6     DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
   7     DBIx::Class::Schema::Loader::DBI
   8 /;
   9 use mro 'c3';
  10 use Try::Tiny;
  11 use namespace::clean;
  12
  13 our $VERSION = '0.07019';
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI
  18 Oracle Implementation.
  19
  20 =head1 DESCRIPTION
  21
  22 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
  23
  24 =cut
  25
  26 sub _setup {
  27     my $self = shift;
  28
  29     $self->next::method(@_);
  30
  31     my ($current_schema) = $self->dbh->selectrow_array('SELECT USER FROM DUAL');
  32
  33     $self->db_schema([ $current_schema ]) unless $self->db_schema;
  34
  35     if (@{ $self->db_schema } == 1 && $self->db_schema->[0] ne '%'
  36         && lc($self->db_schema->[0]) ne lc($current_schema)) {
  37         $self->dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema->[0]);
  38     }
  39
  40     if (not defined $self->preserve_case) {
  41         $self->preserve_case(0);
  42     }
  43     elsif ($self->preserve_case) {
  44         $self->schema->storage->sql_maker->quote_char('"');
  45         $self->schema->storage->sql_maker->name_sep('.');
  46     }
  47 }
  48
  49 sub _build_name_sep { '.' }
  50
  51 sub _system_schemas {
  52     my $self = shift;
  53
  54     # From http://www.adp-gmbh.ch/ora/misc/known_schemas.html
  55
  56     return ($self->next::method(@_), qw/ANONYMOUS APEX_PUBLIC_USER APEX_030200 APPQOSSYS CTXSYS DBSNMP DIP DMSYS EXFSYS LBACSYS MDDATA MDSYS MGMT_VIEW OLAPSYS ORACLE_OCM ORDDATA ORDPLUGINS ORDSYS OUTLN SI_INFORMTN_SCHEMA SPATIAL_CSW_ADMIN_USR SPATIAL_WFS_ADMIN_USR SYS SYSMAN SYSTEM TRACESRV MTSSYS OASPUBLIC OWBSYS OWBSYS_AUDIT WEBSYS WK_PROXY WKSYS WK_TEST WMSYS XDB OSE$HTTP$ADMIN AURORA$JIS$UTILITY$ AURORA$ORB$UNAUTHENTICATED/, qr/^FLOWS_\d\d\d\d\d\d\z/);
  57 }
  58
  59 sub _system_tables {
  60     my $self = shift;
  61
  62     return ($self->next::method(@_), 'PLAN_TABLE');
  63 }
  64
  65 sub _dbh_tables {
  66     my ($self, $schema) = @_;
  67
  68     return $self->dbh->tables(undef, $schema, '%', 'TABLE,VIEW');
  69 }
  70
  71 sub _filter_tables {
  72     my $self = shift;
  73
  74     # silence a warning from older DBD::Oracles in tests
  75     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  76     local $SIG{__WARN__} = sub {
  77         $warn_handler->(@_)
  78         unless $_[0] =~ /^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/;
  79     };
  80
  81     return $self->next::method(@_);
  82 }
  83
  84 sub _table_uniq_info {
  85     my ($self, $table) = @_;
  86
  87     my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1);
  88 SELECT ac.constraint_name, acc.column_name
  89 FROM all_constraints ac, all_cons_columns acc
  90 WHERE acc.table_name=? AND acc.owner = ?
  91     AND ac.table_name = acc.table_name AND ac.owner = acc.owner
  92     AND acc.constraint_name = ac.constraint_name
  93     AND ac.constraint_type='U'
  94 ORDER BY acc.position
  95 EOF
  96
  97     $sth->execute($table->name, $table->schema);
  98
  99     my %constr_names;
 100
 101     while(my $constr = $sth->fetchrow_arrayref) {
 102         my $constr_name = $self->_lc($constr->[0]);
 103         my $constr_col  = $self->_lc($constr->[1]);
 104         push @{$constr_names{$constr_name}}, $constr_col;
 105     }
 106
 107     my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names;
 108     return \@uniqs;
 109 }
 110
 111 sub _table_comment {
 112     my $self = shift;
 113     my ($table) = @_;
 114
 115     my $table_comment = $self->next::method(@_);
 116
 117     return $table_comment if $table_comment;
 118
 119     ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name);
 120 SELECT comments FROM all_tab_comments
 121 WHERE owner = ?
 122   AND table_name = ?
 123   AND (table_type = 'TABLE' OR table_type = 'VIEW')
 124 EOF
 125
 126     return $table_comment
 127 }
 128
 129 sub _column_comment {
 130     my $self = shift;
 131     my ($table, $column_number, $column_name) = @_;
 132
 133     my $column_comment = $self->next::method(@_);
 134
 135     return $column_comment if $column_comment;
 136
 137     ($column_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($column_name));
 138 SELECT comments FROM all_col_comments
 139 WHERE owner = ?
 140   AND table_name = ?
 141   AND column_name = ?
 142 EOF
 143
 144     return $column_comment
 145 }
 146
 147 sub _columns_info_for {
 148     my $self = shift;
 149     my ($table) = @_;
 150
 151     my $result = $self->next::method(@_);
 152
 153     local $self->dbh->{LongReadLen} = 1_000_000;
 154     local $self->dbh->{LongTruncOk} = 1;
 155
 156     my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1);
 157 SELECT trigger_body
 158 FROM all_triggers
 159 WHERE table_name = ? AND table_owner = ?
 160 AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIKE '%insert%'
 161 EOF
 162
 163     $sth->execute($table->name, $table->schema);
 164
 165     while (my ($trigger_body) = $sth->fetchrow_array) {
 166         if (my ($seq_schema, $seq_name) = $trigger_body =~ /(?:\."?(\w+)"?)?"?(\w+)"?\.nextval/i) {
 167             if (my ($col_name) = $trigger_body =~ /:new\.(\w+)/i) {
 168                 $col_name = $self->_lc($col_name);
 169
 170                 $result->{$col_name}{is_auto_increment} = 1;
 171
 172                 $seq_schema = $self->_lc($seq_schema || $table->schema);
 173                 $seq_name   = $self->_lc($seq_name);
 174
 175                 $result->{$col_name}{sequence} = ($self->qualify_objects ? ($seq_schema . '.') : '') . $seq_name;
 176             }
 177         }
 178     }
 179
 180     while (my ($col, $info) = each %$result) {
 181         no warnings 'uninitialized';
 182
 183         my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1);
 184 SELECT data_type, data_length
 185 FROM all_tab_columns
 186 WHERE column_name = ? AND table_name = ? AND owner = ?
 187 EOF
 188         $sth->execute($self->_uc($col), $table->name, $table->schema);
 189         my ($data_type, $data_length) = $sth->fetchrow_array;
 190         $sth->finish;
 191         $data_type = lc $data_type;
 192
 193         if ($data_type =~ /^(?:n(?:var)?char2?|u?rowid|nclob|timestamp\(\d+\)(?: with(?: local)? time zone)?|binary_(?:float|double))\z/i) {
 194             $info->{data_type} = $data_type;
 195
 196             if ($data_type =~ /^u?rowid\z/i) {
 197                 $info->{size} = $data_length;
 198             }
 199         }
 200
 201         if ($info->{data_type} =~ /^(?:n?[cb]lob|long(?: raw)?|bfile|date|binary_(?:float|double)|rowid)\z/i) {
 202             delete $info->{size};
 203         }
 204
 205         if ($info->{data_type} =~ /^n(?:var)?char2?\z/i) {
 206             if (ref $info->{size}) {
 207                 $info->{size} = $info->{size}[0] / 8;
 208             }
 209             else {
 210                 $info->{size} = $info->{size} / 2;
 211             }
 212         }
 213         elsif ($info->{data_type} =~ /^(?:var)?char2?\z/i) {
 214             if (ref $info->{size}) {
 215                 $info->{size} = $info->{size}[0];
 216             }
 217         }
 218         elsif (lc($info->{data_type}) =~ /^(?:number|decimal)\z/i) {
 219             $info->{original}{data_type} = 'number';
 220             $info->{data_type}           = 'numeric';
 221
 222             if (try { $info->{size}[0] == 38 && $info->{size}[1] == 0 }) {
 223                 $info->{original}{size} = $info->{size};
 224
 225                 $info->{data_type} = 'integer';
 226                 delete $info->{size};
 227             }
 228         }
 229         elsif (my ($precision) = $info->{data_type} =~ /^timestamp\((\d+)\)(?: with (?:local )?time zone)?\z/i) {
 230             $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig;
 231
 232             if ($precision == 6) {
 233                 delete $info->{size};
 234             }
 235             else {
 236                 $info->{size} = $precision;
 237             }
 238         }
 239         elsif ($info->{data_type} =~ /timestamp/i && ref $info->{size} && $info->{size}[0] == 0) {
 240             my $size = $info->{size}[1];
 241             delete $info->{size};
 242             $info->{size} = $size unless $size == 6;
 243         }
 244         elsif (($precision) = $info->{data_type} =~ /^interval year\((\d+)\) to month\z/i) {
 245             $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig;
 246
 247             if ($precision == 2) {
 248                 delete $info->{size};
 249             }
 250             else {
 251                 $info->{size} = $precision;
 252             }
 253         }
 254         elsif (my ($day_precision, $second_precision) = $info->{data_type} =~ /^interval day\((\d+)\) to second\((\d+)\)\z/i) {
 255             $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig;
 256
 257             if ($day_precision == 2 && $second_precision == 6) {
 258                 delete $info->{size};
 259             }
 260             else {
 261                 $info->{size} = [ $day_precision, $second_precision ];
 262             }
 263         }
 264         elsif ($info->{data_type} =~ /^interval year to month\z/i && ref $info->{size}) {
 265             my $precision = $info->{size}[0];
 266
 267             if ($precision == 2) {
 268                 delete $info->{size};
 269             }
 270             else {
 271                 $info->{size} = $precision;
 272             }
 273         }
 274         elsif ($info->{data_type} =~ /^interval day to second\z/i && ref $info->{size}) {
 275             if ($info->{size}[0] == 2 && $info->{size}[1] == 6) {
 276                 delete $info->{size};
 277             }
 278         }
 279         elsif (lc($info->{data_type}) eq 'float') {
 280             $info->{original}{data_type} = 'float';
 281             $info->{original}{size}      = $info->{size};
 282
 283             if ($info->{size} <= 63) {
 284                 $info->{data_type} = 'real';
 285             }
 286             else {
 287                 $info->{data_type} = 'double precision';
 288             }
 289             delete $info->{size};
 290         }
 291         elsif (lc($info->{data_type}) eq 'double precision') {
 292             $info->{original}{data_type} = 'float';
 293
 294             my $size = try { $info->{size}[0] };
 295
 296             $info->{original}{size} = $size;
 297
 298             if ($size <= 63) {
 299                 $info->{data_type} = 'real';
 300             }
 301             delete $info->{size};
 302         }
 303         elsif (lc($info->{data_type}) eq 'urowid' && $info->{size} == 4000) {
 304             delete $info->{size};
 305         }
 306         elsif ($info->{data_type} eq '-9104') {
 307             $info->{data_type} = 'rowid';
 308             delete $info->{size};
 309         }
 310         elsif ($info->{data_type} eq '-2') {
 311             $info->{data_type} = 'raw';
 312             $info->{size} = try { $info->{size}[0] / 2 };
 313         }
 314         elsif (lc($info->{data_type}) eq 'date') {
 315             $info->{data_type}           = 'datetime';
 316             $info->{original}{data_type} = 'date';
 317         }
 318         elsif (lc($info->{data_type}) eq 'binary_float') {
 319             $info->{data_type}           = 'real';
 320             $info->{original}{data_type} = 'binary_float';
 321         }
 322         elsif (lc($info->{data_type}) eq 'binary_double') {
 323             $info->{data_type}           = 'double precision';
 324             $info->{original}{data_type} = 'binary_double';
 325         }
 326
 327         # DEFAULT could be missed by ::DBI because of ORA-24345
 328         if (not defined $info->{default_value}) {
 329             local $self->dbh->{LongReadLen} = 1_000_000;
 330             local $self->dbh->{LongTruncOk} = 1;
 331             my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1);
 332 SELECT data_default
 333 FROM all_tab_columns
 334 WHERE column_name = ? AND table_name = ? AND owner = ?
 335 EOF
 336             $sth->execute($self->_uc($col), $table->name, $table->schema);
 337             my ($default) = $sth->fetchrow_array;
 338             $sth->finish;
 339
 340             # this is mostly copied from ::DBI::QuotedDefault
 341             if (defined $default) {
 342                 s/^\s+//, s/\s+\z// for $default;
 343
 344                 if ($default =~ /^'(.*?)'\z/) {
 345                     $info->{default_value} = $1;
 346                 }
 347                 elsif ($default =~ /^(-?\d.*?)\z/) {
 348                     $info->{default_value} = $1;
 349                 }
 350                 elsif ($default =~ /^NULL\z/i) {
 351                     my $null = 'null';
 352                     $info->{default_value} = \$null;
 353                 }
 354                 elsif ($default ne '') {
 355                     my $val = $default;
 356                     $info->{default_value} = \$val;
 357                 }
 358             }
 359         }
 360
 361         if ((try { lc(${ $info->{default_value} }) }||'') eq 'sysdate') {
 362             my $current_timestamp  = 'current_timestamp';
 363             $info->{default_value} = \$current_timestamp;
 364
 365             my $sysdate = 'sysdate';
 366             $info->{original}{default_value} = \$sysdate;
 367         }
 368     }
 369
 370     return $result;
 371 }
 372
 373 sub _dbh_column_info {
 374     my $self  = shift;
 375     my ($dbh) = @_;
 376
 377     # try to avoid ORA-24345
 378     local $dbh->{LongReadLen} = 1_000_000;
 379     local $dbh->{LongTruncOk} = 1;
 380
 381     return $self->next::method(@_);
 382 }
 383
 384 =head1 SEE ALSO
 385
 386 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 387 L<DBIx::Class::Schema::Loader::DBI>
 388
 389 =head1 AUTHOR
 390
 391 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 392
 393 =head1 LICENSE
 394
 395 This library is free software; you can redistribute it and/or modify it under
 396 the same terms as Perl itself.
 397
 398 =cut
 399
 400 1;
 401 # vim:et sts=4 sw=4 tw=0: