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