X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=e8ee87b36c39fb635dc56e2817a7c729f87eb3ad;hb=09c0a8522aa8dee34ce44704a202c18bc7e8a51e;hp=e1387e930f1f9c6c947c8ee25c8f3c8936263f36;hpb=fa5aea38689b2581a2dce216b78b4a42bd134114;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index e1387e9..e8ee87b 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -16,7 +16,7 @@ use File::Temp qw//;
 use Class::Unload;
 require DBIx::Class;
 
-our $VERSION = '0.04999_10';
+our $VERSION = '0.04999_11';
 
 __PACKAGE__->mk_ro_accessors(qw/
                                 schema
@@ -996,15 +996,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) = @_;