use Try::Tiny;
use DBIx::Class ();
use Encode qw/encode/;
+use List::MoreUtils 'all';
use namespace::clean;
our $VERSION = '0.07010';
additional_base_classes
left_base_classes
components
+ schema_components
skip_relationships
skip_load_external
moniker_map
qualify_objects
tables
class_to_table
+ uniq_to_primary
+ quiet
/);
preserve_case
col_collision_map
rel_collision_map
+ rel_name_map
real_dump_directory
result_components_map
result_roles_map
__PACKAGE__->naming('v7');
+=head2 quiet
+
+If true, will not print the usual C<Dumping manual schema ... Schema dump
+completed.> messages. Does not affect warnings (except for warnings related to
+L</really_erase_my_files>.)
+
=head2 generate_pod
By default POD will be generated for columns and relationships, using database
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
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<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
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 $CURRENT_V = 'v7';
my @CLASS_ARGS = qw(
- schema_base_class result_base_class additional_base_classes
- left_base_classes additional_classes components result_roles
+ schema_components 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
}
}
- $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
}
}
+ 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;
}
Could not eval expression '$result_namespace' for result_namespace from
$filename: $@
EOF
- $result_namespace = $ds;
+ $result_namespace = $ds || '';
if ($load_classes && (not defined $self->use_namespaces)) {
warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
}
}
- delete $self->{_dump_storage};
- delete $self->{_relations_started};
+ delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
my $loaded = $self->_load_tables(@current);
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;
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|
$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;
}
}
- warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
+ warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
}
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);
}
}
}
-# 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 ) = @_;
# be careful to not create refs Data::Dump can "optimize"
$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 $cols = $self->_table_columns($table);
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 $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}});
}
}
}
my $class = shift;
my $method = shift;
- if ( $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 = @_;
$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 {
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff