add asterisks to items in POD class lists

[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 4430ae0..fbf36a7 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -1187,6 +1187,8 @@ sub _load_tables {
         @INC = grep $_ ne $self->dump_directory, @INC;
     }
 
+    $self->_load_roles($_) for @tables;
+
     $self->_load_external($_)
         for map { $self->classes->{$_} } @tables;
 
@@ -1393,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);
     }
 
@@ -1683,7 +1689,12 @@ sub _make_src_class {
     $self->classes->{$table}  = $table_class;
     $self->monikers->{$table} = $table_moniker;
 
+    $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
+
     $self->_use   ($table_class, @{$self->additional_classes});
+
+    $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
+
     $self->_inject($table_class, @{$self->left_base_classes});
 
     my @components = @{ $self->components || [] };
@@ -1691,15 +1702,20 @@ sub _make_src_class {
     push @components, @{ $self->result_components_map->{$table_moniker} }
         if exists $self->result_components_map->{$table_moniker};
 
-    $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
+    my @fq_components = @components;
+    foreach my $component (@fq_components) {
+        if ($component !~ s/^\+//) {
+            $component = "DBIx::Class::$component";
+        }
+    }
 
-    $self->_inject($table_class, @{$self->additional_base_classes});
+    $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
 
-    my @roles = @{ $self->result_roles || [] };
-    push @roles, @{ $self->result_roles_map->{$table_moniker} }
-        if exists $self->result_roles_map->{$table_moniker};
+    $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
+
+    $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
 
-    $self->_with($table_class, @roles) if @roles;
+    $self->_inject($table_class, @{$self->additional_base_classes});
 }
 
 sub _is_result_class_method {
@@ -1833,7 +1849,7 @@ sub _setup_src_meta {
     my $schema       = $self->schema;
     my $schema_class = $self->schema_class;
 
-    my $table_class = $self->classes->{$table};
+    my $table_class   = $self->classes->{$table};
     my $table_moniker = $self->monikers->{$table};
 
     my $table_name = $table;
@@ -1998,6 +2014,23 @@ sub _load_relationships {
     }
 }
 
+sub _load_roles {
+    my ($self, $table) = @_;
+
+    my $table_moniker = $self->monikers->{$table};
+    my $table_class   = $self->classes->{$table};
+
+    my @roles = @{ $self->result_roles || [] };
+    push @roles, @{ $self->result_roles_map->{$table_moniker} }
+        if exists $self->result_roles_map->{$table_moniker};
+
+    if (@roles) {
+        $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
+
+        $self->_with($table_class, @roles);
+    }
+}
+
 # Overload these in driver class:
 
 # Returns an arrayref of column names
@@ -2095,6 +2128,31 @@ sub _make_pod {
     }
 }
 
+sub _pod_class_list {
+    my ($self, $class, $title, @classes) = @_;
+
+    return unless @classes && $self->generate_pod;
+
+    $self->_pod($class, "=head1 $title");
+    $self->_pod($class, '=over 4');
+
+    foreach my $link (@classes) {
+        $self->_pod($class, "=item * L<$link>");
+    }
+
+    $self->_pod($class, '=back');
+    $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) = @_;