X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=a576c716a581956f4e4bc2a3bee41d7a477850b9;hb=5c06aa08ab17d9d0e8437a990b5717238deeb8fd;hp=324f7e54ef0d81de0b91b09f8fe902fa0525c75f;hpb=bec8d1bb7d299556a19011f278982dec9e108fc1;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 324f7e5..a576c71 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -17,12 +17,12 @@ use File::Temp qw//; use Class::Unload; use Class::Inspector (); use Scalar::Util 'looks_like_number'; -use File::Slurp 'slurp'; -use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/; +use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/; use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); -use Encode qw/decode encode/; +use Encode qw/encode/; +use List::MoreUtils 'all'; use namespace::clean; our $VERSION = '0.07010'; @@ -37,6 +37,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ additional_base_classes left_base_classes components + schema_components skip_relationships skip_load_external moniker_map @@ -70,6 +71,12 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ config_file loader_class qualify_objects + tables + table_comments_table + column_comments_table + class_to_table + uniq_to_primary + quiet /); @@ -88,15 +95,26 @@ __PACKAGE__->mk_group_accessors('simple', qw/ preserve_case col_collision_map rel_collision_map + rel_name_map real_dump_directory result_components_map result_roles_map datetime_undef_if_invalid _result_class_methods naming_set - tables /); +my $CURRENT_V = 'v7'; + +my @CLASS_ARGS = qw( + schema_components schema_base_class result_base_class + additional_base_classes left_base_classes additional_classes components + result_roles +); + +my $LF = "\x0a"; +my $CRLF = "\x0d\x0a"; + =head1 NAME DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation. @@ -205,6 +223,23 @@ transition instead of just being lowercased, so C becomes C. If you don't have any CamelCase table or column names, you can upgrade without breaking any of your code. +=item preserve + +For L, this option does not inflect the table names but makes +monikers based on the actual name. For L this option does +not normalize CamelCase column names to lowercase column accessors, but makes +accessors that are the same names as the columns (with any non-\w chars +replaced with underscores.) + +=item singular + +For L, singularizes the names using the most current inflector. This +is the same as setting the option to L. + +=item plural + +For L, pluralizes the names, using the most current inflector. + =back Dynamic schemas will always default to the 0.04XXX relationship names and won't @@ -218,13 +253,34 @@ next major version upgrade: __PACKAGE__->naming('v7'); +=head2 quiet + +If true, will not print the usual C messages. Does not affect warnings (except for warnings related to +L.) + =head2 generate_pod By default POD will be generated for columns and relationships, using database metadata for the text if available and supported. -Reading database metadata (e.g. C) is only -supported for Postgres right now. +Metadata can be stored in two ways. + +The first is that you can create two tables named C and +C respectively. They both need to have columns named +C and C. The second one needs to have a column +named C. Then data stored in these tables will be used as a +source of metadata about tables and comments. + +(If you wish you can change the name of these tables with the parameters +L and L.) + +As a fallback you can use built-in commenting mechanisms. Currently this +is only supported for PostgreSQL and MySQL. To create comments in +PostgreSQL you add statements of the form C. +To create comments in MySQL you add C to the end of the +column or table definition. Note that MySQL restricts the length of comments, +and also does not handle complex Unicode characters properly. Set this to C<0> to turn off all POD generation. @@ -260,6 +316,16 @@ which it will be forced into a separate description section. The default is C<60> +=head2 table_comments_table + +The table to look for comments about tables in. By default C. +See L for details. + +=head2 column_comments_table + +The table to look for comments about columns in. By default C. +See L for details. + =head2 relationship_attrs Hashref of attributes to pass to each generated relationship, listed @@ -331,6 +397,43 @@ passed, the code is called with arguments of column_info => hashref of column info (data_type, is_nullable, etc), } +=head2 rel_name_map + +Similar in idea to moniker_map, but different in the details. It can be +a hashref or a code ref. + +If it is a hashref, keys can be either the default relationship name, or the +moniker. The keys that are the default relationship name should map to the +name you want to change the relationship to. Keys that are monikers should map +to hashes mapping relationship names to their translation. You can do both at +once, and the more specific moniker version will be picked up first. So, for +instance, you could have + + { + bar => "baz", + Foo => { + bar => "blat", + }, + } + +and relationships that would have been named C will now be named C +except that in the table whose moniker is C it will be named C. + +If it is a coderef, the argument passed will be a hashref of this form: + + { + name => default relationship name, + type => the relationship type eg: C, + local_class => name of the DBIC class we are building, + local_moniker => moniker of the DBIC class we are building, + local_columns => columns in this table in the relationship, + remote_class => name of the DBIC class we are related to, + remote_moniker => moniker of the DBIC class we are related to, + remote_columns => columns in the other table in the relationship, + } + +DBICSL will try to use the value returned as the relationship name. + =head2 inflect_plural Just like L above (can be hash/code-ref, falls back to default @@ -365,9 +468,13 @@ that need to be leftmost. List of additional classes which all of your table classes will use. +=head2 schema_components + +List of components to load into the Schema class. + =head2 components -List of additional components to be loaded into all of your table +List of additional components to be loaded into all of your Result classes. A good example would be L @@ -568,6 +675,12 @@ rather than column names/accessors. The default is to just append C<_rel> to the relationship name, see L. +=head2 uniq_to_primary + +Automatically promotes the largest unique constraints with non-nullable columns +on tables to primary keys, assuming there is only one largest unique +constraint. + =head1 METHODS None of these methods are intended for direct invocation by regular @@ -576,13 +689,6 @@ L. =cut -my $CURRENT_V = 'v7'; - -my @CLASS_ARGS = qw( - schema_base_class result_base_class additional_base_classes - left_base_classes additional_classes components result_roles -); - # ensure that a peice of object data is a valid arrayref, creating # an empty one or encapsulating whatever's there. sub _ensure_arrayref { @@ -630,17 +736,26 @@ sub new { } } - $self->result_components_map($self->{result_component_map}) - if defined $self->{result_component_map}; - - $self->result_roles_map($self->{result_role_map}) - if defined $self->{result_role_map}; + if (defined $self->{result_component_map}) { + if (defined $self->result_components_map) { + croak "Specify only one of result_components_map or result_component_map"; + } + $self->result_components_map($self->{result_component_map}) + } + + if (defined $self->{result_role_map}) { + if (defined $self->result_roles_map) { + croak "Specify only one of result_roles_map or result_role_map"; + } + $self->result_roles_map($self->{result_role_map}) + } croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1" if ((not defined $self->use_moose) || (not $self->use_moose)) && ((defined $self->result_roles) || (defined $self->result_roles_map)); - $self->_ensure_arrayref(qw/additional_classes + $self->_ensure_arrayref(qw/schema_components + additional_classes additional_base_classes left_base_classes components @@ -689,11 +804,14 @@ sub new { $self->{monikers} = {}; $self->{tables} = {}; + $self->{class_to_table} = {}; $self->{classes} = {}; $self->{_upgrading_classes} = {}; $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); $self->{schema} ||= $self->{schema_class}; + $self->{table_comments_table} ||= 'table_comments'; + $self->{column_comments_table} ||= 'column_comments'; croak "dump_overwrite is deprecated. Please read the" . " DBIx::Class::Schema::Loader::Base documentation" @@ -757,6 +875,24 @@ sub new { } } + if (my $rel_collision_map = $self->rel_collision_map) { + if (my $reftype = ref $rel_collision_map) { + if ($reftype ne 'HASH') { + croak "Invalid type $reftype for option 'rel_collision_map'"; + } + } + else { + $self->rel_collision_map({ '(.*)' => $rel_collision_map }); + } + } + + if (defined(my $rel_name_map = $self->rel_name_map)) { + my $reftype = ref $rel_name_map; + if ($reftype ne 'HASH' && $reftype ne 'CODE') { + croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE"; + } + } + $self; } @@ -802,7 +938,7 @@ EOF } # otherwise check if we need backcompat mode for a static schema - my $filename = $self->_get_dump_filename($self->schema_class); + my $filename = $self->get_dump_filename($self->schema_class); return unless -e $filename; my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) = @@ -816,7 +952,14 @@ EOF } my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0; - my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' }; + + my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' }; + my $ds = eval $result_namespace; + die <<"EOF" if $@; +Could not eval expression '$result_namespace' for result_namespace from +$filename: $@ +EOF + $result_namespace = $ds || ''; if ($load_classes && (not defined $self->use_namespaces)) { warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; @@ -1004,7 +1147,7 @@ sub _load_external { warn qq/# Loaded external class definition for '$class'\n/ if $self->debug; - my $code = $self->_rewrite_old_classnames(decode 'UTF-8', scalar slurp $real_inc_path); + my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path); if ($self->dynamic) { # load the class too eval_package_without_redefine_warnings($class, $code); @@ -1027,7 +1170,7 @@ sub _load_external { } if ($old_real_inc_path) { - my $code = decode 'UTF-8', scalar slurp $old_real_inc_path; + my $code = slurp_file $old_real_inc_path; $self->_ext_stmt($class, <<"EOF"); @@ -1108,8 +1251,7 @@ sub rescan { } } - delete $self->{_dump_storage}; - delete $self->{_relations_started}; + delete @$self{qw/_dump_storage _relations_started _uniqs_started/}; my $loaded = $self->_load_tables(@current); @@ -1179,11 +1321,10 @@ sub _load_tables { if(!$self->skip_relationships) { # The relationship loader needs a working schema - $self->{quiet} = 1; + local $self->{quiet} = 1; local $self->{dump_directory} = $self->{temp_directory}; $self->_reload_classes(\@tables); $self->_load_relationships(\@tables); - $self->{quiet} = 0; # Remove that temp dir from INC so it doesn't get reloaded @INC = grep $_ ne $self->dump_directory, @INC; @@ -1282,7 +1423,7 @@ sub _reload_class { eval_package_without_redefine_warnings ($class, "require $class"); } catch { - my $source = decode 'UTF-8', scalar slurp $self->_get_dump_filename($class); + my $source = slurp_file $self->_get_dump_filename($class); die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source"; }; } @@ -1336,7 +1477,7 @@ sub _dump_to_dir { my $target_dir = $self->dump_directory; warn "Dumping manual schema for $schema_class to directory $target_dir ...\n" - unless $self->{dynamic} or $self->{quiet}; + unless $self->dynamic or $self->quiet; my $schema_text = qq|package $schema_class;\n\n| @@ -1350,6 +1491,15 @@ sub _dump_to_dir { $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|; } + my @schema_components = @{ $self->schema_components || [] }; + + if (@schema_components) { + my $schema_components = dump @schema_components; + $schema_components = "($schema_components)" if @schema_components == 1; + + $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n"; + } + if ($self->use_namespaces) { $schema_text .= qq|__PACKAGE__->load_namespaces|; my $namespace_options; @@ -1360,7 +1510,8 @@ sub _dump_to_dir { for my $attr (@attr) { if ($self->$attr) { - $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n| + my $code = dumper_squashed $self->$attr; + $namespace_options .= qq| $attr => $code,\n| } } $schema_text .= qq|(\n$namespace_options)| if $namespace_options; @@ -1381,26 +1532,30 @@ sub _dump_to_dir { my $src_text = qq|package $src_class;\n\n| . qq|# Created by DBIx::Class::Schema::Loader\n| - . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n| - . qq|use strict;\nuse warnings;\n\n|; + . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|; + + $src_text .= $self->_make_pod_heading($src_class); + + $src_text .= qq|use strict;\nuse warnings;\n\n|; + + $src_text .= $self->_base_class_pod($result_base_class) + unless $result_base_class eq 'DBIx::Class::Core'; + if ($self->use_moose) { $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|; # these options 'use base' which is compile time if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) { - $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|; + $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|; } else { - $src_text .= qq|\nextends '$result_base_class';\n\n|; + $src_text .= qq|\nextends '$result_base_class';\n|; } } else { - $src_text .= qq|use base '$result_base_class';\n\n|; + $src_text .= qq|use base '$result_base_class';\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); } @@ -1421,7 +1576,7 @@ sub _dump_to_dir { } } - warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet}; + warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet; } @@ -1441,7 +1596,7 @@ sub _write_classfile { if (-f $filename && $self->really_erase_my_files) { warn "Deleting existing file '$filename' due to " - . "'really_erase_my_files' setting\n" unless $self->{quiet}; + . "'really_erase_my_files' setting\n" unless $self->quiet; unlink($filename); } @@ -1561,7 +1716,7 @@ sub _parse_generated_file { or croak "Cannot open '$fn' for reading: $!"; my $mark_re = - qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n}; + qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n}; my ($md5, $ts, $ver, $gen); while(<$fh>) { @@ -1570,7 +1725,7 @@ sub _parse_generated_file { $md5 = $2; # Pull out the version and timestamp from the line above - ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m; + ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m; $gen .= $pre_md5; croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader. Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n" @@ -1586,7 +1741,10 @@ sub _parse_generated_file { my $custom = do { local $/; <$fh> } if $md5; - close ($fh); + $custom ||= ''; + $custom =~ s/$CRLF|$LF/\n/g; + + close $fh; return ($gen, $md5, $ver, $ts, $custom); } @@ -1629,6 +1787,8 @@ sub _result_namespace { my ($self, $schema_class, $ns) = @_; my @result_namespace; + $ns = $ns->[0] if ref $ns; + if ($ns =~ /^\+(.*)/) { # Fully qualified namespace @result_namespace = ($1) @@ -1691,6 +1851,7 @@ sub _make_src_class { $self->classes->{$table} = $table_class; $self->monikers->{$table} = $table_moniker; $self->tables->{$table_moniker} = $table; + $self->class_to_table->{$table_class} = $table; $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes}); @@ -1798,8 +1959,7 @@ EOF } } -# use the same logic to run moniker_map, col_accessor_map, and -# relationship_name_map +# use the same logic to run moniker_map, col_accessor_map sub _run_user_map { my ( $self, $map, $default_code, $ident, @extra ) = @_; @@ -1827,9 +1987,11 @@ sub _default_column_accessor_name { # older naming just lc'd the col accessor and that's all. return lc $accessor_name; } + elsif (($self->naming->{column_accessors}||'') eq 'preserve') { + return $accessor_name; + } return join '_', map lc, split_name $column_name; - } sub _make_column_accessor_name { @@ -1922,6 +2084,39 @@ sub _setup_src_meta { my $pks = $self->_table_pk_info($table) || []; + my %uniq_tag; # used to eliminate duplicate uniqs + + $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq + + my $uniqs = $self->_table_uniq_info($table) || []; + my @uniqs; + + foreach my $uniq (@$uniqs) { + my ($name, $cols) = @$uniq; + next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates + push @uniqs, [$name, $cols]; + } + + my @non_nullable_uniqs = grep { + all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] } + } @uniqs; + + if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) { + my @by_colnum = sort { $b->[0] <=> $a->[0] } + map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs; + + if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) { + my @keys = map $_->[1], @by_colnum; + + my $pk = $keys[0]; + + # remove the uniq from list + @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs; + + $pks = $pk->[1]; + } + } + foreach my $pkcol (@$pks) { $col_info->{$pkcol}{is_nullable} = 0; } @@ -1932,19 +2127,13 @@ sub _setup_src_meta { map { $_, ($col_info->{$_}||{}) } @$cols ); - my %uniq_tag; # used to eliminate duplicate uniqs - - @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks) - : carp("$table has no primary key"); - $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq + $self->_dbic_stmt($table_class, 'set_primary_key', @$pks) + if @$pks; - my $uniqs = $self->_table_uniq_info($table) || []; - for (@$uniqs) { - my ($name, $cols) = @$_; - next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates + foreach my $uniq (@uniqs) { + my ($name, $cols) = @$uniq; $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols); } - } sub __columns_info_for { @@ -1997,7 +2186,13 @@ sub _default_table2moniker { my @words = map lc, split_name $table; my $as_phrase = join ' ', @words; - my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase); + my $inflected = $self->naming->{monikers} eq 'plural' ? + Lingua::EN::Inflect::Phrase::to_PL($as_phrase) + : + $self->naming->{monikers} eq 'preserve' ? + $as_phrase + : + Lingua::EN::Inflect::Phrase::to_S($as_phrase); return join '', map ucfirst, split /\W+/, $inflected; } @@ -2033,9 +2228,13 @@ sub _load_relationships { my $rel_stmts = $self->_relbuilder->generate_code(\@tables); foreach my $src_class (sort keys %$rel_stmts) { - my $src_stmts = $rel_stmts->{$src_class}; - foreach my $stmt (@$src_stmts) { - $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}}); + # sort by rel name + my @src_stmts = map $_->[1], + sort { $a->[0] cmp $b->[0] } + map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} }; + + foreach my $stmt (@src_stmts) { + $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}}); } } } @@ -2094,6 +2293,36 @@ sub _dbic_stmt { return; } +sub _make_pod_heading { + my ($self, $class) = @_; + + return '' if not $self->generate_pod; + + my $table = $self->class_to_table->{$class}; + my $pod; + + my $pcm = $self->pod_comment_mode; + my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc); + $comment = $self->__table_comment($table); + $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length); + $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows)); + $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows)); + + $pod .= "=head1 NAME\n\n"; + + my $table_descr = $class; + $table_descr .= " - " . $comment if $comment and $comment_in_name; + + $pod .= "$table_descr\n\n"; + + if ($comment and $comment_in_desc) { + $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n"; + } + $pod .= "=cut\n\n"; + + return $pod; +} + # generates the accompanying pod for a DBIC class method statement, # storing it with $self->_pod sub _make_pod { @@ -2101,25 +2330,13 @@ sub _make_pod { my $class = shift; my $method = shift; - if ( $method eq 'table' ) { - my ($table) = @_; - my $pcm = $self->pod_comment_mode; - my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc); - $comment = $self->__table_comment($table); - $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length); - $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows)); - $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows)); - $self->_pod( $class, "=head1 NAME" ); - my $table_descr = $class; - $table_descr .= " - " . $comment if $comment and $comment_in_name; - $self->{_class2table}{ $class } = $table; - $self->_pod( $class, $table_descr ); - if ($comment and $comment_in_desc) { - $self->_pod( $class, "=head1 DESCRIPTION" ); - $self->_pod( $class, $comment ); - } - $self->_pod_cut( $class ); - } elsif ( $method eq 'add_columns' ) { + if ($method eq 'table') { + my $table = $_[0]; + $table = $$table if ref $table eq 'SCALAR'; + $self->_pod($class, "=head1 TABLE: C<$table>"); + $self->_pod_cut($class); + } + elsif ( $method eq 'add_columns' ) { $self->_pod( $class, "=head1 ACCESSORS" ); my $col_counter = 0; my @cols = @_; @@ -2138,7 +2355,7 @@ sub _make_pod { " $_: $s" } sort keys %$attrs, ); - if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) { + if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) { $self->_pod( $class, $comment ); } } @@ -2152,6 +2369,35 @@ sub _make_pod { $self->_pod_cut( $class ); $self->{_relations_started} { $class } = 1; } + elsif ($method eq 'add_unique_constraint') { + $self->_pod($class, '=head1 UNIQUE CONSTRAINTS') + unless $self->{_uniqs_started}{$class}; + + my ($name, $cols) = @_; + + $self->_pod($class, "=head2 C<$name>"); + $self->_pod($class, '=over 4'); + + foreach my $col (@$cols) { + $self->_pod($class, "=item \* L"); + } + + $self->_pod($class, '=back'); + $self->_pod_cut($class); + + $self->{_uniqs_started}{$class} = 1; + } + elsif ($method eq 'set_primary_key') { + $self->_pod($class, "=head1 PRIMARY KEY"); + $self->_pod($class, '=over 4'); + + foreach my $col (@_) { + $self->_pod($class, "=item \* L"); + } + + $self->_pod($class, '=back'); + $self->_pod_cut($class); + } } sub _pod_class_list { @@ -2171,12 +2417,16 @@ sub _pod_class_list { } sub _base_class_pod { - my ($self, $class, $base_class) = @_; + my ($self, $base_class) = @_; return unless $self->generate_pod; - $self->_pod($class, "=head1 BASE CLASS: L<$base_class>"); - $self->_pod_cut($class); + return <<"EOF" +=head1 BASE CLASS: L<$base_class> + +=cut + +EOF } sub _filter_comment {