new dev release

[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 5d146ec..110046d 100644 (file)
--- 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_12';
 
 __PACKAGE__->mk_ro_accessors(qw/
                                 schema
@@ -130,7 +130,8 @@ Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 
 =head2 result_base_class
 
-Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
+Base class for your table classes (aka result classes). Defaults to
+'DBIx::Class::Core'.
 
 =head2 additional_base_classes
 
@@ -423,6 +424,9 @@ sub _load_tables {
 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;
@@ -522,7 +526,7 @@ sub _dump_to_dir {
 
     $self->_write_classfile($schema_class, $schema_text);
 
-    my $result_base_class = $self->result_base_class || 'DBIx::Class';
+    my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
 
     foreach my $src_class (@classes) {
         my $src_text = 
@@ -697,7 +701,9 @@ sub _make_src_class {
     $self->_use   ($table_class, @{$self->additional_classes});
     $self->_inject($table_class, @{$self->left_base_classes});
 
-    $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
+    if (my @components = @{ $self->components }) {
+        $self->_dbic_stmt($table_class, 'load_components', @components);
+    }
 
     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
         if @{$self->resultset_components};
@@ -852,15 +858,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) = @_;