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_without_redefine_warnings/;
+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 Class::Load 'load_class';
+use Encode qw/encode/;
+use List::MoreUtils 'all';
use namespace::clean;
-our $VERSION = '0.07007';
+our $VERSION = '0.07010';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
default_resultset_class
schema_base_class
result_base_class
+ result_roles
use_moose
overwrite_modifications
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
/);
=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
=head2 db_schema
Set the name of the schema to load (schema in the sense that your database
-vendor means it). Does not currently support loading more than one schema
-name.
+vendor means it).
+
+Can be set to an arrayref of schema names for multiple schemas, or the special
+value C<%> for all schemas.
+
+Multiple schemas have only been tested on PostgreSQL.
=head2 constraint
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
classes. A good example would be
L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
+=head2 result_components_map
+
+A hashref of moniker keys and component values. Unlike L</components>, which
+loads the given components into every Result class, this option allows you to
+load certain components for specified Result classes. For example:
+
+ result_components_map => {
+ StationVisited => '+YourApp::Schema::Component::StationVisited',
+ RouteChange => [
+ '+YourApp::Schema::Component::RouteChange',
+ 'InflateColumn::DateTime',
+ ],
+ }
+
+You may use this in conjunction with L</components>.
+
+=head2 result_roles
+
+List of L<Moose> roles to be applied to all of your Result classes.
+
+=head2 result_roles_map
+
+A hashref of moniker keys and role values. Unlike L</result_roles>, which
+applies the given roles to every Result class, this option allows you to apply
+certain roles for specified Result classes. For example:
+
+ result_roles_map => {
+ StationVisited => [
+ 'YourApp::Role::Building',
+ 'YourApp::Role::Destination',
+ ],
+ RouteChange => 'YourApp::Role::TripEvent',
+ }
+
+You may use this in conjunction with L</result_roles>.
+
=head2 use_namespaces
This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
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
my @CLASS_ARGS = qw(
schema_base_class result_base_class additional_base_classes
- left_base_classes additional_classes components
+ left_base_classes additional_classes components result_roles
);
# ensure that a peice of object data is a valid arrayref, creating
}
}
+ 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
additional_base_classes
left_base_classes
components
+ result_roles
/);
$self->_validate_class_args;
+ croak "result_components_map must be a hash"
+ if defined $self->result_components_map
+ && ref $self->result_components_map ne 'HASH';
+
+ if ($self->result_components_map) {
+ my %rc_map = %{ $self->result_components_map };
+ foreach my $moniker (keys %rc_map) {
+ $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
+ }
+ $self->result_components_map(\%rc_map);
+ }
+ else {
+ $self->result_components_map({});
+ }
+ $self->_validate_result_components_map;
+
+ croak "result_roles_map must be a hash"
+ if defined $self->result_roles_map
+ && ref $self->result_roles_map ne 'HASH';
+
+ if ($self->result_roles_map) {
+ my %rr_map = %{ $self->result_roles_map };
+ foreach my $moniker (keys %rr_map) {
+ $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
+ }
+ $self->result_roles_map(\%rr_map);
+ } else {
+ $self->result_roles_map({});
+ }
+ $self->_validate_result_roles_map;
+
if ($self->use_moose) {
if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
}
$self->{monikers} = {};
- $self->{classes} = {};
+ $self->{tables} = {};
+ $self->{class_to_table} = {};
+ $self->{classes} = {};
$self->{_upgrading_classes} = {};
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
$self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
+ if (not defined $self->naming) {
+ $self->naming_set(0);
+ }
+ else {
+ $self->naming_set(1);
+ }
+
if ((not ref $self->naming) && defined $self->naming) {
my $naming_ver = $self->naming;
$self->{naming} = {
}
}
+ 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";
+ }
+ }
+
+ if (defined $self->db_schema) {
+ if (ref $self->db_schema eq 'ARRAY') {
+ if (@{ $self->db_schema } > 1) {
+ $self->{qualify_objects} = 1;
+ }
+ elsif (@{ $self->db_schema } == 0) {
+ $self->{db_schema} = undef;
+ }
+ }
+ elsif (not ref $self->db_schema) {
+ if ($self->db_schema eq '%') {
+ $self->{qualify_objects} = 1;
+ }
+
+ $self->{db_schema} = [ $self->db_schema ];
+ }
+ else {
+ croak 'db_schema must be an array or single value';
+ }
+ }
+
$self;
}
# just in case, though no one is likely to dump a dynamic schema
$self->schema_version_to_dump('0.04006');
- if (not %{ $self->naming }) {
+ if (not $self->naming_set) {
warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
Dynamic schema detected, will run in 0.04006 mode.
Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
to disable this warning.
-Also consider setting 'use_namespaces => 1' if/when upgrading.
-
See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
details.
EOF
$self->_upgrading_from('v4');
}
+ if ((not defined $self->use_namespaces) && ($self->naming_set)) {
+ $self->use_namespaces(1);
+ }
+
$self->naming->{relationships} ||= 'v4';
$self->naming->{monikers} ||= 'v4';
}
# 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};
sub _validate_class_args {
my $self = shift;
- my $args = shift;
foreach my $k (@CLASS_ARGS) {
next unless $self->$k;
my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
- foreach my $c (@classes) {
- # components default to being under the DBIx::Class namespace unless they
- # are preceeded with a '+'
- if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
- $c = 'DBIx::Class::' . $c;
- }
+ $self->_validate_classes($k, \@classes);
+ }
+}
- # 1 == installed, 0 == not installed, undef == invalid classname
- my $installed = Class::Inspector->installed($c);
- if ( defined($installed) ) {
- if ( $installed == 0 ) {
- croak qq/$c, as specified in the loader option "$k", is not installed/;
- }
- } else {
- croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
+sub _validate_result_components_map {
+ my $self = shift;
+
+ foreach my $classes (values %{ $self->result_components_map }) {
+ $self->_validate_classes('result_components_map', $classes);
+ }
+}
+
+sub _validate_result_roles_map {
+ my $self = shift;
+
+ foreach my $classes (values %{ $self->result_roles_map }) {
+ $self->_validate_classes('result_roles_map', $classes);
+ }
+}
+
+sub _validate_classes {
+ my $self = shift;
+ my $key = shift;
+ my $classes = shift;
+
+ # make a copy to not destroy original
+ my @classes = @$classes;
+
+ foreach my $c (@classes) {
+ # components default to being under the DBIx::Class namespace unless they
+ # are preceeded with a '+'
+ if ( $key =~ m/component/ && $c !~ s/^\+// ) {
+ $c = 'DBIx::Class::' . $c;
+ }
+
+ # 1 == installed, 0 == not installed, undef == invalid classname
+ my $installed = Class::Inspector->installed($c);
+ if ( defined($installed) ) {
+ if ( $installed == 0 ) {
+ croak qq/$c, as specified in the loader option "$key", is not installed/;
}
+ } else {
+ croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
}
}
}
+
sub _find_file_in_inc {
my ($self, $file) = @_;
return;
}
-sub _class_path {
- my ($self, $class) = @_;
-
- my $class_path = $class;
- $class_path =~ s{::}{/}g;
- $class_path .= '.pm';
-
- return $class_path;
-}
-
sub _find_class_in_inc {
my ($self, $class) = @_;
- return $self->_find_file_in_inc($self->_class_path($class));
+ return $self->_find_file_in_inc(class_path($class));
}
sub _rewriting {
warn qq/# Loaded external class definition for '$class'\n/
if $self->debug;
- my $code = $self->_rewrite_old_classnames(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_without_redefine_warnings($code);
+ eval_package_without_redefine_warnings($class, $code);
}
$self->_ext_stmt($class,
}
if ($old_real_inc_path) {
- my $code = slurp $old_real_inc_path;
+ my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
$self->_ext_stmt($class, <<"EOF");
* PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
new name of the Result.
EOF
- eval_without_redefine_warnings($code);
+ eval_package_without_redefine_warnings($class, $code);
}
chomp $code;
}
}
- delete $self->{_dump_storage};
- delete $self->{_relations_started};
+ delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
my $loaded = $self->_load_tables(@current);
->{ $self->naming->{relationships}};
my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
- load_class $relbuilder_class;
+ $self->ensure_class_loaded($relbuilder_class);
$relbuilder_class->new( $self );
};
$self->{quiet} = 1;
local $self->{dump_directory} = $self->{temp_directory};
$self->_reload_classes(\@tables);
- $self->_load_relationships($_) for @tables;
- $self->_relbuilder->cleanup;
+ $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;
}
+ $self->_load_roles($_) for @tables;
+
$self->_load_external($_)
for map { $self->classes->{$_} } @tables;
sub _reload_class {
my ($self, $class) = @_;
- my $class_path = $self->_class_path($class);
- delete $INC{ $class_path };
+ delete $INC{ +class_path($class) };
-# kill redefined warnings
try {
- eval_without_redefine_warnings ("require $class");
+ eval_package_without_redefine_warnings ($class, "require $class");
}
catch {
- my $source = 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->_write_classfile($src_class, $src_text);
}
my $compare_to;
if ($old_md5) {
$compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
- if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
+ if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
return unless $self->_upgrading_from && $is_schema;
}
}
POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
);
- open(my $fh, '>', $filename)
+ open(my $fh, '>:encoding(UTF-8)', $filename)
or croak "Cannot open '$filename' for writing: $!";
# Write the top half and its MD5 sum
- print $fh $text . Digest::MD5::md5_base64($text) . "\n";
+ print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
# Write out anything loaded via external partial class file in @INC
print $fh qq|$_\n|
return unless -f $fn;
- open(my $fh, '<', $fn)
+ open(my $fh, '<:encoding(UTF-8)', $fn)
or croak "Cannot open '$fn' for reading: $!";
my $mark_re =
$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"
- if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
+ if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
last;
}
$self->_raw_stmt($target, "use base qw/$blist/;");
}
+sub _with {
+ my $self = shift;
+ my $target = shift;
+
+ my $rlist = join(q{, }, map { qq{'$_'} } @_);
+
+ return unless $rlist;
+
+ warn "$target: with $rlist;" if $self->debug;
+ $self->_raw_stmt($target, "\nwith $rlist;");
+}
+
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)
unless $table_class eq $old_class;
}
-# this was a bad idea, should be ok now without it
-# my $table_normalized = lc $table;
-# $self->classes->{$table_normalized} = $table_class;
-# $self->monikers->{$table_normalized} = $table_moniker;
-
- $self->classes->{$table} = $table_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});
$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});
- if (my @components = @{ $self->components }) {
- $self->_dbic_stmt($table_class, 'load_components', @components);
+ my @components = @{ $self->components || [] };
+
+ push @components, @{ $self->result_components_map->{$table_moniker} }
+ if exists $self->result_components_map->{$table_moniker};
+
+ my @fq_components = @components;
+ foreach my $component (@fq_components) {
+ if ($component !~ s/^\+//) {
+ $component = "DBIx::Class::$component";
+ }
}
+ $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
+
+ $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
+
+ $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
+
$self->_inject($table_class, @{$self->additional_base_classes});
}
sub _is_result_class_method {
- my ($self, $name) = @_;
+ my ($self, $name, $table_name) = @_;
+
+ my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
- if (not $self->_result_class_methods) {
+ $self->_result_class_methods({})
+ if not defined $self->_result_class_methods;
+
+ if (not exists $self->_result_class_methods->{$table_moniker}) {
my (@methods, %methods);
my $base = $self->result_base_class || 'DBIx::Class::Core';
- my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
- for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
- load_class $class;
+ my @components = @{ $self->components || [] };
+
+ push @components, @{ $self->result_components_map->{$table_moniker} }
+ if exists $self->result_components_map->{$table_moniker};
+
+ for my $c (@components) {
+ $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
+ }
+
+ my @roles = @{ $self->result_roles || [] };
+
+ push @roles, @{ $self->result_roles_map->{$table_moniker} }
+ if exists $self->result_roles_map->{$table_moniker};
+
+ for my $class ($base, @components,
+ ($self->use_moose ? 'Moose::Object' : ()), @roles) {
+ $self->ensure_class_loaded($class);
push @methods, @{ Class::Inspector->methods($class) || [] };
}
@methods{@methods} = ();
- # futureproof meta
- $methods{meta} = undef;
-
- $self->_result_class_methods(\%methods);
+ $self->_result_class_methods->{$table_moniker} = \%methods;
}
- my $result_methods = $self->_result_class_methods;
+ my $result_methods = $self->_result_class_methods->{$table_moniker};
return exists $result_methods->{$name};
}
sub _resolve_col_accessor_collisions {
my ($self, $table, $col_info) = @_;
- my $table_name = ref $table ? $$table : $table;
-
while (my ($col, $info) = each %$col_info) {
my $accessor = $info->{accessor} || $col;
next if $accessor eq 'id'; # special case (very common column)
- if ($self->_is_result_class_method($accessor)) {
+ if ($self->_is_result_class_method($accessor, $table)) {
my $mapped = 0;
if (my $map = $self->col_collision_map) {
if (not $mapped) {
warn <<"EOF";
-Column '$col' in table '$table_name' collides with an inherited method.
+Column '$col' in table '$table' collides with an inherited method.
See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
EOF
$info->{accessor} = undef;
}
}
-# 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 {
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 $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;
- 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($table->schema) . '.') : '')
+ . (ref $table_name eq 'SCALAR' ? $$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->_dbic_stmt($table_class, 'table', $full_table_name);
$info->{accessor} = $self->_make_column_accessor_name( $col, $context );
}
- $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
+ $self->_resolve_col_accessor_collisions($table, $col_info);
# prune any redundant accessor names
while (my ($col, $info) = each %$col_info) {
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
+ $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
+ if @$pks;
- @$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
-
- 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;
}
}
sub _load_relationships {
- my ($self, $table) = @_;
+ my ($self, $tables) = @_;
- my $tbl_fk_info = $self->_table_fk_info($table);
- foreach my $fkdef (@$tbl_fk_info) {
- $fkdef->{remote_source} =
- $self->monikers->{delete $fkdef->{remote_table}};
+ my @tables;
+
+ foreach my $table (@$tables) {
+ my $tbl_fk_info = $self->_table_fk_info($table);
+ foreach my $fkdef (@$tbl_fk_info) {
+ $fkdef->{remote_source} =
+ $self->monikers->{delete $fkdef->{remote_table}};
+ }
+ my $tbl_uniq_info = $self->_table_uniq_info($table);
+
+ my $local_moniker = $self->monikers->{$table};
+
+ push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
}
- my $tbl_uniq_info = $self->_table_uniq_info($table);
- my $local_moniker = $self->monikers->{$table};
- my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
+ my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
foreach my $src_class (sort keys %$rel_stmts) {
my $src_stmts = $rel_stmts->{$src_class};
}
}
+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
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 {
+ 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, $base_class) = @_;
+
+ return unless $self->generate_pod;
+
+ 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 ) = @_;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff