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.07010';
  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
 327     my $comments_table = $table->clone;
 328     $comments_table->name($self->table_comments_table);
 329
 330     my ($comment) = try { $self->dbh->selectrow_array(<<"EOF") };
 331 SELECT comment_text
 332 FROM @{[ $comments_table->sql_name ]}
 333 WHERE table_name = @{[ $self->dbh->quote($table->name) ]}
 334 EOF
 335
 336     return $comment;
 337 }
 338
 339 sub _column_comment {
 340     my ($self, $table, $column_number, $column_name) = @_;
 341
 342     my $comments_table = $table->clone;
 343     $comments_table->name($self->column_comments_table);
 344
 345     my ($comment) = try { $self->dbh->selectrow_array(<<"EOF") };
 346 SELECT comment_text
 347 FROM @{[ $comments_table->sql_name ]}
 348 WHERE table_name = @{[ $self->dbh->quote($table->name) ]}
 349 AND column_name = @{[ $self->dbh->quote($column_name) ]}
 350 EOF
 351
 352     return $comment;
 353 }
 354
 355 # Find relationships
 356 sub _table_fk_info {
 357     my ($self, $table) = @_;
 358
 359     return [] if $self->_disable_fk_detection;
 360
 361     my $sth = try {
 362         $self->dbh->foreign_key_info( '', '', '',
 363                                 '', ($table->schema || ''), $table->name );
 364     }
 365     catch {
 366         warn "Cannot introspect relationships for this driver: $_";
 367         $self->_disable_fk_detection(1);
 368         return undef;
 369     };
 370
 371     return [] if !$sth;
 372
 373     my %rels;
 374
 375     my $i = 1; # for unnamed rels, which hopefully have only 1 column ...
 376     REL: while(my $raw_rel = $sth->fetchrow_arrayref) {
 377         my $uk_scm  = $raw_rel->[1];
 378         my $uk_tbl  = $raw_rel->[2];
 379         my $uk_col  = $self->_lc($raw_rel->[3]);
 380         my $fk_scm  = $raw_rel->[5];
 381         my $fk_col  = $self->_lc($raw_rel->[7]);
 382         my $relid   = ($raw_rel->[11] || ( "__dcsld__" . $i++ ));
 383
 384         foreach my $var ($uk_scm, $uk_tbl, $uk_col, $fk_scm, $fk_col, $relid) {
 385             $var =~ s/[\Q$self->{quote_char}\E]//g;
 386         }
 387
 388         if ($self->db_schema && $self->db_schema->[0] ne '%'
 389             && (not any { $_ eq $uk_scm } @{ $self->db_schema })) {
 390
 391             next REL;
 392         }
 393
 394         $rels{$relid}{tbl} = DBIx::Class::Schema::Loader::Table->new(
 395             loader => $self,
 396             name   => $uk_tbl,
 397             schema => $uk_scm,
 398             ($self->_supports_db_schema ? () : (
 399                 ignore_schema => 1
 400             )),
 401         );
 402         $rels{$relid}{cols}{$uk_col} = $fk_col;
 403     }
 404     $sth->finish;
 405
 406     my @rels;
 407     foreach my $relid (keys %rels) {
 408         push(@rels, {
 409             remote_columns => [ keys   %{$rels{$relid}->{cols}} ],
 410             local_columns  => [ values %{$rels{$relid}->{cols}} ],
 411             remote_table   => $rels{$relid}->{tbl},
 412         });
 413     }
 414
 415     return \@rels;
 416 }
 417
 418 # ported in from DBIx::Class::Storage::DBI:
 419 sub _columns_info_for {
 420     my ($self, $table) = @_;
 421
 422     my $dbh = $self->schema->storage->dbh;
 423
 424     my %result;
 425
 426     if ($dbh->can('column_info')) {
 427         my $sth = $self->_dbh_column_info($dbh, undef, $table->schema, $table->name, '%' );
 428         while ( my $info = $sth->fetchrow_hashref() ){
 429             my $column_info = {};
 430             $column_info->{data_type}     = lc $info->{TYPE_NAME};
 431
 432             my $size = $info->{COLUMN_SIZE};
 433
 434             if (defined $size && defined $info->{DECIMAL_DIGITS}) {
 435                 $column_info->{size} = [$size, $info->{DECIMAL_DIGITS}];
 436             }
 437             elsif (defined $size) {
 438                 $column_info->{size} = $size;
 439             }
 440
 441             $column_info->{is_nullable}   = $info->{NULLABLE} ? 1 : 0;
 442             $column_info->{default_value} = $info->{COLUMN_DEF} if defined $info->{COLUMN_DEF};
 443             my $col_name = $info->{COLUMN_NAME};
 444             $col_name =~ s/^\"(.*)\"$/$1/;
 445
 446             $col_name = $self->_lc($col_name);
 447
 448             my $extra_info = $self->_extra_column_info(
 449                 $table, $col_name, $column_info, $info
 450             ) || {};
 451             $column_info = { %$column_info, %$extra_info };
 452
 453             $result{$col_name} = $column_info;
 454         }
 455         $sth->finish;
 456
 457         return \%result if %result;
 458     }
 459
 460     my $sth = $self->_sth_for($table, undef, \'1 = 0');
 461     $sth->execute;
 462
 463     my @columns = @{ $sth->{NAME} };
 464
 465     for my $i (0 .. $#columns) {
 466         my $column_info = {};
 467         $column_info->{data_type} = lc $sth->{TYPE}[$i];
 468
 469         my $size = $sth->{PRECISION}[$i];
 470
 471         if (defined $size && defined $sth->{SCALE}[$i]) {
 472             $column_info->{size} = [$size, $sth->{SCALE}[$i]];
 473         }
 474         elsif (defined $size) {
 475             $column_info->{size} = $size;
 476         }
 477
 478         $column_info->{is_nullable} = $sth->{NULLABLE}[$i] ? 1 : 0;
 479
 480         if ($column_info->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
 481             $column_info->{data_type} = $1;
 482             $column_info->{size}    = $2;
 483         }
 484
 485         my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info, $sth) || {};
 486         $column_info = { %$column_info, %$extra_info };
 487
 488         $result{ $self->_lc($columns[$i]) } = $column_info;
 489     }
 490     $sth->finish;
 491
 492     foreach my $col (keys %result) {
 493         my $colinfo = $result{$col};
 494         my $type_num = $colinfo->{data_type};
 495         my $type_name;
 496         if (defined $type_num && $type_num =~ /^-?\d+\z/ && $dbh->can('type_info')) {
 497             my $type_name = $self->_dbh_type_info_type_name($type_num);
 498             $colinfo->{data_type} = lc $type_name if $type_name;
 499         }
 500     }
 501
 502     return \%result;
 503 }
 504
 505 # Need to override this for the buggy Firebird ODBC driver.
 506 sub _dbh_type_info_type_name {
 507     my ($self, $type_num) = @_;
 508
 509     # We wrap it in a try block for MSSQL+DBD::Sybase, which can have issues.
 510     # TODO investigate further
 511     my $type_info = try { $self->dbh->type_info($type_num) };
 512
 513     return $type_info ? $type_info->{TYPE_NAME} : undef;
 514 }
 515
 516 # do not use this, override _columns_info_for instead
 517 sub _extra_column_info {}
 518
 519 # override to mask warnings if needed (see mysql)
 520 sub _dbh_column_info {
 521     my ($self, $dbh) = (shift, shift);
 522
 523     return $dbh->column_info(@_);
 524 }
 525
 526 # If a coderef uses DBI->connect, this should get its connect info.
 527 sub _try_infer_connect_info_from_coderef {
 528     my ($self, $code) = @_;
 529
 530     my ($dsn, $user, $pass, $params);
 531
 532     no warnings 'redefine';
 533
 534     local *DBI::connect = sub {
 535         (undef, $dsn, $user, $pass, $params) = @_;
 536     };
 537
 538     $code->();
 539
 540     return ($dsn, $user, $pass, $params);
 541 }
 542
 543 sub dbh {
 544     my $self = shift;
 545
 546     return $self->schema->storage->dbh;
 547 }
 548
 549 =head1 SEE ALSO
 550
 551 L<DBIx::Class::Schema::Loader>
 552
 553 =head1 AUTHOR
 554
 555 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 556
 557 =head1 LICENSE
 558
 559 This library is free software; you can redistribute it and/or modify it under
 560 the same terms as Perl itself.
 561
 562 =cut
 563
 564 1;
 565 # vim:et sts=4 sw=4 tw=0: