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 namespace::clean;
our $VERSION = '0.07010';
config_file
loader_class
qualify_objects
+ tables
+ class_to_table
/);
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
$self->{monikers} = {};
$self->{tables} = {};
+ $self->{class_to_table} = {};
$self->{classes} = {};
$self->{_upgrading_classes} = {};
}
# 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");
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});
# 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 {
return $accessor;
}
+sub _quote {
+ my ($self, $identifier) = @_;
+
+ my $qt = $self->schema->storage->sql_maker->quote_char || '';
+
+ if (ref $qt) {
+ return $qt->[0] . $identifier . $qt->[1];
+ }
+
+ return "${qt}${identifier}${qt}";
+}
+
# Set up metadata (cols, pks, etc)
sub _setup_src_meta {
my ($self, $table) = @_;
my $table_moniker = $self->monikers->{$table};
my $table_name = $table;
- my $name_sep = $self->schema->storage->sql_maker->name_sep;
+
+ my $sql_maker = $self->schema->storage->sql_maker;
+ my $name_sep = $sql_maker->name_sep;
if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
- $table_name = \ $self->_quote_table_name($table_name);
+ $table_name = \ $self->_quote($table_name);
}
- my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
+ my $full_table_name = ($self->qualify_objects ?
+ ($self->_quote($self->db_schema) . '.') : '')
+ . (ref $table_name ? $$table_name : $table_name);
# be careful to not create refs Data::Dump can "optimize"
- $full_table_name = \do {"".$full_table_name} if ref $table_name;
+ $full_table_name = \do {"".$full_table_name} if ref $table_name;
+
+ $self->_raw_stmt($table_class, ''); # add a blank line
$self->_dbic_stmt($table_class, 'table', $full_table_name);
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 '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 );
}
}
}
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 {
push(@{$self->{_ext_storage}->{$class}}, $stmt);
}
-sub _quote_table_name {
- my ($self, $table) = @_;
-
- my $qt = $self->schema->storage->sql_maker->quote_char;
-
- return $table unless $qt;
-
- if (ref $qt) {
- return $qt->[0] . $table . $qt->[1];
- }
-
- return $qt . $table . $qt;
-}
-
sub _custom_column_info {
my ( $self, $table_name, $column_name, $column_info ) = @_;