Revision history for Perl extension DBIx::Class::Schema::Loader
+ - added test for norewrite feature
+ - fix default_value for MSSQL
+
0.04999_10 2009-10-31 12:28:53
- patch from Robert Bohne to make _table_uniq_info more correct for
Oracle
In "normal" L<DBIx::Class::Schema> usage, manually-defined
source classes and relationships have no problems crossing vendor schemas.
-=head1 AUTHOR
+=head1 ACKNOWLEDGEMENTS
-Brandon Black, C<blblack@gmail.com>
+Matt S Trout, all of the #dbix-class folks, and everyone who's ever sent
+in a bug report or suggestion.
Based on L<DBIx::Class::Loader> by Sebastian Riedel
Based upon the work of IKEBE Tomohiro
-=head1 THANK YOU
+=head1 AUTHOR
+
+blblack: Brandon Black <blblack@gmail.com>
-Matt S Trout, all of the #dbix-class folks, and everyone who's ever sent
-in a bug report or suggestion.
+=head1 CONTRIBUTORS
+
+ilmarii: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+arcanez: Justin Hunter <justin.d.hunter@gmail.com>
+
+ash: Ash Berlin <ash@cpan.org>
+
+Caelum: Rafael Kitover <rkitover@cpan.org>
+
+TSUNODA Kazuya <drk@drk7.jp>
+
+Robert Bohne <rbo@openserv.org>
+
+ribasushi: Peter Rabbitson <rabbit+dbic@rabbit.us>
+
+... and lots of other folks. If we forgot you, please write the current
+maintainer or RT.
=head1 LICENSE
sub _reload_classes {
my ($self, @tables) = @_;
+ # so that we don't repeat custom sections
+ @INC = grep $_ ne $self->dump_directory, @INC;
+
$self->_dump_to_dir(map { $self->classes->{$_} } @tables);
unshift @INC, $self->dump_directory;
L<DBIx::Class::Schema::Loader>
+=head1 AUTHOR
+
+See 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;
L<DBIx::Class::Schema::Loader>
+=head1 AUTHOR
+
+See 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;
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>
+=head1 AUTHOR
+
+See 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;
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 = '$table' AND CONSTRAINT_TYPE = 'UNIQUE' ORDER BY KCU.ORDINAL_POSITION});
+ 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 ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
my $dbh = $self->schema->storage->dbh;
- my $sth = $dbh->prepare(qq{SELECT COLUMN_NAME
- FROM INFORMATION_SCHEMA.COLUMNS
- WHERE COLUMNPROPERTY(object_id('$table', 'U'), '$column', 'IsIdentity') = 1 AND TABLE_NAME = '$table' AND COLUMN_NAME = '$column'
- });
+ my $sth = $dbh->prepare(qq{
+ SELECT COLUMN_NAME
+ FROM INFORMATION_SCHEMA.COLUMNS
+ WHERE COLUMNPROPERTY(object_id(@{[ $dbh->quote($table) ]}, 'U'), '$column', 'IsIdentity') = 1
+ AND TABLE_NAME = @{[ $dbh->quote($table) ]} AND COLUMN_NAME = @{[ $dbh->quote($column) ]}
+ });
$sth->execute();
if ($sth->fetchrow_array) {
$extra_info{is_auto_increment} = 1;
}
+# get default
+ $sth = $dbh->prepare(qq{
+ SELECT COLUMN_DEFAULT
+ FROM INFORMATION_SCHEMA.COLUMNS
+ WHERE TABLE_NAME = @{[ $dbh->quote($table) ]} AND COLUMN_NAME = @{[ $dbh->quote($column) ]}
+ });
+ $sth->execute;
+ my ($default) = $sth->fetchrow_array;
+
+ if (defined $default) {
+ # strip parens
+ $default =~ s/^\( (.*) \)\z/$1/x;
+
+ # Literal strings are in ''s, numbers are in ()s (in some versions of
+ # MSSQL, in others they are unquoted) everything else is a function.
+ $extra_info{default_value} =
+ $default =~ /^['(] (.*) [)']\z/x ? $1 :
+ $default =~ /^\d/ ? $default : \$default;
+ }
+
return \%extra_info;
}
-
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
=head1 AUTHOR
-Justin Hunter C<justin.d.hunter@gmail.com>
+See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
-=head1 CONTRIBUTORS
+=head1 LICENSE
-Rafael Kitover <rkitover@cpan.org>
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
=cut
=head1 AUTHOR
-Rafael Kitover C<rkitover@cpan.org>
+See 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
=head1 AUTHOR
-Rafael Kitover C<rkitover@cpan.org>
+See 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
=head1 AUTHOR
-TSUNODA Kazuya C<drk@drk7.jp>
+See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
-Dagfinn Ilmari Mannsåker C<ilmari@ilmari.org>
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
=cut
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>
+=head1 AUTHOR
+
+See 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;
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>
+=head1 AUTHOR
+
+See 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;
my ($self, $table) = @_;
my $dbh = $self->schema->storage->dbh;
- my $columns = $dbh->selectcol_arrayref(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = '$table' AND type = 'U')});
+ my $columns = $dbh->selectcol_arrayref(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = @{[ $dbh->quote($table) ]} AND type = 'U')});
return $columns;
}
my ($self, $table) = @_;
my $dbh = $self->schema->storage->dbh;
- my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
+ my $sth = $dbh->prepare(qq{sp_pkeys @{[ $dbh->quote($table) ]}});
$sth->execute;
my @keydata;
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 = '$table'});
+ my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
$sth->execute;
my $row = $sth->fetchrow_hashref;
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 = '$table'});
+ my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
$sth->execute;
while (my $row = $sth->fetchrow_hashref) {
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 if $_[0] == 17461; };
- my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
+ my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
$sth->execute;
my @fk_info;
my $dbh = $self->schema->storage->dbh;
local $dbh->{FetchHashKeyName} = 'NAME_lc';
- my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname='$table', \@nomsg='nomsg'});
+ my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname=@{[ $dbh->quote($table) ]}, \@nomsg='nomsg'});
eval { $sth->execute };
return if $@;
my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
my $dbh = $self->schema->storage->dbh;
- my $sth = $dbh->prepare(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = '$table') AND (status & 0x80) = 0x80 AND name = '$column'});
+ 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) {
=head1 AUTHOR
-Justin Hunter C<justin.d.hunter@gmail.com>
+See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
-=head1 CONTRIBUTORS
+=head1 LICENSE
-Rafael Kitover <rkitover@cpan.org>
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
=cut
=head1 AUTHOR
-Rafael Kitover <rkitover@cpan.org>
+See 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
=head1 AUTHOR
-Rafael Kitover <rkitover@cpan.org>
+See 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
# Empty. POD only.
-1;
-
=head1 NAME
DBIx::Class::Schema::Loader::DBI::Writing - Loader subclass writing guide for DBI
C<_tables_list> and C<_extra_column_info>. See the included DBD drivers
for examples of these.
+=head1 AUTHOR
+
+See 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;
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>
+=head1 AUTHOR
+
+See 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;
return $all_code;
}
+=head1 AUTHOR
+
+See 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;
use Class::Unload;
use File::Path;
use DBI;
+use Digest::MD5;
+use File::Find 'find';
my $DUMP_DIR = './t/_common_dump';
rmtree $DUMP_DIR;
sub run_tests {
my $self = shift;
- plan tests => 3 + 134 + ($self->{extra}->{count} || 0);
+ plan tests => 139 + ($self->{extra}->{count} || 0);
$self->create();
__PACKAGE__->connection(\@connect_info);
};
- ok(!$@, "Loader initialization") or diag $@;
+ ok(!$@, "Loader initialization") or diag $@;
+
+ my $file_count;
+ find sub { return if -d; $file_count++ }, $DUMP_DIR;
+
+ is $file_count, 34, 'correct number of files generated';
+ exit if $file_count != 34;
my $warn_count = 2;
$warn_count++ if grep /ResultSetManager/, @loader_warnings;
}
}
- # rescan test
+ # rescan and norewrite test
SKIP: {
- skip $self->{skip_rels}, 4 if $self->{skip_rels};
- skip "Can't rescan dumped schema", 4 if $self->{dump};
-
my @statements_rescan = (
qq{
CREATE TABLE loader_test30 (
q{ INSERT INTO loader_test30 (id,loader_test2) VALUES(321, 2) },
);
+ # get md5
+ my $digest = Digest::MD5->new;
+
+ my $find_cb = sub {
+ return if -d;
+ return if $_ eq 'LoaderTest30.pm';
+
+ open my $fh, '<', $_ or die "Could not open $_ for reading: $!";
+ binmode $fh;
+ $digest->addfile($fh);
+ };
+
+ find $find_cb, $DUMP_DIR;
+
+ my $before_digest = $digest->digest;
+
my $dbh = $self->dbconnect(1);
$dbh->do($_) for @statements_rescan;
$dbh->disconnect;
- my @new = $conn->rescan;
+ sleep 1;
+
+ my @new = do {
+ # kill the 'Dumping manual schema' warnings
+ local $SIG{__WARN__} = sub {};
+ $conn->rescan;
+ };
is_deeply(\@new, [ qw/LoaderTest30/ ], "Rescan");
+ $digest = Digest::MD5->new;
+ find $find_cb, $DUMP_DIR;
+ my $after_digest = $digest->digest;
+
+ is $before_digest, $after_digest,
+ 'dumped files are not rewritten when there is no modification';
+
my $rsobj30 = $conn->resultset('LoaderTest30');
isa_ok($rsobj30, 'DBIx::Class::ResultSet');
+
+ skip 'no rels', 2 if $self->{skip_rels};
+
my $obj30 = $rsobj30->find(123);
isa_ok( $obj30->loader_test2, $class2);
dat VARCHAR(8)
)
},
+ qq{
+ CREATE TABLE ${vendor}_loader_test2 (
+ id INT IDENTITY NOT NULL PRIMARY KEY,
+ dat VARCHAR(100) DEFAULT 'foo',
+ num NUMERIC DEFAULT 10.89,
+ anint INT DEFAULT 6,
+ ts DATETIME DEFAULT getdate()
+ )
+ },
],
- drop => [ "[${vendor}_loader_test1.dot]" ],
- count => 6,
+ drop => [ "[${vendor}_loader_test1.dot]", "${vendor}_loader_test2" ],
+ count => 13,
run => sub {
my ($schema, $monikers, $classes) = @_;
ok((my $rs = eval {
$schema->resultset("${vendor_titlecased}LoaderTest1Dot") }),
- 'got a resultset');
+ 'got a resultset for table with dot in name');
ok((my $from = eval { $rs->result_source->from }),
- 'got an $rsrc->from');
+ 'got an $rsrc->from for table with dot in name');
- is ref($from), 'SCALAR', '->table is a scalar ref';
+ is ref($from), 'SCALAR', '->table with dot in name is a scalar ref';
is eval { $$from }, "[${vendor}_loader_test1.dot]",
- '->table name is correct';
+ '->table with dot in name has correct name';
+
+# Test that column defaults are set correctly
+ ok(($rs = eval {
+ $schema->resultset("${vendor_titlecased}LoaderTest2") }),
+ 'got a resultset for table with column with default value');
+
+ my $rsrc = $rs->result_source;
+
+ is eval { $rsrc->column_info('dat')->{default_value} }, 'foo',
+ 'correct default_value for column with literal string default';
+
+ is eval { $rsrc->column_info('anint')->{default_value} }, 6,
+ 'correct default_value for column with literal integer default';
+
+ cmp_ok eval { $rsrc->column_info('num')->{default_value} },
+ '==', 10.89,
+ 'correct default_value for column with literal numeric default';
+
+ ok((my $function_default =
+ eval { $rsrc->column_info('ts')->{default_value} }),
+ 'got default_value for column with function default');
+
+ is ref($function_default), 'SCALAR',
+ 'default_value for function default is a SCALAR ref';
+
+ is eval { $$function_default }, 'getdate()',
+ 'default_value for function default is correct';
# Test that identity columns do not have 'identity' in the data_type, and do
# have is_auto_increment.
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff