From: Rafael Kitover Date: Mon, 30 May 2011 20:01:46 +0000 (-0400) Subject: multi db_schema support X-Git-Tag: 0.07011~50 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c4a69b87bd3d3fdda08f05d363311a6e9d3fc0f7;p=dbsrgits%2FDBIx-Class-Schema-Loader.git multi db_schema support Allows putting multiple schemas or databases and schemas into the db_schema option. Supports cross-schema foreign keys where available. On Sybase ASE, MSSQL and Informix multiple databases as well as schemas are supported (but only Sybase ASE allows cross-database foreign keys.) Adds the moniker_parts option for resolving name clashes when using multiple schemas that have tables with the same name. Table names are now represented by the ::Table class (all the code for which is in the ::DBObject superclass.) There is also ::Table::Sybase for Sybase ASE and MSSQL as well as ::Table::Informix for Informix. In the future other database objects such as sequences may use the ::DBObject class. Currently there are extra tests for objects in separate schemas and cross-schema relationships for each database separately, these may later be merged into the common tests in some fashion. All database backends are up to date with respect to their capabilities for fully qualified table names, with some exceptions. - no support for dblinks in Oracle - no support for serverlinks in MSSQL - no support for databases attached as namespaces in SQLite For SQLite, Firebird and MS Access it is possible to pass a single db_schema and have DBIC names qualified with it, but this capability is primarily for testing and deployment. --- diff --git a/Changes b/Changes index 6129ecc..2e70f2d 100644 --- a/Changes +++ b/Changes @@ -9,6 +9,9 @@ Revision history for Perl extension DBIx::Class::Schema::Loader - $schema->loader is now a public method - add schema_components option - sort relationships so they always come out in the same order + - multi db_schema support with cross-schema rels (RT#39478) + - added moniker_parts option for name clashes in multi db_schema setups + - add quiet option - add rel_name_map option - fix the decimal data type for MS Access over ODBC - fix enum/set detection for MySQL (RT#68717) diff --git a/TODO b/TODO index d389238..2257cca 100644 --- a/TODO +++ b/TODO @@ -47,6 +47,7 @@ - remove implicit rels from common tests so all tests work on MySQL - sort unique keys by name - server link support for Oracle and MSSQL + - add -I support to dbicdump - Relationships - Re-scan relations/tables after initial relation setup to find diff --git a/lib/DBIx/Class/Schema/Loader.pm b/lib/DBIx/Class/Schema/Loader.pm index ab10bf5..f701e74 100644 --- a/lib/DBIx/Class/Schema/Loader.pm +++ b/lib/DBIx/Class/Schema/Loader.pm @@ -465,19 +465,7 @@ Can be imported into your dump script and called as a function as well: =head2 Multiple Database Schemas -Currently the loader is limited to working within a single schema -(using the underlying RDBMS's definition of "schema"). If you have a -multi-schema database with inter-schema relationships (which is easy -to do in PostgreSQL or DB2 for instance), you currently can only -automatically load the tables of one schema, and relationships to -tables in other schemas will be silently ignored. - -At some point in the future, an intelligent way around this might be -devised, probably by allowing the C option to be an -arrayref of schemas to load. - -In "normal" L usage, manually-defined -source classes and relationships have no problems crossing vendor schemas. +See L. =head1 ACKNOWLEDGEMENTS diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index e854e51..11ca730 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -22,7 +22,7 @@ use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); use Encode qw/encode decode/; -use List::MoreUtils 'all'; +use List::MoreUtils qw/all firstidx/; use IPC::Open2; use Symbol 'gensym'; use namespace::clean; @@ -61,7 +61,6 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ relationship_attrs - db_schema _tables classes _upgrading_classes @@ -72,11 +71,10 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ datetime_locale config_file loader_class - qualify_objects - tables table_comments_table column_comments_table class_to_table + moniker_to_table uniq_to_primary quiet /); @@ -105,6 +103,9 @@ __PACKAGE__->mk_group_accessors('simple', qw/ _result_class_methods naming_set filter_generated_code + db_schema + qualify_objects + moniker_parts /); my $CURRENT_V = 'v7'; @@ -354,8 +355,52 @@ decides to execute will be C-ed before execution. =head2 db_schema Set the name of the schema to load (schema in the sense that your database -vendor means it). Does not currently support loading more than one schema -name. +vendor means it). + +Can be set to an arrayref of schema names for multiple schemas, or the special +value C<%> for all schemas. + +For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as +keys and arrays of owners as values, set to the value: + + { '%' => '%' } + +for all owners in all databases. + +You may need to control naming of monikers with L if you have +name clashes for tables in different schemas/databases. + +=head2 moniker_parts + +The database table names are represented by the +L class in the loader, the +L class for Sybase ASE and +L for Informix. + +Monikers are created normally based on just the +L property, corresponding to +the table name, but can consist of other parts of the fully qualified name of +the table. + +The L option is an arrayref of methods on the table class +corresponding to parts of the fully qualified table name, defaulting to +C<['name']>, in the order those parts are used to create the moniker name. + +The C<'name'> entry B be present. + +Below is a table of supported databases and possible L. + +=over 4 + +=item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access + +C, C + +=item * Informix, MSSQL, Sybase ASE + +C, C, C + +=back =head2 constraint @@ -827,8 +872,9 @@ sub new { } } + $self->{_tables} = {}; $self->{monikers} = {}; - $self->{tables} = {}; + $self->{moniker_to_table} = {}; $self->{class_to_table} = {}; $self->{classes} = {}; $self->{_upgrading_classes} = {}; @@ -925,7 +971,40 @@ sub new { } } - $self; + if (defined $self->db_schema) { + if (ref $self->db_schema eq 'ARRAY') { + if (@{ $self->db_schema } > 1) { + $self->{qualify_objects} = 1; + } + elsif (@{ $self->db_schema } == 0) { + $self->{db_schema} = undef; + } + } + elsif (not ref $self->db_schema) { + if ($self->db_schema eq '%') { + $self->{qualify_objects} = 1; + } + + $self->{db_schema} = [ $self->db_schema ]; + } + } + + if (not $self->moniker_parts) { + $self->moniker_parts(['name']); + } + else { + if (not ref $self->moniker_parts) { + $self->moniker_parts([ $self->moniker_parts ]); + } + if (ref $self->moniker_parts ne 'ARRAY') { + croak 'moniker_parts must be an arrayref'; + } + if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) { + croak "moniker_parts option *must* contain 'name'"; + } + } + + return $self; } sub _check_back_compat { @@ -1270,16 +1349,16 @@ sub rescan { my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude }); foreach my $table (@current) { - if(!exists $self->{_tables}->{$table}) { + if(!exists $self->_tables->{$table->sql_name}) { push(@created, $table); } } my %current; - @current{@current} = (); - foreach my $table (keys %{ $self->{_tables} }) { - if (not exists $current{$table}) { - $self->_unregister_source_for_table($table); + @current{map $_->sql_name, @current} = (); + foreach my $table (values %{ $self->_tables }) { + if (not exists $current{$table->sql_name}) { + $self->_remove_table($table); } } @@ -1287,7 +1366,11 @@ sub rescan { my $loaded = $self->_load_tables(@current); - return map { $self->monikers->{$_} } @created; + foreach my $table (@created) { + $self->monikers->{$table->sql_name} = $self->_table2moniker($table); + } + + return map { $self->monikers->{$_->sql_name} } @created; } sub _relbuilder { @@ -1318,24 +1401,24 @@ sub _load_tables { # Save the new tables to the tables list foreach (@tables) { - $self->{_tables}->{$_} = 1; + $self->_tables->{$_->sql_name} = $_; } $self->_make_src_class($_) for @tables; # sanity-check for moniker clashes my $inverse_moniker_idx; - for (keys %{$self->monikers}) { - push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_; + foreach my $table (values %{ $self->_tables }) { + push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table; } my @clashes; - for (keys %$inverse_moniker_idx) { - my $tables = $inverse_moniker_idx->{$_}; + foreach my $moniker (keys %$inverse_moniker_idx) { + my $tables = $inverse_moniker_idx->{$moniker}; if (@$tables > 1) { push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'", - join (', ', map { "'$_'" } @$tables), - $_, + join (', ', map $_->sql_name, @$tables), + $moniker, ); } } @@ -1348,7 +1431,6 @@ sub _load_tables { ; } - $self->_setup_src_meta($_) for @tables; if(!$self->skip_relationships) { @@ -1365,7 +1447,7 @@ sub _load_tables { $self->_load_roles($_) for @tables; $self->_load_external($_) - for map { $self->classes->{$_} } @tables; + for map { $self->classes->{$_->sql_name} } @tables; # Reload without unloading first to preserve any symbols from external # packages. @@ -1388,7 +1470,7 @@ sub _reload_classes { # so that we don't repeat custom sections @INC = grep $_ ne $self->dump_directory, @INC; - $self->_dump_to_dir(map { $self->classes->{$_} } @tables); + $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables); unshift @INC, $self->dump_directory; @@ -1397,8 +1479,8 @@ sub _reload_classes { $self->schema->sources; for my $table (@tables) { - my $moniker = $self->monikers->{$table}; - my $class = $self->classes->{$table}; + my $moniker = $self->monikers->{$table->sql_name}; + my $class = $self->classes->{$table->sql_name}; { no warnings 'redefine'; @@ -1609,7 +1691,6 @@ sub _dump_to_dir { } warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet; - } sub _sig_comment { @@ -1911,16 +1992,15 @@ sub _make_src_class { ); } - my $old_class = join(q{::}, @result_namespace, - $self->_table2moniker($table)); + my $old_class = join(q{::}, @result_namespace, $table_moniker); $self->_upgrading_classes->{$table_class} = $old_class unless $table_class eq $old_class; } - $self->classes->{$table} = $table_class; - $self->monikers->{$table} = $table_moniker; - $self->tables->{$table_moniker} = $table; + $self->classes->{$table->sql_name} = $table_class; + $self->monikers->{$table->sql_name} = $table_moniker; + $self->moniker_to_table->{$table_moniker} = $table; $self->class_to_table->{$table_class} = $table; $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes}); @@ -1953,9 +2033,9 @@ sub _make_src_class { } sub _is_result_class_method { - my ($self, $name, $table_name) = @_; + my ($self, $name, $table) = @_; - my $table_moniker = $table_name ? $self->monikers->{$table_name} : ''; + my $table_moniker = $table ? $self->monikers->{$table->sql_name} : ''; $self->_result_class_methods({}) if not defined $self->_result_class_methods; @@ -1999,14 +2079,12 @@ sub _is_result_class_method { sub _resolve_col_accessor_collisions { my ($self, $table, $col_info) = @_; - my $table_name = ref $table ? $$table : $table; - while (my ($col, $info) = each %$col_info) { my $accessor = $info->{accessor} || $col; next if $accessor eq 'id'; # special case (very common column) - if ($self->_is_result_class_method($accessor, $table_name)) { + if ($self->_is_result_class_method($accessor, $table)) { my $mapped = 0; if (my $map = $self->col_collision_map) { @@ -2020,7 +2098,7 @@ sub _resolve_col_accessor_collisions { if (not $mapped) { warn <<"EOF"; -Column '$col' in table '$table_name' collides with an inherited method. +Column '$col' in table '$table' collides with an inherited method. See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base . EOF $info->{accessor} = undef; @@ -2077,18 +2155,6 @@ sub _make_column_accessor_name { return $accessor; } -sub _quote { - my ($self, $identifier) = @_; - - my $qt = $self->schema->storage->sql_maker->quote_char || ''; - - if (ref $qt) { - return $qt->[0] . $identifier . $qt->[1]; - } - - return "${qt}${identifier}${qt}"; -} - # Set up metadata (cols, pks, etc) sub _setup_src_meta { my ($self, $table) = @_; @@ -2096,26 +2162,10 @@ sub _setup_src_meta { my $schema = $self->schema; my $schema_class = $self->schema_class; - my $table_class = $self->classes->{$table}; - my $table_moniker = $self->monikers->{$table}; - - my $table_name = $table; - - my $sql_maker = $self->schema->storage->sql_maker; - my $name_sep = $sql_maker->name_sep; - - if ($name_sep && $table_name =~ /\Q$name_sep\E/) { - $table_name = \ $self->_quote($table_name); - } - - my $full_table_name = ($self->qualify_objects ? - ($self->_quote($self->db_schema) . '.') : '') - . (ref $table_name ? $$table_name : $table_name); + my $table_class = $self->classes->{$table->sql_name}; + my $table_moniker = $self->monikers->{$table->sql_name}; - # be careful to not create refs Data::Dump can "optimize" - $full_table_name = \do {"".$full_table_name} if ref $table_name; - - $self->_dbic_stmt($table_class, 'table', $full_table_name); + $self->_dbic_stmt($table_class, 'table', $table->dbic_name); my $cols = $self->_table_columns($table); my $col_info = $self->__columns_info_for($table); @@ -2127,8 +2177,8 @@ sub _setup_src_meta { my $context = { table_class => $table_class, table_moniker => $table_moniker, - table_name => $table_name, - full_table_name => $full_table_name, + table_name => $table, + full_table_name => $table->dbic_name, schema_class => $schema_class, column_info => $info, }; @@ -2231,7 +2281,7 @@ names. sub tables { my $self = shift; - return keys %{$self->_tables}; + return values %{$self->_tables}; } # Make a moniker from a table @@ -2239,21 +2289,27 @@ sub _default_table2moniker { no warnings 'uninitialized'; my ($self, $table) = @_; + my @name_parts = map $table->$_, @{ $self->moniker_parts }; + + my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts }; + if ($self->naming->{monikers} eq 'v4') { - return join '', map ucfirst, split /[\W_]+/, lc $table; + return join '', map ucfirst, map split(/[\W_]+/, lc $_), @name_parts; } elsif ($self->naming->{monikers} eq 'v5') { - return join '', map ucfirst, split /[\W_]+/, - Lingua::EN::Inflect::Number::to_S(lc $table); + my @parts = map lc, @name_parts; + $parts[$name_idx] = Lingua::EN::Inflect::Number::to_S($parts[$name_idx]); + + return join '', map ucfirst, map split(/[\W_]+/, $_), @parts; } elsif ($self->naming->{monikers} eq 'v6') { - (my $as_phrase = lc $table) =~ s/_+/ /g; + (my $as_phrase = join '', map lc, @name_parts) =~ s/_+/ /g; my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase); return join '', map ucfirst, split /\W+/, $inflected; } - my @words = map lc, split_name $table; + my @words = map lc, map split_name $_, @name_parts; my $as_phrase = join ' ', @words; my $inflected = $self->naming->{monikers} eq 'plural' ? @@ -2283,15 +2339,18 @@ sub _load_relationships { my @tables; foreach my $table (@$tables) { + my $local_moniker = $self->monikers->{$table->sql_name}; + my $tbl_fk_info = $self->_table_fk_info($table); + foreach my $fkdef (@$tbl_fk_info) { + $fkdef->{local_table} = $table; + $fkdef->{local_moniker} = $local_moniker; $fkdef->{remote_source} = - $self->monikers->{delete $fkdef->{remote_table}}; + $self->monikers->{$fkdef->{remote_table}->sql_name}; } my $tbl_uniq_info = $self->_table_uniq_info($table); - my $local_moniker = $self->monikers->{$table}; - push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ]; } @@ -2312,8 +2371,8 @@ sub _load_relationships { sub _load_roles { my ($self, $table) = @_; - my $table_moniker = $self->monikers->{$table}; - my $table_class = $self->classes->{$table}; + my $table_moniker = $self->monikers->{$table->sql_name}; + my $table_class = $self->classes->{$table->sql_name}; my @roles = @{ $self->result_roles || [] }; push @roles, @{ $self->result_roles_map->{$table_moniker} } @@ -2585,19 +2644,16 @@ sub _uc { return $self->preserve_case ? $name : uc($name); } -sub _unregister_source_for_table { +sub _remove_table { my ($self, $table) = @_; try { - local $@; 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)); - delete $self->monikers->{$table}; - delete $self->classes->{$table}; - delete $self->_upgrading_classes->{$table}; - delete $self->{_tables}{$table}; + $schema->$unregister(delete $self->monikers->{$table->sql_name}); + delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}}; + delete $self->_tables->{$table->sql_name}; }; } diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm index a727fe4..600e269 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI.pm @@ -4,9 +4,10 @@ use strict; use warnings; use base qw/DBIx::Class::Schema::Loader::Base/; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; use Try::Tiny; +use List::MoreUtils 'any'; use namespace::clean; +use DBIx::Class::Schema::Loader::Table (); our $VERSION = '0.07010'; @@ -15,6 +16,8 @@ __PACKAGE__->mk_group_accessors('simple', qw/ _disable_uniq_detection _disable_fk_detection _passwords + quote_char + name_sep /); =head1 NAME @@ -47,8 +50,7 @@ sub new { # rebless to vendor-specific class if it exists and loads and we're not in a # custom class. if (not $self->loader_class) { - my $dbh = $self->schema->storage->dbh; - my $driver = $dbh->{Driver}->{Name}; + my $driver = $self->dbh->{Driver}->{Name}; my $subclass = 'DBIx::Class::Schema::Loader::DBI::' . $driver; if ($self->load_optional_class($subclass)) { @@ -58,34 +60,35 @@ sub new { } # 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; } -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() @@ -94,25 +97,97 @@ 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, $opts) = (shift, shift); - my ($table, $type) = @_ ? @_ : ('%', '%'); + 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; + } + } + + 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; + } + + $schema_name ||= $schema; - my $all_tables_quoted = (grep /$qt/, @tables) == @tables; + my $table = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $table_name, + schema => $schema_name, + ($self->_supports_db_schema ? () : ( + ignore_schema => 1 + )), + ); - if ($self->{_quoter} && $all_tables_quoted) { - s/.* $qt (?= .* $qt\z)//xg for @tables; - } else { - s/^.*\Q$self->{_namesep}\E// for @tables; + push @tables, $table; + } } - s/$qt//g for @tables; return $self->_filter_tables(\@tables, $opts); } @@ -131,18 +206,17 @@ sub _filter_tables { @tables = grep { /$constraint/ } @$tables if defined $constraint; @tables = grep { ! /$exclude/ } @$tables if defined $exclude; - LOOP: for my $table (@tables) { + TABLE: for my $table (@tables) { try { local $^W = 0; # for ADO my $sth = $self->_sth_for($table, undef, \'1 = 0'); $sth->execute; + 1; } catch { warn "Bad table or view '$table', ignoring: $_\n"; - $self->_unregister_source_for_table($table); - no warnings 'exiting'; - next LOOP; - }; + 0; + } or next TABLE; push @filtered_tables, $table; } @@ -159,34 +233,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) = @_; - - my $sql_maker = $self->schema->storage->sql_maker; - my $name_sep = $sql_maker->name_sep; - my $db_schema = $self->db_schema; + local $self->dbh->{RaiseError} = 1; + local $self->dbh->{PrintError} = 0; - if($db_schema) { - return $self->_quote($self->{db_schema}) - . $name_sep - . $self->_quote($table); - } + $self->next::method(@_); - return $self->_quote($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; } @@ -209,10 +268,8 @@ sub _table_pk_info { return [] if $self->_disable_pk_detection; - my $dbh = $self->schema->storage->dbh; - my @primary = try { - $dbh->primary_key('', $self->db_schema, $table); + $self->dbh->primary_key('', $table->schema, $table->name); } catch { warn "Cannot find primary keys for this driver: $_"; @@ -223,7 +280,7 @@ sub _table_pk_info { return [] if not @primary; @primary = map { $self->_lc($_) } @primary; - s/\Q$self->{_quoter}\E//g for @primary; + s/[\Q$self->{quote_char}\E]//g for @primary; return \@primary; } @@ -234,16 +291,14 @@ sub _table_uniq_info { return [] if $self->_disable_uniq_detection; - my $dbh = $self->schema->storage->dbh; - - if (not $dbh->can('statistics_info')) { + 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 @@ -266,75 +321,33 @@ sub _table_uniq_info { return \@retval; } -sub _table_found { - my ( $self, $table ) = @_; - return grep {lc($_) eq lc($table)} $self->_tables_list({}); -} +sub _table_comment { + my ($self, $table) = @_; -sub _table_found_cached { - my ( $self, $table ) = @_; - if (not exists ($self->{found_table}->{$table})) { - $self->{found_table}->{$table} = $self->_table_found($table); - } - return $self->{found_table}->{$table}; -} + my $comments_table = $self->table_comments_table; -sub _table_columns_found { - my ( $self, $table, @columns ) = @_; - my %known_column = map {(lc($_)=>$_)} @{$self->_table_columns($table)}; - for my $column (@columns) { - if (not exists $known_column{lc($column)}) { - return(); - } - } - # In scalar context, whether or not all columns were found. - # In list context, all of the found columns. - return map $known_column{lc($_)}, @columns; -} + my ($comment) = try { $self->dbh->selectrow_array(<<"EOF", {}, $table->name) }; +SELECT comment_text +FROM $comments_table +WHERE table_name = ? +EOF -sub _table_columns_found_cached { - my ( $self, $table, @columns ) = @_; - my $key = join chr(28), $table, @columns; - if (not exists $self->{found_table_columns}->{$key}) { - $self->{found_table_columns}->{$key} - = [$self->_table_columns_found($table, @columns)]; - } - return @{ $self->{found_table_columns}{$key} }; -} - -sub _table_comment { - my ( $self, $table ) = @_; - my $table_comments = $self->table_comments_table; - if ($self->_table_found_cached($table_comments) and - $self->_table_columns_found_cached( - $table_comments, 'table_name', 'comment_text') - ) { - my ($comment) = $self->schema->storage->dbh->selectrow_array( - qq{SELECT comment_text - FROM $table_comments - WHERE table_name = ? - }, undef, $table); - return $comment; - } - return undef; + return $comment; } sub _column_comment { - my ( $self, $table, $column_counter, $column_name ) = @_; - my $column_comments = $self->column_comments_table; - if ($self->_table_found_cached($column_comments) and - $self->_table_columns_found_cached( - $column_comments, 'table_name', 'column_name', 'comment_text') - ) { - my ($comment) = $self->schema->storage->dbh->selectrow_array( - qq{SELECT comment_text - FROM $column_comments - WHERE table_name = ? - AND column_name = ? - }, undef, $table, $column_name); - return $comment; - } - return undef; + my ($self, $table, $column_counter, $column_name) = @_; + + my $comments_table = $self->column_comments_table; + + my ($comment) = try { $self->dbh->selectrow_array(<<"EOF", {}, $table->name, $column_name) }; +SELECT comment_text +FROM $comments_table +WHERE table_name = ? +AND column_name = ? +EOF + + return $comment; } # Find relationships @@ -343,10 +356,9 @@ sub _table_fk_info { return [] if $self->_disable_fk_detection; - my $dbh = $self->schema->storage->dbh; my $sth = try { - $dbh->foreign_key_info( '', $self->db_schema, '', - '', $self->db_schema, $table ); + $self->dbh->foreign_key_info( '', '', '', + '', ($table->schema || ''), $table->name ); } catch { warn "Cannot introspect relationships for this driver: $_"; @@ -359,17 +371,33 @@ sub _table_fk_info { 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 = $self->_lc($raw_rel->[3]); + my $fk_scm = $raw_rel->[5]; my $fk_col = $self->_lc($raw_rel->[7]); 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 ($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 + )), + ); + $rels{$relid}{cols}{$uk_col} = $fk_col; } $sth->finish; @@ -394,7 +422,7 @@ sub _columns_info_for { my %result; if ($dbh->can('column_info')) { - my $sth = $self->_dbh_column_info($dbh, undef, $self->db_schema, $table, '%' ); + my $sth = $self->_dbh_column_info($dbh, undef, $table->schema, $table->name, '%' ); while ( my $info = $sth->fetchrow_hashref() ){ my $column_info = {}; $column_info->{data_type} = lc $info->{TYPE_NAME}; @@ -476,9 +504,7 @@ sub _columns_info_for { sub _dbh_type_info_type_name { my ($self, $type_num) = @_; - my $dbh = $self->schema->storage->dbh; - - my $type_info = $dbh->type_info($type_num); + my $type_info = $self->dbh->type_info($type_num); return $type_info ? $type_info->{TYPE_NAME} : undef; } @@ -510,6 +536,12 @@ sub _try_infer_connect_info_from_coderef { return ($dsn, $user, $pass, $params); } +sub dbh { + my $self = shift; + + return $self->schema->storage->dbh; +} + =head1 SEE ALSO L diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm b/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm index 02657e5..c06d599 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm @@ -4,8 +4,6 @@ use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI'; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; -use namespace::clean; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm index b802b78..a052f38 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm @@ -7,7 +7,6 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS /; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; use Try::Tiny; use namespace::clean; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm index e087ce3..b23a8ab 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm @@ -7,8 +7,6 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::MSSQL /; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; -use namespace::clean; our $VERSION = '0.07010'; @@ -25,6 +23,7 @@ See L for usage information. =head1 SEE ALSO +L, L, L, L, L diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm index c95bfb6..75a92d9 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm @@ -6,44 +6,50 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault DBIx::Class::Schema::Loader::DBI /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; +use List::MoreUtils 'any'; +use namespace::clean; + +use DBIx::Class::Schema::Loader::Table (); + our $VERSION = '0.07010'; =head1 NAME DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation. -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->loader_options( db_schema => "MYSCHEMA" ); - - 1; - =head1 DESCRIPTION -See L. +See L and L. =cut +sub _system_schemas { + my $self = shift; + + return ($self->next::method(@_), qw/ + SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS + /); +} + sub _setup { my $self = shift; $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - $self->{db_schema} ||= $dbh->selectrow_array('VALUES(CURRENT_USER)', {}); + my $ns = $self->name_sep; + + $self->db_schema([ $self->dbh->selectrow_array(<<"EOF", {}) ]) unless $self->db_schema; +SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1 +EOF if (not defined $self->preserve_case) { $self->preserve_case(0); } elsif ($self->preserve_case) { $self->schema->storage->sql_maker->quote_char('"'); - $self->schema->storage->sql_maker->name_sep('.'); + $self->schema->storage->sql_maker->name_sep($ns); } } @@ -52,17 +58,17 @@ sub _table_uniq_info { my @uniqs; - my $dbh = $self->schema->storage->dbh; - - my $sth = $self->{_cache}->{db2_uniq} ||= $dbh->prepare( - q{SELECT kcu.COLNAME, kcu.CONSTNAME, kcu.COLSEQ - FROM SYSCAT.TABCONST as tc - JOIN SYSCAT.KEYCOLUSE as kcu - ON tc.CONSTNAME = kcu.CONSTNAME AND tc.TABSCHEMA = kcu.TABSCHEMA - WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'U'} - ) or die $DBI::errstr; + my $sth = $self->{_cache}->{db2_uniq} ||= $self->dbh->prepare(<<'EOF'); +SELECT kcu.colname, kcu.constname, kcu.colseq +FROM syscat.tabconst as tc +JOIN syscat.keycoluse as kcu + ON tc.constname = kcu.constname + AND tc.tabschema = kcu.tabschema + AND tc.tabname = kcu.tabname +WHERE tc.tabschema = ? and tc.tabname = ? and tc.type = 'U' +EOF - $sth->execute($self->db_schema, $self->_uc($table)) or die $DBI::errstr; + $sth->execute($table->schema, $table->name); my %keydata; while(my $row = $sth->fetchrow_arrayref) { @@ -80,48 +86,74 @@ sub _table_uniq_info { return \@uniqs; } -# DBD::DB2 doesn't follow the DBI API for ->tables -sub _tables_list { - my ($self, $opts) = @_; - - my $dbh = $self->schema->storage->dbh; - my @tables = map $self->_lc($_), $dbh->tables( - $self->db_schema ? { TABLE_SCHEM => $self->db_schema } : undef - ); - s/\Q$self->{_quoter}\E//g for @tables; - s/^.*\Q$self->{_namesep}\E// for @tables; - - return $self->_filter_tables(\@tables, $opts); -} - -sub _table_pk_info { - my ($self, $table) = @_; - return $self->next::method($self->_uc($table)); -} - sub _table_fk_info { my ($self, $table) = @_; - my $rels = $self->next::method($self->_uc($table)); + my $sth = $self->{_cache}->{db2_fk} ||= $self->dbh->prepare(<<'EOF'); +SELECT tc.constname, sr.reftabschema, sr.reftabname, + kcu.colname, rkcu.colname, kcu.colseq +FROM syscat.tabconst tc +JOIN syscat.keycoluse kcu + ON tc.constname = kcu.constname + AND tc.tabschema = kcu.tabschema + AND tc.tabname = kcu.tabname +JOIN syscat.references sr + ON tc.constname = sr.constname + AND tc.tabschema = sr.tabschema + AND tc.tabname = sr.tabname +JOIN syscat.keycoluse rkcu + ON sr.refkeyname = rkcu.constname + AND kcu.colseq = rkcu.colseq +WHERE tc.tabschema = ? + AND tc.tabname = ? + AND tc.type = 'F'; +EOF + $sth->execute($table->schema, $table->name); + + my %rels; + + COLS: while (my @row = $sth->fetchrow_array) { + my ($fk, $remote_schema, $remote_table, $local_col, $remote_col, + $colseq) = @row; + + if (not exists $rels{$fk}) { + if ($self->db_schema && $self->db_schema->[0] ne '%' + && (not any { $_ eq $remote_schema } @{ $self->db_schema })) { + + next COLS; + } - foreach my $rel (@$rels) { - $rel->{remote_table} = $self->_lc($rel->{remote_table}); + $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $remote_table, + schema => $remote_schema, + ); + } + + $rels{$fk}{local_columns}[$colseq-1] = $self->_lc($local_col); + $rels{$fk}{remote_columns}[$colseq-1] = $self->_lc($remote_col); } - return $rels; + return [ values %rels ]; +} + + +# DBD::DB2 doesn't follow the DBI API for ->tables +sub _dbh_tables { + my ($self, $schema) = @_; + + return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema } : undef); } sub _columns_info_for { my $self = shift; my ($table) = @_; - my $result = $self->next::method($self->_uc($table)); - - my $dbh = $self->schema->storage->dbh; + my $result = $self->next::method(@_); while (my ($col, $info) = each %$result) { # check for identities - my $sth = $dbh->prepare_cached( + my $sth = $self->dbh->prepare_cached( q{ SELECT COUNT(*) FROM syscat.columns @@ -129,7 +161,7 @@ sub _columns_info_for { AND identity = 'Y' AND generated != '' }, {}, 1); - $sth->execute($self->db_schema, $self->_uc($table), $self->_uc($col)); + $sth->execute($table->schema, $table->name, $self->_uc($col)); if ($sth->fetchrow_array) { $info->{is_auto_increment} = 1; } @@ -172,7 +204,7 @@ sub _columns_info_for { $info->{data_type} = 'varbinary'; } - my ($size) = $dbh->selectrow_array(<<'EOF', {}, $self->db_schema, $self->_uc($table), $self->_uc($col)); + my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col)); SELECT length FROM syscat.columns WHERE tabschema = ? AND tabname = ? AND colname = ? diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm b/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm index 02fe499..ec39903 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm @@ -2,11 +2,13 @@ package DBIx::Class::Schema::Loader::DBI::Informix; use strict; use warnings; -use mro 'c3'; use base qw/DBIx::Class::Schema::Loader::DBI/; -use Carp::Clan qw/^DBIx::Class/; +use mro 'c3'; use Scalar::Util 'looks_like_number'; +use List::MoreUtils 'any'; +use Try::Tiny; use namespace::clean; +use DBIx::Class::Schema::Loader::Table::Informix (); our $VERSION = '0.07010'; @@ -21,6 +23,43 @@ See L and L. =cut +sub _build_name_sep { '.' } + +sub _system_databases { + return (qw/ + sysmaster sysutils sysuser sysadmin + /); +} + +sub _current_db { + my $self = shift; + + my ($current_db) = $self->dbh->selectrow_array(<<'EOF'); +SELECT rtrim(ODB_DBName) +FROM sysmaster:informix.SysOpenDB +WHERE ODB_SessionID = ( + SELECT DBINFO('sessionid') + FROM informix.SysTables + WHERE TabID = 1 + ) and ODB_IsCurrent = 'Y' +EOF + + return $current_db; +} + +sub _owners { + my ($self, $db) = @_; + + my ($owners) = $self->dbh->selectcol_arrayref(<<"EOF"); +SELECT distinct(rtrim(owner)) +FROM ${db}:informix.systables +EOF + + my @owners = grep $_ && $_ ne 'informix' && !/^\d/, @$owners; + + return @owners; +} + sub _setup { my $self = shift; @@ -33,19 +72,137 @@ sub _setup { $self->schema->storage->sql_maker->quote_char('"'); $self->schema->storage->sql_maker->name_sep('.'); } + + my $current_db = $self->_current_db; + + if (ref $self->db_schema eq 'HASH') { + if (keys %{ $self->db_schema } < 2) { + my ($db) = keys %{ $self->db_schema }; + + $db ||= $current_db; + + if ($db eq '%') { + my $owners = $self->db_schema->{$db}; + + my $db_names = $self->dbh->selectcol_arrayref(<<'EOF'); +SELECT rtrim(name) +FROM sysmaster:sysdatabases +EOF + + my @dbs; + + foreach my $db_name (@$db_names) { + push @dbs, $db_name + unless any { $_ eq $db_name } $self->_system_databases; + } + + $self->db_schema({}); + + DB: foreach my $db (@dbs) { + if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) { + my @owners; + + my @db_owners = try { + $self->_owners($db); + } + catch { + if (/without logging/) { + warn +"Database '$db' is unreferencable due to lack of logging.\n"; + } + return (); + }; + + foreach my $owner (@$owners) { + push @owners, $owner + if any { $_ eq $owner } @db_owners; + } + + next DB unless @owners; + + $self->db_schema->{$db} = \@owners; + } + else { + # for post-processing below + $self->db_schema->{$db} = '%'; + } + } + + $self->qualify_objects(1); + } + else { + if ($db ne $current_db) { + $self->qualify_objects(1); + } + } + } + else { + $self->qualify_objects(1); + } + } + elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) { + my $owners = $self->db_schema; + $owners ||= [ $self->dbh->selectrow_array(<<'EOF') ]; +SELECT rtrim(username) +FROM sysmaster:syssessions +WHERE sid = DBINFO('sessionid') +EOF + + $self->qualify_objects(1) if @$owners > 1; + + $self->db_schema({ $current_db => $owners }); + } + + DB: foreach my $db (keys %{ $self->db_schema }) { + if ($self->db_schema->{$db} eq '%') { + my @db_owners = try { + $self->_owners($db); + } + catch { + if (/without logging/) { + warn +"Database '$db' is unreferencable due to lack of logging.\n"; + } + return (); + }; + + if (not @db_owners) { + delete $self->db_schema->{$db}; + next DB; + } + + $self->db_schema->{$db} = \@db_owners; + + $self->qualify_objects(1); + } + } } sub _tables_list { my ($self, $opts) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); -select tabname from systables t -where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION' + my @tables; + + while (my ($db, $owners) = each %{ $self->db_schema }) { + foreach my $owner (@$owners) { + my $table_names = $self->dbh->selectcol_arrayref(<<"EOF", {}, $owner); +select tabname +FROM ${db}:informix.systables +WHERE rtrim(owner) = ? EOF - $sth->execute; - my @tables = map @$_, @{ $sth->fetchall_arrayref }; + TABLE: foreach my $table_name (@$table_names) { + next if $table_name =~ /^\s/; + + push @tables, DBIx::Class::Schema::Loader::Table::Informix->new( + loader => $self, + name => $table_name, + database => $db, + schema => $owner, + ); + } + } + } return $self->_filter_tables(\@tables, $opts); } @@ -53,15 +210,18 @@ EOF sub _constraints_for { my ($self, $table, $type) = @_; - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; - my $sth = $dbh->prepare(<<'EOF'); -select c.constrname, i.* -from sysconstraints c -join systables t on t.tabid = c.tabid -join sysindexes i on c.idxname = i.idxname -where t.tabname = ? and c.constrtype = ? + my $db = $table->database; + + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT c.constrname, i.* +FROM ${db}:informix.sysconstraints c +JOIN ${db}:informix.systables t + ON t.tabid = c.tabid +JOIN ${db}:informix.sysindexes i + ON c.idxname = i.idxname +WHERE t.tabname = ? and c.constrtype = ? EOF $sth->execute($table, $type); my $indexes = $sth->fetchall_hashref('constrname'); @@ -86,14 +246,16 @@ sub _idx_colnames { sub _colnames_by_colno { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $db = $table->database; - my $sth = $dbh->prepare(<<'EOF'); -select c.colname, c.colno -from syscolumns c -join systables t on c.tabid = t.tabid -where t.tabname = ? + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT c.colname, c.colno +FROM ${db}:informix.syscolumns c +JOIN ${db}:informix.systables t + ON c.tabid = t.tabid +WHERE t.tabname = ? EOF $sth->execute($table); my $cols = $sth->fetchall_hashref('colno'); @@ -124,18 +286,24 @@ sub _table_fk_info { my $local_columns = $self->_constraints_for($table, 'R'); - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; - - my $sth = $dbh->prepare(<<'EOF'); -select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.* -from sysconstraints c -join systables t on c.tabid = t.tabid -join sysreferences r on c.constrid = r.constrid -join sysconstraints rc on rc.constrid = r.primary -join systables rt on r.ptabid = rt.tabid -join sysindexes ri on rc.idxname = ri.idxname -where t.tabname = ? and c.constrtype = 'R' + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $db = $table->database; + + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.* +FROM ${db}:informix.sysconstraints c +JOIN ${db}:informix.systables t + ON c.tabid = t.tabid +JOIN ${db}:informix.sysreferences r + ON c.constrid = r.constrid +JOIN ${db}:informix.sysconstraints rc + ON rc.constrid = r.primary +JOIN ${db}:informix.systables rt + ON r.ptabid = rt.tabid +JOIN ${db}:informix.sysindexes ri + ON rc.idxname = ri.idxname +WHERE t.tabname = ? and c.constrtype = 'R' EOF $sth->execute($table); my $remotes = $sth->fetchall_hashref('local_constraint'); @@ -144,10 +312,17 @@ EOF my @rels; while (my ($local_constraint, $remote_info) = each %$remotes) { + my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new( + loader => $self, + name => $remote_info->{remote_table}, + database => $db, + schema => $remote_info->{remote_owner}, + ); + push @rels, { - local_columns => $local_columns->{$local_constraint}, - remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})), - remote_table => $remote_info->{remote_table}, + local_columns => $local_columns->{$local_constraint}, + remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_table)), + remote_table => $remote_table, }; } @@ -185,14 +360,16 @@ sub _columns_info_for { my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; + my $db = $table->database; - my $sth = $dbh->prepare(<<'EOF'); -select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt -from syscolumns c -join systables t on c.tabid = t.tabid -left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno -where t.tabname = ? + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt +FROM ${db}:informix.syscolumns c +JOIN ${db}:informix.systables t + ON c.tabid = t.tabid +LEFT JOIN ${db}:informix.sysdefaults d + ON t.tabid = d.tabid AND c.colno = d.colno +WHERE t.tabname = ? EOF $sth->execute($table); my $cols = $sth->fetchall_hashref('colname'); diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm index 8490859..122c41e 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm @@ -7,9 +7,12 @@ use base qw/DBIx::Class::Schema::Loader::DBI/; use Carp::Clan qw/^DBIx::Class/; use List::Util 'first'; use namespace::clean; +use DBIx::Class::Schema::Loader::Table (); our $VERSION = '0.07010'; +sub _supports_db_schema { 0 } + =head1 NAME DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI @@ -48,40 +51,33 @@ sub _setup { $self->next::method(@_); if (not defined $self->preserve_case) { - warn <<'EOF'; - -WARNING: Assuming unquoted Firebird DDL, see -perldoc DBIx::Class::Schema::Loader::DBI::InterBase -and the 'preserve_case' option in -perldoc DBIx::Class::Schema::Loader::Base -for more information. - -EOF $self->preserve_case(0); } - - if ($self->preserve_case) { + elsif ($self->preserve_case) { $self->schema->storage->sql_maker->quote_char('"'); $self->schema->storage->sql_maker->name_sep('.'); } - else { - $self->schema->storage->sql_maker->quote_char(undef); - $self->schema->storage->sql_maker->name_sep(undef); + + if ($self->db_schema) { + carp "db_schema is not supported on Firebird"; + + if ($self->db_schema->[0] eq '%') { + $self->db_schema(undef); + } } } sub _table_pk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); + my $sth = $self->dbh->prepare(<<'EOF'); SELECT iseg.rdb$field_name FROM rdb$relation_constraints rc JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ? ORDER BY iseg.rdb$field_position EOF - $sth->execute($table); + $sth->execute($table->name); my @keydata; @@ -98,8 +94,7 @@ sub _table_fk_info { my ($self, $table) = @_; my ($local_cols, $remote_cols, $remote_table, @rels); - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); + my $sth = $self->dbh->prepare(<<'EOF'); SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col FROM rdb$relation_constraints rc JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name @@ -109,14 +104,21 @@ JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_posit WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ? ORDER BY iseg.rdb$field_position EOF - $sth->execute($table); + $sth->execute($table->name); while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) { s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col; push @{$local_cols->{$fk}}, $self->_lc($local_col); push @{$remote_cols->{$fk}}, $self->_lc($remote_col); - $remote_table->{$fk} = $remote_tab; + $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $remote_tab, + ($self->db_schema ? ( + schema => $self->db_schema->[0], + ignore_schema => 1, + ) : ()), + ); } foreach my $fk (keys %$remote_table) { @@ -132,15 +134,14 @@ EOF sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); + my $sth = $self->dbh->prepare(<<'EOF'); SELECT rc.rdb$constraint_name, iseg.rdb$field_name FROM rdb$relation_constraints rc JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ? ORDER BY iseg.rdb$field_position EOF - $sth->execute($table); + $sth->execute($table->name); my $constraints; while (my ($constraint_name, $column) = $sth->fetchrow_array) { @@ -159,20 +160,20 @@ sub _columns_info_for { my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - - local $dbh->{LongReadLen} = 100000; - local $dbh->{LongTruncOk} = 1; + local $self->dbh->{LongReadLen} = 100000; + local $self->dbh->{LongTruncOk} = 1; while (my ($column, $info) = each %$result) { - my $sth = $dbh->prepare(<<'EOF'); + my $data_type = $info->{data_type}; + + my $sth = $self->dbh->prepare(<<'EOF'); SELECT t.rdb$trigger_source FROM rdb$triggers t WHERE t.rdb$relation_name = ? AND t.rdb$system_flag = 0 -- user defined AND t.rdb$trigger_type = 1 -- BEFORE INSERT EOF - $sth->execute($table); + $sth->execute($table->name); while (my ($trigger) = $sth->fetchrow_array) { my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig; @@ -191,7 +192,7 @@ EOF } # fix up types - $sth = $dbh->prepare(<<'EOF'); + $sth = $self->dbh->prepare(<<'EOF'); SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, f.rdb$character_set_id, f.rdb$character_length, t.rdb$type_name, st.rdb$type_name FROM rdb$fields f JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name @@ -200,7 +201,7 @@ LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_na WHERE rf.rdb$relation_name = ? AND rf.rdb$field_name = ? EOF - $sth->execute($table, $self->_uc($column)); + $sth->execute($table->name, $self->_uc($column)); my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array; $scale = -$scale if $scale && $scale < 0; @@ -208,7 +209,7 @@ EOF s/\s+\z// for $type_name, $sub_type_name; # fixups primarily for DBD::InterBase - if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) { + if ($data_type =~ /^(?:integer|int|smallint|bigint|-9581)\z/) { if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') { $info->{data_type} = 'decimal'; } @@ -235,7 +236,9 @@ EOF } } - if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) { + $data_type = $info->{data_type}; + + if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) { if ($precision == 9 && $scale == 0) { delete $info->{size}; } @@ -244,50 +247,52 @@ EOF } } - if ($info->{data_type} eq '11') { + if ($data_type eq '11') { $info->{data_type} = 'timestamp'; } - elsif ($info->{data_type} eq '10') { + elsif ($data_type eq '10') { $info->{data_type} = 'time'; } - elsif ($info->{data_type} eq '9') { + elsif ($data_type eq '9') { $info->{data_type} = 'date'; } - elsif ($info->{data_type} eq 'character varying') { + elsif ($data_type eq 'character varying') { $info->{data_type} = 'varchar'; } - elsif ($info->{data_type} eq 'character') { + elsif ($data_type eq 'character') { $info->{data_type} = 'char'; } - elsif ($info->{data_type} eq 'float') { + elsif ($data_type eq 'float') { $info->{data_type} = 'real'; } - elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') { + elsif ($data_type eq 'int64' || $data_type eq '-9581') { # the constant is just in case, the query should pick up the type $info->{data_type} = 'bigint'; } - if ($info->{data_type} =~ /^(?:char|varchar)\z/) { + $data_type = $info->{data_type}; + + if ($data_type =~ /^(?:char|varchar)\z/) { $info->{size} = $char_length; if ($char_set_id == 3) { $info->{data_type} .= '(x) character set unicode_fss'; } } - elsif ($info->{data_type} !~ /^(?:numeric|decimal)\z/) { + elsif ($data_type !~ /^(?:numeric|decimal)\z/) { delete $info->{size}; } # get default delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL'; - $sth = $dbh->prepare(<<'EOF'); + $sth = $self->dbh->prepare(<<'EOF'); SELECT rf.rdb$default_source FROM rdb$relation_fields rf WHERE rf.rdb$relation_name = ? AND rf.rdb$field_name = ? EOF - $sth->execute($table, $self->_uc($column)); + $sth->execute($table->name, $self->_uc($column)); my ($default_src) = $sth->fetchrow_array; if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) { diff --git a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm index c657349..ae12ded 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm @@ -4,10 +4,12 @@ use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; use Try::Tiny; +use List::MoreUtils 'any'; use namespace::clean; +use DBIx::Class::Schema::Loader::Table::Sybase (); + our $VERSION = '0.07010'; =head1 NAME @@ -31,9 +33,10 @@ Most MSSQL databases use C (case-insensitive) collation, for this reason generated column names are lower-cased as this makes them easier to work with in L. -We attempt to detect the database collation at startup, and set the column -lowercasing behavior accordingly, as lower-cased column names do not work on -case-sensitive databases. +We attempt to detect the database collation at startup for any database +included in L, and set +the column lowercasing behavior accordingly, as lower-cased column names do not +work on case-sensitive databases. To manually control case-sensitive mode, put: @@ -48,145 +51,295 @@ been renamed to a more generic option. =cut +sub _system_databases { + return (qw/ + master model tempdb msdb + /); +} + +sub _system_tables { + return (qw/ + spt_fallback_db spt_fallback_dev spt_fallback_usg spt_monitor spt_values MSreplication_options + /); +} + +sub _owners { + my ($self, $db) = @_; + + my $owners = $self->dbh->selectcol_arrayref(<<"EOF"); +SELECT name +FROM [$db].dbo.sysusers +WHERE uid <> gid +EOF + + return grep !/^(?:#|guest|INFORMATION_SCHEMA|sys)/, @$owners; +} + sub _setup { my $self = shift; $self->next::method(@_); - return if defined $self->preserve_case; + my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()'); - my $dbh = $self->schema->storage->dbh; + if (ref $self->db_schema eq 'HASH') { + if (keys %{ $self->db_schema } < 2) { + my ($db) = keys %{ $self->db_schema }; - # We use the sys.databases query for the general case, and fallback to - # databasepropertyex() if for some reason sys.databases is not available, - # which does not work over DBD::ODBC with unixODBC+FreeTDS. - # - # XXX why does databasepropertyex() not work over DBD::ODBC ? - # - # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx - my ($collation_name) = - eval { $dbh->selectrow_array('SELECT collation_name FROM sys.databases WHERE name = DB_NAME()') } - || eval { $dbh->selectrow_array("SELECT CAST(databasepropertyex(DB_NAME(), 'Collation') AS VARCHAR)") }; + $db ||= $current_db; - if (not $collation_name) { - warn <<'EOF'; + if ($db eq '%') { + my $owners = $self->db_schema->{$db}; -WARNING: MSSQL Collation detection failed. Defaulting to case-insensitive mode. -Override the 'preserve_case' attribute in your Loader options if needed. + my $db_names = $self->dbh->selectcol_arrayref(<<'EOF'); +SELECT name +FROM master.dbo.sysdatabases +EOF -See 'preserve_case' in -perldoc DBIx::Class::Schema::Loader::Base + my @dbs; + + foreach my $db_name (@$db_names) { + push @dbs, $db_name + unless any { $_ eq $db_name } $self->_system_databases; + } + + $self->db_schema({}); + + DB: foreach my $db (@dbs) { + if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) { + my @owners; + + foreach my $owner (@$owners) { + push @owners, $owner + if $self->dbh->selectrow_array(<<"EOF"); +SELECT name +FROM [$db].dbo.sysusers +WHERE name = @{[ $self->dbh->quote($owner) ]} EOF - $self->preserve_case(0); - return; + } + + next DB unless @owners; + + $self->db_schema->{$db} = \@owners; + } + else { + # for post-processing below + $self->db_schema->{$db} = '%'; + } + } + + $self->qualify_objects(1); + } + else { + if ($db ne $current_db) { + $self->dbh->do("USE [$db]"); + + $self->qualify_objects(1); + } + } + } + else { + $self->qualify_objects(1); + } + } + elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) { + my $owners = $self->db_schema; + $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ]; + + $self->qualify_objects(1) if @$owners > 1; + + $self->db_schema({ $current_db => $owners }); } - my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/; + foreach my $db (keys %{ $self->db_schema }) { + if ($self->db_schema->{$db} eq '%') { + $self->db_schema->{$db} = [ $self->_owners($db) ]; + + $self->qualify_objects(1); + } + } - $self->preserve_case($case_sensitive ? 1 : 0); + if (not defined $self->preserve_case) { + foreach my $db (keys %{ $self->db_schema }) { + # We use the sys.databases query for the general case, and fallback to + # databasepropertyex() if for some reason sys.databases is not available, + # which does not work over DBD::ODBC with unixODBC+FreeTDS. + # + # XXX why does databasepropertyex() not work over DBD::ODBC ? + # + # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx + my ($collation_name) = + eval { $self->dbh->selectrow_array("SELECT collation_name FROM sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") } + || eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") }; + + if (not $collation_name) { + warn <<"EOF"; + +WARNING: MSSQL Collation detection failed for database '$db'. Defaulting to +case-insensitive mode. Override the 'preserve_case' attribute in your Loader +options if needed. + +See 'preserve_case' in +perldoc DBIx::Class::Schema::Loader::Base +EOF + $self->preserve_case(0) unless $self->preserve_case; + } + else { + my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/; + + if ($case_sensitive && (not $self->preserve_case)) { + $self->preserve_case(1); + } + else { + $self->preserve_case(0); + } + } + } + } } sub _tables_list { my ($self, $opts) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); -SELECT t.table_name -FROM INFORMATION_SCHEMA.TABLES t -WHERE t.table_schema = ? + my @tables; + + while (my ($db, $owners) = each %{ $self->db_schema }) { + foreach my $owner (@$owners) { + my $table_names = $self->dbh->selectcol_arrayref(<<"EOF"); +SELECT table_name +FROM [$db].INFORMATION_SCHEMA.TABLES +WHERE table_schema = @{[ $self->dbh->quote($owner) ]} EOF - $sth->execute($self->db_schema); - my @tables = map @$_, @{ $sth->fetchall_arrayref }; + TABLE: foreach my $table_name (@$table_names) { + next TABLE if any { $_ eq $table_name } $self->_system_tables; + + push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new( + loader => $self, + name => $table_name, + database => $db, + schema => $owner, + ); + } + } + } return $self->_filter_tables(\@tables, $opts); } sub _table_pk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{sp_pkeys '$table'}); - $sth->execute; - - my @keydata; - while (my $row = $sth->fetchrow_hashref) { - push @keydata, $self->_lc($row->{COLUMN_NAME}); - } - - return \@keydata; + my $db = $table->database; + + return $self->dbh->selectcol_arrayref(<<"EOF") +SELECT kcu.column_name +FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc +JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu + ON kcu.table_name = tc.table_name + AND kcu.table_schema = tc.table_schema + AND kcu.constraint_name = tc.constraint_name +WHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]} + AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]} + AND tc.constraint_type = 'PRIMARY KEY' +ORDER BY kcu.ordinal_position +EOF } sub _table_fk_info { my ($self, $table) = @_; - my ($local_cols, $remote_cols, $remote_table, @rels, $sth); - my $dbh = $self->schema->storage->dbh; - eval { - $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'}); - $sth->execute; - }; - - while (my $row = eval { $sth->fetchrow_hashref }) { - my $fk = $row->{FK_NAME}; - push @{$local_cols->{$fk}}, $self->_lc($row->{FKCOLUMN_NAME}); - push @{$remote_cols->{$fk}}, $self->_lc($row->{PKCOLUMN_NAME}); - $remote_table->{$fk} = $row->{PKTABLE_NAME}; - } + my $db = $table->database; + + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name, fk_kcu.column_name, uk_kcu.column_name +FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc +JOIN [$db].INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc + ON rc.constraint_name = fk_tc.constraint_name + AND rc.constraint_schema = fk_tc.table_schema +JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE fk_kcu + ON fk_kcu.constraint_name = fk_tc.constraint_name + AND fk_kcu.table_name = fk_tc.table_name + AND fk_kcu.table_schema = fk_tc.table_schema +JOIN [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS uk_tc + ON uk_tc.constraint_name = rc.unique_constraint_name + AND uk_tc.table_schema = rc.unique_constraint_schema +JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE uk_kcu + ON uk_kcu.constraint_name = rc.unique_constraint_name + AND uk_kcu.ordinal_position = fk_kcu.ordinal_position + AND uk_kcu.table_name = uk_tc.table_name + AND uk_kcu.table_schema = rc.unique_constraint_schema +WHERE fk_tc.table_name = @{[ $self->dbh->quote($table->name) ]} + AND fk_tc.table_schema = @{[ $self->dbh->quote($table->schema) ]} +ORDER BY fk_kcu.ordinal_position +EOF - foreach my $fk (keys %$remote_table) { - push @rels, { - local_columns => \@{$local_cols->{$fk}}, - remote_columns => \@{$remote_cols->{$fk}}, - remote_table => $remote_table->{$fk}, - }; + $sth->execute; + my %rels; + + while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) { + push @{ $rels{$fk}{local_columns} }, $col; + push @{ $rels{$fk}{remote_columns} }, $remote_col; + + $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table::Sybase->new( + loader => $self, + name => $remote_table, + database => $db, + schema => $remote_schema, + ) unless exists $rels{$fk}{remote_table}; } - return \@rels; + + return [ values %rels ]; } sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; + my $db = $table->database; + + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT tc.constraint_name, kcu.column_name +FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc +JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu + ON kcu.constraint_name = tc.constraint_name + AND kcu.table_name = tc.table_name + AND kcu.table_schema = tc.table_schema +wHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]} + AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]} + AND tc.constraint_type = 'UNIQUE' +ORDER BY kcu.ordinal_position +EOF - my $sth = $dbh->prepare(qq{ -SELECT ccu.constraint_name, ccu.column_name -FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE ccu -JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc on (ccu.constraint_name = tc.constraint_name) -JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name) -wHERE ccu.table_name = @{[ $dbh->quote($table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position - }); $sth->execute; - my $constraints; - while (my $row = $sth->fetchrow_hashref) { - my $name = $row->{constraint_name}; - my $col = $self->_lc($row->{column_name}); - push @{$constraints->{$name}}, $col; + + my %uniq; + + while (my ($constr, $col) = $sth->fetchrow_array) { + push @{ $uniq{$constr} }, $self->_lc($col); } - my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; - return \@uniqs; + return [ map [ $_ => $uniq{$_} ], keys %uniq ]; } sub _columns_info_for { my $self = shift; my ($table) = @_; - my $result = $self->next::method(@_); + my $db = $table->database; - my $dbh = $self->schema->storage->dbh; + my $result = $self->next::method(@_); while (my ($col, $info) = each %$result) { # get type info - my $sth = $dbh->prepare(qq{ -SELECT character_maximum_length, data_type, datetime_precision -FROM INFORMATION_SCHEMA.COLUMNS -WHERE table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]} - }); - $sth->execute; - my ($char_max_length, $data_type, $datetime_precision) = $sth->fetchrow_array; + my ($char_max_length, $data_type, $datetime_precision, $default) = + $self->dbh->selectrow_array(<<"EOF"); +SELECT character_maximum_length, data_type, datetime_precision, column_default +FROM [$db].INFORMATION_SCHEMA.COLUMNS +WHERE table_name = @{[ $self->dbh->quote($table->name) ]} + AND table_schema = @{[ $self->dbh->quote($table->schema) ]} + AND column_name = @{[ $self->dbh->quote($col) ]} +EOF $info->{data_type} = $data_type; @@ -196,13 +349,21 @@ WHERE table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote( } # find identities - $sth = $dbh->prepare(qq{ -SELECT column_name -FROM INFORMATION_SCHEMA.COLUMNS -WHERE columnproperty(object_id(@{[ $dbh->quote($table) ]}, 'U'), @{[ $dbh->quote($col) ]}, 'IsIdentity') = 1 -AND table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]} - }); - if (try { $sth->execute; $sth->fetchrow_array }) { + my ($is_identity) = $self->dbh->selectrow_array(<<"EOF"); +SELECT is_identity +FROM [$db].sys.columns +WHERE object_id = ( + SELECT object_id + FROM [$db].sys.objects + WHERE name = @{[ $self->dbh->quote($table->name) ]} + AND schema_id = ( + SELECT schema_id + FROM [$db].sys.schemas + WHERE name = @{[ $self->dbh->quote($table->schema) ]} + ) +) AND name = @{[ $self->dbh->quote($col) ]} +EOF + if ($is_identity) { $info->{is_auto_increment} = 1; $info->{data_type} =~ s/\s*identity//i; delete $info->{size}; @@ -252,14 +413,6 @@ AND table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($c delete $info->{size}; } -# get default - $sth = $dbh->prepare(qq{ -SELECT column_default -FROM INFORMATION_SCHEMA.COLUMNS -wHERE table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]} - }); - my ($default) = eval { $sth->execute; $sth->fetchrow_array }; - if (defined $default) { # strip parens $default =~ s/^\( (.*) \)\z/$1/x; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm index 48c1fe4..a576d0a 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm @@ -4,8 +4,6 @@ use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI'; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; -use namespace::clean; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm index cfaa902..17cc808 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm @@ -6,9 +6,9 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::ODBC /; use mro 'c3'; -use Carp::Clan qw/^DBIx::Class/; use Try::Tiny; use namespace::clean; +use DBIx::Class::Schema::Loader::Table (); our $VERSION = '0.07010'; @@ -28,6 +28,8 @@ See L for usage information. =cut +sub _supports_db_schema { 0 } + sub _db_path { my $self = shift; @@ -163,7 +165,7 @@ sub _adox_column { my $col_obj; - my $cols = $self->_adox_catalog->Tables->Item($table)->Columns; + my $cols = $self->_adox_catalog->Tables->Item($table->name)->Columns; for my $col_idx (0..$cols->Count-1) { $col_obj = $cols->Item($col_idx); @@ -197,7 +199,7 @@ sub _table_pk_info { my @keydata; my $indexes = try { - $self->_adox_catalog->Tables->Item($table)->Indexes + $self->_adox_catalog->Tables->Item($table->name)->Indexes } catch { warn "Could not retrieve indexes in table '$table', disabling primary key detection: $_\n"; @@ -228,7 +230,7 @@ sub _table_fk_info { return [] if $self->_disable_fk_detection; my $keys = try { - $self->_adox_catalog->Tables->Item($table)->Keys; + $self->_adox_catalog->Tables->Item($table->name)->Keys; } catch { warn "Could not retrieve keys in table '$table', disabling relationship detection: $_\n"; @@ -243,25 +245,32 @@ sub _table_fk_info { my @rels; for my $key_idx (0..($keys->Count-1)) { - my $key = $keys->Item($key_idx); - if ($key->Type == 2) { + my $key = $keys->Item($key_idx); + + next unless $key->Type == 2; + my $local_cols = $key->Columns; my $remote_table = $key->RelatedTable; my (@local_cols, @remote_cols); for my $col_idx (0..$local_cols->Count-1) { - my $col = $local_cols->Item($col_idx); - push @local_cols, $self->_lc($col->Name); - push @remote_cols, $self->_lc($col->RelatedColumn); + my $col = $local_cols->Item($col_idx); + push @local_cols, $self->_lc($col->Name); + push @remote_cols, $self->_lc($col->RelatedColumn); } push @rels, { local_columns => \@local_cols, remote_columns => \@remote_cols, - remote_table => $remote_table, + remote_table => DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $remote_table, + ($self->db_schema ? ( + schema => $self->db_schema->[0], + ignore_schema => 1, + ) : ()), + ), }; - - } } return \@rels; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm index af8103f..7aa095c 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm @@ -6,7 +6,6 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::ODBC DBIx::Class::Schema::Loader::DBI::InterBase /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm index d4187d5..7c02b80 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm @@ -3,9 +3,9 @@ package DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server; use strict; use warnings; use base qw/ + DBIx::Class::Schema::Loader::DBI::ODBC DBIx::Class::Schema::Loader::DBI::MSSQL /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm index 19bca28..32bfb3a 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm @@ -3,9 +3,9 @@ package DBIx::Class::Schema::Loader::DBI::ODBC::SQL_Anywhere; use strict; use warnings; use base qw/ + DBIx::Class::Schema::Loader::DBI::ODBC DBIx::Class::Schema::Loader::DBI::SQLAnywhere /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm index 693122d..68b2ff6 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm @@ -6,7 +6,6 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault DBIx::Class::Schema::Loader::DBI /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; @@ -18,7 +17,7 @@ Oracle Implementation. =head1 DESCRIPTION -See L. +See L and L. =cut @@ -27,14 +26,13 @@ sub _setup { $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; + my ($current_schema) = $self->dbh->selectrow_array('SELECT USER FROM DUAL'); - my ($current_schema) = $dbh->selectrow_array('SELECT USER FROM DUAL', {}); + $self->db_schema([ $current_schema ]) unless $self->db_schema; - $self->{db_schema} ||= $current_schema; - - if (lc($self->db_schema) ne lc($current_schema)) { - $dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema); + if (@{ $self->db_schema } == 1 && $self->db_schema->[0] ne '%' + && lc($self->db_schema->[0]) ne lc($current_schema)) { + $self->dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema->[0]); } if (not defined $self->preserve_case) { @@ -46,49 +44,45 @@ sub _setup { } } -sub _table_as_sql { - my ($self, $table) = @_; +sub _build_name_sep { '.' } + +sub _system_schemas { + my $self = shift; - return $self->_quote($table); + # From http://www.adp-gmbh.ch/ora/misc/known_schemas.html + + return ($self->next::method(@_), qw/ANONYMOUS APEX_PUBLIC_USER APEX_030200 APPQOSSYS CTXSYS DBSNMP DIP DMSYS EXFSYS LBACSYS MDDATA MDSYS MGMT_VIEW OLAPSYS ORACLE_OCM ORDDATA ORDPLUGINS ORDSYS OUTLN SI_INFORMTN_SCHEMA SPATIAL_CSW_ADMIN_USR SPATIAL_WFS_ADMIN_USR SYS SYSMAN SYSTEM TRACESRV MTSSYS OASPUBLIC OWBSYS OWBSYS_AUDIT WEBSYS WK_PROXY WKSYS WK_TEST WMSYS XDB OSE$HTTP$ADMIN AURORA$JIS$UTILITY$ AURORA$ORB$UNAUTHENTICATED/, qr/^FLOWS_\d\d\d\d\d\d\z/); } -sub _tables_list { - my ($self, $opts) = @_; +sub _system_tables { + my $self = shift; - my $dbh = $self->schema->storage->dbh; + return ($self->next::method(@_), 'PLAN_TABLE'); +} - my @tables; - for my $table ( $dbh->tables(undef, $self->db_schema, '%', 'TABLE,VIEW') ) { #catalog, schema, table, type - my $quoter = $dbh->get_info(29); - $table =~ s/$quoter//g; +sub _dbh_tables { + my ($self, $schema) = @_; - # remove "user." (schema) prefixes - $table =~ s/\w+\.//; + return $self->dbh->tables(undef, $schema, '%', 'TABLE,VIEW'); +} - next if $table eq 'PLAN_TABLE'; - $table = $self->_lc($table); - push @tables, $1 - if $table =~ /\A(\w+)\z/; - } +sub _filter_tables { + my $self = shift; - { - # silence a warning from older DBD::Oracles in tests - my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; - local $SIG{__WARN__} = sub { - $warn_handler->(@_) - unless $_[0] =~ /^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/; - }; + # silence a warning from older DBD::Oracles in tests + my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; + local $SIG{__WARN__} = sub { + $warn_handler->(@_) + unless $_[0] =~ /^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/; + }; - return $self->_filter_tables(\@tables, $opts); - } + return $self->next::method(@_); } sub _table_columns { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - - my $sth = $dbh->column_info(undef, $self->db_schema, $self->_uc($table), '%'); + my $sth = $self->dbh->column_info(undef, $table->schema, $table, '%'); return [ map $self->_lc($_->{COLUMN_NAME}), @{ $sth->fetchall_arrayref({ COLUMN_NAME => 1 }) || [] } ]; } @@ -96,24 +90,21 @@ sub _table_columns { sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; + my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1); +SELECT constraint_name, acc.column_name +FROM all_constraints +JOIN all_cons_columns acc USING (constraint_name) +WHERE acc.table_name=? and acc.owner = ? AND constraint_type='U' +ORDER BY acc.position +EOF - my $sth = $dbh->prepare_cached( - q{ - SELECT constraint_name, acc.column_name - FROM all_constraints JOIN all_cons_columns acc USING (constraint_name) - WHERE acc.table_name=? and acc.owner = ? AND constraint_type='U' - ORDER BY acc.position - }, - {}, 1); + $sth->execute($table->name, $table->schema); - $sth->execute($self->_uc($table),$self->{db_schema} ); my %constr_names; + while(my $constr = $sth->fetchrow_arrayref) { my $constr_name = $self->_lc($constr->[0]); my $constr_col = $self->_lc($constr->[1]); - $constr_name =~ s/\Q$self->{_quoter}\E//; - $constr_col =~ s/\Q$self->{_quoter}\E//; push @{$constr_names{$constr_name}}, $constr_col; } @@ -129,14 +120,12 @@ sub _table_comment { return $table_comment if $table_comment; - ($table_comment) = $self->schema->storage->dbh->selectrow_array( - q{ - SELECT comments FROM all_tab_comments - WHERE owner = ? - AND table_name = ? - AND table_type = 'TABLE' - }, undef, $self->db_schema, $self->_uc($table) - ); + ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name); +SELECT comments FROM all_tab_comments +WHERE owner = ? + AND table_name = ? + AND (table_type = 'TABLE' OR table_type = 'VIEW') +EOF return $table_comment } @@ -149,55 +138,35 @@ sub _column_comment { return $column_comment if $column_comment; - ($column_comment) = $self->schema->storage->dbh->selectrow_array( - q{ - SELECT comments FROM all_col_comments - WHERE owner = ? - AND table_name = ? - AND column_name = ? - }, undef, $self->db_schema, $self->_uc( $table ), $self->_uc( $column_name ) - ); - return $column_comment -} - -sub _table_pk_info { - my ($self, $table) = (shift, shift); - - return $self->next::method($self->_uc($table), @_); -} - -sub _table_fk_info { - my ($self, $table) = (shift, shift); - - my $rels = $self->next::method($self->_uc($table), @_); + ($column_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($column_name)); +SELECT comments FROM all_col_comments +WHERE owner = ? + AND table_name = ? + AND column_name = ? +EOF - foreach my $rel (@$rels) { - $rel->{remote_table} = $self->_lc($rel->{remote_table}); - } - - return $rels; + return $column_comment } sub _columns_info_for { - my ($self, $table) = (shift, shift); - - my $result = $self->next::method($self->_uc($table), @_); + my $self = shift; + my ($table) = @_; - my $dbh = $self->schema->storage->dbh; + my $result = $self->next::method(@_); - local $dbh->{LongReadLen} = 100000; - local $dbh->{LongTruncOk} = 1; + local $self->dbh->{LongReadLen} = 100000; + local $self->dbh->{LongTruncOk} = 1; - my $sth = $dbh->prepare_cached(q{ + my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1); SELECT atc.column_name, ut.trigger_body FROM all_triggers ut JOIN all_trigger_cols atc USING (trigger_name) WHERE atc.table_name = ? AND lower(column_usage) LIKE '%new%' AND lower(column_usage) LIKE '%out%' AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIKE '%insert%' - }, {}, 1); +EOF - $sth->execute($self->_uc($table)); + $sth->execute($table->name); while (my ($col_name, $trigger_body) = $sth->fetchrow_array) { $col_name = $self->_lc($col_name); @@ -205,7 +174,7 @@ AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIK $result->{$col_name}{is_auto_increment} = 1; if (my ($seq_schema, $seq_name) = $trigger_body =~ /(?:\."?(\w+)"?)?"?(\w+)"?\.nextval/i) { - $seq_schema = $self->_lc($seq_schema || $self->db_schema); + $seq_schema = $self->_lc($seq_schema || $table->schema); $seq_name = $self->_lc($seq_name); $result->{$col_name}{sequence} = ($self->qualify_objects ? ($seq_schema . '.') : '') . $seq_name; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm index 6901280..c16231a 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm @@ -6,7 +6,6 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault DBIx::Class::Schema::Loader::DBI /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; @@ -16,18 +15,9 @@ our $VERSION = '0.07010'; DBIx::Class::Schema::Loader::DBI::Pg - DBIx::Class::Schema::Loader::DBI PostgreSQL Implementation. -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; - - __PACKAGE__->loader_options( debug => 1 ); - - 1; - =head1 DESCRIPTION -See L. +See L and L. =cut @@ -36,7 +26,7 @@ sub _setup { $self->next::method(@_); - $self->{db_schema} ||= 'public'; + $self->{db_schema} ||= ['public']; if (not defined $self->preserve_case) { $self->preserve_case(0); @@ -47,24 +37,10 @@ sub _setup { } } -sub _tables_list { - my ($self, $opts) = @_; - - my $dbh = $self->schema->storage->dbh; - my @tables = $dbh->tables(undef, $self->db_schema, '%', '%'); - - my $schema_quoted = $tables[0] =~ /^"/; - - if ($schema_quoted) { - s/^"[^"]+"\.// for @tables; - } - else { - s/^[^.]+\.// for @tables; - } - - s/^"([^"]+)"\z/$1/ for @tables; +sub _system_schemas { + my $self = shift; - return $self->_filter_tables(\@tables, $opts); + return ($self->next::method(@_), 'pg_catalog'); } sub _table_uniq_info { @@ -75,18 +51,17 @@ sub _table_uniq_info { if $DBD::Pg::VERSION >= 1.50; my @uniqs; - my $dbh = $self->schema->storage->dbh; # Most of the SQL here is mostly based on # Rose::DB::Object::Metadata::Auto::Pg, after some prodding from # John Siracusa to use his superior SQL code :) - my $attr_sth = $self->{_cache}->{pg_attr_sth} ||= $dbh->prepare( + my $attr_sth = $self->{_cache}->{pg_attr_sth} ||= $self->dbh->prepare( q{SELECT attname FROM pg_catalog.pg_attribute WHERE attrelid = ? AND attnum = ?} ); - my $uniq_sth = $self->{_cache}->{pg_uniq_sth} ||= $dbh->prepare( + my $uniq_sth = $self->{_cache}->{pg_uniq_sth} ||= $self->dbh->prepare( q{SELECT x.indrelid, i.relname, x.indkey FROM pg_catalog.pg_index x @@ -103,7 +78,7 @@ sub _table_uniq_info { c.relname = ?} ); - $uniq_sth->execute($self->db_schema, $table); + $uniq_sth->execute($table->schema, $table); while(my $row = $uniq_sth->fetchrow_arrayref) { my ($tableid, $indexname, $col_nums) = @$row; $col_nums =~ s/^\s+//; @@ -128,37 +103,38 @@ sub _table_uniq_info { } sub _table_comment { - my ( $self, $table ) = @_; - my ($table_comment) = $self->next::method($table); - if (not $table_comment) { - ($table_comment) = $self->schema->storage->dbh->selectrow_array( - q{SELECT obj_description(oid) - FROM pg_class - WHERE relname=? AND relnamespace=( - SELECT oid FROM pg_namespace WHERE nspname=?) - }, undef, $table, $self->db_schema - ); - } + my $self = shift; + my ($table) = @_; + + my $table_comment = $self->next::method(@_); + + return $table_comment if $table_comment; + + ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->name, $table->schema); +SELECT obj_description(oid) +FROM pg_class +WHERE relname=? AND relnamespace=(SELECT oid FROM pg_namespace WHERE nspname=?) +EOF + return $table_comment } sub _column_comment { - my ( $self, $table, $column_number, $column_name ) = @_; - my ($column_comment) = $self->next::method( - $table, $column_number, $column_name); - if (not $column_comment) { - my ($table_oid) = $self->schema->storage->dbh->selectrow_array( - q{SELECT oid - FROM pg_class - WHERE relname=? AND relnamespace=( - SELECT oid FROM pg_namespace WHERE nspname=?) - }, undef, $table, $self->db_schema - ); - $column_comment = $self->schema->storage->dbh->selectrow_array( - 'SELECT col_description(?,?)', undef, $table_oid, $column_number ); - } - return $column_comment; + my $self = shift; + my ($table, $column_number, $column_name) = @_; + + my $column_comment = $self->next::method(@_); + + return $column_comment if $column_comment; + + my ($table_oid) = $self->dbh->selectrow_array(<<'EOF', {}, $table->name, $table->schema); +SELECT oid +FROM pg_class +WHERE relname=? AND relnamespace=(SELECT oid FROM pg_namespace WHERE nspname=?) +EOF + + return $self->dbh->selectrow_array('SELECT col_description(?,?)', {}, $table_oid, $column_number); } # Make sure data_type's that don't need it don't have a 'size' column_info, and @@ -199,7 +175,7 @@ EOF delete $info->{size}; } else { - my ($integer_datetimes) = $self->schema->storage->dbh + my ($integer_datetimes) = $self->dbh ->selectrow_array('show integer_datetimes'); my $max_precision = @@ -223,8 +199,7 @@ EOF elsif ($data_type =~ /^(?:bit(?: varying)?|varbit)\z/i) { $info->{data_type} = 'varbit' if $data_type =~ /var/i; - my ($precision) = $self->schema->storage->dbh - ->selectrow_array(<dbh->selectrow_array(<schema->storage->dbh + my $typevalues = $self->dbh ->selectall_arrayref(<{data_type}); SELECT e.enumlabel FROM pg_catalog.pg_enum e diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm index e5df1f0..b353861 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm @@ -2,12 +2,13 @@ package DBIx::Class::Schema::Loader::DBI::SQLAnywhere; use strict; use warnings; -use mro 'c3'; use base qw/ DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault DBIx::Class::Schema::Loader::DBI /; -use Carp::Clan qw/^DBIx::Class/; +use mro 'c3'; +use List::MoreUtils 'any'; +use namespace::clean; our $VERSION = '0.07010'; @@ -22,27 +23,57 @@ See L and L. =cut +sub _system_schemas { + return (qw/dbo SYS diagnostics rs_systabgroup SA_DEBUG/); +} + sub _setup { my $self = shift; $self->next::method(@_); - $self->{db_schema} ||= - ($self->schema->storage->dbh->selectrow_array('select user'))[0]; + $self->preserve_case(1) + unless defined $self->preserve_case; + + $self->schema->storage->sql_maker->quote_char('"'); + $self->schema->storage->sql_maker->name_sep('.'); + + $self->db_schema([($self->dbh->selectrow_array('select user'))[0]]) + unless $self->db_schema; + + if (ref $self->db_schema eq 'ARRAY' && $self->db_schema->[0] eq '%') { + my @users = grep { my $uname = $_; not any { $_ eq $uname } $self->_system_schemas } + @{ $self->dbh->selectcol_arrayref('select user_name from sysuser') }; + + $self->db_schema(\@users); + } } sub _tables_list { my ($self, $opts) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); -select t.table_name from systab t -join sysuser u on u.user_id = t.creator -where u.user_name = ? + my @tables; + + foreach my $schema (@{ $self->db_schema }) { + my $sth = $self->dbh->prepare(<<'EOF'); +SELECT t.table_name name +FROM systab t +JOIN sysuser u + ON t.creator = u.user_id +WHERE u.user_name = ? EOF - $sth->execute($self->db_schema); + $sth->execute($schema); - my @tables = map @$_, @{ $sth->fetchall_arrayref }; + my @table_names = map @$_, @{ $sth->fetchall_arrayref }; + + foreach my $table_name (@table_names) { + push @tables, DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $table_name, + schema => $schema, + ); + } + } return $self->_filter_tables(\@tables, $opts); } @@ -62,12 +93,16 @@ sub _columns_info_for { $info->{is_auto_increment} = 1; } - my ($user_type) = $dbh->selectrow_array(<<'EOF', {}, $table, $col); + my ($user_type) = $dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $col); SELECT ut.type_name FROM systabcol tc -JOIN systab t ON tc.table_id = t.table_id -JOIN sysusertype ut on tc.user_type = ut.type_id -WHERE t.table_name = ? AND lower(tc.column_name) = ? +JOIN systab t + ON tc.table_id = t.table_id +JOIN sysuser u + ON t.creator = u.user_id +JOIN sysusertype ut + ON tc.user_type = ut.type_id +WHERE u.user_name = ? AND t.table_name = ? AND tc.column_name = ? EOF $info->{data_type} = $user_type if defined $user_type; @@ -85,10 +120,13 @@ EOF my $sth = $dbh->prepare(<<'EOF'); SELECT tc.width, tc.scale FROM systabcol tc -JOIN systab t ON t.table_id = tc.table_id -WHERE t.table_name = ? AND tc.column_name = ? +JOIN systab t + ON t.table_id = tc.table_id +JOIN sysuser u + ON t.creator = u.user_id +WHERE u.user_name = ? AND t.table_name = ? AND tc.column_name = ? EOF - $sth->execute($table, $col); + $sth->execute($table->schema, $table->name, $col); my ($width, $scale) = $sth->fetchrow_array; $sth->finish; @@ -118,10 +156,9 @@ EOF sub _table_pk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; - my $sth = $dbh->prepare(qq{sp_pkeys ?}); - $sth->execute($table); + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; + my $sth = $self->dbh->prepare(qq{sp_pkeys ?, ?}); + $sth->execute($table->name, $table->schema); my @keydata; @@ -136,25 +173,39 @@ sub _table_fk_info { my ($self, $table) = @_; my ($local_cols, $remote_cols, $remote_table, @rels); - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); -select fki.index_name fk_name, fktc.column_name local_column, pkt.table_name remote_table, pktc.column_name remote_column -from sysfkey fk -join systab pkt on fk.primary_table_id = pkt.table_id -join systab fkt on fk.foreign_table_id = fkt.table_id -join sysidx pki on fk.primary_table_id = pki.table_id and fk.primary_index_id = pki.index_id -join sysidx fki on fk.foreign_table_id = fki.table_id and fk.foreign_index_id = fki.index_id -join sysidxcol fkic on fkt.table_id = fkic.table_id and fki.index_id = fkic.index_id -join systabcol pktc on pkt.table_id = pktc.table_id and fkic.primary_column_id = pktc.column_id -join systabcol fktc on fkt.table_id = fktc.table_id and fkic.column_id = fktc.column_id -where fkt.table_name = ? + my $sth = $self->dbh->prepare(<<'EOF'); +SELECT fki.index_name fk_name, fktc.column_name local_column, pku.user_name remote_schema, pkt.table_name remote_table, pktc.column_name remote_column +FROM sysfkey fk +JOIN systab pkt + ON fk.primary_table_id = pkt.table_id +JOIN sysuser pku + ON pkt.creator = pku.user_id +JOIN systab fkt + ON fk.foreign_table_id = fkt.table_id +JOIN sysuser fku + ON fkt.creator = fku.user_id +JOIN sysidx pki + ON fk.primary_table_id = pki.table_id AND fk.primary_index_id = pki.index_id +JOIN sysidx fki + ON fk.foreign_table_id = fki.table_id AND fk.foreign_index_id = fki.index_id +JOIN sysidxcol fkic + ON fkt.table_id = fkic.table_id AND fki.index_id = fkic.index_id +JOIN systabcol pktc + ON pkt.table_id = pktc.table_id AND fkic.primary_column_id = pktc.column_id +JOIN systabcol fktc + ON fkt.table_id = fktc.table_id AND fkic.column_id = fktc.column_id +WHERE fku.user_name = ? AND fkt.table_name = ? EOF - $sth->execute($table); + $sth->execute($table->schema, $table->name); - while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) { + while (my ($fk, $local_col, $remote_schema, $remote_tab, $remote_col) = $sth->fetchrow_array) { push @{$local_cols->{$fk}}, $self->_lc($local_col); push @{$remote_cols->{$fk}}, $self->_lc($remote_col); - $remote_table->{$fk} = $remote_tab; + $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $remote_tab, + schema => $remote_schema, + ); } foreach my $fk (keys %$remote_table) { @@ -170,17 +221,22 @@ EOF sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); -select c.constraint_name, tc.column_name -from sysconstraint c -join systab t on c.table_object_id = t.object_id -join sysidx i on c.ref_object_id = i.object_id -join sysidxcol ic on i.table_id = ic.table_id and i.index_id = ic.index_id -join systabcol tc on ic.table_id = tc.table_id and ic.column_id = tc.column_id -where c.constraint_type = 'U' and t.table_name = ? + my $sth = $self->dbh->prepare(<<'EOF'); +SELECT c.constraint_name, tc.column_name +FROM sysconstraint c +JOIN systab t + ON c.table_object_id = t.object_id +JOIN sysuser u + ON t.creator = u.user_id +JOIN sysidx i + ON c.ref_object_id = i.object_id +JOIN sysidxcol ic + ON i.table_id = ic.table_id AND i.index_id = ic.index_id +JOIN systabcol tc + ON ic.table_id = tc.table_id AND ic.column_id = tc.column_id +WHERE c.constraint_type = 'U' AND u.user_name = ? AND t.table_name = ? EOF - $sth->execute($table); + $sth->execute($table->schema, $table->name); my $constraints; while (my ($constraint_name, $column) = $sth->fetchrow_array) { diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm index 2937030..408534a 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm @@ -6,8 +6,8 @@ use base qw/ DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault DBIx::Class::Schema::Loader::DBI /; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; +use DBIx::Class::Schema::Loader::Table (); our $VERSION = '0.07010'; @@ -39,6 +39,15 @@ sub _setup { if (not defined $self->preserve_case) { $self->preserve_case(0); } + + if ($self->db_schema) { + warn <<'EOF'; +db_schema is not supported on SQLite, the option is implemented only for qualify_objects testing. +EOF + if ($self->db_schema->[0] eq '%') { + $self->db_schema(undef); + } + } } sub rescan { @@ -48,33 +57,16 @@ sub rescan { $self->next::method($schema); } -# A hack so that qualify_objects can be tested on SQLite, SQLite does not -# actually have schemas. -{ - sub _table_as_sql { - my $self = shift; - local $self->{db_schema}; - return $self->next::method(@_); - } - - sub _table_pk_info { - my $self = shift; - local $self->{db_schema}; - return $self->next::method(@_); - } -} - sub _columns_info_for { my $self = shift; my ($table) = @_; my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; - my $sth = $dbh->prepare( - "pragma table_info(" . $dbh->quote_identifier($table) . ")" + my $sth = $self->dbh->prepare( + "pragma table_info(" . $self->dbh->quote_identifier($table) . ")" ); $sth->execute; my $cols = $sth->fetchall_hashref('name'); @@ -108,9 +100,8 @@ sub _columns_info_for { sub _table_fk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare( - "pragma foreign_key_list(" . $dbh->quote_identifier($table) . ")" + my $sth = $self->dbh->prepare( + "pragma foreign_key_list(" . $self->dbh->quote_identifier($table) . ")" ); $sth->execute; @@ -119,14 +110,21 @@ sub _table_fk_info { my $rel = $rels[ $fk->{id} ] ||= { local_columns => [], remote_columns => undef, - remote_table => $fk->{table} + remote_table => DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $fk->{table}, + ($self->db_schema ? ( + schema => $self->db_schema->[0], + ignore_schema => 1, + ) : ()), + ), }; push @{ $rel->{local_columns} }, $self->_lc($fk->{from}); push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to}; warn "This is supposed to be the same rel but remote_table changed from ", - $rel->{remote_table}, " to ", $fk->{table} - if $rel->{remote_table} ne $fk->{table}; + $rel->{remote_table}->name, " to ", $fk->{table} + if $rel->{remote_table}->name ne $fk->{table}; } $sth->finish; return \@rels; @@ -135,9 +133,8 @@ sub _table_fk_info { sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare( - "pragma index_list(" . $dbh->quote($table) . ")" + my $sth = $self->dbh->prepare( + "pragma index_list(" . $self->dbh->quote($table) . ")" ); $sth->execute; @@ -147,7 +144,7 @@ sub _table_uniq_info { my $name = $idx->{name}; - my $get_idx_sth = $dbh->prepare("pragma index_info(" . $dbh->quote($name) . ")"); + my $get_idx_sth = $self->dbh->prepare("pragma index_info(" . $self->dbh->quote($name) . ")"); $get_idx_sth->execute; my @cols; while (my $idx_row = $get_idx_sth->fetchrow_hashref) { @@ -168,14 +165,20 @@ sub _table_uniq_info { sub _tables_list { my ($self, $opts) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare("SELECT * FROM sqlite_master"); + my $sth = $self->dbh->prepare("SELECT * FROM sqlite_master"); $sth->execute; my @tables; while ( my $row = $sth->fetchrow_hashref ) { next unless $row->{type} =~ /^(?:table|view)\z/i; next if $row->{tbl_name} =~ /^sqlite_/; - push @tables, $row->{tbl_name}; + push @tables, DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $row->{tbl_name}, + ($self->db_schema ? ( + schema => $self->db_schema->[0], + ignore_schema => 1, # for qualify_objects tests + ) : ()), + ); } $sth->finish; return $self->_filter_tables(\@tables, $opts); diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm index 3d48a83..02d6dd0 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm @@ -3,8 +3,11 @@ package DBIx::Class::Schema::Loader::DBI::Sybase; use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; +use List::MoreUtils 'any'; +use namespace::clean; + +use DBIx::Class::Schema::Loader::Table::Sybase (); our $VERSION = '0.07010'; @@ -17,17 +20,9 @@ Sybase ASE Implementation. See L and L. -=cut - -sub _setup { - my $self = shift; - - $self->next::method(@_); +This class reblesses into the L class for connections to MSSQL. - if (not defined $self->preserve_case) { - $self->preserve_case(1); - } -} +=cut sub _rebless { my $self = shift; @@ -44,29 +39,166 @@ sub _rebless { } } +sub _system_databases { + return (qw/ + master model sybsystemdb sybsystemprocs tempdb + /); +} + +sub _system_tables { + return (qw/ + sysquerymetrics + /); +} + +sub _setup { + my $self = shift; + + $self->next::method(@_); + + $self->preserve_case(1); + + my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()'); + + if (ref $self->db_schema eq 'HASH') { + if (keys %{ $self->db_schema } < 2) { + my ($db) = keys %{ $self->db_schema }; + + $db ||= $current_db; + + if ($db eq '%') { + my $owners = $self->db_schema->{$db}; + + my $db_names = $self->dbh->selectcol_arrayref(<<'EOF'); +SELECT name +FROM master.dbo.sysdatabases +EOF + + my @dbs; + + foreach my $db_name (@$db_names) { + push @dbs, $db_name + unless any { $_ eq $db_name } $self->_system_databases; + } + + $self->db_schema({}); + + DB: foreach my $db (@dbs) { + if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) { + my @owners; + + foreach my $owner (@$owners) { + push @owners, $owner + if defined $self->_uid($db, $owner); + } + + next DB unless @owners; + + $self->db_schema->{$db} = \@owners; + } + else { + # for post-processing below + $self->db_schema->{$db} = '%'; + } + } + + $self->qualify_objects(1); + } + else { + if ($db ne $current_db) { + $self->dbh->do("USE [$db]"); + + $self->qualify_objects(1); + } + } + } + else { + $self->qualify_objects(1); + } + } + elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) { + my $owners = $self->db_schema; + $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ]; + + $self->qualify_objects(1) if @$owners > 1; + + $self->db_schema({ $current_db => $owners }); + } + + foreach my $db (keys %{ $self->db_schema }) { + if ($self->db_schema->{$db} eq '%') { + my $owners = $self->dbh->selectcol_arrayref(<<"EOF"); +SELECT name +FROM [$db].dbo.sysusers +WHERE uid <> gid +EOF + $self->db_schema->{$db} = $owners; + + $self->qualify_objects(1); + } + } +} + sub _tables_list { my ($self, $opts) = @_; - my $dbh = $self->schema->storage->dbh; + my @tables; - my $sth = $dbh->table_info(undef, $self->db_schema, undef, "'TABLE','VIEW'"); + while (my ($db, $owners) = each %{ $self->db_schema }) { + foreach my $owner (@$owners) { + my ($uid) = $self->_uid($db, $owner); - my @tables = grep $_ ne 'sysquerymetrics', - map $_->{table_name}, @{ $sth->fetchall_arrayref({ table_name => 1 }) }; + my $table_names = $self->dbh->selectcol_arrayref(<<"EOF"); +SELECT name +FROM [$db].dbo.sysobjects +WHERE uid = $uid + AND type IN ('U', 'V') +EOF + + TABLE: foreach my $table_name (@$table_names) { + next TABLE if any { $_ eq $table_name } $self->_system_tables; + + push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new( + loader => $self, + name => $table_name, + database => $db, + schema => $owner, + ); + } + } + } return $self->_filter_tables(\@tables, $opts); } +sub _uid { + my ($self, $db, $owner) = @_; + + my ($uid) = $self->dbh->selectrow_array(<<"EOF"); +SELECT uid +FROM [$db].dbo.sysusers +WHERE name = @{[ $self->dbh->quote($owner) ]} +EOF + + return $uid; +} + sub _table_columns { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $columns = $dbh->selectcol_arrayref(qq{ + my $db = $table->database; + my $owner = $table->schema; + + my $columns = $self->dbh->selectcol_arrayref(<<"EOF"); SELECT c.name -FROM syscolumns c JOIN sysobjects o -ON c.id = o.id -WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' -}); +FROM [$db].dbo.syscolumns c +JOIN [$db].dbo.sysobjects o + ON c.id = o.id +WHERE o.name = @{[ $self->dbh->quote($table->name) ]} + AND o.type IN ('U', 'V') + AND o.uid = @{[ $self->_uid($db, $owner) ]} +ORDER BY c.colid ASC +EOF return $columns; } @@ -74,8 +206,19 @@ WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' sub _table_pk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{sp_pkeys @{[ $dbh->quote($table) ]}}); + my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()'); + + my $db = $table->database; + + $self->dbh->do("USE [$db]"); + + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $self->dbh->prepare(<<"EOF"); +sp_pkeys @{[ $self->dbh->quote($table->name) ]}, + @{[ $self->dbh->quote($table->schema) ]}, + @{[ $self->dbh->quote($db) ]} +EOF $sth->execute; my @keydata; @@ -84,163 +227,178 @@ sub _table_pk_info { push @keydata, $row->{column_name}; } + $self->dbh->do("USE [$current_db]"); + return \@keydata; } sub _table_fk_info { my ($self, $table) = @_; - # check if FK_NAME is supported - - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; - # hide "Object does not exist in this database." when trying to fetch fkeys - local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 }; - my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}}); - $sth->execute; - my $row = $sth->fetchrow_hashref; - - return unless $row; - - if (exists $row->{fk_name}) { - $sth->finish; - return $self->_table_fk_info_by_name($table); - } - - $sth->finish; - return $self->_table_fk_info_by_sp_helpconstraint($table); -} - -sub _table_fk_info_by_name { - my ($self, $table) = @_; - my ($local_cols, $remote_cols, $remote_table, @rels); - - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; - # hide "Object does not exist in this database." when trying to fetch fkeys - local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 }; - my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}}); + my $db = $table->database; + my $owner = $table->schema; + + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT sr.reftabid, sd2.name, sr.keycnt, + fokey1, fokey2, fokey3, fokey4, fokey5, fokey6, fokey7, fokey8, + fokey9, fokey10, fokey11, fokey12, fokey13, fokey14, fokey15, fokey16, + refkey1, refkey2, refkey3, refkey4, refkey5, refkey6, refkey7, refkey8, + refkey9, refkey10, refkey11, refkey12, refkey13, refkey14, refkey15, refkey16 +FROM [$db].dbo.sysreferences sr +JOIN [$db].dbo.sysobjects so1 + ON sr.tableid = so1.id +JOIN [$db].dbo.sysusers su1 + ON so1.uid = su1.uid +JOIN master.dbo.sysdatabases sd2 + ON sr.pmrydbid = sd2.dbid +WHERE so1.name = @{[ $self->dbh->quote($table->name) ]} + AND su1.name = @{[ $self->dbh->quote($table->schema) ]} +EOF $sth->execute; - while (my $row = $sth->fetchrow_hashref) { - my $fk = $row->{fk_name}; - next unless defined $fk; - - push @{$local_cols->{$fk}}, $row->{fkcolumn_name}; - push @{$remote_cols->{$fk}}, $row->{pkcolumn_name}; - $remote_table->{$fk} = $row->{pktable_name}; - } - - foreach my $fk (keys %$remote_table) { - push @rels, { - local_columns => \@{$local_cols->{$fk}}, - remote_columns => \@{$remote_cols->{$fk}}, - remote_table => $remote_table->{$fk}, - }; - - } - return \@rels; -} - -sub _table_fk_info_by_sp_helpconstraint { - my ($self, $table) = @_; + my @rels; - my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; - local $SIG{__WARN__} = sub { - $warn_handler->(@_) unless $_[0] =~ - /^\s*$|^Total Number of|^Details|^(?:--?|=|\+) Number|^Formula for/; - }; + REL: while (my @rel = $sth->fetchrow_array) { + my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3; - my $dbh = $self->schema->storage->dbh; + my ($remote_tab_owner, $remote_tab_name) = + $self->dbh->selectrow_array(<<"EOF"); +SELECT su.name, so.name +FROM [$remote_db].dbo.sysusers su +JOIN [$remote_db].dbo.sysobjects so + ON su.uid = so.uid +WHERE so.id = $remote_tab_id +EOF - local $dbh->{FetchHashKeyName} = 'NAME_lc'; + next REL + unless any { $_ eq $remote_tab_owner } + @{ $self->db_schema->{$remote_db} || [] }; - my $sth = $dbh->prepare("sp_helpconstraint $table"); - $sth->execute; + my @local_col_ids = splice @rel, 0, 16; + my @remote_col_ids = splice @rel, 0, 16; - my $constraints = $sth->fetchall_arrayref({}); + @local_col_ids = splice @local_col_ids, 0, $key_cnt; + @remote_col_ids = splice @remote_col_ids, 0, $key_cnt; - my @rels; + my $remote_table = DBIx::Class::Schema::Loader::Table::Sybase->new( + loader => $self, + name => $remote_tab_name, + database => $remote_db, + schema => $remote_tab_owner, + ); - foreach my $constraint (map $_->{definition}, @$constraints) { - my ($local_cols, $remote_table, $remote_cols) = $constraint =~ -/^$table FOREIGN KEY \(([^)]+)\) REFERENCES ([^(]+)\(([^)]+)\)/; + my $all_local_cols = $self->_table_columns($table); + my $all_remote_cols = $self->_table_columns($remote_table); - next unless $local_cols; + my @local_cols = map $all_local_cols->[$_-1], @local_col_ids; + my @remote_cols = map $all_remote_cols->[$_-1], @remote_col_ids; - my @local_cols = split /,\s*/, $local_cols; - my @remote_cols = split /,\s*/, $remote_cols; + next REL if (any { not defined $_ } @local_cols) + || (any { not defined $_ } @remote_cols); push @rels, { local_columns => \@local_cols, - remote_columns => \@remote_cols, remote_table => $remote_table, + remote_columns => \@remote_cols, }; - } + }; return \@rels; } sub _table_uniq_info { - no warnings 'uninitialized'; # for presumably XS weirdness with null operations my ($self, $table) = @_; - local $SIG{__WARN__} = sub { warn @_ - unless $_[0] =~ /^Formula for Calculation:|^(?:--?|\+|=) Number of (?:self )?references|^Total Number of Referential Constraints|^Details:|^\s*$/ }; + my $db = $table->database; + my $owner = $table->schema; + my $uid = $self->_uid($db, $owner); + + my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()'); + + $self->dbh->do("USE [$db]"); + + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT si.name, si.indid, si.keycnt +FROM [$db].dbo.sysindexes si +JOIN [$db].dbo.sysobjects so + ON si.id = so.id +WHERE so.name = @{[ $self->dbh->quote($table->name) ]} + AND so.uid = $uid + AND si.indid > 0 + AND si.status & 2048 <> 2048 + AND si.status2 & 2 = 2 +EOF + $sth->execute; - my $dbh = $self->schema->storage->dbh; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; - my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname=@{[ $dbh->quote($table) ]}, \@nomsg='nomsg'}); - eval { $sth->execute }; - return if $@; + my %uniqs; - my $constraints; - while (my $row = $sth->fetchrow_hashref) { - if (exists $row->{constraint_type}) { - my $type = $row->{constraint_type} || ''; - if ($type =~ /^unique/i) { - my $name = $row->{constraint_name}; - push @{$constraints->{$name}}, - ( split /,/, $row->{constraint_keys} ); - } - } else { - my $def = $row->{definition} || next; - next unless $def =~ /^unique/i; - my $name = $row->{name}; - my ($keys) = $def =~ /\((.*)\)/; - $keys =~ s/\s*//g; - my @keys = split /,/ => $keys; - push @{$constraints->{$name}}, @keys; + while (my ($ind_name, $ind_id, $key_cnt) = $sth->fetchrow_array) { + COLS: foreach my $col_idx (1 .. ($key_cnt+1)) { + my ($next_col) = $self->dbh->selectrow_array(<<"EOF"); +SELECT index_col( + @{[ $self->dbh->quote($table->name) ]}, + $ind_id, $col_idx, $uid +) +EOF + last COLS unless defined $next_col; + + push @{ $uniqs{$ind_name} }, $next_col; } } - my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; + my @uniqs = map { [ $_ => $uniqs{$_} ] } keys %uniqs; + + $self->dbh->do("USE [$current_db]"); + return \@uniqs; } -# get the correct data types, defaults and size sub _columns_info_for { my $self = shift; my ($table) = @_; my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{ + my $db = $table->database; + my $owner = $table->schema; + my $uid = $self->_uid($db, $owner); + + local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; + my $sth = $self->dbh->prepare(<<"EOF"); SELECT c.name name, bt.name base_type, ut.name user_type, cm.text deflt, c.prec prec, c.scale scale, c.length len -FROM syscolumns c -JOIN sysobjects o ON c.id = o.id -LEFT JOIN systypes bt ON c.type = bt.type -LEFT JOIN systypes ut ON c.usertype = ut.usertype -LEFT JOIN syscomments cm +FROM [$db].dbo.syscolumns c +JOIN [$db].dbo.sysobjects o ON c.id = o.id +LEFT JOIN [$db].dbo.systypes bt ON c.type = bt.type +LEFT JOIN [$db].dbo.systypes ut ON c.usertype = ut.usertype +LEFT JOIN [$db].dbo.syscomments cm ON cm.id = CASE WHEN c.cdefault = 0 THEN c.computedcol ELSE c.cdefault END -WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' -}); +WHERE o.name = @{[ $self->dbh->quote($table) ]} + AND o.uid = $uid + AND o.type IN ('U', 'V') +EOF $sth->execute; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $info = $sth->fetchall_hashref('name'); while (my ($col, $res) = each %$result) { my $data_type = $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type}; + + # check if it's an IDENTITY column + my $sth = $self->dbh->prepare(<<"EOF"); +SELECT name +FROM [$db].dbo.syscolumns +WHERE id = ( + SELECT id + FROM [$db].dbo.sysobjects + WHERE name = @{[ $self->dbh->quote($table->name) ]} + AND uid = $uid +) + AND (status & 0x80) = 0x80 + AND name = @{[ $self->dbh->quote($col) ]} +EOF + $sth->execute; + + if ($sth->fetchrow_array) { + $res->{is_auto_increment} = 1; + } if ($data_type && $data_type =~ /^timestamp\z/i) { $res->{inflate_datetime} = 0; @@ -285,8 +443,12 @@ WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' $res->{size} = [ $prec, $scale ]; } } - elsif ($data_type =~ /^(?:unichar|univarchar)\z/i) { - $res->{size} /= 2; + elsif ($data_type =~ /char/) { + $res->{size} = $info->{$col}{len}; + + if ($data_type =~ /^(?:unichar|univarchar)\z/i) { + $res->{size} /= 2; + } } } @@ -298,21 +460,6 @@ WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' return $result; } -sub _extra_column_info { - my ($self, $table, $column, $info, $dbi_info) = @_; - my %extra_info; - - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = @{[ $dbh->quote($table) ]}) AND (status & 0x80) = 0x80 AND name = @{[ $dbh->quote($column) ]}}); - $sth->execute(); - - if ($sth->fetchrow_array) { - $extra_info{is_auto_increment} = 1; - } - - return \%extra_info; -} - =head1 SEE ALSO L, diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm index 1994870..e9540e8 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm @@ -3,7 +3,6 @@ package DBIx::Class::Schema::Loader::DBI::Sybase::Common; use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI'; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; @@ -20,8 +19,8 @@ See L and L. =cut # DBD::Sybase doesn't implement get_info properly -sub _build_quoter { '"' } -sub _build_namesep { '.' } +sub _build_quote_char { '[]' } +sub _build_name_sep { '.' } sub _setup { my $self = shift; @@ -30,16 +29,6 @@ sub _setup { $self->schema->storage->sql_maker->quote_char([qw/[ ]/]); $self->schema->storage->sql_maker->name_sep('.'); - $self->{db_schema} ||= $self->_build_db_schema; -} - -sub _build_db_schema { - my $self = shift; - my $dbh = $self->schema->storage->dbh; - - my ($db_schema) = $dbh->selectrow_array('select user_name()'); - - return $db_schema; } # remove 'IDENTITY' from column data_type diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Microsoft_SQL_Server.pm index 5ca5308..15d6353 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Microsoft_SQL_Server.pm @@ -3,7 +3,6 @@ package DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server; use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI::MSSQL'; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm b/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm index bf4b2e8..015ce1c 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm @@ -18,7 +18,6 @@ DBIx::Class::Schema::Loader::DBI::Writing - Loader subclass writing guide for DB use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI'; - use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; sub _table_uniq_info { @@ -63,6 +62,9 @@ likely want to override are: C<_table_pk_info>, C<_table_fk_info>, C<_tables_list> and C<_extra_column_info>. See the included DBD drivers for examples of these. +To import comments from the database you need to implement C<_table_comment>, +C<_column_comment> + =head1 AUTHOR See L and L. @@ -72,9 +74,6 @@ See L and L, -C<_column_comment> - =cut 1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm index 50925aa..8131ee2 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm @@ -4,7 +4,9 @@ use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI'; use mro 'c3'; +use Carp::Clan qw/^DBIx::Class/; use List::Util 'first'; +use List::MoreUtils 'any'; use Try::Tiny; use namespace::clean; @@ -31,6 +33,28 @@ sub _setup { if (not defined $self->preserve_case) { $self->preserve_case(0); } + + if ($self->db_schema && $self->db_schema->[0] eq '%') { + my @schemas = try { + map $_->[0], @{ $self->dbh->selectall_arrayref('SHOW DATABASES') }; + } + catch { + croak "no SHOW DATABASES privileges: $_"; + }; + + @schemas = grep { + my $schema = $_; + not any { $schema eq $_ } $self->_system_schemas + } @schemas; + + $self->db_schema(\@schemas); + } +} + +sub _system_schemas { + my $self = shift; + + return ($self->next::method(@_), 'mysql'); } sub _tables_list { @@ -42,32 +66,32 @@ sub _tables_list { sub _table_fk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - - my $table_def_ref = eval { $dbh->selectrow_arrayref("SHOW CREATE TABLE `$table`") }; + my $table_def_ref = eval { $self->dbh->selectrow_arrayref("SHOW CREATE TABLE ".$table->sql_name) }; my $table_def = $table_def_ref->[1]; return [] if not $table_def; - my $qt = qr/["`]/; + my $qt = qr/["`]/; + my $nqt = qr/[^"`]/; my (@reldata) = ($table_def =~ - /CONSTRAINT $qt.*$qt FOREIGN KEY \($qt(.*)$qt\) REFERENCES $qt(.*)$qt \($qt(.*)$qt\)/ig + /CONSTRAINT ${qt}${nqt}+${qt} FOREIGN KEY \($qt(.*)$qt\) REFERENCES (?:$qt($nqt+)$qt\.)?$qt($nqt+)$qt \($qt(.+)$qt\)/ig ); my @rels; while (scalar @reldata > 0) { - my $cols = shift @reldata; - my $f_table = shift @reldata; - my $f_cols = shift @reldata; + my ($cols, $f_schema, $f_table, $f_cols) = splice @reldata, 0, 4; - my @cols = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; $self->_lc($_) } + my @cols = map { s/$qt//g; $self->_lc($_) } split(/$qt?\s*$qt?,$qt?\s*$qt?/, $cols); - my @f_cols = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; $self->_lc($_) } + my @f_cols = map { s/$qt//g; $self->_lc($_) } split(/$qt?\s*$qt?,$qt?\s*$qt?/, $f_cols); - my $remote_table = first { $_ =~ /^${f_table}\z/i } $self->_tables_list; + my $remote_table = first { + lc($_->name) eq lc($f_table) + && ((not $f_schema) || lc($_->schema) eq lc($f_schema)) + } $self->_tables_list; push(@rels, { local_columns => \@cols, @@ -86,8 +110,7 @@ sub _mysql_table_get_keys { if(!exists($self->{_cache}->{_mysql_keys}->{$table})) { my %keydata; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare('SHOW INDEX FROM '.$self->_table_as_sql($table)); + my $sth = $self->dbh->prepare('SHOW INDEX FROM '.$table->sql_name); $sth->execute; while(my $row = $sth->fetchrow_hashref) { next if $row->{Non_unique}; @@ -131,8 +154,6 @@ sub _columns_info_for { my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - while (my ($col, $info) = each %$result) { if ($info->{data_type} eq 'int') { $info->{data_type} = 'integer'; @@ -145,7 +166,7 @@ sub _columns_info_for { delete $info->{size} if $data_type !~ /^(?: (?:var)?(?:char(?:acter)?|binary) | bit | year)\z/ix; # information_schema is available in 5.0+ - my ($precision, $scale, $column_type, $default) = eval { $dbh->selectrow_array(<<'EOF', {}, $table, $col) }; + my ($precision, $scale, $column_type, $default) = eval { $self->dbh->selectrow_array(<<'EOF', {}, $table, $col) }; SELECT numeric_precision, numeric_scale, column_type, column_default FROM information_schema.columns WHERE table_name = ? AND column_name = ? diff --git a/lib/DBIx/Class/Schema/Loader/DBObject.pm b/lib/DBIx/Class/Schema/Loader/DBObject.pm new file mode 100644 index 0000000..e0ec405 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBObject.pm @@ -0,0 +1,159 @@ +package DBIx::Class::Schema::Loader::DBObject; + +use strict; +use warnings; +use base 'Class::Accessor::Grouped'; +use Carp::Clan qw/^DBIx::Class/; +use Scalar::Util 'weaken'; +use namespace::clean; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBObject - Base Class for Database Objects Such as +Tables and Views in L + +=head1 METHODS + +=head2 loader + +The loader object this object is associated with, this is a required parameter +to L. + +=head2 name + +Name of the object. The object stringifies to this value. + +=cut + +__PACKAGE__->mk_group_accessors(simple => qw/ + loader + name + _schema + ignore_schema +/); + +use overload + '""' => sub { $_[0]->name }; + +=head2 new + +The constructor, takes L, L, L, and L +as key-value parameters. + +=cut + +sub new { + my $class = shift; + + my $self = { @_ }; + + croak "loader is required" unless ref $self->{loader}; + + weaken $self->{loader}; + + $self->{_schema} = delete $self->{schema}; + + return bless $self, $class; +} + +=head2 schema + +The schema (or owner) of the object. Returns nothing if L is +true. + +=head2 ignore_schema + +Set to true to make L and L not use the defined L. +Does not affect L (for +L testing on +SQLite.) + +=cut + +sub schema { + my $self = shift; + + return $self->_schema(@_) unless $self->ignore_schema; + + return undef; +} + +sub _quote { + my ($self, $identifier) = @_; + + $identifier = '' if not defined $identifier; + + my $qt = $self->loader->quote_char || ''; + + if (length $qt > 1) { + my @qt = split //, $qt; + return $qt[0] . $identifier . $qt[1]; + } + + return "${qt}${identifier}${qt}"; +} + +=head1 sql_name + +Returns the properly quoted full identifier with L and L. + +=cut + +sub sql_name { + my $self = shift; + + my $name_sep = $self->loader->name_sep; + + if ($self->schema) { + return $self->_quote($self->schema) + . $name_sep + . $self->_quote($self->name); + } + + return $self->_quote($self->name); +} + +=head1 dbic_name + +Returns a value suitable for the C<< __PACKAGE__->table >> call in L Result files. + +=cut + +sub dbic_name { + my $self = shift; + + my $name_sep = $self->loader->name_sep; + + if ($self->loader->qualify_objects && $self->_schema) { + if ($self->_schema =~ /\W/ || $self->name =~ /\W/) { + return \ $self->sql_name; + } + + return $self->_schema . $name_sep . $self->name; + } + + if ($self->name =~ /\W/) { + return \ $self->_quote($self->name); + } + + return $self->name; +} + +=head1 SEE ALSO + +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sts=4 sw=4 tw=0: diff --git a/lib/DBIx/Class/Schema/Loader/DBObject/Informix.pm b/lib/DBIx/Class/Schema/Loader/DBObject/Informix.pm new file mode 100644 index 0000000..9636fb0 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBObject/Informix.pm @@ -0,0 +1,115 @@ +package DBIx::Class::Schema::Loader::DBObject::Informix; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBObject'; +use namespace::clean; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBObject::Informix - Class for Database Objects for +Informix Such as Tables and Views in L + +=head1 DESCRIPTION + +This is a subclass of L that adds +support for fully qualified objects in Informix including both L +and L of the form: + + database:owner.object_name + +=head1 METHODS + +=head2 database + +The database name this object belongs to. + +Returns undef if +L is set. + +=cut + +__PACKAGE__->mk_group_accessors(simple => qw/ + _database +/); + +sub new { + my $class = shift; + + my $self = $class->next::method(@_); + + $self->{_database} = delete $self->{database}; + + return $self; +} + +sub database { + my $self = shift; + + return $self->_database(@_) unless $self->ignore_schema; + + return undef; +} + +=head1 sql_name + +Returns the properly quoted full identifier with L, +L and +L. + +=cut + +sub sql_name { + my $self = shift; + + my $name_sep = $self->loader->name_sep; + + if ($self->database) { + return $self->_quote($self->database) + . ':' + . $self->_quote($self->schema) + . $name_sep + . $self->_quote($self->name); + } + + return $self->next::method(@_); +} + +sub dbic_name { + my $self = shift; + + my $name_sep = $self->loader->name_sep; + + if ($self->loader->qualify_objects && $self->_database) { + if ($self->_database =~ /\W/ + || $self->_schema =~ /\W/ || $self->name =~ /\W/) { + + return \ $self->sql_name; + } + + return $self->_database . ':' . $self->_schema . $name_sep . $self->name; + } + + return $self->next::method(@_); +} + +=head1 SEE ALSO + +L, +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sts=4 sw=4 tw=0: diff --git a/lib/DBIx/Class/Schema/Loader/DBObject/Sybase.pm b/lib/DBIx/Class/Schema/Loader/DBObject/Sybase.pm new file mode 100644 index 0000000..4e2bb47 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBObject/Sybase.pm @@ -0,0 +1,116 @@ +package DBIx::Class::Schema::Loader::DBObject::Sybase; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBObject'; +use namespace::clean; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBObject::Sybase - Class for Database Objects for +Sybase ASE and MSSQL Such as Tables and Views in L + +=head1 DESCRIPTION + +This is a subclass of L that adds +support for fully qualified objects in Sybase ASE and MSSQL including both +L and L of the +form: + + database.owner.object_name + +=head1 METHODS + +=head2 database + +The database name this object belongs to. + +Returns undef if +L is set. + +=cut + +__PACKAGE__->mk_group_accessors(simple => qw/ + _database +/); + +sub new { + my $class = shift; + + my $self = $class->next::method(@_); + + $self->{_database} = delete $self->{database}; + + return $self; +} + +sub database { + my $self = shift; + + return $self->_database(@_) unless $self->ignore_schema; + + return undef; +} + +=head1 sql_name + +Returns the properly quoted full identifier with L, +L and +L. + +=cut + +sub sql_name { + my $self = shift; + + my $name_sep = $self->loader->name_sep; + + if ($self->database) { + return $self->_quote($self->database) + . $name_sep + . $self->_quote($self->schema) + . $name_sep + . $self->_quote($self->name); + } + + return $self->next::method(@_); +} + +sub dbic_name { + my $self = shift; + + my $name_sep = $self->loader->name_sep; + + if ($self->loader->qualify_objects && $self->_database) { + if ($self->_database =~ /\W/ + || $self->_schema =~ /\W/ || $self->name =~ /\W/) { + + return \ $self->sql_name; + } + + return $self->_database . $name_sep . $self->_schema . $name_sep . $self->name; + } + + return $self->next::method(@_); +} + +=head1 SEE ALSO + +L, +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sts=4 sw=4 tw=0: diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm index 7d533b4..29d17f4 100644 --- a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm +++ b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm @@ -6,14 +6,14 @@ use base 'Class::Accessor::Grouped'; use mro 'c3'; use Carp::Clan qw/^DBIx::Class/; use Scalar::Util 'weaken'; -use Lingua::EN::Inflect::Phrase (); -use Lingua::EN::Tagger (); use DBIx::Class::Schema::Loader::Utils qw/split_name slurp_file/; use Try::Tiny; -use Class::Unload (); -use Class::Inspector (); use List::MoreUtils 'apply'; use namespace::clean; +use Lingua::EN::Inflect::Phrase (); +use Lingua::EN::Tagger (); +use Class::Unload (); +use Class::Inspector (); our $VERSION = '0.07010'; @@ -46,10 +46,11 @@ Arguments: $loader object Arguments: - { - local_moniker (scalar) => [ fk_info (arrayref), uniq_info (arrayref) ] + [ + [ local_moniker1 (scalar), fk_info1 (arrayref), uniq_info1 (arrayref) ] + [ local_moniker2 (scalar), fk_info2 (arrayref), uniq_info2 (arrayref) ] ... - } + ] This generates the code for the relationships of each table. @@ -58,14 +59,20 @@ statements. The fk_info arrayref's contents should take the form: [ { - local_columns => [ 'col2', 'col3' ], - remote_columns => [ 'col5', 'col7' ], + local_table => 'some_table', + local_moniker => 'SomeTable', + local_columns => [ 'col2', 'col3' ], + remote_table => 'another_table_moniker', remote_moniker => 'AnotherTableMoniker', + remote_columns => [ 'col5', 'col7' ], }, { - local_columns => [ 'col1', 'col4' ], - remote_columns => [ 'col1', 'col2' ], + local_table => 'some_other_table', + local_moniker => 'SomeOtherTable', + local_columns => [ 'col1', 'col4' ], + remote_table => 'yet_another_table_moniker', remote_moniker => 'YetAnotherTableMoniker', + remote_columns => [ 'col1', 'col2' ], }, # ... ], @@ -287,14 +294,7 @@ sub _remote_attrs { sub _sanitize_name { my ($self, $name) = @_; - if (ref $name) { - # scalar ref for weird table name (like one containing a '.') - ($name = $$name) =~ s/\W+/_/g; - } - else { - # remove 'schema.' prefix if any - $name =~ s/^[^.]+\.//; - } + $name =~ s/\W+/_/g; return $name; } @@ -333,7 +333,7 @@ sub _resolve_relname_collision { return $relname if $relname eq 'id'; # this shouldn't happen, but just in case - my $table = $self->loader->tables->{$moniker}; + my $table = $self->loader->moniker_to_table->{$moniker}; if ($self->loader->_is_result_class_method($relname, $table)) { if (my $map = $self->rel_collision_map) { @@ -350,8 +350,7 @@ sub _resolve_relname_collision { } warn <<"EOF"; -Relationship '$relname' in source '$moniker' for columns '@{[ join ',', @$cols ]}' collides with an inherited method. -Renaming to '$new_relname'. +Relationship '$relname' in source '$moniker' for columns '@{[ join ',', @$cols ]}' collides with an inherited method. Renaming to '$new_relname'. See "RELATIONSHIP NAME COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base . EOF @@ -617,10 +616,10 @@ sub _relnames_and_method { my $remote_moniker = $rel->{remote_source}; my $remote_obj = $self->schema->source( $remote_moniker ); my $remote_class = $self->schema->class( $remote_moniker ); - my $remote_relname = $self->_remote_relname( $remote_obj->from, $cond); + my $remote_relname = $self->_remote_relname( $rel->{remote_table}, $cond); my $local_cols = $rel->{local_columns}; - my $local_table = $self->schema->source($local_moniker)->from; + my $local_table = $rel->{local_table}; my $local_class = $self->schema->class($local_moniker); my $local_source = $self->schema->source($local_moniker); diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_040.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_040.pm index 6bb08cb..728ce68 100644 --- a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_040.pm +++ b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_040.pm @@ -2,10 +2,8 @@ package DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040; use strict; use warnings; -use mro 'c3'; use base 'DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05'; -use Carp::Clan qw/^DBIx::Class/; -use Lingua::EN::Inflect::Number (); +use mro 'c3'; our $VERSION = '0.07010'; @@ -13,9 +11,9 @@ sub _relnames_and_method { my ( $self, $local_moniker, $rel, $cond, $uniqs, $counters ) = @_; my $remote_moniker = $rel->{remote_source}; - my $remote_table = $self->{schema}->source( $remote_moniker )->from; + my $remote_table = $rel->{remote_table}; - my $local_table = $self->{schema}->source($local_moniker)->from; + my $local_table = $rel->{local_table}; my $local_cols = $rel->{local_columns}; # for single-column case, set the remote relname to just the column name diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm index fca23b4..de0cfc5 100644 --- a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm +++ b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_05.pm @@ -2,9 +2,8 @@ package DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05; use strict; use warnings; -use mro 'c3'; use base 'DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06'; -use Carp::Clan qw/^DBIx::Class/; +use mro 'c3'; use Lingua::EN::Inflect::Number (); our $VERSION = '0.07010'; @@ -29,10 +28,10 @@ sub _relnames_and_method { my $remote_moniker = $rel->{remote_source}; my $remote_obj = $self->{schema}->source( $remote_moniker ); my $remote_class = $self->{schema}->class( $remote_moniker ); - my $remote_relname = $self->_remote_relname( $remote_obj->from, $cond); + my $remote_relname = $self->_remote_relname( $rel->{remote_table}, $cond); my $local_cols = $rel->{local_columns}; - my $local_table = $self->{schema}->source($local_moniker)->from; + my $local_table = $rel->{local_table}; # If more than one rel between this pair of tables, use the local # col names to distinguish diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_06.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_06.pm index afb0a06..6016436 100644 --- a/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_06.pm +++ b/lib/DBIx/Class/Schema/Loader/RelBuilder/Compat/v0_06.pm @@ -2,10 +2,8 @@ package DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06; use strict; use warnings; -use mro 'c3'; use base 'DBIx::Class::Schema::Loader::RelBuilder'; -use Carp::Clan qw/^DBIx::Class/; -use Lingua::EN::Inflect::Phrase (); +use mro 'c3'; our $VERSION = '0.07010'; diff --git a/lib/DBIx/Class/Schema/Loader/Table.pm b/lib/DBIx/Class/Schema/Loader/Table.pm new file mode 100644 index 0000000..46116aa --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/Table.pm @@ -0,0 +1,32 @@ +package DBIx::Class::Schema::Loader::Table; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBObject'; + +=head1 NAME + +DBIx::Class::Schema::Loader::Table - Class for Tables in +L + +=head1 DESCRIPTION + +Inherits from L. + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sts=4 sw=4 tw=0: diff --git a/lib/DBIx/Class/Schema/Loader/Table/Informix.pm b/lib/DBIx/Class/Schema/Loader/Table/Informix.pm new file mode 100644 index 0000000..1b0fe63 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/Table/Informix.pm @@ -0,0 +1,35 @@ +package DBIx::Class::Schema::Loader::Table::Informix; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBObject::Informix'; + +=head1 NAME + +DBIx::Class::Schema::Loader::Table::Informix - Class for Informix Tables in +L + +=head1 DESCRIPTION + +Inherits from L, see that module for details. + +=head1 SEE ALSO + +L, +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sts=4 sw=4 tw=0: diff --git a/lib/DBIx/Class/Schema/Loader/Table/Sybase.pm b/lib/DBIx/Class/Schema/Loader/Table/Sybase.pm new file mode 100644 index 0000000..2f900c3 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/Table/Sybase.pm @@ -0,0 +1,35 @@ +package DBIx::Class::Schema::Loader::Table::Sybase; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBObject::Sybase'; + +=head1 NAME + +DBIx::Class::Schema::Loader::Table::Sybase - Class for Sybase ASE and MSSQL +Tables in L + +=head1 DESCRIPTION + +Inherits from L, see that module for details. + +=head1 SEE ALSO + +L, +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sts=4 sw=4 tw=0: diff --git a/script/dbicdump b/script/dbicdump index cb97638..b175855 100644 --- a/script/dbicdump +++ b/script/dbicdump @@ -15,6 +15,10 @@ Examples: $ dbicdump -o dump_directory=./lib \ -o components='["InflateColumn::DateTime"]' \ + MyApp::Schema dbi:SQLite:./foo.db + + $ dbicdump -o dump_directory=./lib \ + -o components='["InflateColumn::DateTime"]' \ MyApp::Schema dbi:SQLite:./foo.db '{ quote_char => "\"" }' $ dbicdump -o dump_directory=./lib \ @@ -72,7 +76,7 @@ L, L. =head1 AUTHOR -Dagfinn Ilmari Mannsåker C<< >> +Dagfinn Ilmari Manns?ker C<< >> =head1 CONTRIBUTORS diff --git a/t/10_02mysql_common.t b/t/10_02mysql_common.t index 9a538ea..2df8a4b 100644 --- a/t/10_02mysql_common.t +++ b/t/10_02mysql_common.t @@ -1,18 +1,30 @@ use strict; -use DBIx::Class::Schema::Loader::Utils 'slurp_file'; +use warnings; use Test::More; +use Test::Exception; +use Try::Tiny; +use File::Path 'rmtree'; +use DBIx::Class::Schema::Loader::Utils 'slurp_file'; +use DBIx::Class::Schema::Loader 'make_schema_at'; + use lib qw(t/lib); + use dbixcsl_common_tests; +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/mysql_extra_dump"; my $dsn = $ENV{DBICTEST_MYSQL_DSN} || ''; my $user = $ENV{DBICTEST_MYSQL_USER} || ''; my $password = $ENV{DBICTEST_MYSQL_PASS} || ''; my $test_innodb = $ENV{DBICTEST_MYSQL_INNODB} || 0; -my $skip_rels_msg = 'You need to set the DBICTEST_MYSQL_INNODB environment variable to test relationships.'; +my $skip_rels_msg = 'You need to set the environment variable DBICTEST_MYSQL_INNODB=1 to test relationships.'; my $innodb = $test_innodb ? q{Engine=InnoDB} : ''; +my ($schema, $databases_created); # for cleanup in END for extra tests + my $tester = dbixcsl_common_tests->new( vendor => 'Mysql', auto_inc_pk => 'INTEGER NOT NULL PRIMARY KEY AUTO_INCREMENT', @@ -171,9 +183,10 @@ my $tester = dbixcsl_common_tests->new( ], pre_drop_ddl => [ 'DROP VIEW mysql_loader_test2', ], drop => [ 'mysql_loader-test1', 'mysql_loader_test3' ], - count => 5, + count => 5 + 28 * 2, run => sub { - my ($schema, $monikers, $classes) = @_; + my ($monikers, $classes); + ($schema, $monikers, $classes) = @_; is $monikers->{'mysql_loader-test1'}, 'MysqlLoaderTest1', 'table with dash correctly monikerized'; @@ -199,6 +212,215 @@ my $tester = dbixcsl_common_tests->new( like $code, qr/^=head2 id\n\n(.+:.+\n)+\nThe\nColumn\n\n/m, 'column comment and attrs'; + SKIP: { + my $dbh = $schema->storage->dbh; + + try { + $dbh->do('CREATE DATABASE `dbicsl-test`'); + } + catch { + skip "no CREATE DATABASE privileges", 28 * 2; + }; + + $dbh->do(<<"EOF"); + CREATE TABLE `dbicsl-test`.mysql_loader_test4 ( + id INT AUTO_INCREMENT PRIMARY KEY, + value VARCHAR(100) + ) $innodb +EOF + $dbh->do(<<"EOF"); + CREATE TABLE `dbicsl-test`.mysql_loader_test5 ( + id INT AUTO_INCREMENT PRIMARY KEY, + value VARCHAR(100), + four_id INTEGER UNIQUE, + FOREIGN KEY (four_id) REFERENCES `dbicsl-test`.mysql_loader_test4 (id) + ) $innodb +EOF + $dbh->do('CREATE DATABASE `dbicsl.test`'); + $dbh->do(<<"EOF"); + CREATE TABLE `dbicsl.test`.mysql_loader_test6 ( + id INT AUTO_INCREMENT PRIMARY KEY, + value VARCHAR(100), + mysql_loader_test4_id INTEGER, + FOREIGN KEY (mysql_loader_test4_id) REFERENCES `dbicsl-test`.mysql_loader_test4 (id) + ) $innodb +EOF + $dbh->do(<<"EOF"); + CREATE TABLE `dbicsl.test`.mysql_loader_test7 ( + id INT AUTO_INCREMENT PRIMARY KEY, + value VARCHAR(100), + six_id INTEGER UNIQUE, + FOREIGN KEY (six_id) REFERENCES `dbicsl.test`.mysql_loader_test6 (id) + ) $innodb +EOF + $dbh->do(<<"EOF"); + CREATE TABLE `dbicsl-test`.mysql_loader_test8 ( + id INT AUTO_INCREMENT PRIMARY KEY, + value VARCHAR(100), + mysql_loader_test7_id INTEGER, + FOREIGN KEY (mysql_loader_test7_id) REFERENCES `dbicsl.test`.mysql_loader_test7 (id) + ) $innodb +EOF + + $databases_created = 1; + + SKIP: foreach my $db_schema (['dbicsl-test', 'dbicsl.test'], '%') { + if ($db_schema eq '%') { + try { + $dbh->selectall_arrayref('SHOW DATABASES'); + } + catch { + skip 'no SHOW DATABASES privileges', 28; + } + } + + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + + make_schema_at( + 'MySQLMultiSchema', + { + naming => 'current', + db_schema => $db_schema, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + [ $dsn, $user, $password ], + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for "dbicsl-test" and "dbicsl.test" databases with no warnings'; + + my ($test_schema, $rsrc, $rs, $row, %uniqs, $rel_info); + + lives_and { + ok $test_schema = MySQLMultiSchema->connect($dsn, $user, $password); + } 'connected test schema'; + + lives_and { + ok $rsrc = $test_schema->source('MysqlLoaderTest4'); + } 'got source for table in database name with dash'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database name with dash'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database name with dash'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database name with dash'; + + lives_and { + ok $rs = $test_schema->resultset('MysqlLoaderTest4'); + } 'got resultset for table in database name with dash'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database name with dash'; + + SKIP: { + skip 'set the environment variable DBICTEST_MYSQL_INNODB=1 to test relationships', 3 unless $test_innodb; + + $rel_info = try { $rsrc->relationship_info('mysql_loader_test5') }; + + is_deeply $rel_info->{cond}, { + 'foreign.four_id' => 'self.id' + }, 'relationship in database name with dash'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database name with dash'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database name with dash'; + } + + lives_and { + ok $rsrc = $test_schema->source('MysqlLoaderTest5'); + } 'got source for table in database name with dash'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database name with dash'; + + lives_and { + ok $rsrc = $test_schema->source('MysqlLoaderTest6'); + } 'got source for table in database name with dot'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database name with dot introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database name with dot introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database name with dot introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('MysqlLoaderTest6'); + } 'got resultset for table in database name with dot'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database name with dot'; + + SKIP: { + skip 'set the environment variable DBICTEST_MYSQL_INNODB=1 to test relationships', 3 unless $test_innodb; + + $rel_info = try { $rsrc->relationship_info('mysql_loader_test7') }; + + is_deeply $rel_info->{cond}, { + 'foreign.six_id' => 'self.id' + }, 'relationship in database name with dot'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database name with dot'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database name with dot'; + } + + lives_and { + ok $rsrc = $test_schema->source('MysqlLoaderTest7'); + } 'got source for table in database name with dot'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database name with dot'; + + SKIP: { + skip 'set the environment variable DBICTEST_MYSQL_INNODB=1 to test relationships', 4 unless $test_innodb; + + lives_and { + ok $test_schema->source('MysqlLoaderTest6') + ->has_relationship('mysql_loader_test4'); + } 'cross-database relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('MysqlLoaderTest4') + ->has_relationship('mysql_loader_test6s'); + } 'cross-database relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('MysqlLoaderTest8') + ->has_relationship('mysql_loader_test7'); + } 'cross-database relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('MysqlLoaderTest7') + ->has_relationship('mysql_loader_test8s'); + } 'cross-database relationship in multi-db_schema'; + } + } + } }, }, ); @@ -211,4 +433,32 @@ else { $tester->run_tests(); } +END { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + if ($databases_created && (my $dbh = try { $schema->storage->dbh })) { + foreach my $table ('`dbicsl-test`.mysql_loader_test8', + '`dbicsl.test`.mysql_loader_test7', + '`dbicsl.test`.mysql_loader_test6', + '`dbicsl-test`.mysql_loader_test5', + '`dbicsl-test`.mysql_loader_test4') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table: $_"; + }; + } + + foreach my $db (qw/dbicsl-test dbicsl.test/) { + try { + $dbh->do("DROP DATABASE `$db`"); + } + catch { + diag "Error dropping test database $db: $_"; + }; + } + } + rmtree EXTRA_DUMP_DIR; + } +} # vim:et sts=4 sw=4 tw=0: diff --git a/t/10_03pg_common.t b/t/10_03pg_common.t index 02f4683..668d4da 100644 --- a/t/10_03pg_common.t +++ b/t/10_03pg_common.t @@ -6,9 +6,14 @@ use DBIx::Class::Schema::Loader::Utils qw/no_warnings slurp_file/; use Test::More; use Test::Exception; use Try::Tiny; +use File::Path 'rmtree'; use namespace::clean; + use lib qw(t/lib); use dbixcsl_common_tests (); +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/pg_extra_dump"; my $dsn = $ENV{DBICTEST_PG_DSN} || ''; my $user = $ENV{DBICTEST_PG_USER} || ''; @@ -164,32 +169,40 @@ my $tester = dbixcsl_common_tests->new( CREATE SCHEMA "dbicsl-test" }, q{ - CREATE TABLE "dbicsl-test".pg_loader_test3 ( + CREATE TABLE "dbicsl-test".pg_loader_test4 ( id SERIAL PRIMARY KEY, value VARCHAR(100) ) }, q{ - CREATE TABLE "dbicsl-test".pg_loader_test4 ( + CREATE TABLE "dbicsl-test".pg_loader_test5 ( id SERIAL PRIMARY KEY, value VARCHAR(100), - three_id INTEGER UNIQUE REFERENCES "dbicsl-test".pg_loader_test3 (id) + four_id INTEGER UNIQUE REFERENCES "dbicsl-test".pg_loader_test4 (id) ) }, q{ CREATE SCHEMA "dbicsl.test" }, q{ - CREATE TABLE "dbicsl.test".pg_loader_test5 ( + CREATE TABLE "dbicsl.test".pg_loader_test6 ( id SERIAL PRIMARY KEY, - value VARCHAR(100) + value VARCHAR(100), + pg_loader_test4_id INTEGER REFERENCES "dbicsl-test".pg_loader_test4 (id) ) }, q{ - CREATE TABLE "dbicsl.test".pg_loader_test6 ( + CREATE TABLE "dbicsl.test".pg_loader_test7 ( + id SERIAL PRIMARY KEY, + value VARCHAR(100), + six_id INTEGER UNIQUE REFERENCES "dbicsl.test".pg_loader_test6 (id) + ) + }, + q{ + CREATE TABLE "dbicsl-test".pg_loader_test8 ( id SERIAL PRIMARY KEY, value VARCHAR(100), - five_id INTEGER UNIQUE REFERENCES "dbicsl.test".pg_loader_test5 (id) + pg_loader_test7_id INTEGER REFERENCES "dbicsl.test".pg_loader_test7 (id) ) }, ], @@ -200,7 +213,7 @@ my $tester = dbixcsl_common_tests->new( 'DROP TYPE pg_loader_test_enum', ], drop => [ qw/ pg_loader_test1 pg_loader_test2 / ], - count => 24, + count => 4 + 28 * 2, run => sub { my ($schema, $monikers, $classes) = @_; @@ -209,7 +222,7 @@ my $tester = dbixcsl_common_tests->new( 'qualified sequence detected'; my $class = $classes->{pg_loader_test1}; - my $filename = $schema->_loader->get_dump_filename($class); + my $filename = $schema->loader->get_dump_filename($class); my $code = slurp_file $filename; @@ -220,115 +233,153 @@ my $tester = dbixcsl_common_tests->new( 'column comment and attrs'; $class = $classes->{pg_loader_test2}; - $filename = $schema->_loader->get_dump_filename($class); + $filename = $schema->loader->get_dump_filename($class); $code = slurp_file $filename; like $code, qr/^=head1 NAME\n\n^$class\n\n=head1 DESCRIPTION\n\n^very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very long comment\n\n^=cut\n/m, 'long table comment is in DESCRIPTION'; - lives_and { - no_warnings { + foreach my $db_schema (['dbicsl-test', 'dbicsl.test'], '%') { + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + make_schema_at( - 'PGSchemaWithDash', + 'PGMultiSchema', { naming => 'current', + db_schema => $db_schema, preserve_case => 1, - db_schema => 'dbicsl-test' + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, }, [ $dsn, $user, $password, { on_connect_do => [ 'SET client_min_messages=WARNING' ], } ], ); - }; - } 'created dynamic schema for "dbicsl-test" with no warnings'; - my ($rsrc, %uniqs, $rel_info); + diag join "\n", @warns if @warns; - lives_and { - ok $rsrc = PGSchemaWithDash->source('PgLoaderTest3'); - } 'got source for table in schema name with dash'; + is @warns, 0; + } 'dumped schema for "dbicsl-test" and "dbicsl.test" schemas with no warnings'; - is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, - 'column in schema name with dash'; + my ($test_schema, $rsrc, $rs, $row, %uniqs, $rel_info); - is try { $rsrc->column_info('value')->{data_type} }, 'varchar', - 'column in schema name with dash'; + lives_and { + ok $test_schema = PGMultiSchema->connect($dsn, $user, $password, { + on_connect_do => [ 'SET client_min_messages=WARNING' ], + }); + } 'connected test schema'; - is try { $rsrc->column_info('value')->{size} }, 100, - 'column in schema name with dash'; + lives_and { + ok $rsrc = $test_schema->source('PgLoaderTest4'); + } 'got source for table in schema name with dash'; - $rel_info = try { $rsrc->relationship_info('pg_loader_test4') }; + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema name with dash'; - is_deeply $rel_info->{cond}, { - 'foreign.three_id' => 'self.id' - }, 'relationship in schema name with dash'; + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema name with dash'; - is $rel_info->{attrs}{accessor}, 'single', - 'relationship in schema name with dash'; + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema name with dash'; - is $rel_info->{attrs}{join_type}, 'LEFT', - 'relationship in schema name with dash'; + lives_and { + ok $rs = $test_schema->resultset('PgLoaderTest4'); + } 'got resultset for table in schema name with dash'; - lives_and { - ok $rsrc = PGSchemaWithDash->source('PgLoaderTest4'); - } 'got source for table in schema name with dash'; + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema name with dash'; - %uniqs = try { $rsrc->unique_constraints }; + $rel_info = try { $rsrc->relationship_info('pg_loader_test5') }; - is keys %uniqs, 2, - 'got unique and primary constraint in schema name with dash'; + is_deeply $rel_info->{cond}, { + 'foreign.four_id' => 'self.id' + }, 'relationship in schema name with dash'; - lives_and { - no_warnings { - make_schema_at( - 'PGSchemaWithDot', - { - naming => 'current', - preserve_case => 1, - db_schema => 'dbicsl.test' - }, - [ $dsn, $user, $password, { - on_connect_do => [ 'SET client_min_messages=WARNING' ], - } ], - ); - }; - } 'created dynamic schema for "dbicsl.test" with no warnings'; + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema name with dash'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema name with dash'; + + lives_and { + ok $rsrc = $test_schema->source('PgLoaderTest5'); + } 'got source for table in schema name with dash'; + + %uniqs = try { $rsrc->unique_constraints }; - lives_and { - ok $rsrc = PGSchemaWithDot->source('PgLoaderTest5'); - } 'got source for table in schema name with dot'; + is keys %uniqs, 2, + 'got unique and primary constraint in schema name with dash'; - is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, - 'column in schema name with dot introspected correctly'; + lives_and { + ok $rsrc = $test_schema->source('PgLoaderTest6'); + } 'got source for table in schema name with dot'; - is try { $rsrc->column_info('value')->{data_type} }, 'varchar', - 'column in schema name with dash introspected correctly'; + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema name with dot introspected correctly'; - is try { $rsrc->column_info('value')->{size} }, 100, - 'column in schema name with dash introspected correctly'; + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema name with dot introspected correctly'; - $rel_info = try { $rsrc->relationship_info('pg_loader_test6') }; + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema name with dot introspected correctly'; - is_deeply $rel_info->{cond}, { - 'foreign.five_id' => 'self.id' - }, 'relationship in schema name with dot'; + lives_and { + ok $rs = $test_schema->resultset('PgLoaderTest6'); + } 'got resultset for table in schema name with dot'; - is $rel_info->{attrs}{accessor}, 'single', - 'relationship in schema name with dot'; + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema name with dot'; - is $rel_info->{attrs}{join_type}, 'LEFT', - 'relationship in schema name with dot'; + $rel_info = try { $rsrc->relationship_info('pg_loader_test7') }; - lives_and { - ok $rsrc = PGSchemaWithDot->source('PgLoaderTest6'); - } 'got source for table in schema name with dot'; + is_deeply $rel_info->{cond}, { + 'foreign.six_id' => 'self.id' + }, 'relationship in schema name with dot'; - %uniqs = try { $rsrc->unique_constraints }; + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema name with dot'; - is keys %uniqs, 2, - 'got unique and primary constraint in schema name with dot'; + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema name with dot'; + lives_and { + ok $rsrc = $test_schema->source('PgLoaderTest7'); + } 'got source for table in schema name with dot'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema name with dot'; + + lives_and { + ok $test_schema->source('PgLoaderTest6') + ->has_relationship('pg_loader_test4'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('PgLoaderTest4') + ->has_relationship('pg_loader_test6s'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('PgLoaderTest8') + ->has_relationship('pg_loader_test7'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('PgLoaderTest7') + ->has_relationship('pg_loader_test8s'); + } 'cross-schema relationship in multi-db_schema'; + } }, }, ); @@ -339,4 +390,8 @@ if( !$dsn || !$user ) { else { $tester->run_tests(); } + +END { + rmtree EXTRA_DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; +} # vim:et sw=4 sts=4 tw=0: diff --git a/t/10_04db2_common.t b/t/10_04db2_common.t index e5d5a0e..03b4b54 100644 --- a/t/10_04db2_common.t +++ b/t/10_04db2_common.t @@ -1,6 +1,17 @@ use strict; - +use warnings; use Test::More; +use Test::Exception; +use Try::Tiny; +use File::Path 'rmtree'; +use DBIx::Class::Schema::Loader 'make_schema_at'; + +use lib qw(t/lib); + +use dbixcsl_common_tests (); +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/db2_extra_dump"; my $dsn = $ENV{DBICTEST_DB2_DSN} || ''; my $user = $ENV{DBICTEST_DB2_USER} || ''; @@ -9,6 +20,8 @@ my $password = $ENV{DBICTEST_DB2_PASS} || ''; plan skip_all => 'You need to set the DBICTEST_DB2_DSN, _USER, and _PASS environment variables' unless ($dsn && $user); +my ($schema, $schemas_created); # for cleanup in END for extra tests + my $srv_ver = do { require DBI; my $dbh = DBI->connect ($dsn, $user, $password, { RaiseError => 1, PrintError => 0} ); @@ -16,9 +29,6 @@ my $srv_ver = do { }; my ($maj_srv_ver) = $srv_ver =~ /^(\d+)/; -use lib qw(t/lib); -use dbixcsl_common_tests; - my $extra_graphics_data_types = { graphic => { data_type => 'graphic', size => 1 }, 'graphic(3)' => { data_type => 'graphic', size => 3 }, @@ -93,8 +103,233 @@ my $tester = dbixcsl_common_tests->new( # XXX I don't know how to make these # datalink => { data_type => 'datalink' }, }, + extra => { + count => 28 * 2, + run => sub { + SKIP: { + $schema = shift; + + my $dbh = $schema->storage->dbh; + + try { + $dbh->do('CREATE SCHEMA "dbicsl-test"'); + } + catch { + $schemas_created = 0; + skip "no CREATE SCHEMA privileges", 28 * 2; + }; + + $dbh->do(<<"EOF"); + CREATE TABLE "dbicsl-test".db2_loader_test4 ( + id INT GENERATED BY DEFAULT AS IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE "dbicsl-test".db2_loader_test5 ( + id INT GENERATED BY DEFAULT AS IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + four_id INTEGER NOT NULL UNIQUE, + FOREIGN KEY (four_id) REFERENCES "dbicsl-test".db2_loader_test4 (id) + ) +EOF + $dbh->do('CREATE SCHEMA "dbicsl.test"'); + $dbh->do(<<"EOF"); + CREATE TABLE "dbicsl.test".db2_loader_test6 ( + id INT GENERATED BY DEFAULT AS IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + db2_loader_test4_id INTEGER, + FOREIGN KEY (db2_loader_test4_id) REFERENCES "dbicsl-test".db2_loader_test4 (id) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE "dbicsl.test".db2_loader_test7 ( + id INT GENERATED BY DEFAULT AS IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + six_id INTEGER NOT NULL UNIQUE, + FOREIGN KEY (six_id) REFERENCES "dbicsl.test".db2_loader_test6 (id) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE "dbicsl-test".db2_loader_test8 ( + id INT GENERATED BY DEFAULT AS IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + db2_loader_test7_id INTEGER, + FOREIGN KEY (db2_loader_test7_id) REFERENCES "dbicsl.test".db2_loader_test7 (id) + ) +EOF + + $schemas_created = 1; + + foreach my $db_schema (['dbicsl-test', 'dbicsl.test'], '%') { + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + + make_schema_at( + 'DB2MultiSchema', + { + naming => 'current', + db_schema => $db_schema, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + [ $dsn, $user, $password ], + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for "dbicsl-test" and "dbicsl.test" schemas with no warnings'; + + my ($test_schema, $rsrc, $rs, $row, %uniqs, $rel_info); + + lives_and { + ok $test_schema = DB2MultiSchema->connect($dsn, $user, $password); + } 'connected test schema'; + + lives_and { + ok $rsrc = $test_schema->source('Db2LoaderTest4'); + } 'got source for table in schema name with dash'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema name with dash'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema name with dash'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema name with dash'; + + lives_and { + ok $rs = $test_schema->resultset('Db2LoaderTest4'); + } 'got resultset for table in schema name with dash'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema name with dash'; + + $rel_info = try { $rsrc->relationship_info('db2_loader_test5') }; + + is_deeply $rel_info->{cond}, { + 'foreign.four_id' => 'self.id' + }, 'relationship in schema name with dash'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema name with dash'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema name with dash'; + + lives_and { + ok $rsrc = $test_schema->source('Db2LoaderTest5'); + } 'got source for table in schema name with dash'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema name with dash'; + + lives_and { + ok $rsrc = $test_schema->source('Db2LoaderTest6'); + } 'got source for table in schema name with dot'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema name with dot introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema name with dot introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema name with dot introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('Db2LoaderTest6'); + } 'got resultset for table in schema name with dot'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema name with dot'; + + $rel_info = try { $rsrc->relationship_info('db2_loader_test7') }; + + is_deeply $rel_info->{cond}, { + 'foreign.six_id' => 'self.id' + }, 'relationship in schema name with dot'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema name with dot'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema name with dot'; + + lives_and { + ok $rsrc = $test_schema->source('Db2LoaderTest7'); + } 'got source for table in schema name with dot'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema name with dot'; + + lives_and { + ok $test_schema->source('Db2LoaderTest6') + ->has_relationship('db2_loader_test4'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('Db2LoaderTest4') + ->has_relationship('db2_loader_test6s'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('Db2LoaderTest8') + ->has_relationship('db2_loader_test7'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('Db2LoaderTest7') + ->has_relationship('db2_loader_test8s'); + } 'cross-schema relationship in multi-db_schema'; + } + } + + }, + }, ); $tester->run_tests(); +END { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + if ($schemas_created && (my $dbh = try { $schema->storage->dbh })) { + foreach my $table ('"dbicsl-test".db2_loader_test8', + '"dbicsl.test".db2_loader_test7', + '"dbicsl.test".db2_loader_test6', + '"dbicsl-test".db2_loader_test5', + '"dbicsl-test".db2_loader_test4') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table: $_"; + }; + } + + foreach my $db_schema (qw/dbicsl-test dbicsl.test/) { + try { + $dbh->do(qq{DROP SCHEMA "$db_schema" RESTRICT}); + } + catch { + diag "Error dropping test schema $db_schema: $_"; + }; + } + } + rmtree EXTRA_DUMP_DIR; + } +} # vim:et sts=4 sw=4 tw=0: diff --git a/t/10_05ora_common.t b/t/10_05ora_common.t index 3eb59f5..29127e5 100644 --- a/t/10_05ora_common.t +++ b/t/10_05ora_common.t @@ -2,15 +2,24 @@ use strict; use warnings; use Test::More; use Test::Exception; +use DBIx::Class::Schema::Loader 'make_schema_at'; use DBIx::Class::Schema::Loader::Utils 'slurp_file'; +use Try::Tiny; +use File::Path 'rmtree'; use namespace::clean; + use lib qw(t/lib); -use dbixcsl_common_tests; +use dbixcsl_common_tests (); +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/ora_extra_dump"; my $dsn = $ENV{DBICTEST_ORA_DSN} || ''; my $user = $ENV{DBICTEST_ORA_USER} || ''; my $password = $ENV{DBICTEST_ORA_PASS} || ''; +my ($schema, $extra_schema); # for cleanup in END for extra tests + my $tester = dbixcsl_common_tests->new( vendor => 'Oracle', auto_inc_pk => 'INTEGER NOT NULL PRIMARY KEY', @@ -145,9 +154,10 @@ my $tester = dbixcsl_common_tests->new( q{ COMMENT ON COLUMN oracle_loader_test1.value IS 'oracle_loader_test1.value column comment' }, ], drop => [qw/oracle_loader_test1/], - count => 3, + count => 3 + 6 * 2, run => sub { - my ($schema, $monikers, $classes) = @_; + my ($monikers, $classes); + ($schema, $monikers, $classes) = @_; SKIP: { if (my $source = $monikers->{loader_test1s}) { @@ -161,7 +171,8 @@ my $tester = dbixcsl_common_tests->new( } my $class = $classes->{oracle_loader_test1}; - my $filename = $schema->_loader->get_dump_filename($class); + + my $filename = $schema->loader->get_dump_filename($class); my $code = slurp_file $filename; like $code, qr/^=head1 NAME\n\n^$class - oracle_loader_test1 table comment\n\n^=cut\n/m, @@ -169,6 +180,105 @@ my $tester = dbixcsl_common_tests->new( like $code, qr/^=head2 value\n\n(.+:.+\n)+\noracle_loader_test1\.value column comment\n\n/m, 'column comment and attrs'; + + SKIP: { + skip 'Set the DBICTEST_ORA_EXTRAUSER_DSN, _USER and _PASS environment variables to run the cross-schema relationship tests', 6 * 2 + unless $ENV{DBICTEST_ORA_EXTRAUSER_DSN}; + + $extra_schema = $schema->clone; + $extra_schema->connection(@ENV{map "DBICTEST_ORA_EXTRAUSER_$_", + qw/DSN USER PASS/ + }); + + my $dbh1 = $schema->storage->dbh; + my $dbh2 = $extra_schema->storage->dbh; + + my ($schema1) = $dbh1->selectrow_array('SELECT USER FROM DUAL'); + my ($schema2) = $dbh2->selectrow_array('SELECT USER FROM DUAL'); + + $dbh1->do(<<'EOF'); + CREATE TABLE oracle_loader_test4 ( + id INT NOT NULL PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh1->do("GRANT ALL ON oracle_loader_test4 TO $schema2"); + $dbh2->do(<<"EOF"); + CREATE TABLE oracle_loader_test6 ( + id INT NOT NULL PRIMARY KEY, + value VARCHAR(100), + oracle_loader_test4_id INT REFERENCES ${schema1}.oracle_loader_test4 (id) + ) +EOF + $dbh2->do("GRANT ALL ON oracle_loader_test6 to $schema1"); + $dbh2->do(<<"EOF"); + CREATE TABLE oracle_loader_test7 ( + id INT NOT NULL PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh2->do("GRANT ALL ON oracle_loader_test7 to $schema1"); + $dbh1->do(<<"EOF"); + CREATE TABLE oracle_loader_test8 ( + id INT NOT NULL PRIMARY KEY, + value VARCHAR(100), + oracle_loader_test7_id INT REFERENCES ${schema2}.oracle_loader_test7 (id) + ) +EOF + + foreach my $db_schema ([$schema1, $schema2], '%') { + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + + make_schema_at( + 'OracleMultiSchema', + { + naming => 'current', + db_schema => $db_schema, + preserve_case => 1, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + [ $dsn, $user, $password ], + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } qq{dumped schema for "$schema1" and "$schema2" schemas with no warnings}; + + my $test_schema; + + lives_and { + ok $test_schema = OracleMultiSchema->connect($dsn, $user, $password); + } 'connected test schema'; + + lives_and { + ok $test_schema->source('OracleLoaderTest6') + ->has_relationship('oracle_loader_test4'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('OracleLoaderTest4') + ->has_relationship('oracle_loader_test6s'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('OracleLoaderTest8') + ->has_relationship('oracle_loader_test7'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('OracleLoaderTest7') + ->has_relationship('oracle_loader_test8s'); + } 'cross-schema relationship in multi-db_schema'; + } + } }, }, ); @@ -179,4 +289,24 @@ if( !$dsn || !$user ) { else { $tester->run_tests(); } + +END { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + if (my $dbh2 = try { $extra_schema->storage->dbh }) { + my $dbh1 = $schema->storage->dbh; + + try { + $dbh2->do('DROP TABLE oracle_loader_test6'); + $dbh1->do('DROP TABLE oracle_loader_test4'); + $dbh1->do('DROP TABLE oracle_loader_test8'); + $dbh2->do('DROP TABLE oracle_loader_test7'); + } + catch { + die "Error dropping cross-schema test tables: $_"; + }; + } + + rmtree EXTRA_DUMP_DIR; + } +} # vim:et sw=4 sts=4 tw=0: diff --git a/t/10_06sybase_common.t b/t/10_06sybase_common.t index 1d943a5..bf7ed8f 100644 --- a/t/10_06sybase_common.t +++ b/t/10_06sybase_common.t @@ -1,14 +1,25 @@ use strict; -use lib qw(t/lib); -use dbixcsl_common_tests; +use warnings; use Test::More; use Test::Exception; -use List::MoreUtils 'apply'; +use Try::Tiny; +use File::Path 'rmtree'; +use DBIx::Class::Schema::Loader 'make_schema_at'; +use DBI (); + +use lib qw(t/lib); + +use dbixcsl_common_tests (); +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/sybase_extra_dump"; my $dsn = $ENV{DBICTEST_SYBASE_DSN} || ''; my $user = $ENV{DBICTEST_SYBASE_USER} || ''; my $password = $ENV{DBICTEST_SYBASE_PASS} || ''; +my ($schema, $databases_created); # for cleanup in END for extra tests + my $tester = dbixcsl_common_tests->new( vendor => 'sybase', auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY', @@ -94,6 +105,267 @@ my $tester = dbixcsl_common_tests->new( }, ], drop => [ qw/sybase_loader_test1 sybase_loader_test2/ ], + count => 28 * 4, + run => sub { + $schema = shift; + + SKIP: { + my $dbh = $schema->storage->dbh; + + try { + $dbh->do('USE master'); + } + catch { + skip "these tests require the sysadmin role", 28 * 4; + }; + + try { + $dbh->do('CREATE DATABASE [dbicsl_test1]'); + $dbh->do('CREATE DATABASE [dbicsl_test2]'); + } + catch { + skip "cannot create databases: $_", 28 * 4; + }; + + try { + my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; + local $SIG{__WARN__} = sub { + $warn_handler->(@_) + unless $_[0] =~ /^Password correctly set\.$|^Account unlocked\.$|^New login created\.$|^New user added\.$/; + }; + + $dbh->do("sp_addlogin dbicsl_user1, dbicsl, [dbicsl_test1]"); + $dbh->do("sp_addlogin dbicsl_user2, dbicsl, [dbicsl_test2]"); + + $dbh->do("USE [dbicsl_test1]"); + $dbh->do("sp_adduser dbicsl_user1"); + $dbh->do("sp_adduser dbicsl_user2"); + $dbh->do("GRANT ALL TO dbicsl_user1"); + $dbh->do("GRANT ALL TO dbicsl_user2"); + + $dbh->do("USE [dbicsl_test2]"); + $dbh->do("sp_adduser dbicsl_user2"); + $dbh->do("sp_adduser dbicsl_user1"); + $dbh->do("GRANT ALL TO dbicsl_user2"); + $dbh->do("GRANT ALL TO dbicsl_user1"); + } + catch { + skip "cannot add logins: $_", 28 * 4; + }; + + my ($dbh1, $dbh2); + { + my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; + local $SIG{__WARN__} = sub { + $warn_handler->(@_) unless $_[0] =~ /can't change context/; + }; + + $dbh1 = DBI->connect($dsn, 'dbicsl_user1', 'dbicsl', { + RaiseError => 1, + PrintError => 0, + }); + $dbh1->do('USE [dbicsl_test1]'); + + $dbh2 = DBI->connect($dsn, 'dbicsl_user2', 'dbicsl', { + RaiseError => 1, + PrintError => 0, + }); + $dbh2->do('USE [dbicsl_test2]'); + } + + $dbh1->do(<<"EOF"); + CREATE TABLE sybase_loader_test4 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) NULL + ) +EOF + $dbh1->do('GRANT ALL ON sybase_loader_test4 TO dbicsl_user2'); + $dbh1->do(<<"EOF"); + CREATE TABLE sybase_loader_test5 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) NULL, + four_id INTEGER UNIQUE, + FOREIGN KEY (four_id) REFERENCES sybase_loader_test4 (id) + ) +EOF + $dbh2->do(<<"EOF"); + CREATE TABLE sybase_loader_test6 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) NULL, + sybase_loader_test4_id INTEGER NULL, + FOREIGN KEY (sybase_loader_test4_id) REFERENCES [dbicsl_test1].dbicsl_user1.sybase_loader_test4 (id) + ) +EOF + $dbh2->do(<<"EOF"); + CREATE TABLE sybase_loader_test7 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) NULL, + six_id INTEGER UNIQUE, + FOREIGN KEY (six_id) REFERENCES sybase_loader_test6 (id) + ) +EOF + $dbh2->do('GRANT ALL ON sybase_loader_test7 TO dbicsl_user1'); + $dbh1->do(<<"EOF"); + CREATE TABLE sybase_loader_test8 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) NULL, + sybase_loader_test7_id INTEGER, + FOREIGN KEY (sybase_loader_test7_id) REFERENCES [dbicsl_test2].dbicsl_user2.sybase_loader_test7 (id) + ) +EOF + + $databases_created = 1; + + foreach my $databases (['dbicsl_test1', 'dbicsl_test2'], '%') { + foreach my $owners ([qw/dbicsl_user1 dbicsl_user2/], '%') { + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/ + || $_[0] =~ /can't change context/; + }; + + my $database = $databases; + + $database = [ $database ] unless ref $database; + + my $db_schema = {}; + + foreach my $db (@$database) { + $db_schema->{$db} = $owners; + } + + make_schema_at( + 'SybaseMultiSchema', + { + naming => 'current', + db_schema => $db_schema, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + [ $dsn, $user, $password ], + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for "dbicsl_test1" and "dbicsl_test2" databases with no warnings'; + + my ($test_schema, $rsrc, $rs, $row, %uniqs, $rel_info); + + lives_and { + ok $test_schema = SybaseMultiSchema->connect($dsn, $user, $password); + } 'connected test schema'; + + lives_and { + ok $rsrc = $test_schema->source('SybaseLoaderTest4'); + } 'got source for table in database one'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database one'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database one'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database one'; + + lives_and { + ok $rs = $test_schema->resultset('SybaseLoaderTest4'); + } 'got resultset for table in database one'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database one'; + + $rel_info = try { $rsrc->relationship_info('sybase_loader_test5') }; + + is_deeply $rel_info->{cond}, { + 'foreign.four_id' => 'self.id' + }, 'relationship in database one'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database one'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database one'; + + lives_and { + ok $rsrc = $test_schema->source('SybaseLoaderTest5'); + } 'got source for table in database one'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database one'; + + lives_and { + ok $rsrc = $test_schema->source('SybaseLoaderTest6'); + } 'got source for table in database two'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database two introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database two introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database two introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('SybaseLoaderTest6'); + } 'got resultset for table in database two'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database two'; + + $rel_info = try { $rsrc->relationship_info('sybase_loader_test7') }; + + is_deeply $rel_info->{cond}, { + 'foreign.six_id' => 'self.id' + }, 'relationship in database two'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database two'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database two'; + + lives_and { + ok $rsrc = $test_schema->source('SybaseLoaderTest7'); + } 'got source for table in database two'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database two'; + + lives_and { + ok $test_schema->source('SybaseLoaderTest6') + ->has_relationship('sybase_loader_test4'); + } 'cross-database relationship in multi database schema'; + + lives_and { + ok $test_schema->source('SybaseLoaderTest4') + ->has_relationship('sybase_loader_test6s'); + } 'cross-database relationship in multi database schema'; + + lives_and { + ok $test_schema->source('SybaseLoaderTest8') + ->has_relationship('sybase_loader_test7'); + } 'cross-database relationship in multi database schema'; + + lives_and { + ok $test_schema->source('SybaseLoaderTest7') + ->has_relationship('sybase_loader_test8s'); + } 'cross-database relationship in multi database schema'; + } + } + } + }, }, ); @@ -104,4 +376,64 @@ else { $tester->run_tests(); } +END { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + rmtree EXTRA_DUMP_DIR; + + if ($databases_created) { + my $dbh = $schema->storage->dbh; + + $dbh->do('USE master'); + + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare('sp_who'); + $sth->execute; + + while (my $row = $sth->fetchrow_hashref) { + if ($row->{dbname} =~ /^dbicsl_test[12]\z/) { + $dbh->do("kill $row->{spid}"); + } + } + + foreach my $table ('[dbicsl_test1].dbicsl_user1.sybase_loader_test8', + '[dbicsl_test2].dbicsl_user2.sybase_loader_test7', + '[dbicsl_test2].dbicsl_user2.sybase_loader_test6', + '[dbicsl_test1].dbicsl_user1.sybase_loader_test5', + '[dbicsl_test1].dbicsl_user1.sybase_loader_test4') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table $table: $_"; + }; + } + + foreach my $db (qw/dbicsl_test1 dbicsl_test2/) { + try { + $dbh->do("DROP DATABASE [$db]"); + } + catch { + diag "Error dropping test database $db: $_"; + }; + } + + foreach my $login (qw/dbicsl_user1 dbicsl_user2/) { + try { + my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; + local $SIG{__WARN__} = sub { + $warn_handler->(@_) + unless $_[0] =~ /^Account locked\.$|^Login dropped\.$/; + }; + + $dbh->do("sp_droplogin $login"); + } + catch { + diag "Error dropping login $login: $_" + unless /Incorrect syntax/; + }; + } + } + } +} # vim:et sts=4 sw=4 tw=0: diff --git a/t/10_07mssql_common.t b/t/10_07mssql_common.t index 316da7f..df6ba37 100644 --- a/t/10_07mssql_common.t +++ b/t/10_07mssql_common.t @@ -3,6 +3,9 @@ use warnings; use Test::More; use Test::Exception; use DBIx::Class::Schema::Loader::Utils 'warnings_exist_silent'; +use Try::Tiny; +use File::Path 'rmtree'; +use DBIx::Class::Schema::Loader 'make_schema_at'; use namespace::clean; # use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else @@ -12,7 +15,18 @@ BEGIN { } } +use lib qw(t/lib); + +use dbixcsl_common_tests (); +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/mssql_extra_dump"; + +# for cleanup in END for extra tests +my ($schema, $schemas_created, $databases_created); + my ($dsns, $common_version); + for (qw/MSSQL MSSQL_ODBC MSSQL_ADO/) { next unless $ENV{"DBICTEST_${_}_DSN"}; @@ -38,9 +52,6 @@ for (qw/MSSQL MSSQL_ODBC MSSQL_ADO/) { plan skip_all => 'You need to set the DBICTEST_MSSQL_DSN, _USER and _PASS and/or the DBICTEST_MSSQL_ODBC_DSN, _USER and _PASS environment variables' unless $dsns; -use lib qw(t/lib); -use dbixcsl_common_tests; - my $mssql_2008_new_data_types = { date => { data_type => 'date' }, time => { data_type => 'time' }, @@ -199,13 +210,16 @@ my $tester = dbixcsl_common_tests->new( 'MSSQL_Loader_Test6', 'MSSQL_Loader_Test5', ], - count => 10, + count => 10 + 28 * 2 + 24, run => sub { - my ($schema, $monikers, $classes) = @_; + my ($monikers, $classes, $self); + ($schema, $monikers, $classes, $self) = @_; + + my $connect_info = [@$self{qw/dsn user password/}]; # Test that the table above (with '.' in name) gets loaded correctly. ok((my $rs = eval { - $schema->resultset($monikers->{'[mssql_loader_test1.dot]'}) }), + $schema->resultset('MssqlLoaderTest1Dot') }), 'got a resultset for table with dot in name'); ok((my $from = eval { $rs->result_source->from }), @@ -220,7 +234,7 @@ my $tester = dbixcsl_common_tests->new( ok ((my $rsrc = $schema->resultset($monikers->{mssql_loader_test5})->result_source), 'got result_source'); - if ($schema->_loader->preserve_case) { + if ($schema->loader->preserve_case) { is_deeply [ $rsrc->columns ], [qw/Id FooCol BarCol/], 'column name case is preserved with case-sensitive collation'; @@ -244,7 +258,7 @@ my $tester = dbixcsl_common_tests->new( lives_and { my $five_row = $schema->resultset($monikers->{mssql_loader_test5})->new_result({}); - if ($schema->_loader->preserve_case) { + if ($schema->loader->preserve_case) { $five_row->foo_col(1); $five_row->bar_col(2); } @@ -270,10 +284,435 @@ my $tester = dbixcsl_common_tests->new( $schema->resultset($monikers->{mssql_loader_test4}) } qr/Can't find source/, 'no source registered for bad view'; + + SKIP: { + my $dbh = $schema->storage->dbh; + + try { + $dbh->do('CREATE SCHEMA "dbicsl-test"'); + } + catch { + $schemas_created = 0; + skip "no CREATE SCHEMA privileges", 28 * 2; + }; + + $dbh->do(<<"EOF"); + CREATE TABLE [dbicsl-test].mssql_loader_test8 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE [dbicsl-test].mssql_loader_test9 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100), + eight_id INTEGER NOT NULL UNIQUE, + FOREIGN KEY (eight_id) REFERENCES [dbicsl-test].mssql_loader_test8 (id) + ) +EOF + $dbh->do('CREATE SCHEMA [dbicsl.test]'); + $dbh->do(<<"EOF"); + CREATE TABLE [dbicsl.test].mssql_loader_test10 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100), + mssql_loader_test8_id INTEGER, + FOREIGN KEY (mssql_loader_test8_id) REFERENCES [dbicsl-test].mssql_loader_test8 (id) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE [dbicsl.test].mssql_loader_test11 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100), + ten_id INTEGER NOT NULL UNIQUE, + FOREIGN KEY (ten_id) REFERENCES [dbicsl.test].mssql_loader_test10 (id) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE [dbicsl-test].mssql_loader_test12 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100), + mssql_loader_test11_id INTEGER, + FOREIGN KEY (mssql_loader_test11_id) REFERENCES [dbicsl.test].mssql_loader_test11 (id) + ) +EOF + + $schemas_created = 1; + + foreach my $db_schema (['dbicsl-test', 'dbicsl.test'], '%') { + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + + make_schema_at( + 'MSSQLMultiSchema', + { + naming => 'current', + db_schema => $db_schema, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + $connect_info, + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for "dbicsl-test" and "dbicsl.test" schemas with no warnings'; + + my ($test_schema, $rsrc, $rs, $row, %uniqs, $rel_info); + + lives_and { + ok $test_schema = MSSQLMultiSchema->connect(@$connect_info); + } 'connected test schema'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest8'); + } 'got source for table in schema name with dash'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema name with dash'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema name with dash'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema name with dash'; + + lives_and { + ok $rs = $test_schema->resultset('MssqlLoaderTest8'); + } 'got resultset for table in schema name with dash'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema name with dash'; + + $rel_info = try { $rsrc->relationship_info('mssql_loader_test9') }; + + is_deeply $rel_info->{cond}, { + 'foreign.eight_id' => 'self.id' + }, 'relationship in schema name with dash'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema name with dash'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema name with dash'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest9'); + } 'got source for table in schema name with dash'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema name with dash'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest10'); + } 'got source for table in schema name with dot'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema name with dot introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema name with dot introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema name with dot introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('MssqlLoaderTest10'); + } 'got resultset for table in schema name with dot'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema name with dot'; + + $rel_info = try { $rsrc->relationship_info('mssql_loader_test11') }; + + is_deeply $rel_info->{cond}, { + 'foreign.ten_id' => 'self.id' + }, 'relationship in schema name with dot'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema name with dot'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema name with dot'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest11'); + } 'got source for table in schema name with dot'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema name with dot'; + + lives_and { + ok $test_schema->source('MssqlLoaderTest10') + ->has_relationship('mssql_loader_test8'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('MssqlLoaderTest8') + ->has_relationship('mssql_loader_test10s'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('MssqlLoaderTest12') + ->has_relationship('mssql_loader_test11'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('MssqlLoaderTest11') + ->has_relationship('mssql_loader_test12s'); + } 'cross-schema relationship in multi-db_schema'; + } + } + + SKIP: { + my $dbh = $schema->storage->dbh; + + try { + $dbh->do('USE master'); + $dbh->do('CREATE DATABASE dbicsl_test1'); + } + catch { + skip "no CREATE DATABASE privileges", 24; + }; + + $dbh->do('CREATE DATABASE dbicsl_test2'); + + $dbh->do('USE dbicsl_test1'); + + $dbh->do(<<'EOF'); + CREATE TABLE mssql_loader_test13 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh->do(<<'EOF'); + CREATE TABLE mssql_loader_test14 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100), + thirteen_id INTEGER UNIQUE REFERENCES mssql_loader_test13 (id) + ) +EOF + + $dbh->do('USE master'); + $dbh->do('USE dbicsl_test2'); + + $dbh->do(<<"EOF"); + CREATE TABLE mssql_loader_test15 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE mssql_loader_test16 ( + id INT IDENTITY PRIMARY KEY, + value VARCHAR(100), + fifteen_id INTEGER UNIQUE REFERENCES mssql_loader_test15 (id) + ) +EOF + + $databases_created = 1; + + lives_and { + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + + make_schema_at( + 'MSSQLMultiDatabase', + { + naming => 'current', + db_schema => { '%' => '%' }, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + $connect_info, + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for all databases with no warnings'; + + my $test_schema; + + lives_and { + ok $test_schema = MSSQLMultiDatabase->connect(@$connect_info); + } 'connected test schema'; + + my ($rsrc, $rs, $row, $rel_info, %uniqs); + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest13'); + } 'got source for table in database one'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database one'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database one'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database one'; + + lives_and { + ok $rs = $test_schema->resultset('MssqlLoaderTest13'); + } 'got resultset for table in database one'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database one'; + + $rel_info = try { $rsrc->relationship_info('mssql_loader_test14') }; + + is_deeply $rel_info->{cond}, { + 'foreign.thirteen_id' => 'self.id' + }, 'relationship in database one'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database one'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database one'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest14'); + } 'got source for table in database one'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database one'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest15'); + } 'got source for table in database two'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database two introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database two introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database two introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('MssqlLoaderTest15'); + } 'got resultset for table in database two'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database two'; + + $rel_info = try { $rsrc->relationship_info('mssql_loader_test16') }; + + is_deeply $rel_info->{cond}, { + 'foreign.fifteen_id' => 'self.id' + }, 'relationship in database two'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database two'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database two'; + + lives_and { + ok $rsrc = $test_schema->source('MssqlLoaderTest16'); + } 'got source for table in database two'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database two'; + } }, }, ); $tester->run_tests(); +END { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + if ($schema) { + # switch back to default database + $schema->storage->disconnect; + my $dbh = $schema->storage->dbh; + + if ($schemas_created) { + foreach my $table ('[dbicsl-test].mssql_loader_test12', + '[dbicsl.test].mssql_loader_test11', + '[dbicsl.test].mssql_loader_test10', + '[dbicsl-test].mssql_loader_test9', + '[dbicsl-test].mssql_loader_test8') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table: $_"; + }; + } + + foreach my $db_schema (qw/dbicsl-test dbicsl.test/) { + try { + $dbh->do(qq{DROP SCHEMA [$db_schema]}); + } + catch { + diag "Error dropping test schema $db_schema: $_"; + }; + } + } + + if ($databases_created) { + $dbh->do('USE dbicsl_test1'); + + foreach my $table ('mssql_loader_test14', + 'mssql_loader_test13') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table: $_"; + }; + } + + $dbh->do('USE dbicsl_test2'); + + foreach my $table ('mssql_loader_test16', + 'mssql_loader_test15') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table: $_"; + }; + } + + $dbh->do('USE master'); + + foreach my $database (qw/dbicsl_test1 dbicsl_test2/) { + try { + $dbh->do(qq{DROP DATABASE $database}); + } + catch { + diag "Error dropping test database '$database': $_"; + }; + } + } + + rmtree EXTRA_DUMP_DIR; + } + } +} # vim:et sts=4 sw=4 tw=0: diff --git a/t/10_08sqlanywhere_common.t b/t/10_08sqlanywhere_common.t index 797c542..f52bc4e 100644 --- a/t/10_08sqlanywhere_common.t +++ b/t/10_08sqlanywhere_common.t @@ -1,7 +1,18 @@ use strict; use warnings; +use Test::More; +use Test::Exception; +use Try::Tiny; +use File::Path 'rmtree'; +use DBIx::Class::Schema::Loader 'make_schema_at'; +use Scope::Guard (); + use lib qw(t/lib); + use dbixcsl_common_tests; +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/sqlanywhere_extra_dump"; # The default max_cursor_count and max_statement_count settings of 50 are too # low to run this test. @@ -16,6 +27,8 @@ my $odbc_dsn = $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN} || ''; my $odbc_user = $ENV{DBICTEST_SQLANYWHERE_ODBC_USER} || ''; my $odbc_password = $ENV{DBICTEST_SQLANYWHERE_ODBC_PASS} || ''; +my ($schema, $schemas_created); # for cleanup in END for extra tests + my $tester = dbixcsl_common_tests->new( vendor => 'SQLAnywhere', auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY', @@ -130,7 +143,207 @@ my $tester = dbixcsl_common_tests->new( 'long nvarchar'=> { data_type => 'long nvarchar' }, 'ntext' => { data_type => 'ntext' }, }, + extra => { + count => 28 * 2, + run => sub { + SKIP: { + $schema = $_[0]; + my $self = $_[3]; + + my $connect_info = [@$self{qw/dsn user password/}]; + + my $dbh = $schema->storage->dbh; + + try { + $dbh->do("CREATE USER dbicsl_test1 identified by 'dbicsl'"); + } + catch { + $schemas_created = 0; + skip "no CREATE USER privileges", 28 * 2; + }; + + $dbh->do(<<"EOF"); + CREATE TABLE dbicsl_test1.sqlanywhere_loader_test4 ( + id INT IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE dbicsl_test1.sqlanywhere_loader_test5 ( + id INT IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + four_id INTEGER NOT NULL UNIQUE, + FOREIGN KEY (four_id) REFERENCES dbicsl_test1.sqlanywhere_loader_test4 (id) + ) +EOF + $dbh->do("CREATE USER dbicsl_test2 identified by 'dbicsl'"); + $dbh->do(<<"EOF"); + CREATE TABLE dbicsl_test2.sqlanywhere_loader_test6 ( + id INT IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + sqlanywhere_loader_test4_id INTEGER, + FOREIGN KEY (sqlanywhere_loader_test4_id) REFERENCES dbicsl_test1.sqlanywhere_loader_test4 (id) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE dbicsl_test2.sqlanywhere_loader_test7 ( + id INT IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + six_id INTEGER NOT NULL UNIQUE, + FOREIGN KEY (six_id) REFERENCES dbicsl_test2.sqlanywhere_loader_test6 (id) + ) +EOF + $dbh->do(<<"EOF"); + CREATE TABLE dbicsl_test1.sqlanywhere_loader_test8 ( + id INT IDENTITY NOT NULL PRIMARY KEY, + value VARCHAR(100), + sqlanywhere_loader_test7_id INTEGER, + FOREIGN KEY (sqlanywhere_loader_test7_id) REFERENCES dbicsl_test2.sqlanywhere_loader_test7 (id) + ) +EOF + + $schemas_created = 1; + + my $guard = Scope::Guard->new(\&extra_cleanup); + + foreach my $db_schema (['dbicsl_test1', 'dbicsl_test2'], '%') { + lives_and { + rmtree EXTRA_DUMP_DIR; + + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/; + }; + + make_schema_at( + 'SQLAnywhereMultiSchema', + { + naming => 'current', + db_schema => $db_schema, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + $connect_info, + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for dbicsl_test1 and dbicsl_test2 schemas with no warnings'; + + my ($test_schema, $rsrc, $rs, $row, %uniqs, $rel_info); + + lives_and { + ok $test_schema = SQLAnywhereMultiSchema->connect(@$connect_info); + } 'connected test schema'; + + lives_and { + ok $rsrc = $test_schema->source('SqlanywhereLoaderTest4'); + } 'got source for table in schema one'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema one'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema one'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema one'; + + lives_and { + ok $rs = $test_schema->resultset('SqlanywhereLoaderTest4'); + } 'got resultset for table in schema one'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema one'; + + $rel_info = try { $rsrc->relationship_info('sqlanywhere_loader_test5') }; + + is_deeply $rel_info->{cond}, { + 'foreign.four_id' => 'self.id' + }, 'relationship in schema one'; + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema one'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema one'; + + lives_and { + ok $rsrc = $test_schema->source('SqlanywhereLoaderTest5'); + } 'got source for table in schema one'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema one'; + + lives_and { + ok $rsrc = $test_schema->source('SqlanywhereLoaderTest6'); + } 'got source for table in schema two'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in schema two introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in schema two introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in schema two introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('SqlanywhereLoaderTest6'); + } 'got resultset for table in schema two'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in schema two'; + + $rel_info = try { $rsrc->relationship_info('sqlanywhere_loader_test7') }; + + is_deeply $rel_info->{cond}, { + 'foreign.six_id' => 'self.id' + }, 'relationship in schema two'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in schema two'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in schema two'; + + lives_and { + ok $rsrc = $test_schema->source('SqlanywhereLoaderTest7'); + } 'got source for table in schema two'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in schema two'; + + lives_and { + ok $test_schema->source('SqlanywhereLoaderTest6') + ->has_relationship('sqlanywhere_loader_test4'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('SqlanywhereLoaderTest4') + ->has_relationship('sqlanywhere_loader_test6s'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('SqlanywhereLoaderTest8') + ->has_relationship('sqlanywhere_loader_test7'); + } 'cross-schema relationship in multi-db_schema'; + + lives_and { + ok $test_schema->source('SqlanywhereLoaderTest7') + ->has_relationship('sqlanywhere_loader_test8s'); + } 'cross-schema relationship in multi-db_schema'; + } + } + }, + }, ); if (not ($dbd_sqlanywhere_dsn || $odbc_dsn)) { @@ -139,4 +352,33 @@ if (not ($dbd_sqlanywhere_dsn || $odbc_dsn)) { else { $tester->run_tests(); } + +sub extra_cleanup { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + if ($schemas_created && (my $dbh = try { $schema->storage->dbh })) { + foreach my $table ('dbicsl_test1.sqlanywhere_loader_test8', + 'dbicsl_test2.sqlanywhere_loader_test7', + 'dbicsl_test2.sqlanywhere_loader_test6', + 'dbicsl_test1.sqlanywhere_loader_test5', + 'dbicsl_test1.sqlanywhere_loader_test4') { + try { + $dbh->do("DROP TABLE $table"); + } + catch { + diag "Error dropping table: $_"; + }; + } + + foreach my $db_schema (qw/dbicsl_test1 dbicsl_test2/) { + try { + $dbh->do("DROP USER $db_schema"); + } + catch { + diag "Error dropping test user $db_schema: $_"; + }; + } + } + rmtree EXTRA_DUMP_DIR; + } +} # vim:et sts=4 sw=4 tw=0: diff --git a/t/10_09firebird_common.t b/t/10_09firebird_common.t index 0dbbd11..39fc849 100644 --- a/t/10_09firebird_common.t +++ b/t/10_09firebird_common.t @@ -5,9 +5,13 @@ use Scope::Guard (); use lib qw(t/lib); use dbixcsl_common_tests; -my $dbd_interbase_dsn = $ENV{DBICTEST_FIREBIRD_DSN} || ''; -my $dbd_interbase_user = $ENV{DBICTEST_FIREBIRD_USER} || ''; -my $dbd_interbase_password = $ENV{DBICTEST_FIREBIRD_PASS} || ''; +my $dbd_firebird_dsn = $ENV{DBICTEST_FIREBIRD_DSN} || ''; +my $dbd_firebird_user = $ENV{DBICTEST_FIREBIRD_USER} || ''; +my $dbd_firebird_password = $ENV{DBICTEST_FIREBIRD_PASS} || ''; + +my $dbd_interbase_dsn = $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN} || ''; +my $dbd_interbase_user = $ENV{DBICTEST_FIREBIRD_INTERBASE_USER} || ''; +my $dbd_interbase_password = $ENV{DBICTEST_FIREBIRD_INTERBASE_PASS} || ''; my $odbc_dsn = $ENV{DBICTEST_FIREBIRD_ODBC_DSN} || ''; my $odbc_user = $ENV{DBICTEST_FIREBIRD_ODBC_USER} || ''; @@ -43,8 +47,14 @@ my $tester = dbixcsl_common_tests->new( null => '', preserve_case_mode_is_exclusive => 1, quote_char => '"', - warnings => [ qr/'preserve_case' option/ ], - connect_info => [ ($dbd_interbase_dsn ? { + connect_info => [ + ($dbd_firebird_dsn ? { + dsn => $dbd_firebird_dsn, + user => $dbd_firebird_user, + password => $dbd_firebird_password, + connect_info_opts => { on_connect_call => 'use_softcommit' }, + } : ()), + ($dbd_interbase_dsn ? { dsn => $dbd_interbase_dsn, user => $dbd_interbase_user, password => $dbd_interbase_password, @@ -109,7 +119,6 @@ my $tester = dbixcsl_common_tests->new( 'varchar(33) character set unicode_fss' => => { data_type => 'varchar(x) character set unicode_fss', size => 33 }, - # Blob types 'blob' => { data_type => 'blob' }, 'blob sub_type text' @@ -151,8 +160,8 @@ q{ my $guard = Scope::Guard->new(\&cleanup_extra); - local $schema->_loader->{preserve_case} = 1; - $schema->_loader->_setup; + local $schema->loader->{preserve_case} = 1; + $schema->loader->_setup; $self->rescan_without_warnings($schema); @@ -179,7 +188,7 @@ q{ ); for my $type_num (keys %truncated_types) { - is $schema->_loader->_dbh_type_info_type_name($type_num), + is $schema->loader->_dbh_type_info_type_name($type_num), $truncated_types{$type_num}, "ODBC ->_dbh_type_info_type_name correct for '$truncated_types{$type_num}'"; } @@ -192,17 +201,18 @@ q{ }, ); -if (not ($dbd_interbase_dsn || $odbc_dsn)) { - $tester->skip_tests('You need to set the DBICTEST_FIREBIRD_DSN, _USER and _PASS and/or the DBICTEST_FIREBIRD_ODBC_DSN, _USER and _PASS environment variables'); +if (not ($dbd_firebird_dsn || $dbd_interbase_dsn || $odbc_dsn)) { + $tester->skip_tests('You need to set the DBICTEST_FIREBIRD_DSN, _USER and _PASS and/or the DBICTEST_FIREBIRD_INTERBASE_DSN and/or the DBICTEST_FIREBIRD_ODBC_DSN environment variables'); } else { # get rid of stupid warning from InterBase/GetInfo.pm if ($dbd_interbase_dsn) { local $SIG{__WARN__} = sub { warn @_ - unless $_[0] =~ m|^Use of uninitialized value in sprintf at \S+DBD/InterBase/GetInfo\.pm line \d+\.$| }; + unless $_[0] =~ m{^Use of uninitialized value in sprintf at \S+DBD/InterBase/GetInfo\.pm line \d+\.$|^Missing argument in sprintf at \S+DBD/InterBase/GetInfo.pm line \d+\.$} }; require DBD::InterBase; require DBD::InterBase::GetInfo; } + $tester->run_tests(); } diff --git a/t/10_10informix_common.t b/t/10_10informix_common.t index 07b0523..f3d5d53 100644 --- a/t/10_10informix_common.t +++ b/t/10_10informix_common.t @@ -1,6 +1,17 @@ use strict; +use warnings; +use Test::More; +use Test::Exception; +use Try::Tiny; +use File::Path 'rmtree'; +use DBIx::Class::Schema::Loader 'make_schema_at'; + use lib qw(t/lib); -use dbixcsl_common_tests; + +use dbixcsl_common_tests (); +use dbixcsl_test_dir '$tdir'; + +use constant EXTRA_DUMP_DIR => "$tdir/informix_extra_dump"; # to support " quoted identifiers BEGIN { $ENV{DELIMIDENT} = 'y' } @@ -11,6 +22,8 @@ my $dsn = $ENV{DBICTEST_INFORMIX_DSN} || ''; my $user = $ENV{DBICTEST_INFORMIX_USER} || ''; my $password = $ENV{DBICTEST_INFORMIX_PASS} || ''; +my ($schema, $extra_schema); # for cleanup in END for extra tests + my $tester = dbixcsl_common_tests->new( vendor => 'Informix', auto_inc_pk => 'serial primary key', @@ -113,6 +126,166 @@ my $tester = dbixcsl_common_tests->new( 'set(varchar(20) not null)' => { data_type => 'set' }, }, + extra => { + count => 24, + run => sub { + ($schema) = @_; + + SKIP: { + skip 'Set the DBICTEST_INFORMIX_EXTRADB_DSN, _USER and _PASS environment variables to run the multi-database tests', 24 + unless $ENV{DBICTEST_INFORMIX_EXTRADB_DSN}; + + $extra_schema = $schema->clone; + $extra_schema->connection(@ENV{map "DBICTEST_INFORMIX_EXTRADB_$_", + qw/DSN USER PASS/ + }); + + my $dbh1 = $schema->storage->dbh; + my $dbh2 = $extra_schema->storage->dbh; + + $dbh1->do(<<'EOF'); + CREATE TABLE informix_loader_test4 ( + id SERIAL PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh1->do(<<'EOF'); + CREATE TABLE informix_loader_test5 ( + id SERIAL PRIMARY KEY, + value VARCHAR(100), + four_id INTEGER UNIQUE REFERENCES informix_loader_test4 (id) + ) +EOF + $dbh2->do(<<"EOF"); + CREATE TABLE informix_loader_test6 ( + id SERIAL PRIMARY KEY, + value VARCHAR(100) + ) +EOF + $dbh2->do(<<"EOF"); + CREATE TABLE informix_loader_test7 ( + id SERIAL PRIMARY KEY, + value VARCHAR(100), + six_id INTEGER UNIQUE REFERENCES informix_loader_test6 (id) + ) +EOF + lives_and { + my @warns; + local $SIG{__WARN__} = sub { + push @warns, $_[0] unless $_[0] =~ /\bcollides\b/ + || $_[0] =~ /unreferencable/; + }; + + make_schema_at( + 'InformixMultiDatabase', + { + naming => 'current', + db_schema => { '%' => '%' }, + dump_directory => EXTRA_DUMP_DIR, + quiet => 1, + }, + [ $dsn, $user, $password ], + ); + + diag join "\n", @warns if @warns; + + is @warns, 0; + } 'dumped schema for all databases with no warnings'; + + my $test_schema; + + lives_and { + ok $test_schema = InformixMultiDatabase->connect($dsn, $user, $password); + } 'connected test schema'; + + my ($rsrc, $rs, $row, $rel_info, %uniqs); + + lives_and { + ok $rsrc = $test_schema->source('InformixLoaderTest4'); + } 'got source for table in database one'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database one'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database one'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database one'; + + lives_and { + ok $rs = $test_schema->resultset('InformixLoaderTest4'); + } 'got resultset for table in database one'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database one'; + + $rel_info = try { $rsrc->relationship_info('informix_loader_test5') }; + + is_deeply $rel_info->{cond}, { + 'foreign.four_id' => 'self.id' + }, 'relationship in database one'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database one'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database one'; + + lives_and { + ok $rsrc = $test_schema->source('InformixLoaderTest5'); + } 'got source for table in database one'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database one'; + + lives_and { + ok $rsrc = $test_schema->source('InformixLoaderTest6'); + } 'got source for table in database two'; + + is try { $rsrc->column_info('id')->{is_auto_increment} }, 1, + 'column in database two introspected correctly'; + + is try { $rsrc->column_info('value')->{data_type} }, 'varchar', + 'column in database two introspected correctly'; + + is try { $rsrc->column_info('value')->{size} }, 100, + 'column in database two introspected correctly'; + + lives_and { + ok $rs = $test_schema->resultset('InformixLoaderTest6'); + } 'got resultset for table in database two'; + + lives_and { + ok $row = $rs->create({ value => 'foo' }); + } 'executed SQL on table in database two'; + + $rel_info = try { $rsrc->relationship_info('informix_loader_test7') }; + + is_deeply $rel_info->{cond}, { + 'foreign.six_id' => 'self.id' + }, 'relationship in database two'; + + is $rel_info->{attrs}{accessor}, 'single', + 'relationship in database two'; + + is $rel_info->{attrs}{join_type}, 'LEFT', + 'relationship in database two'; + + lives_and { + ok $rsrc = $test_schema->source('InformixLoaderTest7'); + } 'got source for table in database two'; + + %uniqs = try { $rsrc->unique_constraints }; + + is keys %uniqs, 2, + 'got unique and primary constraint in database two'; + } + }, + }, ); if( !$dsn ) { @@ -121,4 +294,24 @@ if( !$dsn ) { else { $tester->run_tests(); } + +END { + if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { + if (my $dbh2 = try { $extra_schema->storage->dbh }) { + my $dbh1 = $schema->storage->dbh; + + try { + $dbh2->do('DROP TABLE informix_loader_test7'); + $dbh2->do('DROP TABLE informix_loader_test6'); + $dbh1->do('DROP TABLE informix_loader_test5'); + $dbh1->do('DROP TABLE informix_loader_test4'); + } + catch { + die "Error dropping test tables: $_"; + }; + } + + rmtree EXTRA_DUMP_DIR; + } +} # vim:et sts=4 sw=4 tw=0: diff --git a/t/23dumpmore.t b/t/23dumpmore.t index a2d0247..2c1ef7b 100644 --- a/t/23dumpmore.t +++ b/t/23dumpmore.t @@ -56,7 +56,7 @@ $t->cleanup; $t->dump_test( classname => 'DBICTest::Schema::_clashing_monikers', test_db_class => 'make_dbictest_db_clashing_monikers', - error => qr/tables 'bar', 'bars' reduced to the same source moniker 'Bar'/, + error => qr/tables (?:"bar", "bars"|"bars", "bar") reduced to the same source moniker 'Bar'/, ); @@ -278,6 +278,9 @@ $t->dump_test( qualify_objects => 1, use_namespaces => 1 }, + warnings => [ + qr/^db_schema is not supported on SQLite/, + ], regexes => { 'Result/Foo' => [ qr/^\Q__PACKAGE__->table("foo_schema.foo");\E/m, @@ -287,6 +290,27 @@ $t->dump_test( }, ); +# test moniker_parts +$t->dump_test( + classname => 'DBICTest::DumpMore::1', + options => { + db_schema => 'my_schema', + moniker_parts => ['_schema', 'name'], + qualify_objects => 1, + use_namespaces => 1, + }, + warnings => [ + qr/^db_schema is not supported on SQLite/, + ], + regexes => { + 'Result/MySchemaFoo' => [ + qr/^\Q__PACKAGE__->table("my_schema.foo");\E/m, + # the has_many relname should not have the schema in it! + qr/^__PACKAGE__->has_many\(\n "bars"/m, + ], + }, +); + $t->dump_test( classname => 'DBICTest::DumpMore::1', options => { diff --git a/t/24loader_subclass.t b/t/24loader_subclass.t index 78a5535..5d54a2f 100644 --- a/t/24loader_subclass.t +++ b/t/24loader_subclass.t @@ -41,6 +41,6 @@ while (my ($style,$subref) = each %invocations) { while (my ($arg, $class) = each %loader_class) { my $schema = $subref->($arg); $schema = $schema->clone unless ref $schema; - isa_ok($schema->_loader, $class, "$style($arg)"); + isa_ok($schema->loader, $class, "$style($arg)"); } } diff --git a/t/25backcompat.t b/t/25backcompat.t index 57540f8..eaa97bd 100644 --- a/t/25backcompat.t +++ b/t/25backcompat.t @@ -734,7 +734,7 @@ sub class_content_like; my $res = run_loader(static => 1, naming => 'current'); my $schema = $res->{schema}; - my $file = $schema->_loader->get_dump_filename($SCHEMA_CLASS); + my $file = $schema->loader->get_dump_filename($SCHEMA_CLASS); my $code = slurp $file; my ($dumped_ver) = @@ -1301,7 +1301,7 @@ sub _rel_condition { sub class_content_like { my ($schema, $class, $re, $test_name) = @_; - my $file = $schema->_loader->get_dump_filename($class); + my $file = $schema->loader->get_dump_filename($class); my $code = slurp $file; like $code, $re, $test_name; @@ -1333,7 +1333,7 @@ EOF sub _write_custom_content { my ($schema, $class, $content) = @_; - my $pm = $schema->_loader->get_dump_filename($class); + my $pm = $schema->loader->get_dump_filename($class); { local ($^I, @ARGV) = ('.bak', $pm); while (<>) { diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index 4ee6d78..7911ac2 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -7,7 +7,7 @@ use Test::More; use Test::Exception; use DBIx::Class::Schema::Loader; use Class::Unload; -use File::Path; +use File::Path 'rmtree'; use DBI; use Digest::MD5; use File::Find 'find'; @@ -20,7 +20,7 @@ use File::Spec::Functions 'catfile'; use File::Basename 'basename'; use namespace::clean; -use dbixcsl_test_dir qw/$tdir/; +use dbixcsl_test_dir '$tdir'; use constant DUMP_DIR => "$tdir/common_dump"; @@ -578,12 +578,12 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent ); is( - sprintf("%.3f", $class35->column_info('a_double')->{default_value}), '10.555', + sprintf("%.3f", $class35->column_info('a_double')->{default_value}||0), '10.555', 'constant numeric default', ); is( - sprintf("%.3f", $class35->column_info('a_negative_double')->{default_value}), -10.555, + sprintf("%.3f", $class35->column_info('a_negative_double')->{default_value}||0), -10.555, 'constant negative numeric default', ); @@ -802,7 +802,7 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent 'might_have does not have is_deferrable'); # find on multi-col pk - if ($conn->_loader->preserve_case) { + if ($conn->loader->preserve_case) { my $obj5 = $rsobj5->find({id1 => 1, iD2 => 1}); is $obj5->i_d2, 1, 'Find on multi-col PK'; } @@ -1184,11 +1184,11 @@ EOF $self->test_data_types($conn); + $self->test_preserve_case($conn); + # run extra tests $self->{extra}{run}->($conn, $monikers, $classes, $self) if $self->{extra}{run}; - $self->test_preserve_case($conn); - $self->drop_tables unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; $conn->storage->disconnect; @@ -1254,8 +1254,8 @@ qq| INSERT INTO ${oqt}${table41_name}${cqt} VALUES (1, 1) |, ); $conn->storage->disconnect; - local $conn->_loader->{preserve_case} = 1; - $conn->_loader->_setup; + local $conn->loader->{preserve_case} = 1; + $conn->loader->_setup; $self->rescan_without_warnings($conn); @@ -1280,9 +1280,7 @@ sub monikers_and_classes { my ($monikers, $classes); foreach my $source_name ($schema_class->sources) { - my $table_name = $schema_class->source($source_name)->from; - - $table_name = $$table_name if ref $table_name; + my $table_name = $schema_class->loader->moniker_to_table->{$source_name}; my $result_class = $schema_class->source($source_name)->result_class; @@ -1449,6 +1447,8 @@ sub create { c_char_as_data VARCHAR(100) ) $self->{innodb} }, + # DB2 does not allow nullable uniq components, SQLAnywhere automatically + # converts nullable uniq components to NOT NULL qq{ CREATE TABLE loader_test50 ( id INTEGER NOT NULL UNIQUE, @@ -2168,7 +2168,7 @@ sub setup_data_type_tests { $col_name .= "_sz_$size_name"; } - # XXX would be better to check _loader->preserve_case + # XXX would be better to check loader->preserve_case $col_name = lc $col_name; $col_name .= '_' . $seen_col_names{$col_name} if $seen_col_names{$col_name}++;