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