X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI.pm;h=09155748a62daf689c7c30214fe56a0f4e42ffe2;hb=8990a2b23d98bcb87da292ee3731de3ac4f1b86f;hp=d87d5097d4eab982ec992e61c17550fc98c4784e;hpb=c5ff1f26b1537e8184313cb6d05f86c4a31fd3b8;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm index d87d509..0915574 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI.pm @@ -3,10 +3,23 @@ package DBIx::Class::Schema::Loader::DBI; use strict; use warnings; use base qw/DBIx::Class::Schema::Loader::Base/; -use Class::C3; +use mro 'c3'; +use Try::Tiny; +use List::MoreUtils 'any'; use Carp::Clan qw/^DBIx::Class/; +use namespace::clean; +use DBIx::Class::Schema::Loader::Table (); -our $VERSION = '0.05000'; +our $VERSION = '0.07028'; + +__PACKAGE__->mk_group_accessors('simple', qw/ + _disable_pk_detection + _disable_uniq_detection + _disable_fk_detection + _passwords + quote_char + name_sep +/); =head1 NAME @@ -35,44 +48,49 @@ things. sub new { my $self = shift->next::method(@_); - # rebless to vendor-specific class if it exists and loads - my $dbh = $self->schema->storage->dbh; - my $driver = $dbh->{Driver}->{Name}; + # rebless to vendor-specific class if it exists and loads and we're not in a + # custom class. + if (not $self->loader_class) { + my $driver = $self->dbh->{Driver}->{Name}; - my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver; - if ($self->load_optional_class($subclass)) { - bless $self, $subclass unless $self->isa($subclass); - $self->_rebless; + my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver; + if ((not $self->isa($subclass)) && $self->load_optional_class($subclass)) { + bless $self, $subclass; + $self->_rebless; + Class::C3::reinitialize() if $] < 5.009005; + } } # Set up the default quoting character and name seperators - $self->{_quoter} = $self->_build_quoter; - $self->{_namesep} = $self->_build_namesep; - # For our usage as regex matches, concatenating multiple quoter - # values works fine (e.g. s/\Q<>\E// if quoter was [ '<', '>' ]) - if( ref $self->{_quoter} eq 'ARRAY') { - $self->{_quoter} = join(q{}, @{$self->{_quoter}}); - } + $self->quote_char($self->_build_quote_char); + $self->name_sep($self->_build_name_sep); $self->_setup; - $self; + return $self; } -sub _build_quoter { +sub _build_quote_char { my $self = shift; - my $dbh = $self->schema->storage->dbh; - return $dbh->get_info(29) + + my $quote_char = $self->dbh->get_info(29) || $self->schema->storage->sql_maker->quote_char || q{"}; + + # For our usage as regex matches, concatenating multiple quote_char + # values works fine (e.g. s/[\Q<>\E]// if quote_char was [ '<', '>' ]) + if (ref $quote_char eq 'ARRAY') { + $quote_char = join '', @$quote_char; + } + + return $quote_char; } -sub _build_namesep { +sub _build_name_sep { my $self = shift; - my $dbh = $self->schema->storage->dbh; - return $dbh->get_info(41) + return $self->dbh->get_info(41) || $self->schema->storage->sql_maker->name_sep - || q{.}; + || '.'; } # Override this in vendor modules to do things at the end of ->new() @@ -81,54 +99,128 @@ sub _setup { } # Override this in vendor module to load a subclass if necessary sub _rebless { } -# Returns an array of table names +sub _system_schemas { + return ('information_schema'); +} + +sub _system_tables { + return (); +} + +sub _dbh_tables { + my ($self, $schema) = (shift, shift); + + my ($table_pattern, $table_type_pattern) = @_ ? @_ : ('%', '%'); + + return $self->dbh->tables(undef, $schema, $table_pattern, $table_type_pattern); +} + +# default to be overridden in subclasses if necessary +sub _supports_db_schema { 1 } + +# Returns an array of table objects sub _tables_list { - my $self = shift; + my ($self, $opts) = (shift, shift); + + my @tables; + + my $qt = qr/[\Q$self->{quote_char}\E"'`\[\]]/; + my $nqt = qr/[^\Q$self->{quote_char}\E"'`\[\]]/; + my $ns = qr/[\Q$self->{name_sep}\E]/; + my $nns = qr/[^\Q$self->{name_sep}\E]/; + + foreach my $schema (@{ $self->db_schema || [undef] }) { + my @raw_table_names = $self->_dbh_tables($schema, @_); + + TABLE: foreach my $raw_table_name (@raw_table_names) { + my $quoted = $raw_table_name =~ /^$qt/; + + # These regexes are not entirely correct, but hopefully they will work + # in most cases. RT reports welcome. + my ($schema_name, $table_name1, $table_name2) = $quoted ? + $raw_table_name =~ /^(?:${qt}(${nqt}+?)${qt}${ns})?(?:${qt}(.+?)${qt}|(${nns}+))\z/ + : + $raw_table_name =~ /^(?:(${nns}+?)${ns})?(?:${qt}(.+?)${qt}|(${nns}+))\z/; + + my $table_name = $table_name1 || $table_name2; + + foreach my $system_schema ($self->_system_schemas) { + if ($schema_name) { + my $matches = 0; + + if (ref $system_schema) { + $matches = 1 + if $schema_name =~ $system_schema + && $schema !~ $system_schema; + } + else { + $matches = 1 + if $schema_name eq $system_schema + && $schema ne $system_schema; + } + + next TABLE if $matches; + } + } - my ($table, $type) = @_ ? @_ : ('%', '%'); + foreach my $system_table ($self->_system_tables) { + my $matches = 0; - my $dbh = $self->schema->storage->dbh; - my @tables = $dbh->tables(undef, $self->db_schema, $table, $type); + if (ref $system_table) { + $matches = 1 if $table_name =~ $system_table; + } + else { + $matches = 1 if $table_name eq $system_table + } - my $qt = qr/[\Q$self->{_quoter}\E"'`\[\]]/; + next TABLE if $matches; + } - my $all_tables_quoted = (grep /$qt/, @tables) == @tables; + $schema_name ||= $schema; - if ($self->{_quoter} && $all_tables_quoted) { - s/.* $qt (?= .* $qt)//xg for @tables; - } else { - s/^.*\Q$self->{_namesep}\E// for @tables; + my $table = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $table_name, + schema => $schema_name, + ($self->_supports_db_schema ? () : ( + ignore_schema => 1 + )), + ); + + push @tables, $table; + } } - s/$qt//g for @tables; - return $self->_filter_tables(@tables); + return $self->_filter_tables(\@tables, $opts); } -# ignore bad tables and views +# apply constraint/exclude and ignore bad tables and views sub _filter_tables { - my ($self, @tables) = @_; + my ($self, $tables, $opts) = @_; + my @tables = @$tables; my @filtered_tables; - for my $table (@tables) { - eval { + $opts ||= {}; + my $constraint = $opts->{constraint}; + my $exclude = $opts->{exclude}; + + @tables = grep { /$constraint/ } @tables if defined $constraint; + @tables = grep { ! /$exclude/ } @tables if defined $exclude; + + TABLE: for my $table (@tables) { + try { + local $^W = 0; # for ADO my $sth = $self->_sth_for($table, undef, \'1 = 0'); $sth->execute; - }; - if (not $@) { - push @filtered_tables, $table; - } - else { - warn "Bad table or view '$table', ignoring: $@\n"; - local $@; - eval { - my $schema = $self->schema; - # in older DBIC it's a private method - my $unregister = $schema->can('unregister_source') - || $schema->can('_unregister_source'); - $schema->$unregister($self->_table2moniker($table)); - }; + 1; } + catch { + warn "Bad table or view '$table', ignoring: $_\n"; + 0; + } or next TABLE; + + push @filtered_tables, $table; } return @filtered_tables; @@ -143,31 +235,19 @@ We override L here to hook in our locali sub load { my $self = shift; - local $self->schema->storage->dbh->{RaiseError} = 1; - local $self->schema->storage->dbh->{PrintError} = 0; - $self->next::method(@_); -} - -sub _table_as_sql { - my ($self, $table) = @_; + local $self->dbh->{RaiseError} = 1; + local $self->dbh->{PrintError} = 0; - if($self->{db_schema}) { - $table = $self->{db_schema} . $self->{_namesep} . - $self->_quote_table_name($table); - } else { - $table = $self->_quote_table_name($table); - } + $self->next::method(@_); - return $table; + $self->schema->storage->disconnect unless $self->dynamic; } sub _sth_for { my ($self, $table, $fields, $where) = @_; - my $dbh = $self->schema->storage->dbh; - - my $sth = $dbh->prepare($self->schema->storage->sql_maker - ->select(\$self->_table_as_sql($table), $fields, $where)); + my $sth = $self->dbh->prepare($self->schema->storage->sql_maker + ->select(\$table->sql_name, $fields, $where)); return $sth; } @@ -178,20 +258,33 @@ sub _table_columns { my $sth = $self->_sth_for($table, undef, \'1 = 0'); $sth->execute; - my $retval = \@{$sth->{NAME_lc}}; + + my $retval = [ map $self->_lc($_), @{$sth->{NAME}} ]; + $sth->finish; - $retval; + return $retval; } # Returns arrayref of pk col names sub _table_pk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; + return [] if $self->_disable_pk_detection; + + my @primary = try { + $self->dbh->primary_key('', $table->schema, $table->name); + } + catch { + warn "Cannot find primary keys for this driver: $_"; + $self->_disable_pk_detection(1); + return (); + }; - my @primary = map { lc } $dbh->primary_key('', $self->db_schema, $table); - s/\Q$self->{_quoter}\E//g for @primary; + return [] if not @primary; + + @primary = map { $self->_lc($_) } @primary; + s/[\Q$self->{quote_char}\E]//g for @primary; return \@primary; } @@ -200,14 +293,16 @@ sub _table_pk_info { sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - if(!$dbh->can('statistics_info')) { - warn "No UNIQUE constraint information can be gathered for this vendor"; + return [] if $self->_disable_uniq_detection; + + if (not $self->dbh->can('statistics_info')) { + warn "No UNIQUE constraint information can be gathered for this driver"; + $self->_disable_uniq_detection(1); return []; } my %indices; - my $sth = $dbh->statistics_info(undef, $self->db_schema, $table, 1, 1); + my $sth = $self->dbh->statistics_info(undef, $table->schema, $table->name, 1, 1); while(my $row = $sth->fetchrow_hashref) { # skip table-level stats, conditional indexes, and any index missing # critical fields @@ -217,53 +312,131 @@ sub _table_uniq_info { || !defined $row->{ORDINAL_POSITION} || !$row->{COLUMN_NAME}; - $indices{$row->{INDEX_NAME}}->{$row->{ORDINAL_POSITION}} = $row->{COLUMN_NAME}; + $indices{$row->{INDEX_NAME}}[$row->{ORDINAL_POSITION}] = $self->_lc($row->{COLUMN_NAME}); } $sth->finish; my @retval; foreach my $index_name (keys %indices) { my $index = $indices{$index_name}; - push(@retval, [ $index_name => [ - map { $index->{$_} } - sort keys %$index - ]]); + push(@retval, [ $index_name => [ @$index[1..$#$index] ] ]); } return \@retval; } +sub _table_comment { + my ($self, $table) = @_; + my $dbh = $self->dbh; + + my $comments_table = $table->clone; + $comments_table->name($self->table_comments_table); + + my ($comment) = + (exists $self->_tables->{$comments_table->sql_name} || undef) + && try { $dbh->selectrow_array(<<"EOF") }; +SELECT comment_text +FROM @{[ $comments_table->sql_name ]} +WHERE table_name = @{[ $dbh->quote($table->name) ]} +EOF + + # Failback: try the REMARKS column on table_info + if (!$comment && $dbh->can('table_info')) { + my $sth = $self->_dbh_table_info( $dbh, undef, $table->schema, $table->name ); + my $info = $sth->fetchrow_hashref(); + $comment = $info->{REMARKS}; + } + + return $comment; +} + +sub _column_comment { + my ($self, $table, $column_number, $column_name) = @_; + my $dbh = $self->dbh; + + my $comments_table = $table->clone; + $comments_table->name($self->column_comments_table); + + my ($comment) = + (exists $self->_tables->{$comments_table->sql_name} || undef) + && try { $dbh->selectrow_array(<<"EOF") }; +SELECT comment_text +FROM @{[ $comments_table->sql_name ]} +WHERE table_name = @{[ $dbh->quote($table->name) ]} +AND column_name = @{[ $dbh->quote($column_name) ]} +EOF + + # Failback: try the REMARKS column on column_info + if (!$comment && $dbh->can('column_info')) { + if (my $sth = try { $self->_dbh_column_info( $dbh, undef, $table->schema, $table->name, $column_name ) }) { + my $info = $sth->fetchrow_hashref(); + $comment = $info->{REMARKS}; + } + } + + return $comment; +} + # Find relationships sub _table_fk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->foreign_key_info( '', $self->db_schema, '', - '', $self->db_schema, $table ); + return [] if $self->_disable_fk_detection; + + my $sth = try { + $self->dbh->foreign_key_info( '', '', '', + '', ($table->schema || ''), $table->name ); + } + catch { + warn "Cannot introspect relationships for this driver: $_"; + $self->_disable_fk_detection(1); + return undef; + }; + return [] if !$sth; my %rels; my $i = 1; # for unnamed rels, which hopefully have only 1 column ... - while(my $raw_rel = $sth->fetchrow_arrayref) { + REL: while(my $raw_rel = $sth->fetchrow_arrayref) { + my $uk_scm = $raw_rel->[1]; my $uk_tbl = $raw_rel->[2]; - my $uk_col = lc $raw_rel->[3]; - my $fk_col = lc $raw_rel->[7]; + my $uk_col = $self->_lc($raw_rel->[3]); + my $fk_scm = $raw_rel->[5]; + my $fk_col = $self->_lc($raw_rel->[7]); + my $key_seq = $raw_rel->[8] - 1; my $relid = ($raw_rel->[11] || ( "__dcsld__" . $i++ )); - $uk_tbl =~ s/\Q$self->{_quoter}\E//g; - $uk_col =~ s/\Q$self->{_quoter}\E//g; - $fk_col =~ s/\Q$self->{_quoter}\E//g; - $relid =~ s/\Q$self->{_quoter}\E//g; - $rels{$relid}->{tbl} = $uk_tbl; - $rels{$relid}->{cols}->{$uk_col} = $fk_col; + + foreach my $var ($uk_scm, $uk_tbl, $uk_col, $fk_scm, $fk_col, $relid) { + $var =~ s/[\Q$self->{quote_char}\E]//g if defined $var; + } + + if ($self->db_schema && $self->db_schema->[0] ne '%' + && (not any { $_ eq $uk_scm } @{ $self->db_schema })) { + + next REL; + } + + $rels{$relid}{tbl} = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $uk_tbl, + schema => $uk_scm, + ($self->_supports_db_schema ? () : ( + ignore_schema => 1 + )), + ); + + # Add this data IN ORDER + $rels{$relid}{rcols}[$key_seq] = $uk_col; + $rels{$relid}{lcols}[$key_seq] = $fk_col; } $sth->finish; my @rels; foreach my $relid (keys %rels) { push(@rels, { - remote_columns => [ keys %{$rels{$relid}->{cols}} ], - local_columns => [ values %{$rels{$relid}->{cols}} ], + remote_columns => [ grep defined, @{ $rels{$relid}{rcols} } ], + local_columns => [ grep defined, @{ $rels{$relid}{lcols} } ], remote_table => $rels{$relid}->{tbl}, }); } @@ -277,46 +450,70 @@ sub _columns_info_for { my $dbh = $self->schema->storage->dbh; - if ($dbh->can('column_info')) { - my %result; - eval { - my $sth = $dbh->column_info( undef, $self->db_schema, $table, '%' ); - while ( my $info = $sth->fetchrow_hashref() ){ - my %column_info; - $column_info{data_type} = $info->{TYPE_NAME}; - $column_info{size} = $info->{COLUMN_SIZE}; - $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0; - $column_info{default_value} = $info->{COLUMN_DEF}; - my $col_name = $info->{COLUMN_NAME}; - $col_name =~ s/^\"(.*)\"$/$1/; - - my $extra_info = $self->_extra_column_info($info) || {}; - - $result{$col_name} = { %column_info, %$extra_info }; + my %result; + + if (my $sth = try { $self->_dbh_column_info($dbh, undef, $table->schema, $table->name, '%' ) }) { + COL_INFO: while (my $info = try { $sth->fetchrow_hashref } catch { +{} }) { + next COL_INFO unless %$info; + + my $column_info = {}; + $column_info->{data_type} = lc $info->{TYPE_NAME}; + + my $size = $info->{COLUMN_SIZE}; + + if (defined $size && defined $info->{DECIMAL_DIGITS}) { + $column_info->{size} = [$size, $info->{DECIMAL_DIGITS}]; + } + elsif (defined $size) { + $column_info->{size} = $size; } - $sth->finish; - }; - return \%result if !$@ && scalar keys %result; + + $column_info->{is_nullable} = $info->{NULLABLE} ? 1 : 0; + $column_info->{default_value} = $info->{COLUMN_DEF} if defined $info->{COLUMN_DEF}; + my $col_name = $info->{COLUMN_NAME}; + $col_name =~ s/^\"(.*)\"$/$1/; + + my $extra_info = $self->_extra_column_info( + $table, $col_name, $column_info, $info + ) || {}; + $column_info = { %$column_info, %$extra_info }; + + $result{$col_name} = $column_info; + } + $sth->finish; } - my %result; my $sth = $self->_sth_for($table, undef, \'1 = 0'); $sth->execute; - my @columns = @{$sth->{NAME_lc}}; - for my $i ( 0 .. $#columns ){ - my %column_info; - $column_info{data_type} = $sth->{TYPE}->[$i]; - $column_info{size} = $sth->{PRECISION}->[$i]; - $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0; - - if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) { - $column_info{data_type} = $1; - $column_info{size} = $2; + + my @columns = @{ $sth->{NAME} }; + + COL: for my $i (0 .. $#columns) { + next COL if %{ $result{ $columns[$i] }||{} }; + + my $column_info = {}; + $column_info->{data_type} = lc $sth->{TYPE}[$i]; + + my $size = $sth->{PRECISION}[$i]; + + if (defined $size && defined $sth->{SCALE}[$i]) { + $column_info->{size} = [$size, $sth->{SCALE}[$i]]; + } + elsif (defined $size) { + $column_info->{size} = $size; + } + + $column_info->{is_nullable} = $sth->{NULLABLE}[$i] ? 1 : 0; + + if ($column_info->{data_type} =~ m/^(.*?)\((.*?)\)$/) { + $column_info->{data_type} = $1; + $column_info->{size} = $2; } - my $extra_info = $self->_extra_column_info($table, $columns[$i], $sth, $i) || {}; + my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info, $sth) || {}; + $column_info = { %$column_info, %$extra_info }; - $result{$columns[$i]} = { %column_info, %$extra_info }; + $result{ $columns[$i] } = $column_info; } $sth->finish; @@ -324,20 +521,92 @@ sub _columns_info_for { my $colinfo = $result{$col}; my $type_num = $colinfo->{data_type}; my $type_name; - if(defined $type_num && $dbh->can('type_info')) { - my $type_info = $dbh->type_info($type_num); - $type_name = $type_info->{TYPE_NAME} if $type_info; - $colinfo->{data_type} = $type_name if $type_name; + if (defined $type_num && $type_num =~ /^-?\d+\z/ && $dbh->can('type_info')) { + my $type_name = $self->_dbh_type_info_type_name($type_num); + $colinfo->{data_type} = lc $type_name if $type_name; + } + } + + # check for instances of the same column name with different case in preserve_case=0 mode + if (not $self->preserve_case) { + my %lc_colnames; + + foreach my $col (keys %result) { + push @{ $lc_colnames{lc $col} }, $col; + } + + if (keys %lc_colnames != keys %result) { + my @offending_colnames = map @$_, grep @$_ > 1, values %lc_colnames; + + my $offending_colnames = join ", ", map "'$_'", @offending_colnames; + + croak "columns $offending_colnames in table @{[ $table->sql_name ]} collide in preserve_case=0 mode. preserve_case=1 mode required"; + } + + # apply lowercasing + my %lc_result; + + while (my ($col, $info) = each %result) { + $lc_result{ $self->_lc($col) } = $info; } + + %result = %lc_result; } return \%result; } -# Override this in vendor class to return any additional column -# attributes +# Need to override this for the buggy Firebird ODBC driver. +sub _dbh_type_info_type_name { + my ($self, $type_num) = @_; + + # We wrap it in a try block for MSSQL+DBD::Sybase, which can have issues. + # TODO investigate further + my $type_info = try { $self->dbh->type_info($type_num) }; + + return $type_info ? $type_info->{TYPE_NAME} : undef; +} + +# do not use this, override _columns_info_for instead sub _extra_column_info {} +# override to mask warnings if needed +sub _dbh_table_info { + my ($self, $dbh) = (shift, shift); + + return $dbh->table_info(@_); +} + +# override to mask warnings if needed (see mysql) +sub _dbh_column_info { + my ($self, $dbh) = (shift, shift); + + return $dbh->column_info(@_); +} + +# If a coderef uses DBI->connect, this should get its connect info. +sub _try_infer_connect_info_from_coderef { + my ($self, $code) = @_; + + my ($dsn, $user, $pass, $params); + + no warnings 'redefine'; + + local *DBI::connect = sub { + (undef, $dsn, $user, $pass, $params) = @_; + }; + + $code->(); + + return ($dsn, $user, $pass, $params); +} + +sub dbh { + my $self = shift; + + return $self->schema->storage->dbh; +} + =head1 SEE ALSO L @@ -354,3 +623,4 @@ the same terms as Perl itself. =cut 1; +# vim:et sts=4 sw=4 tw=0: