From: Rafael Kitover <rkitover@cpan.org>
Date: Tue, 17 May 2011 21:02:24 +0000 (-0400)
Subject: generate POD for result_base_class as well
X-Git-Tag: 0.07011~112
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a8acb698c8b9d11794d863aa2fc9b8885f4282de;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

generate POD for result_base_class as well
---

diff --git a/Changes b/Changes
index 228d759..06a78b7 100644
--- a/Changes
+++ b/Changes
@@ -1,8 +1,8 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
-        - generate POD for additional_classes, additional_base_classes,
-          left_base_classes, components, result_components_map,
-          result_roles and result_roles_map
+        - generate POD for result_base_class, additional_classes,
+          additional_base_classes, left_base_classes, components,
+          result_components_map, result_roles and result_roles_map
         - rename result_component_map to result_components_map (old name still
           works)
         - fix accessor collision detection for methods from
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 18dc57c..fbfc4d3 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -1395,6 +1395,10 @@ sub _dump_to_dir {
         else {
              $src_text .= qq|use base '$result_base_class';\n\n|;
         }
+
+        $self->_base_class_pod($src_class, $result_base_class)
+            unless $result_base_class eq 'DBIx::Class::Core';
+
         $self->_write_classfile($src_class, $src_text);
     }
 
@@ -2140,6 +2144,15 @@ sub _pod_class_list {
     $self->_pod_cut($class);
 }
 
+sub _base_class_pod {
+    my ($self, $class, $base_class) = @_;
+
+    return unless $self->generate_pod;
+
+    $self->_pod($class, "=head1 BASE CLASS: L<$base_class>");
+    $self->_pod_cut($class);
+}
+
 sub _filter_comment {
     my ($self, $txt) = @_;
 
diff --git a/t/23dumpmore.t b/t/23dumpmore.t
index 8da4e1d..9bd82a6 100644
--- a/t/23dumpmore.t
+++ b/t/23dumpmore.t
@@ -82,6 +82,7 @@ $t->dump_test(
       my ($table, $col, $info) = @_;
       return +{ extra => { is_footext => 1 } } if $col eq 'footext';
     },
+    result_base_class => 'My::ResultBaseClass',
     additional_classes => 'TestAdditional',
     additional_base_classes => 'TestAdditionalBase',
     left_base_classes => 'TestLeftBase',
@@ -99,6 +100,7 @@ $t->dump_test(
     Foo => [
       qr/package DBICTest::DumpMore::1::Foo;/,
       qr/\n=head1 NAME\n\nDBICTest::DumpMore::1::Foo\n\n=cut\n\n/,
+      qr/\n=head1 BASE CLASS: L<My::ResultBaseClass>\n\n=cut\n\n/,
       qr/\n=head1 ADDITIONAL CLASSES USED\n\n=over 4\n\n=item L<TestAdditional>\n\n=back\n\n=cut\n\n/,
       qr/\n=head1 ADDITIONAL BASE CLASSES\n\n=over 4\n\n=item L<TestAdditionalBase>\n\n=back\n\n=cut\n\n/,
       qr/\n=head1 LEFT BASE CLASSES\n\n=over 4\n\n=item L<TestLeftBase>\n\n=back\n\n=cut\n\n/,
@@ -114,6 +116,7 @@ $t->dump_test(
     Bar => [
       qr/package DBICTest::DumpMore::1::Bar;/,
       qr/\n=head1 NAME\n\nDBICTest::DumpMore::1::Bar\n\n=cut\n\n/,
+      qr/\n=head1 BASE CLASS: L<My::ResultBaseClass>\n\n=cut\n\n/,
       qr/\n=head1 ADDITIONAL CLASSES USED\n\n=over 4\n\n=item L<TestAdditional>\n\n=back\n\n=cut\n\n/,
       qr/\n=head1 ADDITIONAL BASE CLASSES\n\n=over 4\n\n=item L<TestAdditionalBase>\n\n=back\n\n=cut\n\n/,
       qr/\n=head1 LEFT BASE CLASSES\n\n=over 4\n\n=item L<TestLeftBase>\n\n=back\n\n=cut\n\n/,