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.07017';
  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
 260     my $retval = [ map $self->_lc($_), @{$sth->{NAME}} ];
 261
 262     $sth->finish;
 263
 264     return $retval;
 265 }
 266
 267 # Returns arrayref of pk col names
 268 sub _table_pk_info {
 269     my ($self, $table) = @_;
 270
 271     return [] if $self->_disable_pk_detection;
 272
 273     my @primary = try {
 274         $self->dbh->primary_key('', $table->schema, $table->name);
 275     }
 276     catch {
 277         warn "Cannot find primary keys for this driver: $_";
 278         $self->_disable_pk_detection(1);
 279         return ();
 280     };
 281
 282     return [] if not @primary;
 283
 284     @primary = map { $self->_lc($_) } @primary;
 285     s/[\Q$self->{quote_char}\E]//g for @primary;
 286
 287     return \@primary;
 288 }
 289
 290 # Override this for vendor-specific uniq info
 291 sub _table_uniq_info {
 292     my ($self, $table) = @_;
 293
 294     return [] if $self->_disable_uniq_detection;
 295
 296     if (not $self->dbh->can('statistics_info')) {
 297         warn "No UNIQUE constraint information can be gathered for this driver";
 298         $self->_disable_uniq_detection(1);
 299         return [];
 300     }
 301
 302     my %indices;
 303     my $sth = $self->dbh->statistics_info(undef, $table->schema, $table->name, 1, 1);
 304     while(my $row = $sth->fetchrow_hashref) {
 305         # skip table-level stats, conditional indexes, and any index missing
 306         #  critical fields
 307         next if $row->{TYPE} eq 'table'
 308             || defined $row->{FILTER_CONDITION}
 309             || !$row->{INDEX_NAME}
 310             || !defined $row->{ORDINAL_POSITION}
 311             || !$row->{COLUMN_NAME};
 312
 313         $indices{$row->{INDEX_NAME}}[$row->{ORDINAL_POSITION}] = $self->_lc($row->{COLUMN_NAME});
 314     }
 315     $sth->finish;
 316
 317     my @retval;
 318     foreach my $index_name (keys %indices) {
 319         my $index = $indices{$index_name};
 320         push(@retval, [ $index_name => [ @$index[1..$#$index] ] ]);
 321     }
 322
 323     return \@retval;
 324 }
 325
 326 sub _table_comment {
 327     my ($self, $table) = @_;
 328     my $dbh = $self->dbh;
 329
 330     my $comments_table = $table->clone;
 331     $comments_table->name($self->table_comments_table);
 332
 333     my ($comment) =
 334         (exists $self->_tables->{$comments_table->sql_name} || undef)
 335         && try { $dbh->selectrow_array(<<"EOF") };
 336 SELECT comment_text
 337 FROM @{[ $comments_table->sql_name ]}
 338 WHERE table_name = @{[ $dbh->quote($table->name) ]}
 339 EOF
 340
 341     # Failback: try the REMARKS column on table_info
 342     if (!$comment && $dbh->can('table_info')) {
 343         my $sth = $self->_dbh_table_info( $dbh, undef, $table->schema, $table->name );
 344         my $info = $sth->fetchrow_hashref();
 345         $comment = $info->{REMARKS};
 346     }
 347
 348     return $comment;
 349 }
 350
 351 sub _column_comment {
 352     my ($self, $table, $column_number, $column_name) = @_;
 353     my $dbh = $self->dbh;
 354
 355     my $comments_table = $table->clone;
 356     $comments_table->name($self->column_comments_table);
 357
 358     my ($comment) =
 359         (exists $self->_tables->{$comments_table->sql_name} || undef)
 360         && try { $dbh->selectrow_array(<<"EOF") };
 361 SELECT comment_text
 362 FROM @{[ $comments_table->sql_name ]}
 363 WHERE table_name = @{[ $dbh->quote($table->name) ]}
 364 AND column_name = @{[ $dbh->quote($column_name) ]}
 365 EOF
 366
 367     # Failback: try the REMARKS column on column_info
 368     if (!$comment && $dbh->can('column_info')) {
 369         if (my $sth = try { $self->_dbh_column_info( $dbh, undef, $table->schema, $table->name, $column_name ) }) {
 370             my $info = $sth->fetchrow_hashref();
 371             $comment = $info->{REMARKS};
 372         }
 373     }
 374
 375     return $comment;
 376 }
 377
 378 # Find relationships
 379 sub _table_fk_info {
 380     my ($self, $table) = @_;
 381
 382     return [] if $self->_disable_fk_detection;
 383
 384     my $sth = try {
 385         $self->dbh->foreign_key_info( '', '', '',
 386                                 '', ($table->schema || ''), $table->name );
 387     }
 388     catch {
 389         warn "Cannot introspect relationships for this driver: $_";
 390         $self->_disable_fk_detection(1);
 391         return undef;
 392     };
 393
 394     return [] if !$sth;
 395
 396     my %rels;
 397
 398     my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
 399     REL: while(my $raw_rel = $sth->fetchrow_arrayref) {
 400         my $uk_scm  = $raw_rel->[1];
 401         my $uk_tbl  = $raw_rel->[2];
 402         my $uk_col  = $self->_lc($raw_rel->[3]);
 403         my $fk_scm  = $raw_rel->[5];
 404         my $fk_col  = $self->_lc($raw_rel->[7]);
 405         my $relid   = ($raw_rel->[11] || ( "__dcsld__" . $i++ ));
 406
 407         foreach my $var ($uk_scm, $uk_tbl, $uk_col, $fk_scm, $fk_col, $relid) {
 408             $var =~ s/[\Q$self->{quote_char}\E]//g if defined $var;
 409         }
 410
 411         if ($self->db_schema && $self->db_schema->[0] ne '%'
 412             && (not any { $_ eq $uk_scm } @{ $self->db_schema })) {
 413
 414             next REL;
 415         }
 416
 417         $rels{$relid}{tbl} = DBIx::Class::Schema::Loader::Table->new(
 418             loader => $self,
 419             name   => $uk_tbl,
 420             schema => $uk_scm,
 421             ($self->_supports_db_schema ? () : (
 422                 ignore_schema => 1
 423             )),
 424         );
 425         $rels{$relid}{cols}{$uk_col} = $fk_col;
 426     }
 427     $sth->finish;
 428
 429     my @rels;
 430     foreach my $relid (keys %rels) {
 431         push(@rels, {
 432             remote_columns => [ keys   %{$rels{$relid}->{cols}} ],
 433             local_columns  => [ values %{$rels{$relid}->{cols}} ],
 434             remote_table   => $rels{$relid}->{tbl},
 435         });
 436     }
 437
 438     return \@rels;
 439 }
 440
 441 # ported in from DBIx::Class::Storage::DBI:
 442 sub _columns_info_for {
 443     my ($self, $table) = @_;
 444
 445     my $dbh = $self->schema->storage->dbh;
 446
 447     my %result;
 448
 449     if (my $sth = try { $self->_dbh_column_info($dbh, undef, $table->schema, $table->name, '%' ) }) {
 450         COL_INFO: while (my $info = try { $sth->fetchrow_hashref } catch { +{} }) {
 451             next COL_INFO unless %$info;
 452
 453             my $column_info = {};
 454             $column_info->{data_type}     = lc $info->{TYPE_NAME};
 455
 456             my $size = $info->{COLUMN_SIZE};
 457
 458             if (defined $size && defined $info->{DECIMAL_DIGITS}) {
 459                 $column_info->{size} = [$size, $info->{DECIMAL_DIGITS}];
 460             }
 461             elsif (defined $size) {
 462                 $column_info->{size} = $size;
 463             }
 464
 465             $column_info->{is_nullable}   = $info->{NULLABLE} ? 1 : 0;
 466             $column_info->{default_value} = $info->{COLUMN_DEF} if defined $info->{COLUMN_DEF};
 467             my $col_name = $info->{COLUMN_NAME};
 468             $col_name =~ s/^\"(.*)\"$/$1/;
 469
 470             $col_name = $self->_lc($col_name);
 471
 472             my $extra_info = $self->_extra_column_info(
 473                 $table, $col_name, $column_info, $info
 474             ) || {};
 475             $column_info = { %$column_info, %$extra_info };
 476
 477             $result{$col_name} = $column_info;
 478         }
 479         $sth->finish;
 480     }
 481
 482     my $sth = $self->_sth_for($table, undef, \'1 = 0');
 483     $sth->execute;
 484
 485     my @columns = @{ $sth->{NAME} };
 486
 487     COL: for my $i (0 .. $#columns) {
 488         next COL if %{ $result{ $self->_lc($columns[$i]) }||{} };
 489
 490         my $column_info = {};
 491         $column_info->{data_type} = lc $sth->{TYPE}[$i];
 492
 493         my $size = $sth->{PRECISION}[$i];
 494
 495         if (defined $size && defined $sth->{SCALE}[$i]) {
 496             $column_info->{size} = [$size, $sth->{SCALE}[$i]];
 497         }
 498         elsif (defined $size) {
 499             $column_info->{size} = $size;
 500         }
 501
 502         $column_info->{is_nullable} = $sth->{NULLABLE}[$i] ? 1 : 0;
 503
 504         if ($column_info->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
 505             $column_info->{data_type} = $1;
 506             $column_info->{size}    = $2;
 507         }
 508
 509         my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info, $sth) || {};
 510         $column_info = { %$column_info, %$extra_info };
 511
 512         $result{ $self->_lc($columns[$i]) } = $column_info;
 513     }
 514     $sth->finish;
 515
 516     foreach my $col (keys %result) {
 517         my $colinfo = $result{$col};
 518         my $type_num = $colinfo->{data_type};
 519         my $type_name;
 520         if (defined $type_num && $type_num =~ /^-?\d+\z/ && $dbh->can('type_info')) {
 521             my $type_name = $self->_dbh_type_info_type_name($type_num);
 522             $colinfo->{data_type} = lc $type_name if $type_name;
 523         }
 524     }
 525
 526     return \%result;
 527 }
 528
 529 # Need to override this for the buggy Firebird ODBC driver.
 530 sub _dbh_type_info_type_name {
 531     my ($self, $type_num) = @_;
 532
 533     # We wrap it in a try block for MSSQL+DBD::Sybase, which can have issues.
 534     # TODO investigate further
 535     my $type_info = try { $self->dbh->type_info($type_num) };
 536
 537     return $type_info ? $type_info->{TYPE_NAME} : undef;
 538 }
 539
 540 # do not use this, override _columns_info_for instead
 541 sub _extra_column_info {}
 542
 543 # override to mask warnings if needed
 544 sub _dbh_table_info {
 545     my ($self, $dbh) = (shift, shift);
 546
 547     return $dbh->table_info(@_);
 548 }
 549
 550 # override to mask warnings if needed (see mysql)
 551 sub _dbh_column_info {
 552     my ($self, $dbh) = (shift, shift);
 553
 554     return $dbh->column_info(@_);
 555 }
 556
 557 # If a coderef uses DBI->connect, this should get its connect info.
 558 sub _try_infer_connect_info_from_coderef {
 559     my ($self, $code) = @_;
 560
 561     my ($dsn, $user, $pass, $params);
 562
 563     no warnings 'redefine';
 564
 565     local *DBI::connect = sub {
 566         (undef, $dsn, $user, $pass, $params) = @_;
 567     };
 568
 569     $code->();
 570
 571     return ($dsn, $user, $pass, $params);
 572 }
 573
 574 sub dbh {
 575     my $self = shift;
 576
 577     return $self->schema->storage->dbh;
 578 }
 579
 580 =head1 SEE ALSO
 581
 582 L<DBIx::Class::Schema::Loader>
 583
 584 =head1 AUTHOR
 585
 586 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 587
 588 =head1 LICENSE
 589
 590 This library is free software; you can redistribute it and/or modify it under
 591 the same terms as Perl itself.
 592
 593 =cut
 594
 595 1;
 596 # vim:et sts=4 sw=4 tw=0: