loader_class
qualify_objects
tables
+ table_comments_table
+ column_comments_table
class_to_table
uniq_to_primary
quiet
By default POD will be generated for columns and relationships, using database
metadata for the text if available and supported.
-Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
-supported for Postgres right now.
+Metadata can be stored in two ways.
+
+The first is that you can create two tables named C<table_comments> and
+C<column_comments> respectively. They both need to have columns named
+C<table_name> and C<comment_text>. The second one needs to have a column
+named C<column_name>. Then data stored in these tables will be used as a
+source of metadata about tables and comments.
+
+(If you wish you can change the name of these tables with the parameters
+L</table_comments_table> and L</column_comments_table>.)
+
+As a fallback you can use built-in commenting mechanisms. Currently this
+is only supported for PostgreSQL and MySQL. To create comments in
+PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table ...>.
+To create comments in MySQL you add C<COMMENT '...'> to the end of the
+column or table definition. Note that MySQL restricts the length of comments,
+and also does not handle complex Unicode characters properly.
Set this to C<0> to turn off all POD generation.
The default is C<60>
+=head2 table_comments_table
+
+The table to look for comments about tables in. By default C<table_comments>.
+See L</generate_pod> for details.
+
+=head2 column_comments_table
+
+The table to look for comments about columns in. By default C<column_comments>.
+See L</generate_pod> for details.
+
=head2 relationship_attrs
Hashref of attributes to pass to each generated relationship, listed
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$self->{schema} ||= $self->{schema_class};
+ $self->{table_comments_table} ||= 'table_comments';
+ $self->{column_comments_table} ||= 'column_comments';
croak "dump_overwrite is deprecated. Please read the"
. " DBIx::Class::Schema::Loader::Base documentation"
return \@retval;
}
+sub _table_found {
+ my ( $self, $table ) = @_;
+ return grep {lc($_) eq lc($table)} $self->_tables_list({});
+}
+
+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};
+}
+
+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;
+}
+
+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;
+}
+
+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;
+}
+
# Find relationships
sub _table_fk_info {
my ($self, $table) = @_;
sub _table_comment {
my ( $self, $table ) = @_;
- my ($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 ($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
+ );
+ }
return $table_comment
}
sub _column_comment {
- my ( $self, $table, $column_number ) = @_;
- 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
- );
- return $self->schema->storage->dbh->selectrow_array('SELECT col_description(?,?)', undef, $table_oid,
- $column_number );
+ 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;
}
# Make sure data_type's that don't need it don't have a 'size' column_info, and
$self->next::method(@_);
}
+sub _table_comment {
+ my ( $self, $table ) = @_;
+ my $comment = $self->next::method($table);
+ if (not $comment) {
+ ($comment) = $self->schema->storage->dbh->selectrow_array(
+ qq{SELECT table_comment
+ FROM information_schema.tables
+ WHERE table_schema = schema()
+ AND table_name = ?
+ }, undef, $table);
+ # InnoDB likes to auto-append crap.
+ if (not $comment) {
+ # Do nothing.
+ }
+ elsif ($comment =~ /^InnoDB free:/) {
+ $comment = undef;
+ }
+ else {
+ $comment =~ s/; InnoDB.*//;
+ }
+ }
+ return $comment || "Gotcha $table?";
+}
+
+sub _column_comment {
+ my ( $self, $table, $column_number, $column_name ) = @_;
+ my $comment = $self->next::method($table, $column_number, $column_name);
+ if (not $comment) {
+ ($comment) = $self->schema->storage->dbh->selectrow_array(
+ qq{SELECT column_comment
+ FROM information_schema.columns
+ WHERE table_schema = schema()
+ AND table_name = ?
+ AND column_name = ?
+ }, undef, $table, $column_name);
+ }
+ return $comment;
+}
+
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
# validate the relationship_attrs arg
if( defined $self->relationship_attrs ) {
- ref $self->relationship_attrs eq 'HASH'
- or croak "relationship_attrs must be a hashref";
+ ref $self->relationship_attrs eq 'HASH'
+ or croak "relationship_attrs must be a hashref";
}
return $self;
);
if( my $specific = $r->{$reltype} ) {
- while( my ($k,$v) = each %$specific ) {
- $composite{$k} = $v;
- }
+ while( my ($k,$v) = each %$specific ) {
+ $composite{$k} = $v;
+ }
}
return \%composite;
}
use strict;
+use File::Slurp qw(slurp);
use Test::More;
use lib qw(t/lib);
use dbixcsl_common_tests;
+use utf8;
+use Encode 'decode';
my $dsn = $ENV{DBICTEST_MYSQL_DSN} || '';
my $user = $ENV{DBICTEST_MYSQL_USER} || '';
create => [
qq{
CREATE TABLE `mysql_loader-test1` (
- id INT AUTO_INCREMENT PRIMARY KEY,
+ id INT AUTO_INCREMENT PRIMARY KEY COMMENT 'The\15\12Column',
value varchar(100)
- ) $innodb
+ ) $innodb COMMENT 'The\15\12Table'
},
q{
CREATE VIEW mysql_loader_test2 AS SELECT * FROM `mysql_loader-test1`
],
pre_drop_ddl => [ 'DROP VIEW mysql_loader_test2', ],
drop => [ 'mysql_loader-test1', 'mysql_loader_test3' ],
- count => 3,
+ count => 5,
run => sub {
my ($schema, $monikers, $classes) = @_;
is_deeply $rsrc->column_info('del_group')->{extra}{list}, ['19,90 (<500)/0 EUR','4,90 (<120)/0 EUR','7,90 (<200)/0 CHF','300 (<6000)/0 CZK','4,90 (<100)/0 EUR','39 (<900)/0 DKK','299 (<5000)/0 EEK','9,90 (<250)/0 EUR','3,90 (<100)/0 GBP','3000 (<70000)/0 HUF','4000 (<70000)/0 JPY','13,90 (<200)/0 LVL','99 (<2500)/0 NOK','39 (<1000)/0 PLN','1000 (<20000)/0 RUB','49 (<2500)/0 SEK','29 (<600)/0 USD','19,90 (<600)/0 EUR','0 EUR','0 CHF'],
'hairy enum introspected correctly';
+
+ my $class = $classes->{'mysql_loader-test1'};
+ my $filename = $schema->_loader->get_dump_filename($class);
+
+ my $code = decode('UTF-8', scalar slurp $filename);
+
+ like $code, qr/^=head1 NAME\n\n^$class - The\nTable\n\n^=cut\n/m,
+ 'table comment';
+
+ like $code, qr/^=head2 id\n\n(.+:.+\n)+\nThe\nColumn\n\n/m,
+ 'column comment and attrs';
+
},
},
);
if( !$dsn || !$user ) {
- $tester->skip_tests('You need to set the DBICTEST_MYSQL_DSN, _USER, and _PASS environment variables');
+ $tester->skip_tests('You need to set the DBICTEST_MYSQL_DSN, DBICTEST_MYSQL_USER, and DBICTEST_MYSQL_PASS environment variables');
}
else {
diag $skip_rels_msg if not $test_innodb;
--- /dev/null
+use strict;
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use lib qw(t/lib);
+use File::Slurp qw(slurp);
+use File::Path;
+use make_dbictest_db_comments;
+use dbixcsl_test_dir qw/$tdir/;
+
+my $dump_path = "$tdir/dump";
+
+{
+ package DBICTest::Schema::1;
+ use base qw/ DBIx::Class::Schema::Loader /;
+ __PACKAGE__->loader_options(
+ dump_directory => $dump_path,
+ );
+}
+
+DBICTest::Schema::1->connect($make_dbictest_db_comments::dsn);
+
+plan tests => 4;
+
+my $foo = slurp("$dump_path/DBICTest/Schema/1/Result/Foo.pm");
+my $bar = slurp("$dump_path/DBICTest/Schema/1/Result/Bar.pm");
+
+like($foo, qr/Result::Foo - a short comment/, 'Short table comment inline');
+like($bar, qr/Result::Bar\n\n=head1 DESCRIPTION\n\na (very ){80}long comment/,
+ 'Long table comment in DESCRIPTION');
+
+like($foo, qr/=head2 fooid\n\n( .*\n)+\na short comment/,
+ 'Short column comment recorded');
+like($foo, qr/=head2 footext\n\n( .*\n)+\na (very ){80}long comment/,
+ 'Long column comment recorded');
+
+END { rmtree($dump_path, 1, 1); }
--- /dev/null
+use strict;
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use lib qw(t/lib);
+use File::Slurp qw(slurp);
+use File::Path;
+use make_dbictest_db_bad_comment_tables;
+use dbixcsl_test_dir qw/$tdir/;
+
+my $dump_path = "$tdir/dump";
+
+{
+ package DBICTest::Schema::1;
+ use base qw/ DBIx::Class::Schema::Loader /;
+ __PACKAGE__->loader_options(
+ dump_directory => $dump_path,
+ );
+}
+
+DBICTest::Schema::1->connect($make_dbictest_db_bad_comment_tables::dsn);
+
+plan tests => 1;
+
+my $foo = slurp("$dump_path/DBICTest/Schema/1/Result/Foo.pm");
+my $bar = slurp("$dump_path/DBICTest/Schema/1/Result/Bar.pm");
+
+like($foo, qr/Result::Foo\n/, 'No error from no comment table');
+
+END { rmtree($dump_path, 1, 1); }
--- /dev/null
+use strict;
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use lib qw(t/lib);
+use File::Slurp qw(slurp);
+use File::Path;
+use make_dbictest_db;
+use dbixcsl_test_dir qw/$tdir/;
+
+my $dump_path = "$tdir/dump";
+
+{
+ package DBICTest::Schema::1;
+ use base qw/ DBIx::Class::Schema::Loader /;
+ __PACKAGE__->loader_options(
+ dump_directory => $dump_path,
+ );
+}
+
+DBICTest::Schema::1->connect($make_dbictest_db::dsn);
+
+plan tests => 1;
+
+my $foo = slurp("$dump_path/DBICTest/Schema/1/Result/Foo.pm");
+my $bar = slurp("$dump_path/DBICTest/Schema/1/Result/Bar.pm");
+
+like($foo, qr/Result::Foo\n/, 'No error from no comments');
+
+END { rmtree($dump_path, 1, 1); }
--- /dev/null
+package make_dbictest_db_bad_comment_tables;
+
+use strict;
+use warnings;
+use DBI;
+use dbixcsl_test_dir qw/$tdir/;
+
+eval { require DBD::SQLite };
+my $class = $@ ? 'SQLite2' : 'SQLite';
+
+my $fn = "$tdir/dbictest.db";
+
+unlink($fn);
+our $dsn = "dbi:$class:dbname=$fn";
+my $dbh = DBI->connect($dsn);
+$dbh->do('PRAGMA SYNCHRONOUS = OFF');
+
+$dbh->do($_) for (
+ q|CREATE TABLE table_comments(
+ id INTEGER PRIMARY KEY
+ )|,
+ q|CREATE TABLE column_comments(
+ id INTEGER PRIMARY KEY
+ )|,
+ q|CREATE TABLE foo (
+ fooid INTEGER PRIMARY KEY,
+ footext TEXT DEFAULT 'footext',
+ foodt TIMESTAMP DEFAULT CURRENT_TIMESTAMP
+ )|,
+ q|CREATE TABLE bar (
+ barid INTEGER PRIMARY KEY,
+ fooref INTEGER REFERENCES foo(fooid)
+ )|,
+ q|INSERT INTO foo (fooid, footext) VALUES (1,'Foo text for number 1')|,
+ q|INSERT INTO foo (fooid, footext) VALUES (2,'Foo record associated with the Bar with barid 3')|,
+ q|INSERT INTO foo (fooid, footext) VALUES (3,'Foo text for number 3')|,
+ q|INSERT INTO foo (fooid, footext) VALUES (4,'Foo text for number 4')|,
+ q|INSERT INTO bar VALUES (1,4)|,
+ q|INSERT INTO bar VALUES (2,3)|,
+ q|INSERT INTO bar VALUES (3,2)|,
+ q|INSERT INTO bar VALUES (4,1)|,
+);
+
+END { unlink($fn); }
+
+1
--- /dev/null
+package make_dbictest_db_comments;
+
+use strict;
+use warnings;
+use DBI;
+use dbixcsl_test_dir qw/$tdir/;
+
+eval { require DBD::SQLite };
+my $class = $@ ? 'SQLite2' : 'SQLite';
+
+my $fn = "$tdir/dbictest.db";
+
+unlink($fn);
+our $dsn = "dbi:$class:dbname=$fn";
+my $dbh = DBI->connect($dsn);
+$dbh->do('PRAGMA SYNCHRONOUS = OFF');
+
+$dbh->do($_) for (
+ q|CREATE TABLE table_comments (
+ id INTEGER PRIMARY KEY,
+ table_name TEXT,
+ comment_text TEXT
+ )|,
+ q|CREATE TABLE column_comments (
+ id INTEGER PRIMARY KEY,
+ table_name TEXT,
+ column_name TEXT,
+ comment_text TEXT
+ )|,
+ q|CREATE TABLE foo (
+ fooid INTEGER PRIMARY KEY,
+ footext TEXT DEFAULT 'footext',
+ foodt TIMESTAMP DEFAULT CURRENT_TIMESTAMP
+ )|,
+ q|CREATE TABLE bar (
+ barid INTEGER PRIMARY KEY,
+ fooref INTEGER REFERENCES foo(fooid)
+ )|,
+ q|INSERT INTO table_comments (id, table_name, comment_text)
+ VALUES (1, 'foo', 'a short comment')
+ |,
+ q|INSERT INTO table_comments (id, table_name, comment_text)
+ VALUES (2, 'bar', 'a | . ('very ' x 80) . q|long comment')
+ |,
+ q|INSERT INTO column_comments (id, table_name, column_name, comment_text)
+ VALUES (1, 'foo', 'fooid', 'a short comment')
+ |,
+ q|INSERT INTO column_comments (id, table_name, column_name, comment_text)
+ VALUES (2, 'foo', 'footext', 'a | . ('very ' x 80) . q|long comment')
+ |,
+ q|INSERT INTO foo (fooid, footext) VALUES (1,'Foo text for number 1')|,
+ q|INSERT INTO foo (fooid, footext) VALUES (2,'Foo record associated with the Bar with barid 3')|,
+ q|INSERT INTO foo (fooid, footext) VALUES (3,'Foo text for number 3')|,
+ q|INSERT INTO foo (fooid, footext) VALUES (4,'Foo text for number 4')|,
+ q|INSERT INTO bar VALUES (1,4)|,
+ q|INSERT INTO bar VALUES (2,3)|,
+ q|INSERT INTO bar VALUES (3,2)|,
+ q|INSERT INTO bar VALUES (4,1)|,
+);
+
+END { unlink($fn); }
+
+1
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff