Index: t/23dumpmore.t
===================================================================
--- t/23dumpmore.t (revision 7921)
+++ t/23dumpmore.t (working copy)
@@ -8,7 +8,7 @@
$^O eq 'MSWin32'
? plan(skip_all => "ActiveState perl produces additional warnings, and this test uses unix paths")
- : plan(tests => 145);
+ : plan(tests => 153);
my $DUMP_PATH = './t/_dump';
@@ -142,11 +142,15 @@
],
Foo => [
qr/package DBICTest::DumpMore::1::Foo;/,
+ qr/=head1 NAME/,
+ qr/=head1 ACCESSORS/,
qr/->set_primary_key/,
qr/1;\n$/,
],
Bar => [
qr/package DBICTest::DumpMore::1::Bar;/,
+ qr/=head1 NAME/,
+ qr/=head1 ACCESSORS/,
qr/->set_primary_key/,
qr/1;\n$/,
],
Index: lib/DBIx/Class/Schema/Loader/Base.pm
===================================================================
--- lib/DBIx/Class/Schema/Loader/Base.pm (revision 7921)
+++ lib/DBIx/Class/Schema/Loader/Base.pm (working copy)
@@ -852,15 +852,59 @@
my $self = shift;
my $class = shift;
my $method = shift;
-
+ if ( $method eq 'table' ) {
+ my ($table) = @_;
+ $self->_pod( $class, "=head1 NAME" );
+ my $table_descr = $class;
+ if ( $self->can('_table_comment') ) {
+ my $comment = $self->_table_comment($table);
+ $table_descr .= " - " . $comment if $comment;
+ }
+ $self->{_class2table}{ $class } = $table;
+ $self->_pod( $class, $table_descr );
+ $self->_pod_cut( $class );
+ } elsif ( $method eq 'add_columns' ) {
+ $self->_pod( $class, "=head1 ACCESSORS" );
+ my $i = 0;
+ foreach ( @_ ) {
+ $i++;
+ next unless $i % 2;
+ $self->_pod( $class, '=head2 ' . $_ );
+ my $comment;
+ $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1 ) if $self->can('_column_comment');
+ $self->_pod( $class, $comment ) if $comment;
+ }
+ $self->_pod_cut( $class );
+ } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
+ $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
+ my ( $accessor, $rel_class ) = @_;
+ $self->_pod( $class, "=head2 $accessor" );
+ $self->_pod( $class, 'Type: ' . $method );
+ $self->_pod( $class, "Related object: L<$rel_class>" );
+ $self->_pod_cut( $class );
+ $self->{_relations_started} { $class } = 1;
+ }
my $args = dump(@_);
$args = '(' . $args . ')' if @_ < 2;
my $stmt = $method . $args . q{;};
warn qq|$class\->$stmt\n| if $self->debug;
$self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
+ return;
+}
+
+# Stores a POD documentation
+sub _pod {
+ my ($self, $class, $stmt) = @_;
+ $self->_raw_stmt( $class, "\n" . $stmt );
+}
+
+sub _pod_cut {
+ my ($self, $class ) = @_;
+ $self->_raw_stmt( $class, "\n=cut\n" );
}
+
# Store a raw source line for a class (for dumping purposes)
sub _raw_stmt {
my ($self, $class, $stmt) = @_;
Index: lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
===================================================================
--- lib/DBIx/Class/Schema/Loader/DBI/Pg.pm (revision 7921)
+++ lib/DBIx/Class/Schema/Loader/DBI/Pg.pm (working copy)
@@ -35,6 +35,7 @@
$self->{db_schema} ||= 'public';
}
+
sub _table_uniq_info {
my ($self, $table) = @_;
@@ -95,6 +96,32 @@
return \@uniqs;
}
+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
+ );
+ 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 );
+}
+
sub _extra_column_info {
my ($self, $info) = @_;
my %extra_info;
Index: lib/DBIx/Class/Schema/Loader/DBI/Writing.pm
===================================================================
--- lib/DBIx/Class/Schema/Loader/DBI/Writing.pm (revision 7921)
+++ lib/DBIx/Class/Schema/Loader/DBI/Writing.pm (working copy)
@@ -40,6 +40,16 @@
# concatenated if you wish.
}
+ sub _table_comment {
+ my ( $self, $table ) = @_;
+ return 'Comment';
+ }
+
+ sub _column_comment {
+ my ( $self, $table, $column_number ) = @_;
+ return 'Col. comment';
+ }
+
1;
=head1 DETAILS
@@ -55,6 +65,9 @@
C<_tables_list> and C<_extra_column_info>. See the included DBD drivers
for examples of these.
+To import comments from database you need to implement C<_table_comment>,
+C<_column_comment>
+
=cut
1;
