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