added patch to generate POD from postgres by Andrey Kostenko (GUGU)

diff --git a/Changes b/Changes
index de5f14f..a6b7663 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - added patch to generate POD from postgres by Andrey Kostenko (GUGU)
         - added test for norewrite feature
         - fix default_value for MSSQL
 

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 878d028..b0cba0c 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -855,15 +855,59 @@ sub _dbic_stmt {
     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) = @_;

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
index 8f6c0be..aa72058 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
@@ -35,6 +35,7 @@ sub _setup {
     $self->{db_schema} ||= 'public';
 }
 
+
 sub _table_uniq_info {
     my ($self, $table) = @_;
 
@@ -95,6 +96,32 @@ sub _table_uniq_info {
     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;

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm b/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm
index 64b5df1..7f1ae64 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Writing.pm
@@ -38,6 +38,16 @@ DBIx::Class::Schema::Loader::DBI::Writing - Loader subclass writing guide for DB
       # 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
@@ -62,6 +72,9 @@ See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 This library is free software; you can redistribute it and/or modify it under
 the same terms as Perl itself.
 
+To import comments from database you need to implement C<_table_comment>,
+C<_column_comment>
+
 =cut
 
 1;

diff --git a/t/23dumpmore.t b/t/23dumpmore.t
index 3c9cf12..2bdc126 100644 (file)
--- a/t/23dumpmore.t
+++ b/t/23dumpmore.t
@@ -8,7 +8,7 @@ require DBIx::Class::Schema::Loader;
 
 $^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 @@ do_dump_test(
         ],
         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$/,
         ],