- $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)
- 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
=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<db_schema> option to be an
-arrayref of schemas to load.
-
-In "normal" L<DBIx::Class::Schema> usage, manually-defined
-source classes and relationships have no problems crossing vendor schemas.
+See L<DBIx::Class::Schema::Loader::Base/db_schema>.
=head1 ACKNOWLEDGEMENTS
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;
relationship_attrs
- db_schema
_tables
classes
_upgrading_classes
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
/);
_result_class_methods
naming_set
filter_generated_code
+ db_schema
+ qualify_objects
+ moniker_parts
/);
my $CURRENT_V = 'v7';
=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</moniker_parts> if you have
+name clashes for tables in different schemas/databases.
+
+=head2 moniker_parts
+
+The database table names are represented by the
+L<DBIx::Class::Schema::Loader::Table> class in the loader, the
+L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
+L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
+
+Monikers are created normally based on just the
+L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
+the table name, but can consist of other parts of the fully qualified name of
+the table.
+
+The L</moniker_parts> 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<must> be present.
+
+Below is a table of supported databases and possible L</moniker_parts>.
+
+=over 4
+
+=item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
+
+C<schema>, C<name>
+
+=item * Informix, MSSQL, Sybase ASE
+
+C<database>, C<schema>, C<name>
+
+=back
=head2 constraint
}
}
+ $self->{_tables} = {};
$self->{monikers} = {};
- $self->{tables} = {};
+ $self->{moniker_to_table} = {};
$self->{class_to_table} = {};
$self->{classes} = {};
$self->{_upgrading_classes} = {};
}
}
- $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 {
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);
}
}
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 {
# 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,
);
}
}
;
}
-
$self->_setup_src_meta($_) for @tables;
if(!$self->skip_relationships) {
$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.
# 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;
$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';
}
warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
-
}
sub _sig_comment {
);
}
- 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});
}
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;
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) {
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;
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) = @_;
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);
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,
};
sub tables {
my $self = shift;
- return keys %{$self->_tables};
+ return values %{$self->_tables};
}
# Make a moniker from a table
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' ?
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 ];
}
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} }
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};
};
}
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';
_disable_uniq_detection
_disable_fk_detection
_passwords
+ quote_char
+ name_sep
/);
=head1 NAME
# rebless to vendor-specific class if it exists and loads and we're not in a
# custom class.
if (not $self->loader_class) {
- my $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)) {
}
# 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()
# 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);
}
@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;
}
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;
}
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: $_";
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;
}
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
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
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: $_";
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;
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};
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;
}
return ($dsn, $user, $pass, $params);
}
+sub dbh {
+ my $self = shift;
+
+ return $self->schema->storage->dbh;
+}
+
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader>
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';
DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
use Try::Tiny;
use namespace::clean;
DBIx::Class::Schema::Loader::DBI::MSSQL
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
-use namespace::clean;
our $VERSION = '0.07010';
=head1 SEE ALSO
+L<DBIx::Class::Schema::Loader::DBI::ADO>,
L<DBIx::Class::Schema::Loader::DBI::MSSQL>,
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>
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<DBIx::Class::Schema::Loader::Base>.
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
=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);
}
}
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) {
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
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;
}
$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 = ?
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';
=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;
$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);
}
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');
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');
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');
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,
};
}
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');
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
$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;
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
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) {
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) {
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;
}
# 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
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;
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';
}
}
}
- 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};
}
}
}
- 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)) {
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
generated column names are lower-cased as this makes them easier to work with
in L<DBIx::Class>.
-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<db_schema|DBIx::Class::Schema::Loader::Base/db_schema>, 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:
=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;
}
# 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};
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;
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';
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';
=cut
+sub _supports_db_schema { 0 }
+
sub _db_path {
my $self = shift;
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);
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";
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";
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;
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';
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';
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';
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';
=head1 DESCRIPTION
-See L<DBIx::Class::Schema::Loader::Base>.
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
=cut
$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) {
}
}
-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 }) || [] } ];
}
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;
}
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
}
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);
$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;
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';
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<DBIx::Class::Schema::Loader::Base>.
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
=cut
$self->next::method(@_);
- $self->{db_schema} ||= 'public';
+ $self->{db_schema} ||= ['public'];
if (not defined $self->preserve_case) {
$self->preserve_case(0);
}
}
-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 {
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
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+//;
}
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
delete $info->{size};
}
else {
- my ($integer_datetimes) = $self->schema->storage->dbh
+ my ($integer_datetimes) = $self->dbh
->selectrow_array('show integer_datetimes');
my $max_precision =
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(<<EOF, {}, $table, $col);
+ my ($precision) = $self->dbh->selectrow_array(<<EOF, {}, $table, $col);
SELECT character_maximum_length
FROM information_schema.columns
WHERE table_name = ? and column_name = ?
FROM pg_catalog.pg_type
WHERE typname = ?
EOF
- if ($typetype eq 'e') {
+ if ($typetype && $typetype eq 'e') {
# The following will extract a list of allowed values for the
# enum.
- my $typevalues = $self->schema->storage->dbh
+ my $typevalues = $self->dbh
->selectall_arrayref(<<EOF, {}, $info->{data_type});
SELECT e.enumlabel
FROM pg_catalog.pg_enum e
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';
=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);
}
$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;
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;
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;
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) {
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) {
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';
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 {
$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');
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;
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;
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;
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) {
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);
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';
See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
-=cut
-
-sub _setup {
- my $self = shift;
-
- $self->next::method(@_);
+This class reblesses into the L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> class for connections to MSSQL.
- if (not defined $self->preserve_case) {
- $self->preserve_case(1);
- }
-}
+=cut
sub _rebless {
my $self = shift;
}
}
+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;
}
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;
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;
$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;
+ }
}
}
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<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';
=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;
$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
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';
use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI';
- use Carp::Clan qw/^DBIx::Class/;
use mro 'c3';
sub _table_uniq_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<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
-To import comments from database you need to implement C<_table_comment>,
-C<_column_comment>
-
=cut
1;
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;
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 {
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,
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};
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';
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 = ?
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 METHODS
+
+=head2 loader
+
+The loader object this object is associated with, this is a required parameter
+to L</new>.
+
+=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</loader>, L</name>, L</schema>, and L</ignore_schema>
+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</ignore_schema> is
+true.
+
+=head2 ignore_schema
+
+Set to true to make L</schema> and L</sql_name> not use the defined L</schema>.
+Does not affect L</dbic_name> (for
+L<qualify_objects|DBIx::Class::Schema::Loader::Base/qualify_objects> 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</schema> and L</name>.
+
+=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<DBIx::Class> 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<DBIx::Class::Schema::Loader::Table>, L<DBIx::Class::Schema::Loader>,
+L<DBIx::Class::Schema::Loader::Base>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=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:
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+This is a subclass of L<DBIx::Class::Schema::Loader::DBObject> that adds
+support for fully qualified objects in Informix including both L</database>
+and L<schema|DBIx::Class::Schema::Loader::DBObject/schema> of the form:
+
+ database:owner.object_name
+
+=head1 METHODS
+
+=head2 database
+
+The database name this object belongs to.
+
+Returns undef if
+L<ignore_schema|DBIx::Class::Schema::Loader::DBObject/ignore_schema> 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</database>,
+L<schema|DBIx::Class::Schema::Loader::DBObject/schema> and
+L<name|DBIx::Class::Schema::Loader::DBObject/name>.
+
+=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<DBIx::Class::Schema::Loader::Table::Informix>,
+L<DBIx::Class::Schema::Loader::DBObject>,
+L<DBIx::Class::Schema::Loader::Table>, L<DBIx::Class::Schema::Loader>,
+L<DBIx::Class::Schema::Loader::Base>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=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:
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+This is a subclass of L<DBIx::Class::Schema::Loader::DBObject> that adds
+support for fully qualified objects in Sybase ASE and MSSQL including both
+L</database> and L<schema|DBIx::Class::Schema::Loader::DBObject/schema> of the
+form:
+
+ database.owner.object_name
+
+=head1 METHODS
+
+=head2 database
+
+The database name this object belongs to.
+
+Returns undef if
+L<ignore_schema|DBIx::Class::Schema::Loader::DBObject/ignore_schema> 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</database>,
+L<schema|DBIx::Class::Schema::Loader::DBObject/schema> and
+L<name|DBIx::Class::Schema::Loader::DBObject/name>.
+
+=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<DBIx::Class::Schema::Loader::Table::Sybase>,
+L<DBIx::Class::Schema::Loader::DBObject>,
+L<DBIx::Class::Schema::Loader::Table>, L<DBIx::Class::Schema::Loader>,
+L<DBIx::Class::Schema::Loader::Base>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=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:
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';
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.
[
{
- 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' ],
},
# ...
],
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;
}
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) {
}
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
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);
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';
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
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';
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
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';
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+Inherits from L<DBIx::Class::Schema::Loader::DBObject>.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBObject>, L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=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:
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+Inherits from L<DBIx::Class::Schema::Loader::DBObject::Informix>, see that module for details.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBObject::Informix>,
+L<DBIx::Class::Schema::Loader::DBObject>,
+L<DBIx::Class::Schema::Loader::Table>, L<DBIx::Class::Schema::Loader>,
+L<DBIx::Class::Schema::Loader::Base>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=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:
--- /dev/null
+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<DBIx::Class::Schema::Loader>
+
+=head1 DESCRIPTION
+
+Inherits from L<DBIx::Class::Schema::Loader::DBObject::Sybase>, see that module for details.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBObject::Sybase>,
+L<DBIx::Class::Schema::Loader::DBObject>,
+L<DBIx::Class::Schema::Loader::Table>, L<DBIx::Class::Schema::Loader>,
+L<DBIx::Class::Schema::Loader::Base>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=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:
$ 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 \
=head1 AUTHOR
-Dagfinn Ilmari Mannsåker C<< <ilmari@ilmari.org> >>
+Dagfinn Ilmari Manns?ker C<< <ilmari@ilmari.org> >>
=head1 CONTRIBUTORS
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',
],
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';
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';
+ }
+ }
+ }
},
},
);
$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:
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} || '';
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)
)
},
],
'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) = @_;
'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;
'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';
+ }
},
},
);
else {
$tester->run_tests();
}
+
+END {
+ rmtree EXTRA_DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
+}
# vim:et sw=4 sts=4 tw=0:
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} || '';
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} );
};
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 },
# 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:
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',
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}) {
}
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,
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';
+ }
+ }
},
},
);
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:
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',
},
],
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';
+ }
+ }
+ }
+ },
},
);
$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:
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
}
}
+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"};
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' },
'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 }),
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';
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);
}
$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:
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.
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',
'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)) {
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:
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} || '';
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,
'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'
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);
);
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}'";
}
},
);
-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();
}
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' }
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',
'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 ) {
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:
$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'/,
);
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,
},
);
+# 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 => {
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)");
}
}
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) =
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;
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 (<>) {
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';
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";
);
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',
);
'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';
}
$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;
);
$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);
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;
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,
$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}++;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff