use Class::Unload;
use Class::Inspector ();
use Scalar::Util 'looks_like_number';
-use File::Slurp 'slurp';
+use File::Slurp 'read_file';
use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
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';
config_file
loader_class
qualify_objects
+ tables
+ class_to_table
+ uniq_to_primary
/);
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
/);
=head1 NAME
If you don't have any CamelCase table or column names, you can upgrade without
breaking any of your code.
+=item preserve
+
+For L</monikers>, this option does not inflect the table names but makes
+monikers based on the actual name. For L</column_accessors> 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</monikers>, singularizes the names using the most current inflector. This
+is the same as setting the option to L</current>.
+
+=item plural
+
+For L</monikers>, pluralizes the names, using the most current inflector.
+
=back
Dynamic schemas will always default to the 0.04XXX relationship names and won't
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<bar> will now be named C<baz>
+except that in the table whose moniker is C<Foo> it will be named C<blat>.
+
+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<has_many>,
+ 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</moniker_map> above (can be hash/code-ref, falls back to default
The default is to just append C<_rel> to the relationship name, see
L</RELATIONSHIP NAME COLLISIONS>.
+=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
$self->{monikers} = {};
$self->{tables} = {};
+ $self->{class_to_table} = {};
$self->{classes} = {};
$self->{_upgrading_classes} = {};
}
}
+ 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;
}
}
# 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) =
}
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};
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(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
if ($self->dynamic) { # load the class too
eval_package_without_redefine_warnings($class, $code);
}
if ($old_real_inc_path) {
- my $code = decode 'UTF-8', scalar slurp $old_real_inc_path;
+ my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
$self->_ext_stmt($class, <<"EOF");
}
}
- delete $self->{_dump_storage};
- delete $self->{_relations_started};
+ delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
my $loaded = $self->_load_tables(@current);
eval_package_without_redefine_warnings ($class, "require $class");
}
catch {
- my $source = decode 'UTF-8', scalar slurp $self->_get_dump_filename($class);
+ my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
};
}
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;
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);
}
my ($self, $schema_class, $ns) = @_;
my @result_namespace;
+ $ns = $ns->[0] if ref $ns;
+
if ($ns =~ /^\+(.*)/) {
# Fully qualified namespace
@result_namespace = ($1)
$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});
}
}
-# 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 ) = @_;
# 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 {
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;
}
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 {
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;
}
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 {
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 = @_;
" $_: $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 );
}
}
$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</$col>");
+ }
+
+ $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</$col>");
+ }
+
+ $self->_pod($class, '=back');
+ $self->_pod_cut($class);
+ }
}
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 {
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff