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

   1 package DBIx::Class::Schema::Loader::DBI;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/DBIx::Class::Schema::Loader::Base/;
   6 use mro 'c3';
   7 use Try::Tiny;
   8 use List::MoreUtils 'any';
   9 use namespace::clean;
  10 use DBIx::Class::Schema::Loader::Table ();
  11
  12 our $VERSION = '0.07015';
  13
  14 __PACKAGE__->mk_group_accessors('simple', qw/
  15     _disable_pk_detection
  16     _disable_uniq_detection
  17     _disable_fk_detection
  18     _passwords
  19     quote_char
  20     name_sep
  21 /);
  22
  23 =head1 NAME
  24
  25 DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation.
  26
  27 =head1 SYNOPSIS
  28
  29 See L<DBIx::Class::Schema::Loader::Base>
  30
  31 =head1 DESCRIPTION
  32
  33 This is the base class for L<DBIx::Class::Schema::Loader::Base> classes for
  34 DBI-based storage backends, and implements the common functionality between them.
  35
  36 See L<DBIx::Class::Schema::Loader::Base> for the available options.
  37
  38 =head1 METHODS
  39
  40 =head2 new
  41
  42 Overlays L<DBIx::Class::Schema::Loader::Base/new> to do some DBI-specific
  43 things.
  44
  45 =cut
  46
  47 sub new {
  48     my $self = shift->next::method(@_);
  49
  50     # rebless to vendor-specific class if it exists and loads and we're not in a
  51     # custom class.
  52     if (not $self->loader_class) {
  53         my $driver = $self->dbh->{Driver}->{Name};
  54
  55         my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver;
  56         if ($self->load_optional_class($subclass)) {
  57             bless $self, $subclass unless $self->isa($subclass);
  58             $self->_rebless;
  59         }
  60     }
  61
  62     # Set up the default quoting character and name seperators
  63     $self->quote_char($self->_build_quote_char);
  64     $self->name_sep($self->_build_name_sep);
  65
  66     $self->_setup;
  67
  68     $self;
  69 }
  70
  71 sub _build_quote_char {
  72     my $self = shift;
  73
  74     my $quote_char = $self->dbh->get_info(29)
  75            || $self->schema->storage->sql_maker->quote_char
  76            || q{"};
  77
  78     # For our usage as regex matches, concatenating multiple quote_char
  79     # values works fine (e.g. s/[\Q<>\E]// if quote_char was [ '<', '>' ])
  80     if (ref $quote_char eq 'ARRAY') {
  81         $quote_char = join '', @$quote_char;
  82     }
  83
  84     return $quote_char;
  85 }
  86
  87 sub _build_name_sep {
  88     my $self = shift;
  89     return $self->dbh->get_info(41)
  90            || $self->schema->storage->sql_maker->name_sep
  91            || '.';
  92 }
  93
  94 # Override this in vendor modules to do things at the end of ->new()
  95 sub _setup { }
  96
  97 # Override this in vendor module to load a subclass if necessary
  98 sub _rebless { }
  99
 100 sub _system_schemas {
 101     return ('information_schema');
 102 }
 103
 104 sub _system_tables {
 105     return ();
 106 }
 107
 108 sub _dbh_tables {
 109     my ($self, $schema) = (shift, shift);
 110
 111     my ($table_pattern, $table_type_pattern) = @_ ? @_ : ('%', '%');
 112
 113     return $self->dbh->tables(undef, $schema, $table_pattern, $table_type_pattern);
 114 }
 115
 116 # default to be overridden in subclasses if necessary
 117 sub _supports_db_schema { 1 }
 118
 119 # Returns an array of table objects
 120 sub _tables_list {
 121     my ($self, $opts) = (shift, shift);
 122
 123     my @tables;
 124
 125     my $qt  = qr/[\Q$self->{quote_char}\E"'`\[\]]/;
 126     my $nqt = qr/[^\Q$self->{quote_char}\E"'`\[\]]/;
 127     my $ns  = qr/[\Q$self->{name_sep}\E]/;
 128     my $nns = qr/[^\Q$self->{name_sep}\E]/;
 129
 130     foreach my $schema (@{ $self->db_schema || [undef] }) {
 131         my @raw_table_names = $self->_dbh_tables($schema, @_);
 132
 133         TABLE: foreach my $raw_table_name (@raw_table_names) {
 134             my $quoted = $raw_table_name =~ /^$qt/;
 135
 136             # These regexes are not entirely correct, but hopefully they will work
 137             # in most cases. RT reports welcome.
 138             my ($schema_name, $table_name1, $table_name2) = $quoted ?
 139                 $raw_table_name =~ /^(?:${qt}(${nqt}+?)${qt}${ns})?(?:${qt}(.+?)${qt}|(${nns}+))\z/
 140                 :
 141                 $raw_table_name =~ /^(?:(${nns}+?)${ns})?(?:${qt}(.+?)${qt}|(${nns}+))\z/;
 142
 143             my $table_name = $table_name1 || $table_name2;
 144
 145             foreach my $system_schema ($self->_system_schemas) {
 146                 if ($schema_name) {
 147                     my $matches = 0;
 148
 149                     if (ref $system_schema) {
 150                         $matches = 1
 151                             if $schema_name =~ $system_schema
 152                                  && $schema !~ $system_schema;
 153                     }
 154                     else {
 155                         $matches = 1
 156                             if $schema_name eq $system_schema
 157                                 && $schema  ne $system_schema;
 158                     }
 159
 160                     next TABLE if $matches;
 161                 }
 162             }
 163
 164             foreach my $system_table ($self->_system_tables) {
 165                 my $matches = 0;
 166
 167                 if (ref $system_table) {
 168                     $matches = 1 if $table_name =~ $system_table;
 169                 }
 170                 else {
 171                     $matches = 1 if $table_name eq $system_table
 172                 }
 173
 174                 next TABLE if $matches;
 175             }
 176
 177             $schema_name ||= $schema;
 178
 179             my $table = DBIx::Class::Schema::Loader::Table->new(
 180                 loader => $self,
 181                 name   => $table_name,
 182                 schema => $schema_name,
 183                 ($self->_supports_db_schema ? () : (
 184                     ignore_schema => 1
 185                 )),
 186             );
 187
 188             push @tables, $table;
 189         }
 190     }
 191
 192     return $self->_filter_tables(\@tables, $opts);
 193 }
 194
 195 # apply constraint/exclude and ignore bad tables and views
 196 sub _filter_tables {
 197     my ($self, $tables, $opts) = @_;
 198
 199     my @tables = @$tables;
 200     my @filtered_tables;
 201
 202     $opts ||= {};
 203     my $constraint   = $opts->{constraint};
 204     my $exclude      = $opts->{exclude};
 205
 206     @tables = grep { /$constraint/ } @tables if defined $constraint;
 207     @tables = grep { ! /$exclude/  } @tables if defined $exclude;
 208
 209     TABLE: for my $table (@tables) {
 210         try {
 211             local $^W = 0; # for ADO
 212             my $sth = $self->_sth_for($table, undef, \'1 = 0');
 213             $sth->execute;
 214             1;
 215         }
 216         catch {
 217             warn "Bad table or view '$table', ignoring: $_\n";
 218             0;
 219         } or next TABLE;
 220
 221         push @filtered_tables, $table;
 222     }
 223
 224     return @filtered_tables;
 225 }
 226
 227 =head2 load
 228
 229 We override L<DBIx::Class::Schema::Loader::Base/load> here to hook in our localized settings for C<$dbh> error handling.
 230
 231 =cut
 232
 233 sub load {
 234     my $self = shift;
 235
 236     local $self->dbh->{RaiseError} = 1;
 237     local $self->dbh->{PrintError} = 0;
 238
 239     $self->next::method(@_);
 240
 241     $self->schema->storage->disconnect unless $self->dynamic;
 242 }
 243
 244 sub _sth_for {
 245     my ($self, $table, $fields, $where) = @_;
 246
 247     my $sth = $self->dbh->prepare($self->schema->storage->sql_maker
 248         ->select(\$table->sql_name, $fields, $where));
 249
 250     return $sth;
 251 }
 252
 253 # Returns an arrayref of column names
 254 sub _table_columns {
 255     my ($self, $table) = @_;
 256
 257     my $sth = $self->_sth_for($table, undef, \'1 = 0');
 258     $sth->execute;
 259     my $retval = $self->preserve_case ? \@{$sth->{NAME}} : \@{$sth->{NAME_lc}};
 260     $sth->finish;
 261
 262     $retval;
 263 }
 264
 265 # Returns arrayref of pk col names
 266 sub _table_pk_info {
 267     my ($self, $table) = @_;
 268
 269     return [] if $self->_disable_pk_detection;
 270
 271     my @primary = try {
 272         $self->dbh->primary_key('', $table->schema, $table->name);
 273     }
 274     catch {
 275         warn "Cannot find primary keys for this driver: $_";
 276         $self->_disable_pk_detection(1);
 277         return ();
 278     };
 279
 280     return [] if not @primary;
 281
 282     @primary = map { $self->_lc($_) } @primary;
 283     s/[\Q$self->{quote_char}\E]//g for @primary;
 284
 285     return \@primary;
 286 }
 287
 288 # Override this for vendor-specific uniq info
 289 sub _table_uniq_info {
 290     my ($self, $table) = @_;
 291
 292     return [] if $self->_disable_uniq_detection;
 293
 294     if (not $self->dbh->can('statistics_info')) {
 295         warn "No UNIQUE constraint information can be gathered for this driver";
 296         $self->_disable_uniq_detection(1);
 297         return [];
 298     }
 299
 300     my %indices;
 301     my $sth = $self->dbh->statistics_info(undef, $table->schema, $table->name, 1, 1);
 302     while(my $row = $sth->fetchrow_hashref) {
 303         # skip table-level stats, conditional indexes, and any index missing
 304         #  critical fields
 305         next if $row->{TYPE} eq 'table'
 306             || defined $row->{FILTER_CONDITION}
 307             || !$row->{INDEX_NAME}
 308             || !defined $row->{ORDINAL_POSITION}
 309             || !$row->{COLUMN_NAME};
 310
 311         $indices{$row->{INDEX_NAME}}[$row->{ORDINAL_POSITION}] = $self->_lc($row->{COLUMN_NAME});
 312     }
 313     $sth->finish;
 314
 315     my @retval;
 316     foreach my $index_name (keys %indices) {
 317         my $index = $indices{$index_name};
 318         push(@retval, [ $index_name => [ @$index[1..$#$index] ] ]);
 319     }
 320
 321     return \@retval;
 322 }
 323
 324 sub _table_comment {
 325     my ($self, $table) = @_;
 326     my $dbh = $self->dbh;
 327
 328     my $comments_table = $table->clone;
 329     $comments_table->name($self->table_comments_table);
 330
 331     my ($comment) = try { $dbh->selectrow_array(<<"EOF") };
 332 SELECT comment_text
 333 FROM @{[ $comments_table->sql_name ]}
 334 WHERE table_name = @{[ $dbh->quote($table->name) ]}
 335 EOF
 336
 337     # Failback: try the REMARKS column on table_info
 338     if (!$comment && $dbh->can('table_info')) {
 339         my $sth = $self->_dbh_table_info( $dbh, undef, $table->schema, $table->name );
 340         my $info = $sth->fetchrow_hashref();
 341         $comment = $info->{REMARKS};
 342     }
 343
 344     return $comment;
 345 }
 346
 347 sub _column_comment {
 348     my ($self, $table, $column_number, $column_name) = @_;
 349     my $dbh = $self->dbh;
 350
 351     my $comments_table = $table->clone;
 352     $comments_table->name($self->column_comments_table);
 353
 354     my ($comment) = try { $dbh->selectrow_array(<<"EOF") };
 355 SELECT comment_text
 356 FROM @{[ $comments_table->sql_name ]}
 357 WHERE table_name = @{[ $dbh->quote($table->name) ]}
 358 AND column_name = @{[ $dbh->quote($column_name) ]}
 359 EOF
 360
 361     # Failback: try the REMARKS column on column_info
 362     if (!$comment && $dbh->can('column_info')) {
 363         my $sth = $self->_dbh_column_info( $dbh, undef, $table->schema, $table->name, $column_name );
 364         my $info = $sth->fetchrow_hashref();
 365         $comment = $info->{REMARKS};
 366     }
 367
 368     return $comment;
 369 }
 370
 371 # Find relationships
 372 sub _table_fk_info {
 373     my ($self, $table) = @_;
 374
 375     return [] if $self->_disable_fk_detection;
 376
 377     my $sth = try {
 378         $self->dbh->foreign_key_info( '', '', '',
 379                                 '', ($table->schema || ''), $table->name );
 380     }
 381     catch {
 382         warn "Cannot introspect relationships for this driver: $_";
 383         $self->_disable_fk_detection(1);
 384         return undef;
 385     };
 386
 387     return [] if !$sth;
 388
 389     my %rels;
 390
 391     my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
 392     REL: while(my $raw_rel = $sth->fetchrow_arrayref) {
 393         my $uk_scm  = $raw_rel->[1];
 394         my $uk_tbl  = $raw_rel->[2];
 395         my $uk_col  = $self->_lc($raw_rel->[3]);
 396         my $fk_scm  = $raw_rel->[5];
 397         my $fk_col  = $self->_lc($raw_rel->[7]);
 398         my $relid   = ($raw_rel->[11] || ( "__dcsld__" . $i++ ));
 399
 400         foreach my $var ($uk_scm, $uk_tbl, $uk_col, $fk_scm, $fk_col, $relid) {
 401             $var =~ s/[\Q$self->{quote_char}\E]//g;
 402         }
 403
 404         if ($self->db_schema && $self->db_schema->[0] ne '%'
 405             && (not any { $_ eq $uk_scm } @{ $self->db_schema })) {
 406
 407             next REL;
 408         }
 409
 410         $rels{$relid}{tbl} = DBIx::Class::Schema::Loader::Table->new(
 411             loader => $self,
 412             name   => $uk_tbl,
 413             schema => $uk_scm,
 414             ($self->_supports_db_schema ? () : (
 415                 ignore_schema => 1
 416             )),
 417         );
 418         $rels{$relid}{cols}{$uk_col} = $fk_col;
 419     }
 420     $sth->finish;
 421
 422     my @rels;
 423     foreach my $relid (keys %rels) {
 424         push(@rels, {
 425             remote_columns => [ keys   %{$rels{$relid}->{cols}} ],
 426             local_columns  => [ values %{$rels{$relid}->{cols}} ],
 427             remote_table   => $rels{$relid}->{tbl},
 428         });
 429     }
 430
 431     return \@rels;
 432 }
 433
 434 # ported in from DBIx::Class::Storage::DBI:
 435 sub _columns_info_for {
 436     my ($self, $table) = @_;
 437
 438     my $dbh = $self->schema->storage->dbh;
 439
 440     my %result;
 441
 442     if ($dbh->can('column_info')) {
 443         my $sth = $self->_dbh_column_info($dbh, undef, $table->schema, $table->name, '%' );
 444         while ( my $info = $sth->fetchrow_hashref() ){
 445             my $column_info = {};
 446             $column_info->{data_type}     = lc $info->{TYPE_NAME};
 447
 448             my $size = $info->{COLUMN_SIZE};
 449
 450             if (defined $size && defined $info->{DECIMAL_DIGITS}) {
 451                 $column_info->{size} = [$size, $info->{DECIMAL_DIGITS}];
 452             }
 453             elsif (defined $size) {
 454                 $column_info->{size} = $size;
 455             }
 456
 457             $column_info->{is_nullable}   = $info->{NULLABLE} ? 1 : 0;
 458             $column_info->{default_value} = $info->{COLUMN_DEF} if defined $info->{COLUMN_DEF};
 459             my $col_name = $info->{COLUMN_NAME};
 460             $col_name =~ s/^\"(.*)\"$/$1/;
 461
 462             $col_name = $self->_lc($col_name);
 463
 464             my $extra_info = $self->_extra_column_info(
 465                 $table, $col_name, $column_info, $info
 466             ) || {};
 467             $column_info = { %$column_info, %$extra_info };
 468
 469             $result{$col_name} = $column_info;
 470         }
 471         $sth->finish;
 472
 473         return \%result if %result;
 474     }
 475
 476     my $sth = $self->_sth_for($table, undef, \'1 = 0');
 477     $sth->execute;
 478
 479     my @columns = @{ $sth->{NAME} };
 480
 481     for my $i (0 .. $#columns) {
 482         my $column_info = {};
 483         $column_info->{data_type} = lc $sth->{TYPE}[$i];
 484
 485         my $size = $sth->{PRECISION}[$i];
 486
 487         if (defined $size && defined $sth->{SCALE}[$i]) {
 488             $column_info->{size} = [$size, $sth->{SCALE}[$i]];
 489         }
 490         elsif (defined $size) {
 491             $column_info->{size} = $size;
 492         }
 493
 494         $column_info->{is_nullable} = $sth->{NULLABLE}[$i] ? 1 : 0;
 495
 496         if ($column_info->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
 497             $column_info->{data_type} = $1;
 498             $column_info->{size}    = $2;
 499         }
 500
 501         my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info, $sth) || {};
 502         $column_info = { %$column_info, %$extra_info };
 503
 504         $result{ $self->_lc($columns[$i]) } = $column_info;
 505     }
 506     $sth->finish;
 507
 508     foreach my $col (keys %result) {
 509         my $colinfo = $result{$col};
 510         my $type_num = $colinfo->{data_type};
 511         my $type_name;
 512         if (defined $type_num && $type_num =~ /^-?\d+\z/ && $dbh->can('type_info')) {
 513             my $type_name = $self->_dbh_type_info_type_name($type_num);
 514             $colinfo->{data_type} = lc $type_name if $type_name;
 515         }
 516     }
 517
 518     return \%result;
 519 }
 520
 521 # Need to override this for the buggy Firebird ODBC driver.
 522 sub _dbh_type_info_type_name {
 523     my ($self, $type_num) = @_;
 524
 525     # We wrap it in a try block for MSSQL+DBD::Sybase, which can have issues.
 526     # TODO investigate further
 527     my $type_info = try { $self->dbh->type_info($type_num) };
 528
 529     return $type_info ? $type_info->{TYPE_NAME} : undef;
 530 }
 531
 532 # do not use this, override _columns_info_for instead
 533 sub _extra_column_info {}
 534
 535 # override to mask warnings if needed
 536 sub _dbh_table_info {
 537     my ($self, $dbh) = (shift, shift);
 538
 539     return $dbh->table_info(@_);
 540 }
 541
 542 # override to mask warnings if needed (see mysql)
 543 sub _dbh_column_info {
 544     my ($self, $dbh) = (shift, shift);
 545
 546     return $dbh->column_info(@_);
 547 }
 548
 549 # If a coderef uses DBI->connect, this should get its connect info.
 550 sub _try_infer_connect_info_from_coderef {
 551     my ($self, $code) = @_;
 552
 553     my ($dsn, $user, $pass, $params);
 554
 555     no warnings 'redefine';
 556
 557     local *DBI::connect = sub {
 558         (undef, $dsn, $user, $pass, $params) = @_;
 559     };
 560
 561     $code->();
 562
 563     return ($dsn, $user, $pass, $params);
 564 }
 565
 566 sub dbh {
 567     my $self = shift;
 568
 569     return $self->schema->storage->dbh;
 570 }
 571
 572 =head1 SEE ALSO
 573
 574 L<DBIx::Class::Schema::Loader>
 575
 576 =head1 AUTHOR
 577
 578 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 579
 580 =head1 LICENSE
 581
 582 This library is free software; you can redistribute it and/or modify it under
 583 the same terms as Perl itself.
 584
 585 =cut
 586
 587 1;
 588 # vim:et sts=4 sw=4 tw=0: