use Class::Unload;
use Class::Inspector ();
use Scalar::Util 'looks_like_number';
-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::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/encode/;
-use List::MoreUtils 'all';
+use Encode qw/encode decode/;
+use List::MoreUtils qw/all firstidx/;
+use IPC::Open2;
+use Symbol 'gensym';
use namespace::clean;
our $VERSION = '0.07010';
additional_base_classes
left_base_classes
components
+ schema_components
skip_relationships
skip_load_external
moniker_map
relationship_attrs
- db_schema
_tables
classes
_upgrading_classes
datetime_locale
config_file
loader_class
- qualify_objects
- tables
+ table_comments_table
+ column_comments_table
class_to_table
+ moniker_to_table
uniq_to_primary
+ quiet
/);
datetime_undef_if_invalid
_result_class_methods
naming_set
+ filter_generated_code
+ db_schema
+ qualify_objects
+ moniker_parts
/);
+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 $CR = "\x0d";
+my $LF = "\x0a";
+my $CRLF = "\x0d\x0a";
+
=head1 NAME
DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
__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
metadata for the text if available and supported.
-Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
-supported for Postgres right now.
+Comment metadata can be stored in two ways.
+
+The first is that you can create two tables named C<table_comments> and
+C<column_comments> respectively. They both need to have columns named
+C<table_name> and C<comment_text>. The second one needs to have a column
+named C<column_name>. 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</table_comments_table> and L</column_comments_table>.)
+
+As a fallback you can use built-in commenting mechanisms. Currently this is
+only supported for PostgreSQL, Oracle and MySQL. To create comments in
+PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
+'...'>, the same syntax is used in Oracle. To create comments in MySQL you add
+C<COMMENT '...'> 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.
The default is C<60>
+=head2 table_comments_table
+
+The table to look for comments about tables in. By default C<table_comments>.
+See L</generate_pod> for details.
+
+=head2 column_comments_table
+
+The table to look for comments about columns in. By default C<column_comments>.
+See L</generate_pod> for details.
+
=head2 relationship_attrs
Hashref of attributes to pass to each generated relationship, listed
=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.
+
+For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
+keys and arrays of owners as values, set to the value:
+
+ { '%' => '%' }
+
+for all owners in all databases.
+
+You may need to control naming of monikers with L</moniker_parts> if you have
+name clashes for tables in different schemas/databases.
+
+=head2 moniker_parts
+
+The database table names are represented by the
+L<DBIx::Class::Schema::Loader::Table> class in the loader, the
+L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
+L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
+
+Monikers are created normally based on just the
+L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
+the table name, but can consist of other parts of the fully qualified name of
+the table.
+
+The L</moniker_parts> option is an arrayref of methods on the table class
+corresponding to parts of the fully qualified table name, defaulting to
+C<['name']>, in the order those parts are used to create the moniker name.
+
+The C<'name'> entry B<must> be present.
+
+Below is a table of supported databases and possible L</moniker_parts>.
+
+=over 4
+
+=item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
+
+C<schema>, C<name>
+
+=item * Informix, MSSQL, Sybase ASE
+
+C<database>, C<schema>, C<name>
+
+=back
=head2 constraint
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>
on tables to primary keys, assuming there is only one largest unique
constraint.
+=head2 filter_generated_code
+
+An optional hook that lets you filter the generated text for various classes
+through a function that change it in any way that you want. The function will
+receive the type of file, C<schema> or C<result>, class and code; and returns
+the new code to use instead. For instance you could add custom comments, or do
+anything else that you want.
+
+The option can also be set to a string, which is then used as a filter program,
+e.g. C<perltidy>.
+
+If this exists but fails to return text matching C</\bpackage\b/>, no file will
+be generated.
+
+ filter_generated_code => sub {
+ my ($type, $class, $text) = @_;
+ ...
+ return $new_code;
+ }
+
=head1 METHODS
None of these methods are intended for direct invocation by regular
=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 {
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
}
}
+ $self->{_tables} = {};
$self->{monikers} = {};
- $self->{tables} = {};
+ $self->{moniker_to_table} = {};
$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"
}
}
- $self;
+ if (defined(my $filter = $self->filter_generated_code)) {
+ my $reftype = ref $filter;
+ if ($reftype && $reftype ne 'CODE') {
+ croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
+ }
+ }
+
+ 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 ];
+ }
+ }
+
+ if (not $self->moniker_parts) {
+ $self->moniker_parts(['name']);
+ }
+ else {
+ if (not ref $self->moniker_parts) {
+ $self->moniker_parts([ $self->moniker_parts ]);
+ }
+ if (ref $self->moniker_parts ne 'ARRAY') {
+ croak 'moniker_parts must be an arrayref';
+ }
+ if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
+ croak "moniker_parts option *must* contain 'name'";
+ }
+ }
+
+ return $self;
}
sub _check_back_compat {
warn qq/# Loaded external class definition for '$class'\n/
if $self->debug;
- my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
+ 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);
}
if ($old_real_inc_path) {
- my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
+ my $code = slurp_file $old_real_inc_path;
$self->_ext_stmt($class, <<"EOF");
my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
foreach my $table (@current) {
- if(!exists $self->{_tables}->{$table}) {
+ if(!exists $self->_tables->{$table->sql_name}) {
push(@created, $table);
}
}
my %current;
- @current{@current} = ();
- foreach my $table (keys %{ $self->{_tables} }) {
- if (not exists $current{$table}) {
- $self->_unregister_source_for_table($table);
+ @current{map $_->sql_name, @current} = ();
+ foreach my $table (values %{ $self->_tables }) {
+ if (not exists $current{$table->sql_name}) {
+ $self->_remove_table($table);
}
}
my $loaded = $self->_load_tables(@current);
- return map { $self->monikers->{$_} } @created;
+ foreach my $table (@created) {
+ $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
+ }
+
+ return map { $self->monikers->{$_->sql_name} } @created;
}
sub _relbuilder {
# Save the new tables to the tables list
foreach (@tables) {
- $self->{_tables}->{$_} = 1;
+ $self->_tables->{$_->sql_name} = $_;
}
$self->_make_src_class($_) for @tables;
# sanity-check for moniker clashes
my $inverse_moniker_idx;
- for (keys %{$self->monikers}) {
- push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
+ foreach my $table (values %{ $self->_tables }) {
+ push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table;
}
my @clashes;
- for (keys %$inverse_moniker_idx) {
- my $tables = $inverse_moniker_idx->{$_};
+ foreach my $moniker (keys %$inverse_moniker_idx) {
+ my $tables = $inverse_moniker_idx->{$moniker};
if (@$tables > 1) {
push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
- join (', ', map { "'$_'" } @$tables),
- $_,
+ join (', ', map $_->sql_name, @$tables),
+ $moniker,
);
}
}
;
}
-
$self->_setup_src_meta($_) for @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;
$self->_load_roles($_) for @tables;
$self->_load_external($_)
- for map { $self->classes->{$_} } @tables;
+ for map { $self->classes->{$_->sql_name} } @tables;
# Reload without unloading first to preserve any symbols from external
# packages.
# so that we don't repeat custom sections
@INC = grep $_ ne $self->dump_directory, @INC;
- $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
+ $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
unshift @INC, $self->dump_directory;
$self->schema->sources;
for my $table (@tables) {
- my $moniker = $self->monikers->{$table};
- my $class = $self->classes->{$table};
+ my $moniker = $self->monikers->{$table->sql_name};
+ my $class = $self->classes->{$table->sql_name};
{
no warnings 'redefine';
eval_package_without_redefine_warnings ($class, "require $class");
}
catch {
- my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
+ my $source = slurp_file $self->_get_dump_filename($class);
die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
};
}
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;
}
sub _sig_comment {
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);
}
$text .= qq|$_\n|
for @{$self->{_dump_storage}->{$class} || []};
- # Check and see if the dump is infact differnt
+ if ($self->filter_generated_code) {
+ my $filter = $self->filter_generated_code;
+
+ if (ref $filter eq 'CODE') {
+ $text = $filter->(
+ ($is_schema ? 'schema' : 'result'),
+ $class,
+ $text
+ );
+ }
+ else {
+ my ($out, $in) = (gensym, gensym);
+
+ my $pid = open2($out, $in, $filter)
+ or croak "Could not open pipe to $filter: $!";
+
+ print $in $text;
+
+ close $in;
+
+ $text = decode('UTF-8', do { local $/; <$out> });
+
+ $text =~ s/$CR?$LF/\n/g;
+
+ waitpid $pid, 0;
+
+ my $exit_code = $? >> 8;
+
+ if ($exit_code != 0) {
+ croak "filter '$filter' exited non-zero: $exit_code";
+ }
+ }
+ if (not $text or not $text =~ /\bpackage\b/) {
+ warn("$class skipped due to filter") if $self->debug;
+ return;
+ }
+ }
+
+ # Check and see if the dump is in fact different
my $compare_to;
if ($old_md5) {
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>) {
$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"
my $custom = do { local $/; <$fh> }
if $md5;
- close ($fh);
+ $custom ||= '';
+ $custom =~ s/$CRLF|$LF/\n/g;
+
+ close $fh;
return ($gen, $md5, $ver, $ts, $custom);
}
);
}
- my $old_class = join(q{::}, @result_namespace,
- $self->_table2moniker($table));
+ my $old_class = join(q{::}, @result_namespace, $table_moniker);
$self->_upgrading_classes->{$table_class} = $old_class
unless $table_class eq $old_class;
}
- $self->classes->{$table} = $table_class;
- $self->monikers->{$table} = $table_moniker;
- $self->tables->{$table_moniker} = $table;
+ $self->classes->{$table->sql_name} = $table_class;
+ $self->monikers->{$table->sql_name} = $table_moniker;
+ $self->moniker_to_table->{$table_moniker} = $table;
$self->class_to_table->{$table_class} = $table;
$self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
}
sub _is_result_class_method {
- my ($self, $name, $table_name) = @_;
+ my ($self, $name, $table) = @_;
- my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
+ my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
$self->_result_class_methods({})
if not defined $self->_result_class_methods;
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, $table_name)) {
+ 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;
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_moniker = $self->monikers->{$table};
-
- my $table_name = $table;
-
- 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);
- }
-
- 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;
+ my $table_class = $self->classes->{$table->sql_name};
+ my $table_moniker = $self->monikers->{$table->sql_name};
- $self->_dbic_stmt($table_class, 'table', $full_table_name);
+ $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
my $cols = $self->_table_columns($table);
my $col_info = $self->__columns_info_for($table);
my $context = {
table_class => $table_class,
table_moniker => $table_moniker,
- table_name => $table_name,
- full_table_name => $full_table_name,
+ table_name => $table,
+ full_table_name => $table->dbic_name,
schema_class => $schema_class,
column_info => $info,
};
$self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
if @$pks;
+ # Sort unique constraints by constraint name for repeatable results (rels
+ # are sorted as well elsewhere.)
+ @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
+
foreach my $uniq (@uniqs) {
my ($name, $cols) = @$uniq;
$self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
sub tables {
my $self = shift;
- return keys %{$self->_tables};
+ return values %{$self->_tables};
}
# Make a moniker from a table
no warnings 'uninitialized';
my ($self, $table) = @_;
+ my @name_parts = map $table->$_, @{ $self->moniker_parts };
+
+ my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
+
if ($self->naming->{monikers} eq 'v4') {
- return join '', map ucfirst, split /[\W_]+/, lc $table;
+ return join '', map ucfirst, map split(/[\W_]+/, lc $_), @name_parts;
}
elsif ($self->naming->{monikers} eq 'v5') {
- return join '', map ucfirst, split /[\W_]+/,
- Lingua::EN::Inflect::Number::to_S(lc $table);
+ my @parts = map lc, @name_parts;
+ $parts[$name_idx] = Lingua::EN::Inflect::Number::to_S($parts[$name_idx]);
+
+ return join '', map ucfirst, map split(/[\W_]+/, $_), @parts;
}
elsif ($self->naming->{monikers} eq 'v6') {
- (my $as_phrase = lc $table) =~ s/_+/ /g;
+ (my $as_phrase = join '', map lc, @name_parts) =~ s/_+/ /g;
my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
return join '', map ucfirst, split /\W+/, $inflected;
}
- my @words = map lc, split_name $table;
+ my @words = map lc, map split_name $_, @name_parts;
my $as_phrase = join ' ', @words;
my $inflected = $self->naming->{monikers} eq 'plural' ?
my @tables;
foreach my $table (@$tables) {
+ my $local_moniker = $self->monikers->{$table->sql_name};
+
my $tbl_fk_info = $self->_table_fk_info($table);
+
foreach my $fkdef (@$tbl_fk_info) {
+ $fkdef->{local_table} = $table;
+ $fkdef->{local_moniker} = $local_moniker;
$fkdef->{remote_source} =
- $self->monikers->{delete $fkdef->{remote_table}};
+ $self->monikers->{$fkdef->{remote_table}->sql_name};
}
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 ];
}
sub _load_roles {
my ($self, $table) = @_;
- my $table_moniker = $self->monikers->{$table};
- my $table_class = $self->classes->{$table};
+ my $table_moniker = $self->monikers->{$table->sql_name};
+ my $table_class = $self->classes->{$table->sql_name};
my @roles = @{ $self->result_roles || [] };
push @roles, @{ $self->result_roles_map->{$table_moniker} }
return $self->preserve_case ? $name : uc($name);
}
-sub _unregister_source_for_table {
+sub _remove_table {
my ($self, $table) = @_;
try {
- local $@;
my $schema = $self->schema;
# in older DBIC it's a private method
my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
- $schema->$unregister($self->_table2moniker($table));
- delete $self->monikers->{$table};
- delete $self->classes->{$table};
- delete $self->_upgrading_classes->{$table};
- delete $self->{_tables}{$table};
+ $schema->$unregister(delete $self->monikers->{$table->sql_name});
+ delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
+ delete $self->_tables->{$table->sql_name};
};
}
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff