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 Class::Unload ();
-use DBIx::Class::Schema::Loader::Utils 'dumper_squashed';
+use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file/;
use List::MoreUtils 'apply';
use DBIx::Class::Schema::Loader::Optional::Dependencies ();
use Try::Tiny;
-use File::Slurp 'read_file';
use File::Spec::Functions 'catfile';
use File::Basename 'basename';
use namespace::clean;
-use dbixcsl_test_dir qw/$tdir/;
+use dbixcsl_test_dir '$tdir';
use constant DUMP_DIR => "$tdir/common_dump";
my $extra_count = $self->{extra}{count} || 0;
my $col_accessor_map_tests = 5;
- my $num_rescans = 5;
+ my $num_rescans = 6;
$num_rescans++ if $self->{vendor} eq 'mssql';
$num_rescans++ if $self->{vendor} eq 'Firebird';
plan tests => @connect_info *
- (207 + $num_rescans * $col_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
+ (214 + $num_rescans * $col_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
foreach my $info_idx (0..$#connect_info) {
my $info = $connect_info[$info_idx];
$dbh->do($_) for @{ $self->{extra}{create} || [] };
if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) {
- $dbh->do($_) for @{ $self->{data_type_tests}{ddl} || []};
+ foreach my $ddl (@{ $self->{data_type_tests}{ddl} || []}) {
+ if (my $cb = $self->{data_types_ddl_cb}) {
+ $cb->($ddl);
+ }
+ else {
+ $dbh->do($ddl);
+ }
+ }
}
$self->{_created} = 1;
qr/^(?:\S+\.)?(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i,
result_namespace => RESULT_NAMESPACE,
resultset_namespace => RESULTSET_NAMESPACE,
+ schema_base_class => 'TestSchemaBaseClass',
+ schema_components => [ 'TestSchemaComponent', '+TestSchemaComponentFQN' ],
additional_classes => 'TestAdditional',
additional_base_classes => 'TestAdditionalBase',
left_base_classes => [ qw/TestLeftBase/ ],
'Result files dumped to first entry in result_namespace';
# parse out the resultset_namespace
- my $schema_code = read_file($conn->_loader->get_dump_filename(SCHEMA_CLASS), binmode => ':encoding(UTF-8)');
+ my $schema_code = slurp_file $conn->_loader->get_dump_filename(SCHEMA_CLASS);
my ($schema_resultset_namespace) = $schema_code =~ /\bresultset_namespace => (.*)/;
$schema_resultset_namespace = eval $schema_resultset_namespace;
is_deeply $schema_resultset_namespace, RESULTSET_NAMESPACE,
'resultset_namespace set correctly on Schema';
+ like $schema_code,
+qr/\nuse base 'TestSchemaBaseClass';\n\n|\nextends 'TestSchemaBaseClass';\n\n/,
+ 'schema_base_class works';
+
+ is $conn->testschemabaseclass, 'TestSchemaBaseClass works',
+ 'schema base class works';
+
+ like $schema_code,
+qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponentFQN"\);\n\n__PACKAGE__->load_namespaces/,
+ 'schema_components works';
+
+ is $conn->dbix_class_testschemacomponent, 'dbix_class_testschemacomponent works',
+ 'schema component works';
+
+ is $conn->testschemacomponent_fqn, 'TestSchemaComponentFQN works',
+ 'fully qualified schema component works';
+
my @columns_lt2 = $class2->columns;
is_deeply( \@columns_lt2, [ qw/id dat dat2 set_primary_key can dbix_class_testcomponent dbix_class_testcomponentmap testcomponent_fqn meta test_role_method test_role_for_map_method crumb_crisp_coating/ ], "Column Ordering" );
);
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',
);
is( $class2->column_info('crumb_crisp_coating')->{accessor}, 'trivet',
'col_accessor_map is being run' );
+ is $class1->column_info('dat')->{is_nullable}, 0,
+ 'is_nullable=0 detection';
+
+ is $class2->column_info('set_primary_key')->{is_nullable}, 1,
+ 'is_nullable=1 detection';
+
SKIP: {
skip $self->{skip_rels}, 131 if $self->{skip_rels};
'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';
}
$class6->column_info('Id2');
ok($id2_info->{is_foreign_key}, 'Foreign key detected');
- unlike read_file($conn->_loader->get_dump_filename($class6), binmode => ':encoding(UTF-8)'),
+ unlike slurp_file $conn->_loader->get_dump_filename($class6),
qr/\n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\(
\s+ "(\w+?)"
.*?
\s+ "\1"/xs,
'did not create two relationships with the same name';
- unlike read_file($conn->_loader->get_dump_filename($class8), binmode => ':encoding(UTF-8)'),
+ unlike slurp_file $conn->_loader->get_dump_filename($class8),
qr/\n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\(
\s+ "(\w+?)"
.*?
find $find_cb, DUMP_DIR;
-# system "rm -f /tmp/before_rescan/* /tmp/after_rescan/*";
-# system "cp $tdir/common_dump/DBIXCSL_Test/Schema/*.pm /tmp/before_rescan";
+# system "rm -rf /tmp/before_rescan /tmp/after_rescan";
+# system "mkdir /tmp/before_rescan";
+# system "mkdir /tmp/after_rescan";
+# system "cp -a @{[DUMP_DIR]} /tmp/before_rescan";
my $before_digest = $digest->b64digest;
is_deeply(\@new, [ qw/LoaderTest30/ ], "Rescan");
-# system "cp t/_common_dump/DBIXCSL_Test/Schema/*.pm /tmp/after_rescan";
+# system "cp -a @{[DUMP_DIR]} /tmp/after_rescan";
$digest = Digest::MD5->new;
find $find_cb, DUMP_DIR;
$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;
+ my $orig_preserve_case = $conn->loader->preserve_case;
+ $conn->loader->preserve_case(1);
+ $conn->loader->_setup;
$self->rescan_without_warnings($conn);
if (not $self->{skip_rels}) {
is try { $conn->resultset('LoaderTest40')->find(1)->foo3_bar }, 'foo',
'accessor for mixed-case column name in mixed case table';
}
+
+ # Further tests may expect preserve_case to be unset, so reset it to the
+ # original value and rescan again.
+
+ $conn->loader->preserve_case($orig_preserve_case);
+ $conn->loader->_setup;
+ $self->rescan_without_warnings($conn);
}
sub monikers_and_classes {
my ($monikers, $classes);
foreach my $source_name ($schema_class->sources) {
- my $table_name = $schema_class->source($source_name)->from;
-
- $table_name = $$table_name if ref $table_name;
+ my $table_name = $schema_class->loader->moniker_to_table->{$source_name};
my $result_class = $schema_class->source($source_name)->result_class;
$monikers->{$table_name} = $source_name;
$classes->{$table_name} = $result_class;
- # some DBs (Firebird) uppercase everything
+ # some DBs (Firebird, Oracle) uppercase everything
$monikers->{lc $table_name} = $source_name;
$classes->{lc $table_name} = $result_class;
}
$self->drop_tables;
- my $make_auto_inc = $self->{auto_inc_cb} || sub {};
+ my $make_auto_inc = $self->{auto_inc_cb} || sub { return () };
@statements = (
qq{
CREATE TABLE loader_test1s (
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,
id1 INTEGER NOT NULL,
id2 INTEGER NOT NULL,
- id3 INTEGER $self->{null},
- id4 INTEGER NOT NULL,
- UNIQUE (id1, id2),
- UNIQUE (id3, id4)
+ @{[ $self->{vendor} !~ /^(?:DB2|SQLAnywhere)\z/i ? "
+ id3 INTEGER $self->{null},
+ id4 INTEGER NOT NULL,
+ UNIQUE (id3, id4),
+ " : '' ]}
+ UNIQUE (id1, id2)
) $self->{innodb}
},
);
$dbh->do($_) foreach (@statements);
if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) {
- $dbh->do($_) foreach (@{ $self->{data_type_tests}{ddl} || [] });
+ foreach my $ddl (@{ $self->{data_type_tests}{ddl} || [] }) {
+ if (my $cb = $self->{data_types_ddl_cb}) {
+ $cb->($ddl);
+ }
+ else {
+ $dbh->do($ddl);
+ }
+ }
}
unless ($self->{skip_rels}) {
my %seen_col_names;
while (my ($col_def, $expected_info) = each %$types) {
- (my $type_alias = $col_def) =~ s/\( ([^)]+) \)//xg;
+ (my $type_alias = $col_def) =~ s/\( (.+) \)(?=(?:[^()]* '(?:[^']* (?:''|\\')* [^']*)* [^\\']' [^()]*)*\z)//xg;
my $size = $1;
$size = '' unless defined $size;
+ $size = '' unless $size =~ /^[\d, ]+\z/;
$size =~ s/\s+//g;
my @size = split /,/, $size;
# some DBs don't like very long column names
- if ($self->{vendor} =~ /^(?:firebird|sqlanywhere|oracle|db2)\z/i) {
+ if ($self->{vendor} =~ /^(?:Firebird|SQLAnywhere|Oracle|DB2)\z/i) {
my ($col_def, $default) = $type_alias =~ /^(.*)(default.*)?\z/i;
$type_alias = substr $col_def, 0, 15;
$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 / blobdiff