@@ -1,5 +1,16 @@
Revision history for Perl extension DBIx::Class::Schema::Loader
+0.07043 2015-05-13
+ - Fix many_to_many bridges with overlapping foreign keys
+ - Add option to allow extra columns in many_to_many link tables
+ - Document how to add perltidy markers via filter_generated_code
+ - Fix DB2 foreign-key introspection
+ - Remove dependency on List::MoreUtils and Sub::Name
+ - Ensure schema files are generated as binary files on Windows
+ - Fix overwrite_modifications not overwriting if the table hasn't changed
+ - Filter out disabled constraints and triggers for Oracle (GH#5)
+
+0.07042 2014-08-20
- Fix unescaped left braces in regexes in tests
- Use undef instead of '%' for the table and type arguments
to $dbh->tables (fixes breakage with DBD::Pg 3.4.0)
@@ -25,7 +25,7 @@ configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
-generated_by: 'Module::Install version 1.10'
+generated_by: 'Module::Install version 1.14'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -49,12 +49,12 @@ requires:
Lingua::EN::Inflect::Number: '1.1'
Lingua::EN::Inflect::Phrase: '0.15'
Lingua::EN::Tagger: '0.23'
- List::MoreUtils: '0.32'
+ List::Util: '1.33'
MRO::Compat: '0.09'
Scope::Guard: '0.20'
String::CamelCase: '0.02'
String::ToIdentifier::EN: '0.05'
- Sub::Name: 0
+ Sub::Util: '1.40'
Try::Tiny: 0
namespace::clean: '0.23'
perl: 5.8.1
@@ -63,4 +63,4 @@ resources:
MailingList: http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class
license: http://dev.perl.org/licenses/
repository: https://github.com/dbsrgits/dbix-class-schema-loader
-version: '0.07042'
+version: '0.07043'
@@ -49,13 +49,13 @@ requires 'Hash::Merge' => '0.12';
requires 'Lingua::EN::Inflect::Number' => '1.1';
requires 'Lingua::EN::Tagger' => '0.23';
requires 'Lingua::EN::Inflect::Phrase' => '0.15';
-requires 'List::MoreUtils' => '0.32';
+requires 'List::Util' => '1.33';
requires 'MRO::Compat' => '0.09';
requires 'namespace::clean' => '0.23';
requires 'Scope::Guard' => '0.20';
requires 'String::ToIdentifier::EN' => '0.05';
requires 'String::CamelCase' => '0.02';
-requires 'Sub::Name' => 0;
+requires 'Sub::Util' => '1.40';
requires 'Try::Tiny' => 0;
# core, but specific versions not available on older perls
@@ -3,49 +3,49 @@ NAME
database
SYNOPSIS
- ### use this module to generate a set of class files
-
- # in a script
- use DBIx::Class::Schema::Loader qw/ make_schema_at /;
- make_schema_at(
- 'My::Schema',
- { debug => 1,
- dump_directory => './lib',
- },
- [ 'dbi:Pg:dbname="foo"', 'myuser', 'mypassword',
- { loader_class => 'MyLoader' } # optionally
- ],
- );
-
- # from the command line or a shell script with dbicdump (distributed
- # with this module). Do `perldoc dbicdump` for usage.
- dbicdump -o dump_directory=./lib \
- -o components='["InflateColumn::DateTime"]' \
- -o debug=1 \
- My::Schema \
- 'dbi:Pg:dbname=foo' \
- myuser \
- mypassword
-
- ### or generate and load classes at runtime
- # note: this technique is not recommended
- # for use in production code
-
- package My::Schema;
- use base qw/DBIx::Class::Schema::Loader/;
-
- __PACKAGE__->loader_options(
- constraint => '^foo.*',
- # debug => 1,
- );
-
- #### in application code elsewhere:
-
- use My::Schema;
-
- my $schema1 = My::Schema->connect( $dsn, $user, $password, $attrs);
- # -or-
- my $schema1 = "My::Schema"; $schema1->connection(as above);
+ ### use this module to generate a set of class files
+
+ # in a script
+ use DBIx::Class::Schema::Loader qw/ make_schema_at /;
+ make_schema_at(
+ 'My::Schema',
+ { debug => 1,
+ dump_directory => './lib',
+ },
+ [ 'dbi:Pg:dbname="foo"', 'myuser', 'mypassword',
+ { loader_class => 'MyLoader' } # optionally
+ ],
+ );
+
+ # from the command line or a shell script with dbicdump (distributed
+ # with this module). Do `perldoc dbicdump` for usage.
+ dbicdump -o dump_directory=./lib \
+ -o components='["InflateColumn::DateTime"]' \
+ -o debug=1 \
+ My::Schema \
+ 'dbi:Pg:dbname=foo' \
+ myuser \
+ mypassword
+
+ ### or generate and load classes at runtime
+ # note: this technique is not recommended
+ # for use in production code
+
+ package My::Schema;
+ use base qw/DBIx::Class::Schema::Loader/;
+
+ __PACKAGE__->loader_options(
+ constraint => '^foo.*',
+ # debug => 1,
+ );
+
+ #### in application code elsewhere:
+
+ use My::Schema;
+
+ my $schema1 = My::Schema->connect( $dsn, $user, $password, $attrs);
+ # -or-
+ my $schema1 = "My::Schema"; $schema1->connection(as above);
DESCRIPTION
DBIx::Class::Schema::Loader automates the definition of a
@@ -327,6 +327,10 @@ CONTRIBUTORS
moritz: Moritz Lenz <moritz@faui2k3.org>
+ oalders: Olaf Alders <olaf@wundersolutions.com>
+
+ mephinet: Philipp Gortan <philipp.gortan@apa.at>
+
... and lots of other folks. If we forgot you, please write the current
maintainer or RT.
@@ -8,7 +8,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
}
# special map on pre-defined feature sets
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -91,7 +91,3 @@ sub auto_install_now {
}
1;
-
-__END__
-
-#line 109
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
}
# Suspend handler for "redefined" warnings
@@ -8,7 +8,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -91,7 +91,3 @@ END_FTP
}
1;
-
-__END__
-
-#line 109
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -32,7 +32,3 @@ sub auto_include_dependent_dists {
}
1;
-
-__END__
-
-#line 50
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -453,40 +453,24 @@ sub author_from {
#Stolen from M::B
my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
-
-## from Software-License - should we be using S-L instead ?
-# duplicates commeted out, see hack above ^^
-# open_source => 'http://www.gnu.org/licenses/agpl-3.0.txt',
-# apache => 'http://www.apache.org/licenses/LICENSE-1.1',
- apache => 'http://www.apache.org/licenses/LICENSE-2.0.txt',
- artistic => 'http://www.perlfoundation.org/artistic_license_1_0',
- artistic_2 => 'http://www.perlfoundation.org/artistic_license_2_0',
- bsd => 'http://opensource.org/licenses/BSD-3-Clause',
-# unrestricted => 'http://creativecommons.org/publicdomain/zero/1.0/',
-# open_source => 'http://www.freebsd.org/copyright/freebsd-license.html',
-# open_source => 'http://www.gnu.org/licenses/fdl-1.2.txt',
-# open_source => 'http://www.gnu.org/licenses/fdl-1.3.txt',
-# gpl => 'http://www.gnu.org/licenses/old-licenses/gpl-1.0.txt',
-# gpl => 'http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt',
- gpl => 'http://www.gnu.org/licenses/gpl-3.0.txt',
-# lgpl => 'http://www.gnu.org/licenses/old-licenses/lgpl-2.1.txt',
- lgpl => 'http://www.gnu.org/licenses/lgpl-3.0.txt',
- mit => 'http://www.opensource.org/licenses/mit-license.php',
-# mozilla => 'http://www.mozilla.org/MPL/MPL-1.0.txt',
-# mozilla => 'http://www.mozilla.org/MPL/MPL-1.1.txt',
- mozilla => 'http://www.mozilla.org/MPL/2.0/index.txt',
-# restrictive => '',
-# open_source => 'http://www.openssl.org/source/license.html',
- perl => 'http://dev.perl.org/licenses/',
-# open_source => 'http://www.opensource.org/licenses/postgresql',
-# open_source => 'http://trolltech.com/products/qt/licenses/licensing/qpl',
-# unrestricted => 'http://h71000.www7.hp.com/doc/83final/BA554_90007/apcs02.html',
-# open_source => 'http://www.openoffice.org/licenses/sissl_license.html',
-# open_source => 'http://www.zlib.net/zlib_license.html',
);
sub license {
@@ -527,43 +511,31 @@ sub __extract_license {
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
-
- # the following are relied on by the test system even if they are wrong :(
+ 'Artistic and GPL' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'GNU Free Documentation license' => 'unrestricted', 1,
+ 'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'Apache (?:Software )?license' => 'apache', 1,
+ 'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
-
-## from Software-License
- 'The GNU Affero General Public License, Version 3, November 2007' => 'open_source', 1,
- 'The Apache Software License, Version 1.1' => 'apache', 1,
- 'The Apache License, Version 2.0, January 2004' => 'apache', 1,
- 'The Artistic License 1.0' => 'artistic', 1,
- 'The Artistic License 2.0 (GPL Compatible)' => 'artistic_2', 1,
- 'The (three-clause) BSD License' => 'bsd', 1,
- 'CC0 License' => 'unrestricted', 1,
- 'The (two-clause) FreeBSD License' => 'open_source', 1,
- 'GNU Free Documentation License v1.2' => 'open_source', 1,
- 'GNU Free Documentation License v1.3' => 'open_source', 1,
- 'The GNU General Public License, Version 1, February 1989' => 'gpl', 1,
- 'The GNU General Public License, Version 2, June 1991' => 'gpl', 1,
- 'The GNU General Public License, Version 3, June 2007' => 'gpl', 1,
- 'The GNU Lesser General Public License, Version 2.1, February 1999' => 'lgpl', 1,
- 'The GNU Lesser General Public License, Version 3, June 2007' => 'lgpl', 1,
- 'The MIT (X11) License' => 'mit', 1,
- 'The Mozilla Public License 1.0' => 'mozilla', 1,
- 'The Mozilla Public License 1.1' => 'mozilla', 1,
- 'Mozilla Public License Version 2.0' => 'mozilla', 1,
- '"No License" License' => 'restrictive', 1,
- 'OpenSSL License' => 'open_source', 1,
- 'the same terms as the perl 5 programming language system itself' => 'perl', 1,
- 'The PostgreSQL License' => 'open_source', 1,
- 'The Q Public License, Version 1.0' => 'open_source', 1,
- 'Original SSLeay License' => 'unrestricted', 1,
- 'Sun Internet Standards Source License (SISSL)' => 'open_source', 1,
- 'The zlib License' => 'open_source', 1,
+ 'Mozilla Public License' => 'mozilla', 1,
+ 'Q Public License' => 'open_source', 1,
+ 'OpenSSL License' => 'unrestricted', 1,
+ 'SSLeay License' => 'unrestricted', 1,
+ 'zlib License' => 'open_source', 1,
+ 'proprietary' => 'proprietary', 0,
);
-
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
@@ -748,7 +720,3 @@ sub _write_mymeta_data {
}
1;
-
-__END__
-
-#line 766
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -27,7 +27,3 @@ sub install_script {
}
1;
-
-__END__
-
-#line 45
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -62,7 +62,3 @@ END_MESSAGE
}
1;
-
-__END__
-
-#line 80
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.10';
+ $VERSION = '1.14';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -61,7 +61,3 @@ sub WriteAll {
}
1;
-
-__END__
-
-#line 79
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.10';
+ $VERSION = '1.14';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -378,6 +378,7 @@ eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
@@ -386,6 +387,7 @@ END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
@@ -416,6 +418,7 @@ eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
@@ -425,6 +428,7 @@ END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
@@ -467,7 +471,4 @@ sub _CLASS {
1;
-
-__END__
-
-#line 485
+# Copyright 2008 - 2012 Adam Kennedy.
@@ -20,16 +20,16 @@ use File::Temp ();
use Class::Unload;
use Class::Inspector ();
use Scalar::Util 'looks_like_number';
-use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file sigwarn_silencer/;
+use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file sigwarn_silencer firstidx uniq/;
use DBIx::Class::Schema::Loader::Optional::Dependencies ();
use Try::Tiny;
use DBIx::Class ();
use Encode qw/encode decode/;
-use List::MoreUtils qw/all any firstidx uniq/;
+use List::Util qw/all any none/;
use File::Temp 'tempfile';
use namespace::clean;
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
@@ -84,6 +84,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
moniker_to_table
uniq_to_primary
quiet
+ allow_extra_m2m_cols
/);
@@ -210,7 +211,7 @@ How to name column accessors in Result classes.
=item force_ascii
For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
-L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
+L<String::ToIdentifier::EN::Unicode> to force monikers and other identifiers to
ASCII.
=back
@@ -993,6 +994,13 @@ Automatically promotes the largest unique constraints with non-nullable columns
on tables to primary keys, assuming there is only one largest unique
constraint.
+=head2 allow_extra_m2m_cols
+
+Generate C<many_to_many> relationship bridges even if the link table has
+extra columns other than the foreign keys. The primary key must still
+equal the union of the foreign keys.
+
+
=head2 filter_generated_code
An optional hook that lets you filter the generated text for various classes
@@ -1009,8 +1017,19 @@ be generated.
filter_generated_code => sub {
my ($type, $class, $text) = @_;
- ...
- return $new_code;
+ ...
+ return $new_code;
+ }
+
+You can also use this option to set L<perltidy markers|perltidy/Skipping
+Selected Sections of Code> in your generated classes. This will leave
+the generated code in the default format, but will allow you to tidy
+your classes at any point in future, without worrying about changing the
+portions of the file which are checksummed, since C<perltidy> will just
+ignore all text between the markers.
+
+ filter_generated_code => sub {
+ return "#<<<\n$_[2]\n#>>>";
}
=head1 METHODS
@@ -1272,7 +1291,7 @@ sub new {
if (ref $self->moniker_parts ne 'ARRAY') {
croak 'moniker_parts must be an arrayref';
}
- if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
+ if (none { $_ eq 'name' } @{ $self->moniker_parts }) {
croak "moniker_parts option *must* contain 'name'";
}
}
@@ -2143,10 +2162,10 @@ sub _write_classfile {
croak "filter '$filter' exited non-zero: $exit_code";
}
}
- if (not $text or not $text =~ /\bpackage\b/) {
- warn("$class skipped due to filter") if $self->debug;
- return;
- }
+ if (not $text or not $text =~ /\bpackage\b/) {
+ warn("$class skipped due to filter") if $self->debug;
+ return;
+ }
}
# Check and see if the dump is in fact different
@@ -2168,7 +2187,7 @@ sub _write_classfile {
$self->omit_timestamp ? undef : POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
);
- open(my $fh, '>:encoding(UTF-8)', $filename)
+ open(my $fh, '>:raw:encoding(UTF-8)', $filename)
or croak "Cannot open '$filename' for writing: $!";
# Write the top half and its MD5 sum
@@ -2217,12 +2236,12 @@ sub _parse_generated_file {
my $mark_re =
qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
- my ($md5, $ts, $ver, $gen);
+ my ($real_md5, $ts, $ver, $gen);
local $_;
while(<$fh>) {
if(/$mark_re/) {
my $pre_md5 = $1;
- $md5 = $2;
+ my $mark_md5 = $2;
# Pull out the version and timestamp from the line above
($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader( v[\d.]+)?( @ [\d-]+ [\d:]+)?\r?\Z/m;
@@ -2230,8 +2249,9 @@ sub _parse_generated_file {
$ts =~ s/^ @ // if $ts;
$gen .= $pre_md5;
+ $real_md5 = Digest::MD5::md5_base64(encode 'UTF-8', $gen);
croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader. Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
- if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
+ if !$self->overwrite_modifications && $real_md5 ne $mark_md5;
last;
}
@@ -2241,14 +2261,14 @@ sub _parse_generated_file {
}
my $custom = do { local $/; <$fh> }
- if $md5;
+ if $real_md5;
$custom ||= '';
$custom =~ s/$CRLF|$LF/\n/g;
close $fh;
- return ($gen, $md5, $ver, $ts, $custom);
+ return ($gen, $real_md5, $ver, $ts, $custom);
}
sub _use {
@@ -3011,12 +3031,7 @@ sub _base_class_pod {
return '' unless $self->generate_pod;
- return <<"EOF"
-=head1 BASE CLASS: L<$base_class>
-
-=cut
-
-EOF
+ return "\n=head1 BASE CLASS: L<$base_class>\n\n=cut\n\n";
}
sub _filter_comment {
@@ -10,7 +10,7 @@ use mro 'c3';
use Try::Tiny;
use namespace::clean;
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -11,7 +11,7 @@ use DBIx::Class::Schema::Loader::Utils qw/sigwarn_silencer/;
use namespace::clean;
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -20,21 +20,21 @@ See L<DBIx::Class::Schema::Loader::Base> for usage information.
=cut
sub _rebless {
- my $self = shift;
-
- return if ref $self ne __PACKAGE__;
-
- my $dbh = $self->schema->storage->dbh;
- my $dbtype = eval { $dbh->get_info(17) };
- unless ( $@ ) {
- # Translate the backend name into a perl identifier
- $dbtype =~ s/\W/_/gi;
- my $class = "DBIx::Class::Schema::Loader::DBI::ADO::${dbtype}";
- if ($self->load_optional_class($class) && !$self->isa($class)) {
- bless $self, $class;
- $self->_rebless;
+ my $self = shift;
+
+ return if ref $self ne __PACKAGE__;
+
+ my $dbh = $self->schema->storage->dbh;
+ my $dbtype = eval { $dbh->get_info(17) };
+ unless ( $@ ) {
+ # Translate the backend name into a perl identifier
+ $dbtype =~ s/\W/_/gi;
+ my $class = "DBIx::Class::Schema::Loader::DBI::ADO::${dbtype}";
+ if ($self->load_optional_class($class) && !$self->isa($class)) {
+ bless $self, $class;
+ $self->_rebless;
+ }
}
- }
}
sub _filter_tables {
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -8,12 +8,12 @@ use base qw/
/;
use mro 'c3';
-use List::MoreUtils 'any';
+use List::Util 'any';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -104,6 +104,8 @@ JOIN syscat.references sr
AND tc.tabname = sr.tabname
JOIN syscat.keycoluse rkcu
ON sr.refkeyname = rkcu.constname
+ AND sr.reftabschema = rkcu.tabschema
+ AND sr.reftabname = rkcu.tabname
AND kcu.colseq = rkcu.colseq
WHERE tc.tabschema = ?
AND tc.tabname = ?
@@ -162,6 +164,14 @@ sub _dbh_tables {
return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema, TABLE_NAME => '%' } : undef);
}
+sub _dbh_table_info {
+ my $self = shift;
+
+ local $^W = 0; # shut up undef warning from DBD::DB2
+
+ $self->next::method(@_);
+}
+
sub _columns_info_for {
my $self = shift;
my ($table) = @_;
@@ -5,7 +5,7 @@ use warnings;
use base qw/DBIx::Class::Schema::Loader::DBI::InterBase/;
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -5,12 +5,12 @@ use warnings;
use base qw/DBIx::Class::Schema::Loader::DBI/;
use mro 'c3';
use Scalar::Util 'looks_like_number';
-use List::MoreUtils 'any';
+use List::Util 'any';
use Try::Tiny;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table::Informix ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -9,7 +9,7 @@ use List::Util 'first';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
sub _supports_db_schema { 0 }
@@ -5,12 +5,12 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
use mro 'c3';
use Try::Tiny;
-use List::MoreUtils 'any';
+use List::Util 'any';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table::Sybase ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -8,7 +8,7 @@ use Try::Tiny;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
__PACKAGE__->mk_group_accessors('simple', qw/
__ado_connection
@@ -8,7 +8,7 @@ use base qw/
/;
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -8,7 +8,7 @@ use base qw/
/;
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -8,7 +8,7 @@ use base qw/
/;
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -22,22 +22,22 @@ See L<DBIx::Class::Schema::Loader::Base> for usage information.
=cut
sub _rebless {
- my $self = shift;
-
- return if ref $self ne __PACKAGE__;
-
-# stolen from DBIC ODBC storage
- my $dbh = $self->schema->storage->dbh;
- my $dbtype = eval { $dbh->get_info(17) };
- unless ( $@ ) {
- # Translate the backend name into a perl identifier
- $dbtype =~ s/\W/_/gi;
- my $class = "DBIx::Class::Schema::Loader::DBI::ODBC::${dbtype}";
- if ($self->load_optional_class($class) && !$self->isa($class)) {
- bless $self, $class;
- $self->_rebless;
+ my $self = shift;
+
+ return if ref $self ne __PACKAGE__;
+
+ # stolen from DBIC ODBC storage
+ my $dbh = $self->schema->storage->dbh;
+ my $dbtype = eval { $dbh->get_info(17) };
+ unless ( $@ ) {
+ # Translate the backend name into a perl identifier
+ $dbtype =~ s/\W/_/gi;
+ my $class = "DBIx::Class::Schema::Loader::DBI::ODBC::${dbtype}";
+ if ($self->load_optional_class($class) && !$self->isa($class)) {
+ bless $self, $class;
+ $self->_rebless;
+ }
}
- }
}
=head1 SEE ALSO
@@ -8,7 +8,7 @@ use Try::Tiny;
use DBIx::Class::Schema::Loader::Utils qw/sigwarn_silencer/;
use namespace::clean;
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -85,22 +85,25 @@ sub _table_fk_info {
my $deferrable_sth = $self->dbh->prepare_cached(<<'EOF');
select deferrable from all_constraints
-where owner = ? and table_name = ? and constraint_name = ?
+where owner = ? and table_name = ? and constraint_name = ? and status = 'ENABLED'
EOF
+ my @enabled_rels;
foreach my $rel (@$rels) {
# Oracle does not have update rules
$rel->{attrs}{on_update} = 'NO ACTION';;
# DBD::Oracle's foreign_key_info does not return DEFERRABILITY, so we get it ourselves
- my ($deferrable) = $self->dbh->selectrow_array(
+ # Also use this to filter out disabled foreign keys, which are returned by DBD::Oracle < 1.76
+ my $deferrable = $self->dbh->selectrow_array(
$deferrable_sth, undef, $table->schema, $table->name, $rel->{_constraint_name}
- );
+ ) or next;
- $rel->{attrs}{is_deferrable} = $deferrable && $deferrable =~ /^DEFERRABLE/i ? 1 : 0;
+ $rel->{attrs}{is_deferrable} = $deferrable =~ /^DEFERRABLE/i ? 1 : 0;
+ push @enabled_rels, $rel;
}
- return $rels;
+ return \@enabled_rels;
}
sub _table_uniq_info {
@@ -112,7 +115,8 @@ FROM all_constraints ac, all_cons_columns acc
WHERE acc.table_name=? AND acc.owner = ?
AND ac.table_name = acc.table_name AND ac.owner = acc.owner
AND acc.constraint_name = ac.constraint_name
- AND ac.constraint_type='U'
+ AND ac.constraint_type = 'U'
+ AND ac.status = 'ENABLED'
ORDER BY acc.position
EOF
@@ -177,7 +181,7 @@ sub _columns_info_for {
my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1);
SELECT trigger_body
FROM all_triggers
-WHERE table_name = ? AND table_owner = ?
+WHERE table_name = ? AND table_owner = ? AND status = 'ENABLED'
AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIKE '%insert%'
EOF
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -4,11 +4,11 @@ use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
use mro 'c3';
-use List::MoreUtils 'any';
+use List::Util 'any';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -6,7 +6,7 @@ use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
use mro 'c3';
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::MSSQL';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -4,12 +4,12 @@ use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
use mro 'c3';
-use List::MoreUtils 'any';
+use List::Util 'any';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table::Sybase ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -1,7 +1,7 @@
package DBIx::Class::Schema::Loader::DBI::Writing;
use strict;
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
# Empty. POD only.
@@ -5,15 +5,14 @@ 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 List::Util qw/any first/;
use Try::Tiny;
use Scalar::Util 'blessed';
use DBIx::Class::Schema::Loader::Utils qw/sigwarn_silencer/;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
=head1 NAME
@@ -5,12 +5,12 @@ use warnings;
use base qw/DBIx::Class::Schema::Loader::Base/;
use mro 'c3';
use Try::Tiny;
-use List::MoreUtils 'any';
+use List::Util 'any';
use Carp::Clan qw/^DBIx::Class/;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
__PACKAGE__->mk_group_accessors('simple', qw/
_disable_pk_detection
@@ -157,7 +157,7 @@ sub dbic_name {
=head2 name_parts
Returns an arrayref of the values returned by the methods specified in
-the L<moniker_parts|DBIx::Class::Scheam::Loader::Base/moniker_parts> of
+the L<moniker_parts|DBIx::Class::Schema::Loader::Base/moniker_parts> of
the L</loader> object. The object arrayrefifies to this value.
=cut
@@ -18,7 +18,7 @@ Somewhere in your build-file (e.g. L<Module::Install>'s Makefile.PL):
...
- configure_requires 'DBIx::Class::Schema::Loader' => '0.07042';
+ configure_requires 'DBIx::Class::Schema::Loader' => '0.07043';
require DBIx::Class::Schema::Loader::Optional::Dependencies;
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
sub _relnames_and_method {
my ( $self, $local_moniker, $rel, $cond, $uniqs, $counters ) = @_;
@@ -8,7 +8,7 @@ use DBIx::Class::Schema::Loader::Utils 'array_eq';
use namespace::clean;
use Lingua::EN::Inflect::Number ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
sub _to_PL {
my ($self, $name) = @_;
@@ -5,7 +5,7 @@ use warnings;
use base 'DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_07';
use mro 'c3';
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
sub _normalize_name {
my ($self, $name) = @_;
@@ -17,7 +17,7 @@ L<DBIx::Class::Schema::Loader::RelBuilder>.
=cut
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
sub _strip_id_postfix {
my ($self, $name) = @_;
@@ -6,10 +6,9 @@ use base 'Class::Accessor::Grouped';
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util 'weaken';
-use DBIx::Class::Schema::Loader::Utils qw/split_name slurp_file array_eq/;
+use DBIx::Class::Schema::Loader::Utils qw/split_name slurp_file array_eq apply uniq/;
use Try::Tiny;
-use List::Util 'first';
-use List::MoreUtils qw/apply uniq any all/;
+use List::Util qw/all any first/;
use namespace::clean;
use Lingua::EN::Inflect::Phrase ();
use Lingua::EN::Tagger ();
@@ -18,7 +17,7 @@ use String::ToIdentifier::EN::Unicode ();
use Class::Unload ();
use Class::Inspector ();
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
# Glossary:
#
@@ -116,6 +115,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/
relationship_attrs
rel_collision_map
rel_name_map
+ allow_extra_m2m_cols
_temp_classes
__tagger
/);
@@ -134,12 +134,11 @@ sub new {
my $self = {
loader => $loader,
- schema => $loader->schema,
- inflect_plural => $loader->inflect_plural,
- inflect_singular => $loader->inflect_singular,
- relationship_attrs => $loader->relationship_attrs,
- rel_collision_map => $loader->rel_collision_map,
- rel_name_map => $loader->rel_name_map,
+ (map { $_ => $loader->$_ } qw(
+ schema inflect_plural inflect_singular
+ relationship_attrs rel_collision_map
+ rel_name_map allow_extra_m2m_cols
+ )),
_temp_classes => [],
};
@@ -547,6 +546,8 @@ sub _generate_m2ms {
} ];
$class{to_cols} = [ apply { s/^foreign\.//i } keys %{ $rels[$that]{args}[2] } ];
+
+ $class{from_link_cols} = [ apply { s/^self\.//i } values %{ $rels[$this]{args}[2] } ];
}
my $link_moniker = $rels[0]{extra}{local_moniker};
@@ -557,8 +558,10 @@ sub _generate_m2ms {
my @link_table_primary_cols =
@{[ $self->schema->source($link_moniker)->primary_columns ]};
- next unless @{$class[0]{to_cols}} + @{$class[1]{to_cols}} == @link_table_cols
- && @link_table_cols == @link_table_primary_cols;
+ next unless array_eq(
+ [ sort +uniq @{$class[0]{from_link_cols}}, @{$class[1]{from_link_cols}} ],
+ [ sort @link_table_primary_cols ],
+ ) && ($self->allow_extra_m2m_cols || @link_table_cols == @link_table_primary_cols);
foreach my $this (0, 1) {
my $that = $this ? 0 : 1;
@@ -6,12 +6,12 @@ use warnings;
use Test::More;
use String::CamelCase 'wordsplit';
use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util 'looks_like_number';
+use List::Util 'all';
use namespace::clean;
use Exporter 'import';
use Data::Dumper ();
-our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_package_without_redefine_warnings class_path no_warnings warnings_exist warnings_exist_silent slurp_file write_file array_eq sigwarn_silencer/;
+our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_package_without_redefine_warnings class_path no_warnings warnings_exist warnings_exist_silent slurp_file write_file array_eq sigwarn_silencer apply firstidx uniq/;
use constant BY_CASE_TRANSITION_V7 =>
qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/;
@@ -52,13 +52,34 @@ sub dumper_squashed($) {
# copied from DBIx::Class::_Util, import from there once it's released
sub sigwarn_silencer {
- my $pattern = shift;
+ my $pattern = shift;
- croak "Expecting a regexp" if ref $pattern ne 'Regexp';
+ croak "Expecting a regexp" if ref $pattern ne 'Regexp';
- my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
+ my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
- return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
+ return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
+}
+
+# Copied with stylistic adjustments from List::MoreUtils::PP
+sub firstidx (&@) {
+ my $f = shift;
+ foreach my $i (0..$#_) {
+ local *_ = \$_[$i];
+ return $i if $f->();
+ }
+ return -1;
+}
+
+sub uniq (@) {
+ my %seen = ();
+ grep { not $seen{$_}++ } @_;
+}
+
+sub apply (&@) {
+ my $action = shift;
+ $action->() foreach my @values = @_;
+ wantarray ? @values : $values[-1];
}
sub eval_package_without_redefine_warnings {
@@ -177,19 +198,9 @@ sub write_file($$) {
sub array_eq($$) {
no warnings 'uninitialized';
- my ($a, $b) = @_;
-
- return unless @$a == @$b;
+ my ($l, $r) = @_;
- for (my $i = 0; $i < @$a; $i++) {
- if (looks_like_number $a->[$i]) {
- return unless $a->[$i] == $b->[$i];
- }
- else {
- return unless $a->[$i] eq $b->[$i];
- }
- }
- return 1;
+ return @$l == @$r && all { $l->[$_] eq $r->[$_] } 0..$#$l;
}
1;
@@ -7,7 +7,7 @@ use MRO::Compat;
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util 'weaken';
-use Sub::Name 'subname';
+use Sub::Util 'set_subname';
use DBIx::Class::Schema::Loader::Utils 'array_eq';
use Try::Tiny;
use Hash::Merge 'merge';
@@ -16,7 +16,7 @@ use namespace::clean;
# Always remember to do all digits for the version even if they're 0
# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
# brain damage and presumably various other packaging systems too
-our $VERSION = '0.07042';
+our $VERSION = '0.07043';
__PACKAGE__->mk_group_accessors('inherited', qw/
_loader_args
@@ -37,49 +37,49 @@ DBIx::Class::Schema::Loader - Create a DBIx::Class::Schema based on a database
=head1 SYNOPSIS
- ### use this module to generate a set of class files
-
- # in a script
- use DBIx::Class::Schema::Loader qw/ make_schema_at /;
- make_schema_at(
- 'My::Schema',
- { debug => 1,
- dump_directory => './lib',
- },
- [ 'dbi:Pg:dbname="foo"', 'myuser', 'mypassword',
- { loader_class => 'MyLoader' } # optionally
- ],
- );
-
- # from the command line or a shell script with dbicdump (distributed
- # with this module). Do `perldoc dbicdump` for usage.
- dbicdump -o dump_directory=./lib \
- -o components='["InflateColumn::DateTime"]' \
- -o debug=1 \
- My::Schema \
- 'dbi:Pg:dbname=foo' \
- myuser \
- mypassword
-
- ### or generate and load classes at runtime
- # note: this technique is not recommended
- # for use in production code
-
- package My::Schema;
- use base qw/DBIx::Class::Schema::Loader/;
-
- __PACKAGE__->loader_options(
- constraint => '^foo.*',
- # debug => 1,
- );
-
- #### in application code elsewhere:
-
- use My::Schema;
-
- my $schema1 = My::Schema->connect( $dsn, $user, $password, $attrs);
- # -or-
- my $schema1 = "My::Schema"; $schema1->connection(as above);
+ ### use this module to generate a set of class files
+
+ # in a script
+ use DBIx::Class::Schema::Loader qw/ make_schema_at /;
+ make_schema_at(
+ 'My::Schema',
+ { debug => 1,
+ dump_directory => './lib',
+ },
+ [ 'dbi:Pg:dbname="foo"', 'myuser', 'mypassword',
+ { loader_class => 'MyLoader' } # optionally
+ ],
+ );
+
+ # from the command line or a shell script with dbicdump (distributed
+ # with this module). Do `perldoc dbicdump` for usage.
+ dbicdump -o dump_directory=./lib \
+ -o components='["InflateColumn::DateTime"]' \
+ -o debug=1 \
+ My::Schema \
+ 'dbi:Pg:dbname=foo' \
+ myuser \
+ mypassword
+
+ ### or generate and load classes at runtime
+ # note: this technique is not recommended
+ # for use in production code
+
+ package My::Schema;
+ use base qw/DBIx::Class::Schema::Loader/;
+
+ __PACKAGE__->loader_options(
+ constraint => '^foo.*',
+ # debug => 1,
+ );
+
+ #### in application code elsewhere:
+
+ use My::Schema;
+
+ my $schema1 = My::Schema->connect( $dsn, $user, $password, $attrs);
+ # -or-
+ my $schema1 = "My::Schema"; $schema1->connection(as above);
=head1 DESCRIPTION
@@ -341,7 +341,7 @@ sub connection {
# ->load_components and we are now in a different place in the mro.
no warnings 'redefine';
- local *connection = subname __PACKAGE__.'::connection' => sub {
+ local *connection = set_subname __PACKAGE__.'::connection' => sub {
my $self = shift;
$self->next::method(@_);
};
@@ -679,6 +679,10 @@ Dag-Erling Smørgrav <des@des.no>
moritz: Moritz Lenz <moritz@faui2k3.org>
+oalders: Olaf Alders <olaf@wundersolutions.com>
+
+mephinet: Philipp Gortan <philipp.gortan@apa.at>
+
... and lots of other folks. If we forgot you, please write the current
maintainer or RT.
@@ -115,7 +115,6 @@ my $tester = dbixcsl_common_tests->new(
'time' => { data_type => 'time' },
'year' => { data_type => 'year' },
'year(4)' => { data_type => 'year' },
- 'year(2)' => { data_type => 'year', size => 2 },
# String Types
'char' => { data_type => 'char', size => 1 },
@@ -152,7 +152,7 @@ my $tester = dbixcsl_common_tests->new(
}
catch {
$schemas_created = 0;
- skip "no CREATE SCHEMA privileges", 28 * 2;
+ skip "no CREATE SCHEMA privileges", 30 * 2;
};
$dbh->do(<<"EOF");
@@ -27,7 +27,7 @@ my $auto_inc_cb = sub {
return (
qq{ CREATE SEQUENCE ${table}_${col}_seq START WITH 1 INCREMENT BY 1},
qq{
- CREATE OR REPLACE TRIGGER ${table}_${col}_trigger
+ CREATE OR REPLACE TRIGGER ${table}_${col}_trg
BEFORE INSERT ON ${table}
FOR EACH ROW
BEGIN
@@ -181,9 +181,18 @@ my $tester = dbixcsl_common_tests->new(
on delete set null deferrable
)
},
+ q{
+ create table oracle_loader_test11 (
+ id int primary key disable,
+ ten_id int unique disable,
+ foreign key (ten_id) references oracle_loader_test10(id) disable
+ )
+ },
+ $auto_inc_cb->('oracle_loader_test11', 'id'),
+ 'alter trigger oracle_loader_test11_id_trg disable',
],
- drop => [qw/oracle_loader_test1 oracle_loader_test9 oracle_loader_test10/],
- count => 7 + 31 * 2,
+ drop => [qw/oracle_loader_test1 oracle_loader_test9 oracle_loader_test10 oracle_loader_test11/],
+ count => 10 + 31 * 2, # basic + cross-schema * 2
run => sub {
my ($monikers, $classes);
($schema, $monikers, $classes) = @_;
@@ -223,6 +232,19 @@ my $tester = dbixcsl_common_tests->new(
is $rel_info->{attrs}{is_deferrable}, 1,
'DEFERRABLE clause introspected correctly';
+ my $source11 = $schema->source('OracleLoaderTest11');
+
+ # DBD::Oracle < 1.76 doesn't filter out disabled primary keys
+ my $uniqs = eval { DBD::Oracle->VERSION('1.76') } ? [] : ['primary'];
+ is_deeply [keys %{{$source11->unique_constraints}}], $uniqs,
+ 'Disabled unique constraints not loaded';
+
+ ok !$source11->relationship_info('ten'),
+ 'Disabled FK not loaded';
+
+ ok !$source11->column_info('id')->{is_auto_increment},
+ 'Disabled autoinc trigger not loaded';
+
SKIP: {
skip 'Set the DBICTEST_ORA_EXTRAUSER_DSN, _USER and _PASS environment variables to run the cross-schema relationship tests', 31 * 2
unless $ENV{DBICTEST_ORA_EXTRAUSER_DSN};
@@ -485,34 +507,36 @@ else {
END {
if (not $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) {
- if (my $dbh2 = try { $extra_schema->storage->dbh }) {
- my $dbh1 = $schema->storage->dbh;
-
- try {
- $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test8', 'id');
- $dbh2->do($_) for $auto_inc_drop_cb->('oracle_loader_test7', 'id');
- $dbh2->do($_) for $auto_inc_drop_cb->('oracle_loader_test6', 'id');
- $dbh2->do($_) for $auto_inc_drop_cb->('oracle_loader_test5', 'pk');
- $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test5', 'id');
- $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test4', 'id');
- }
- catch {
- die "Error dropping sequences for cross-schema test tables: $_";
- };
-
- try {
- $dbh1->do('DROP TABLE oracle_loader_test8');
- $dbh2->do('DROP TABLE oracle_loader_test7');
- $dbh2->do('DROP TABLE oracle_loader_test6');
- $dbh2->do('DROP TABLE oracle_loader_test5');
- $dbh1->do('DROP TABLE oracle_loader_test5');
- $dbh1->do('DROP TABLE oracle_loader_test4');
+ if (my $dbh1 = try { $schema->storage->dbh }) {
+ $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test11','id');
+
+ if (my $dbh2 = try { $extra_schema->storage->dbh }) {
+
+ try {
+ $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test8', 'id');
+ $dbh2->do($_) for $auto_inc_drop_cb->('oracle_loader_test7', 'id');
+ $dbh2->do($_) for $auto_inc_drop_cb->('oracle_loader_test6', 'id');
+ $dbh2->do($_) for $auto_inc_drop_cb->('oracle_loader_test5', 'pk');
+ $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test5', 'id');
+ $dbh1->do($_) for $auto_inc_drop_cb->('oracle_loader_test4', 'id');
+ }
+ catch {
+ die "Error dropping sequences for cross-schema test tables: $_";
+ };
+
+ try {
+ $dbh1->do('DROP TABLE oracle_loader_test8');
+ $dbh2->do('DROP TABLE oracle_loader_test7');
+ $dbh2->do('DROP TABLE oracle_loader_test6');
+ $dbh2->do('DROP TABLE oracle_loader_test5');
+ $dbh1->do('DROP TABLE oracle_loader_test5');
+ $dbh1->do('DROP TABLE oracle_loader_test4');
+ }
+ catch {
+ die "Error dropping cross-schema test tables: $_";
+ };
}
- catch {
- die "Error dropping cross-schema test tables: $_";
- };
}
-
rmtree EXTRA_DUMP_DIR;
}
}
@@ -22,7 +22,7 @@ for (qw(FIREBIRD FIREBIRD_ODBC FIREBIRD_INTERBASE)) {
$dsns{$_}{user} = $ENV{"DBICTEST_${_}_USER"};
$dsns{$_}{password} = $ENV{"DBICTEST_${_}_PASS"};
$dsns{$_}{connect_info_opts} = { on_connect_call => 'use_softcommit' }
- if /\AFIREBIRD(?:_INTERBASE)\z/;
+ if /\AFIREBIRD(?:_INTERBASE)?\z/;
};
plan skip_all => 'You need to set the DBICTEST_FIREBIRD_DSN, _USER and _PASS and/or the DBICTEST_FIREBIRD_ODBC_DSN, _USER and _PASS and/or the DBICTEST_FIREBIRD_INTERBASE_DSN, _USER and _PASS environment variables'
@@ -1,5 +1,5 @@
use strict;
-use Test::More tests => 5;
+use Test::More;
use Test::Exception;
use Test::Warn;
use lib qw(t/lib);
@@ -10,6 +10,7 @@ use File::Spec;
use File::Temp qw/ tempdir tempfile /;
use DBIx::Class::Schema::Loader;
+use DBIx::Class::Schema::Loader::Utils qw/ slurp_file /;
my $tempdir = tempdir( CLEANUP => 1 );
my $foopm = File::Spec->catfile( $tempdir,
@@ -41,6 +42,9 @@ lives_ok {
dump_schema( overwrite_modifications => 1 );
} 'does not throw when dumping with overwrite_modifications';
+
+unlike slurp_file $foopm, qr/"somethingelse"/, "Modifications actually overwritten";
+
sub dump_schema {
# need to poke _loader_invoked in order to be able to rerun the
@@ -57,3 +61,5 @@ sub dump_schema {
);
} [qr/^Dumping manual schema/, qr/^Schema dump completed/ ];
}
+
+done_testing();
@@ -436,7 +436,11 @@ sub run_tests {
$obj10_2->loader_test11( $obj11->id11() );
$obj10_2->update();
};
- is($@, '', 'No errors after eval{}');
+ is($@, '', 'No errors after eval{}')
+ or do {
+ diag explain $rsobj10->result_source->relationship_info('loader_test11');
+ diag explain $rsobj11->result_source->relationship_info('loader_test10');
+ };
SKIP: {
skip 'Previous eval block failed', 3
@@ -13,8 +13,7 @@ use File::Path 'rmtree';
use DBI;
use File::Find 'find';
use Class::Unload ();
-use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file sigwarn_silencer/;
-use List::MoreUtils 'apply';
+use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file sigwarn_silencer apply/;
use DBIx::Class::Schema::Loader::Optional::Dependencies ();
use Try::Tiny;
use File::Spec::Functions 'catfile';
@@ -123,7 +122,7 @@ sub run_tests {
$num_rescans++ if $self->{vendor} eq 'Firebird';
plan tests => @connect_info *
- (225 + $num_rescans * $col_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
+ (232 + $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];
@@ -288,7 +287,7 @@ sub setup_schema {
my $standard_sources = not defined $expected_count;
if ($standard_sources) {
- $expected_count = 38;
+ $expected_count = 41;
if (not ($self->{vendor} eq 'mssql' && $connect_info->[0] =~ /Sybase/)) {
$expected_count++ for @{ $self->{data_type_tests}{table_names} || [] };
@@ -629,7 +628,7 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
'is_nullable=1 detection';
SKIP: {
- skip $self->{skip_rels}, 142 if $self->{skip_rels};
+ skip $self->{skip_rels}, 149 if $self->{skip_rels};
my $moniker3 = $monikers->{loader_test3};
my $class3 = $classes->{loader_test3};
@@ -731,6 +730,18 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
my $class37 = $classes->{loader_test37};
my $rsobj37 = $conn->resultset($moniker37);
+ my $moniker42 = $monikers->{loader_test42};
+ my $class42 = $classes->{loader_test42};
+ my $rsobj42 = $conn->resultset($moniker42);
+
+ my $moniker43 = $monikers->{loader_test43};
+ my $class43 = $classes->{loader_test43};
+ my $rsobj43 = $conn->resultset($moniker43);
+
+ my $moniker44 = $monikers->{loader_test44};
+ my $class44 = $classes->{loader_test44};
+ my $rsobj44 = $conn->resultset($moniker44);
+
isa_ok( $rsobj3, "DBIx::Class::ResultSet" );
isa_ok( $rsobj4, "DBIx::Class::ResultSet" );
isa_ok( $rsobj5, "DBIx::Class::ResultSet" );
@@ -756,6 +767,9 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
isa_ok( $rsobj34, "DBIx::Class::ResultSet" );
isa_ok( $rsobj36, "DBIx::Class::ResultSet" );
isa_ok( $rsobj37, "DBIx::Class::ResultSet" );
+ isa_ok( $rsobj42, "DBIx::Class::ResultSet" );
+ isa_ok( $rsobj43, "DBIx::Class::ResultSet" );
+ isa_ok( $rsobj44, "DBIx::Class::ResultSet" );
# basic rel test
my $obj4 = try { $rsobj4->find(123) } || $rsobj4->search({ id => 123 })->single;
@@ -986,6 +1000,45 @@ qr/\n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\(
is_deeply($class32->_m2m_metadata, {}, 'many_to_many not created for might_have');
is_deeply($class34->_m2m_metadata, {}, 'many_to_many not created for might_have');
+ # test m2m with overlapping compound keys
+ is_deeply(
+ $class44->relationship_info('loader_test42')->{cond},
+ {
+ 'foreign.id1' => 'self.id42',
+ 'foreign.id2' => 'self.id2',
+ },
+ 'compound belongs_to key detected for overlapping m2m',
+ );
+ is_deeply(
+ $class44->relationship_info('loader_test43')->{cond},
+ {
+ 'foreign.id1' => 'self.id43',
+ 'foreign.id2' => 'self.id2',
+ },
+ 'compound belongs_to key detected for overlapping m2m',
+ );
+ cmp_deeply(
+ $class42->_m2m_metadata,
+ {
+ loader_test43s => superhashof({
+ accessor => "loader_test43s",
+ foreign_relation => "loader_test43",
+ }),
+ },
+ 'm2m created for overlapping multi-column foreign keys'
+ );
+
+ cmp_deeply(
+ $class43->_m2m_metadata,
+ {
+ loader_test42s => superhashof({
+ accessor => "loader_test42s",
+ foreign_relation => "loader_test42",
+ }),
+ },
+ 'm2m created for overlapping multi-column foreign keys'
+ );
+
# test double multi-col fk 26 -> 25
my $obj26 = try { $rsobj26->find(33) } || $rsobj26->search({ id => 33 })->single;
@@ -1920,6 +1973,31 @@ sub create {
) $self->{innodb}
},
q{ INSERT INTO loader_test37 (parent, child) VALUES (1,1) },
+
+ qq{
+ CREATE TABLE loader_test42 (
+ id1 INTEGER NOT NULL,
+ id2 INTEGER NOT NULL,
+ PRIMARY KEY (id1, id2)
+ ) $self->{innodb}
+ },
+ qq{
+ CREATE TABLE loader_test43 (
+ id1 INTEGER NOT NULL,
+ id2 INTEGER NOT NULL,
+ PRIMARY KEY (id1, id2)
+ ) $self->{innodb}
+ },
+ qq{
+ CREATE TABLE loader_test44 (
+ id42 INTEGER NOT NULL,
+ id43 INTEGER NOT NULL,
+ id2 INTEGER NOT NULL,
+ PRIMARY KEY (id42, id43, id2),
+ FOREIGN KEY (id42, id2) REFERENCES loader_test42 (id1, id2),
+ FOREIGN KEY (id43, id2) REFERENCES loader_test43 (id1, id2)
+ ) $self->{innodb}
+ },
);
@statements_advanced = (
@@ -2117,6 +2195,9 @@ sub drop_tables {
loader_test31
loader_test34
loader_test33
+ loader_test44
+ loader_test43
+ loader_test42
/;
my @tables_advanced = qw/
@@ -5,7 +5,7 @@ use Test::More;
use File::Path;
use IPC::Open3;
use IO::Handle;
-use List::MoreUtils 'any';
+use List::Util 'any';
use DBIx::Class::Schema::Loader::Utils 'dumper_squashed';
use DBIx::Class::Schema::Loader ();
use Class::Unload ();
@@ -210,19 +210,21 @@ sub _test_dumps {
}
}
-sub _dump_file_like {
+sub _slurp {
my $path = shift;
- open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
+ open(my $dumpfh, '<:raw', $path) or die "Failed to open '$path': $!";
my $contents = do { local $/; <$dumpfh>; };
close($dumpfh);
+ return ($path, $contents);
+}
+
+sub _dump_file_like {
+ my ($path, $contents) = _slurp shift;
like($contents, $_, "$path matches $_") for @_;
}
sub _dump_file_not_like {
- my $path = shift;
- open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
- my $contents = do { local $/; <$dumpfh>; };
- close($dumpfh);
+ my ($path, $contents) = _slurp shift;
unlike($contents, $_, "$path does not match $_") for @_;
}