use strict;
use warnings;
use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
-use namespace::autoclean;
-use Class::C3;
+use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class::Schema::Loader::RelBuilder;
use Data::Dump qw/ dump /;
use File::Temp qw//;
use Class::Unload;
use Class::Inspector ();
-use Data::Dumper::Concise;
use Scalar::Util 'looks_like_number';
use File::Slurp 'slurp';
-use DBIx::Class::Schema::Loader::Utils 'split_name';
-require DBIx::Class;
+use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/;
+use DBIx::Class::Schema::Loader::Optional::Dependencies ();
+use Try::Tiny;
+use DBIx::Class ();
+use Class::Load 'load_class';
+use namespace::clean;
-our $VERSION = '0.07000';
+our $VERSION = '0.07004';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
additional_base_classes
left_base_classes
components
- resultset_components
skip_relationships
skip_load_external
moniker_map
+ column_accessor_map
custom_column_info
inflect_singular
inflect_plural
default_resultset_class
schema_base_class
result_base_class
- overwrite_modifications
+ use_moose
+ overwrite_modifications
relationship_attrs
pod_comment_mode
pod_comment_spillover_length
preserve_case
+ col_collision_map
+ rel_collision_map
+ real_dump_directory
+ datetime_undef_if_invalid
+ _result_class_methods
/);
=head1 NAME
__PACKAGE__->naming('current');
-Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
+Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
next major version upgrade:
- __PACKAGE__->naming('v5');
+ __PACKAGE__->naming('v7');
=head2 generate_pod
For example:
relationship_attrs => {
- belongs_to => { is_deferrable => 1 },
+ belongs_to => { is_deferrable => 0 },
},
-use this to make your foreign key constraints DEFERRABLE.
+use this to turn off DEFERRABLE on your foreign key constraints.
=head2 debug
stations_visited | StationVisited
routeChange | RouteChange
+=head2 column_accessor_map
+
+Same as moniker_map, but for column accessor names. If a coderef is
+passed, the code is called with arguments of
+
+ the name of the column in the underlying database,
+ default accessor name that DBICSL would ordinarily give this column,
+ {
+ table_class => name of the DBIC class we are building,
+ table_moniker => calculated moniker for this table (after moniker_map if present),
+ table_name => name of the database table,
+ full_table_name => schema-qualified name of the database table (RDBMS specific),
+ schema_class => name of the schema class we are building,
+ column_info => hashref of column info (data_type, is_nullable, etc),
+ }
+
=head2 inflect_plural
Just like L</moniker_map> above (can be hash/code-ref, falls back to default
if hash key does not exist or coderef returns false), but acts as a map
for pluralizing relationship names. The default behavior is to utilize
-L<Lingua::EN::Inflect::Number/to_PL>.
+L<Lingua::EN::Inflect::Phrase/to_PL>.
=head2 inflect_singular
As L</inflect_plural> above, but for singularizing relationship names.
-Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
+Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
=head2 schema_base_class
classes. A good example would be
L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
-=head2 resultset_components
-
-List of additional ResultSet components to be loaded into your table
-classes. A good example would be C<AlwaysRS>. Component
-C<ResultSetManager> will be automatically added to the above
-C<components> list if this option is set.
-
=head2 use_namespaces
This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
=head2 dump_directory
-This option is designed to be a tool to help you transition from this
-loader to a manually-defined schema when you decide it's time to do so.
-
The value of this option is a perl libdir pathname. Within
that directory this module will create a baseline manual
-L<DBIx::Class::Schema> module set, based on what it creates at runtime
-in memory.
+L<DBIx::Class::Schema> module set, based on what it creates at runtime.
The created schema class will have the same classname as the one on
which you are setting this option (and the ResultSource classes will be
The default behavior is instead to only replace the top portion of the
file, up to and including the final stanza which contains
-C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
+C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
leaving any customizations you placed after that as they were.
When C<really_erase_my_files> is not set, if the output file already exists,
Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
columns with the DATE/DATETIME/TIMESTAMP data_types.
-=head1 config_file
+=head2 datetime_undef_if_invalid
+
+Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
+datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
+TIMESTAMP columns.
+
+The default is recommended to deal with data such as C<00/00/00> which
+sometimes ends up in such columns in MySQL.
+
+=head2 config_file
File in Perl format, which should return a HASH reference, from which to read
loader options.
-=head1 preserve_case
+=head2 preserve_case
Usually column names are lowercased, to make them easier to work with in
L<DBIx::Class>. This option lets you turn this behavior off, if the driver
Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
setting this option.
-=head1 qualify_objects
+=head2 qualify_objects
Set to true to prepend the L</db_schema> to table names for C<<
__PACKAGE__->table >> calls, and to some other things like Oracle sequences.
+=head2 use_moose
+
+Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
+L<namespace::autoclean>. The default content after the md5 sum also makes the
+classes immutable.
+
+It is safe to upgrade your existing Schema to this option.
+
+=head2 col_collision_map
+
+This option controls how accessors for column names which collide with perl
+methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
+
+This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
+strings which are compiled to regular expressions that map to
+L<sprintf|perlfunc/sprintf> formats.
+
+Examples:
+
+ col_collision_map => 'column_%s'
+
+ col_collision_map => { '(.*)' => 'column_%s' }
+
+ col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
+
+=head2 rel_collision_map
+
+Works just like L</col_collision_map>, but for relationship names/accessors
+rather than column names/accessors.
+
+The default is to just append C<_rel> to the relationship name, see
+L</RELATIONSHIP NAME COLLISIONS>.
+
=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 resultset_components
+ left_base_classes additional_classes components
);
# ensure that a peice of object data is a valid arrayref, creating
my $self = { %args };
+ # don't lose undef options
+ for (values %$self) {
+ $_ = 0 unless defined $_;
+ }
+
bless $self => $class;
if (my $config_file = $self->config_file) {
additional_base_classes
left_base_classes
components
- resultset_components
/);
$self->_validate_class_args;
- push(@{$self->{components}}, 'ResultSetManager')
- if @{$self->{resultset_components}};
+ 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",
+ DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
+ }
+ }
$self->{monikers} = {};
$self->{classes} = {};
$self->{dump_directory} ||= $self->{temp_directory};
+ $self->real_dump_directory($self->{dump_directory});
+
$self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
$self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
$self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
$self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
+ if (my $col_collision_map = $self->col_collision_map) {
+ if (my $reftype = ref $col_collision_map) {
+ if ($reftype ne 'HASH') {
+ croak "Invalid type $reftype for option 'col_collision_map'";
+ }
+ }
+ else {
+ $self->col_collision_map({ '(.*)' => $col_collision_map });
+ }
+ }
+
$self;
}
my $filename = $self->_get_dump_filename($self->schema_class);
return unless -e $filename;
- open(my $fh, '<', $filename)
- or croak "Cannot open '$filename' for reading: $!";
+ my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
+ $self->_parse_generated_file($filename);
- my $load_classes = 0;
- my $result_namespace = '';
+ return unless $old_ver;
- while (<$fh>) {
- if (/^__PACKAGE__->load_classes;/) {
- $load_classes = 1;
- } elsif (/result_namespace => '([^']+)'/) {
- $result_namespace = $1;
- } elsif (my ($real_ver) =
- /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
+ # determine if the existing schema was dumped with use_moose => 1
+ if (! defined $self->use_moose) {
+ $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
+ }
+
+ my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
+ my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
- if ($load_classes && (not defined $self->use_namespaces)) {
- warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+ if ($load_classes && (not defined $self->use_namespaces)) {
+ warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
'load_classes;' static schema detected, turning off 'use_namespaces'.
See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
details.
EOF
- $self->use_namespaces(0);
- }
- elsif ($load_classes && $self->use_namespaces) {
- $self->_upgrading_from_load_classes(1);
- }
- elsif ((not $load_classes) && defined $self->use_namespaces
- && (not $self->use_namespaces)) {
- $self->_downgrading_to_load_classes(
- $result_namespace || 'Result'
- );
- }
- elsif ((not defined $self->use_namespaces)
- || $self->use_namespaces) {
- if (not $self->result_namespace) {
- $self->result_namespace($result_namespace || 'Result');
- }
- elsif ($result_namespace ne $self->result_namespace) {
- $self->_rewriting_result_namespace(
- $result_namespace || 'Result'
- );
- }
- }
+ $self->use_namespaces(0);
+ }
+ elsif ($load_classes && $self->use_namespaces) {
+ $self->_upgrading_from_load_classes(1);
+ }
+ elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
+ $self->_downgrading_to_load_classes(
+ $result_namespace || 'Result'
+ );
+ }
+ elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
+ if (not $self->result_namespace) {
+ $self->result_namespace($result_namespace || 'Result');
+ }
+ elsif ($result_namespace ne $self->result_namespace) {
+ $self->_rewriting_result_namespace(
+ $result_namespace || 'Result'
+ );
+ }
+ }
- # XXX when we go past .0 this will need fixing
- my ($v) = $real_ver =~ /([1-9])/;
- $v = "v$v";
+ # XXX when we go past .0 this will need fixing
+ my ($v) = $old_ver =~ /([1-9])/;
+ $v = "v$v";
- last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
+ return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
- if (not %{ $self->naming }) {
- warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+ if (not %{ $self->naming }) {
+ warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
-Version $real_ver static schema detected, turning on backcompat mode.
+Version $old_ver static schema detected, turning on backcompat mode.
Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
to disable this warning.
See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
from version 0.04006.
EOF
- }
- else {
- $self->_upgrading_from($v);
- last;
- }
-
- $self->naming->{relationships} ||= $v;
- $self->naming->{monikers} ||= $v;
- $self->naming->{column_accessors} ||= $v;
- $self->schema_version_to_dump($real_ver);
+ $self->naming->{relationships} ||= $v;
+ $self->naming->{monikers} ||= $v;
+ $self->naming->{column_accessors} ||= $v;
- last;
- }
+ $self->schema_version_to_dump($old_ver);
+ }
+ else {
+ $self->_upgrading_from($v);
}
- close $fh;
}
sub _validate_class_args {
my $self = shift;
my $args = shift;
-
+
foreach my $k (@CLASS_ARGS) {
next unless $self->$k;
my $fullpath = File::Spec->catfile($prefix, $file);
return $fullpath if -f $fullpath
# abs_path throws on Windows for nonexistant files
- and eval { Cwd::abs_path($fullpath) } ne
- (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
+ and (try { Cwd::abs_path($fullpath) }) ne
+ ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
}
return;
warn qq/# Loaded external class definition for '$class'\n/
if $self->debug;
- open(my $fh, '<', $real_inc_path)
- or croak "Failed to open '$real_inc_path' for reading: $!";
- my $code = do { local $/; <$fh> };
- close($fh)
- or croak "Failed to close $real_inc_path: $!";
- $code = $self->_rewrite_old_classnames($code);
+ my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
if ($self->dynamic) { # load the class too
- # kill redefined warnings
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
- };
- eval $code;
- die $@ if $@;
+ eval_without_redefine_warnings($code);
}
$self->_ext_stmt($class,
* PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
new name of the Result.
EOF
- # kill redefined warnings
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
- };
- eval $code;
- die $@ if $@;
+ eval_without_redefine_warnings($code);
}
chomp $code;
}
sub _relbuilder {
- no warnings 'uninitialized';
my ($self) = @_;
return if $self->{skip_relationships};
- if ($self->naming->{relationships} eq 'v4') {
- require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
- return $self->{relbuilder} ||=
- DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
- $self->schema,
- $self->inflect_plural,
- $self->inflect_singular,
- $self->relationship_attrs,
- );
- }
- elsif ($self->naming->{relationships} eq 'v5') {
- require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
- return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
- $self->schema,
- $self->inflect_plural,
- $self->inflect_singular,
- $self->relationship_attrs,
- );
- }
- elsif ($self->naming->{relationships} eq 'v6') {
- require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
- return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
- $self->schema,
- $self->inflect_plural,
- $self->inflect_singular,
- $self->relationship_attrs,
- );
- }
+ return $self->{relbuilder} ||= do {
- return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
- $self->schema,
- $self->inflect_plural,
- $self->inflect_singular,
- $self->relationship_attrs,
- );
+ no warnings 'uninitialized';
+ my $relbuilder_suff =
+ {qw{
+ v4 ::Compat::v0_040
+ v5 ::Compat::v0_05
+ v6 ::Compat::v0_06
+ }}
+ ->{ $self->naming->{relationships}};
+
+ my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
+ load_class $relbuilder_class;
+ $relbuilder_class->new( $self );
+
+ };
}
sub _load_tables {
local $self->{dump_directory} = $self->{temp_directory};
$self->_reload_classes(\@tables);
$self->_load_relationships($_) for @tables;
+# $self->_relbuilder->cleanup; # this breaks perl 5.8.x
$self->{quiet} = 0;
# Remove that temp dir from INC so it doesn't get reloaded
# Reload without unloading first to preserve any symbols from external
# packages.
- $self->_reload_classes(\@tables, 0);
+ $self->_reload_classes(\@tables, { unload => 0 });
# Drop temporary cache
delete $self->{_cache};
}
sub _reload_classes {
- my ($self, $tables, $unload) = @_;
+ my ($self, $tables, $opts) = @_;
my @tables = @$tables;
+
+ my $unload = $opts->{unload};
$unload = 1 unless defined $unload;
# so that we don't repeat custom sections
{
no warnings 'redefine';
- local *Class::C3::reinitialize = sub {};
+ local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
use warnings;
+ if (my $mc = $self->_moose_metaclass($class)) {
+ $mc->make_mutable;
+ }
Class::Unload->unload($class) if $unload;
my ($source, $resultset_class);
if (
&& ($resultset_class ne 'DBIx::Class::ResultSet')
) {
my $has_file = Class::Inspector->loaded_filename($resultset_class);
+ if (my $mc = $self->_moose_metaclass($resultset_class)) {
+ $mc->make_mutable;
+ }
Class::Unload->unload($resultset_class) if $unload;
$self->_reload_class($resultset_class) if $has_file;
}
}
}
+sub _moose_metaclass {
+ return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
+
+ my $class = $_[1];
+
+ my $mc = try { Class::MOP::class_of($class) }
+ or return undef;
+
+ return $mc->isa('Moose::Meta::Class') ? $mc : undef;
+}
+
# We use this instead of ensure_class_loaded when there are package symbols we
# want to preserve.
sub _reload_class {
delete $INC{ $class_path };
# kill redefined warnings
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
+ try {
+ eval_without_redefine_warnings ("require $class");
+ }
+ catch {
+ my $source = slurp $self->_get_dump_filename($class);
+ die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
};
- eval "require $class;";
}
sub _get_dump_filename {
return $self->dump_directory . q{/} . $class . q{.pm};
}
+=head2 get_dump_filename
+
+Arguments: class
+
+Returns the full path to the file for a class that the class has been or will
+be dumped to. This is a file in a temp dir for a dynamic schema.
+
+=cut
+
+sub get_dump_filename {
+ my ($self, $class) = (@_);
+
+ local $self->{dump_directory} = $self->real_dump_directory;
+
+ return $self->_get_dump_filename($class);
+}
+
sub _ensure_dump_subdirs {
my ($self, $class) = (@_);
my $schema_text =
qq|package $schema_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|use base '$schema_base_class';\n\n|;
+ . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
+
+ if ($self->use_moose) {
+ $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
+ }
+ else {
+ $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
+ }
if ($self->use_namespaces) {
$schema_text .= qq|__PACKAGE__->load_namespaces|;
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|use base '$result_base_class';\n\n|;
+ . qq|use strict;\nuse warnings;\n\n|;
+ 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|;
+ }
+ else {
+ $src_text .= qq|\nextends '$result_base_class';\n\n|;
+ }
+ }
+ else {
+ $src_text .= qq|use base '$result_base_class';\n\n|;
+ }
$self->_write_classfile($src_class, $src_text);
}
warn "Deleting existing file '$filename' due to "
. "'really_erase_my_files' setting\n" unless $self->{quiet};
unlink($filename);
- }
+ }
- my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
+ my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
+ = $self->_parse_generated_file($filename);
- if (my $old_class = $self->_upgrading_classes->{$class}) {
- my $old_filename = $self->_get_dump_filename($old_class);
+ if (! $old_gen && -f $filename) {
+ croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
+ . " it does not appear to have been generated by Loader"
+ }
- my ($old_custom_content) = $self->_get_custom_content(
- $old_class, $old_filename, 0 # do not add default comment
- );
+ my $custom_content = $old_custom || '';
+
+ # prepend extra custom content from a *renamed* class (singularization effect)
+ if (my $renamed_class = $self->_upgrading_classes->{$class}) {
+ my $old_filename = $self->_get_dump_filename($renamed_class);
- $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
+ if (-f $old_filename) {
+ my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
- if ($old_custom_content) {
- $custom_content =
- "\n" . $old_custom_content . "\n" . $custom_content;
+ $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
+
+ $custom_content = join ("\n", '', $extra_custom, $custom_content)
+ if $extra_custom;
+
+ unlink $old_filename;
}
+ }
- unlink $old_filename;
+ $custom_content ||= $self->_default_custom_content($is_schema);
+
+ # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
+ # If there is already custom content, which does not have the Moose content, add it.
+ if ($self->use_moose) {
+
+ my $non_moose_custom_content = do {
+ local $self->{use_moose} = 0;
+ $self->_default_custom_content;
+ };
+
+ if ($custom_content eq $non_moose_custom_content) {
+ $custom_content = $self->_default_custom_content($is_schema);
+ }
+ elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
+ $custom_content .= $self->_default_custom_content($is_schema);
+ }
+ }
+ elsif (defined $self->use_moose && $old_gen) {
+ croak 'It is not possible to "downgrade" a schema that was loaded with use_moose => 1 to use_moose => 0, due to differing custom content'
+ if $old_gen =~ /use \s+ MooseX?\b/x;
}
$custom_content = $self->_rewrite_old_classnames($custom_content);
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) {
return unless $self->_upgrading_from && $is_schema;
}
or croak "Error closing '$filename': $!";
}
-sub _default_custom_content {
- return qq|\n\n# You can replace this text with custom|
- . qq| content, and it will be preserved on regeneration|
- . qq|\n1;\n|;
+sub _default_moose_custom_content {
+ my ($self, $is_schema) = @_;
+
+ if (not $is_schema) {
+ return qq|\n__PACKAGE__->meta->make_immutable;|;
+ }
+
+ return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
}
-sub _get_custom_content {
- my ($self, $class, $filename, $add_default) = @_;
+sub _default_custom_content {
+ my ($self, $is_schema) = @_;
+ my $default = qq|\n\n# You can replace this text with custom|
+ . qq| code or comments, and it will be preserved on regeneration|;
+ if ($self->use_moose) {
+ $default .= $self->_default_moose_custom_content($is_schema);
+ }
+ $default .= qq|\n1;\n|;
+ return $default;
+}
- $add_default = 1 unless defined $add_default;
+sub _parse_generated_file {
+ my ($self, $fn) = @_;
- return ($self->_default_custom_content) if ! -f $filename;
+ return unless -f $fn;
- open(my $fh, '<', $filename)
- or croak "Cannot open '$filename' for reading: $!";
+ open(my $fh, '<', $fn)
+ or croak "Cannot open '$fn' for reading: $!";
- my $mark_re =
+ my $mark_re =
qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
- my $buffer = '';
- my ($md5, $ts, $ver);
+ my ($md5, $ts, $ver, $gen);
while(<$fh>) {
- if(!$md5 && /$mark_re/) {
+ if(/$mark_re/) {
+ my $pre_md5 = $1;
$md5 = $2;
- my $line = $1;
- # Pull out the previous version and timestamp
- ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
+ # Pull out the version and timestamp from the line above
+ ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
- $buffer .= $line;
- croak "Checksum mismatch in '$filename', 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($buffer) ne $md5;
+ $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;
- $buffer = '';
+ last;
}
else {
- $buffer .= $_;
+ $gen .= $_;
}
}
- croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
- . " it does not appear to have been generated by Loader"
- if !$md5;
+ my $custom = do { local $/; <$fh> }
+ if $md5;
- # Default custom content:
- $buffer ||= $self->_default_custom_content if $add_default;
+ close ($fh);
- return ($buffer, $md5, $ver, $ts);
+ return ($gen, $md5, $ver, $ts, $custom);
}
sub _use {
sub _inject {
my $self = shift;
my $target = shift;
- my $schema_class = $self->schema_class;
my $blist = join(q{ }, @_);
- warn "$target: use base qw/ $blist /;" if $self->debug && @_;
- $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
+
+ return unless $blist;
+
+ warn "$target: use base qw/$blist/;" if $self->debug;
+ $self->_raw_stmt($target, "use base qw/$blist/;");
}
sub _result_namespace {
$self->_dbic_stmt($table_class, 'load_components', @components);
}
- $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
- if @{$self->resultset_components};
$self->_inject($table_class, @{$self->additional_base_classes});
}
-sub _resolve_col_accessor_collisions {
- my ($self, $col_info) = @_;
+sub _is_result_class_method {
+ my ($self, $name) = @_;
- my $base = $self->result_base_class || 'DBIx::Class::Core';
- my @components = map "DBIx::Class::$_", @{ $self->components || [] };
+ if (not $self->_result_class_methods) {
+ my (@methods, %methods);
+ my $base = $self->result_base_class || 'DBIx::Class::Core';
+ my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
- my @methods;
+ for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
+ load_class $class;
- for my $class ($base, @components) {
- eval "require ${class};";
- die $@ if $@;
+ push @methods, @{ Class::Inspector->methods($class) || [] };
+ }
+
+ push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
+
+ @methods{@methods} = ();
- push @methods, @{ Class::Inspector->methods($class) || [] };
+ # futureproof meta
+ $methods{meta} = undef;
+
+ $self->_result_class_methods(\%methods);
}
+ my $result_methods = $self->_result_class_methods;
+
+ return exists $result_methods->{$name};
+}
- my %methods;
- @methods{@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 (exists $methods{$accessor}) {
- $info->{accessor} = undef;
+ if ($self->_is_result_class_method($accessor)) {
+ my $mapped = 0;
+
+ if (my $map = $self->col_collision_map) {
+ for my $re (keys %$map) {
+ if (my @matches = $col =~ /$re/) {
+ $info->{accessor} = sprintf $map->{$re}, @matches;
+ $mapped = 1;
+ }
+ }
+ }
+
+ if (not $mapped) {
+ warn <<"EOF";
+Column '$col' in table '$table_name' collides with an inherited method.
+See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
+EOF
+ $info->{accessor} = undef;
+ }
}
}
}
-sub _make_column_accessor_name {
- my ($self, $column_name) = @_;
+# use the same logic to run moniker_map, column_accessor_map, and
+# relationship_name_map
+sub _run_user_map {
+ my ( $self, $map, $default_code, $ident, @extra ) = @_;
+
+ my $default_ident = $default_code->( $ident, @extra );
+ my $new_ident;
+ if( $map && ref $map eq 'HASH' ) {
+ $new_ident = $map->{ $ident };
+ }
+ elsif( $map && ref $map eq 'CODE' ) {
+ $new_ident = $map->( $ident, $default_ident, @extra );
+ }
+
+ $new_ident ||= $default_ident;
+
+ return $new_ident;
+}
+
+sub _default_column_accessor_name {
+ my ( $self, $column_name ) = @_;
+
+ my $accessor_name = $column_name;
+ $accessor_name =~ s/\W+/_/g;
+
+ if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
+ # older naming just lc'd the col accessor and that's all.
+ return lc $accessor_name;
+ }
return join '_', map lc, split_name $column_name;
+
+}
+
+sub _make_column_accessor_name {
+ my ($self, $column_name, $column_context_info ) = @_;
+
+ my $accessor = $self->_run_user_map(
+ $self->column_accessor_map,
+ sub { $self->_default_column_accessor_name( shift ) },
+ $column_name,
+ $column_context_info,
+ );
+
+ return $accessor;
}
# Set up metadata (cols, pks, etc)
$table_name = \ $self->_quote_table_name($table_name);
}
- $self->_dbic_stmt($table_class, 'table', ($self->qualify_objects ? ($self->db_schema . '.') : '') . $table_name);
+ my $full_table_name = ($self->qualify_objects ? ($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;
+
+ $self->_dbic_stmt($table_class, 'table', $full_table_name);
- my $cols = $self->_table_columns($table);
+ my $cols = $self->_table_columns($table);
my $col_info = $self->__columns_info_for($table);
+ ### generate all the column accessor names
while (my ($col, $info) = each %$col_info) {
- if ($col =~ /\W/) {
- ($info->{accessor} = $col) =~ s/\W+/_/g;
- }
- }
+ # hashref of other info that could be used by
+ # user-defined accessor map functions
+ my $context = {
+ table_class => $table_class,
+ table_moniker => $table_moniker,
+ table_name => $table_name,
+ full_table_name => $full_table_name,
+ schema_class => $schema_class,
+ column_info => $info,
+ };
- if ($self->preserve_case) {
- while (my ($col, $info) = each %$col_info) {
- if ($col ne lc($col)) {
- if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
- $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
- }
- else {
- $info->{accessor} = lc($info->{accessor} || $col);
- }
- }
- }
- }
- else {
- # XXX this needs to go away
- $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
+ $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
}
- $self->_resolve_col_accessor_collisions($col_info);
+ $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
+
+ # prune any redundant accessor names
+ while (my ($col, $info) = each %$col_info) {
+ no warnings 'uninitialized';
+ delete $info->{accessor} if $info->{accessor} eq $col;
+ }
my $fks = $self->_table_fk_info($table);
- for my $fkdef (@$fks) {
+ foreach my $fkdef (@$fks) {
for my $col (@{ $fkdef->{local_columns} }) {
$col_info->{$col}{is_foreign_key} = 1;
}
}
+
+ my $pks = $self->_table_pk_info($table) || [];
+
+ foreach my $pkcol (@$pks) {
+ $col_info->{$pkcol}{is_nullable} = 0;
+ }
+
$self->_dbic_stmt(
$table_class,
'add_columns',
my %uniq_tag; # used to eliminate duplicate uniqs
- my $pks = $self->_table_pk_info($table) || [];
@$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
sub _table2moniker {
my ( $self, $table ) = @_;
- my $moniker;
-
- if( ref $self->moniker_map eq 'HASH' ) {
- $moniker = $self->moniker_map->{$table};
- }
- elsif( ref $self->moniker_map eq 'CODE' ) {
- $moniker = $self->moniker_map->($table);
- }
-
- $moniker ||= $self->_default_table2moniker($table);
-
- return $moniker;
+ $self->_run_user_map(
+ $self->moniker_map,
+ sub { $self->_default_table2moniker( shift ) },
+ $table
+ );
}
sub _load_relationships {
my ($table) = @_;
my $pcm = $self->pod_comment_mode;
my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
- if ( $self->can('_table_comment') ) {
- $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));
- }
+ $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;
} elsif ( $method eq 'add_columns' ) {
$self->_pod( $class, "=head1 ACCESSORS" );
my $col_counter = 0;
- my @cols = @_;
+ my @cols = @_;
while( my ($name,$attrs) = splice @cols,0,2 ) {
- $col_counter++;
+ $col_counter++;
$self->_pod( $class, '=head2 ' . $name );
- $self->_pod( $class,
- join "\n", map {
- my $s = $attrs->{$_};
- $s = !defined $s ? 'undef' :
- length($s) == 0 ? '(empty string)' :
- ref($s) eq 'SCALAR' ? $$s :
- ref($s) ? do {
- my $dd = Dumper;
- $dd->Indent(0);
- $dd->Values([$s]);
- $dd->Dump;
- } :
- looks_like_number($s) ? $s :
- qq{'$s'}
- ;
-
- " $_: $s"
- } sort keys %$attrs,
- );
-
- if( $self->can('_column_comment')
- and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
- ) {
- $self->_pod( $class, $comment );
- }
+ $self->_pod( $class,
+ join "\n", map {
+ my $s = $attrs->{$_};
+ $s = !defined $s ? 'undef' :
+ length($s) == 0 ? '(empty string)' :
+ ref($s) eq 'SCALAR' ? $$s :
+ ref($s) ? dumper_squashed $s :
+ looks_like_number($s) ? $s : qq{'$s'};
+
+ " $_: $s"
+ } sort keys %$attrs,
+ );
+ if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
+ $self->_pod( $class, $comment );
+ }
}
$self->_pod_cut( $class );
} elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
}
}
+sub _filter_comment {
+ my ($self, $txt) = @_;
+
+ $txt = '' if not defined $txt;
+
+ $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
+
+ return $txt;
+}
+
+sub __table_comment {
+ my $self = shift;
+
+ if (my $code = $self->can('_table_comment')) {
+ return $self->_filter_comment($self->$code(@_));
+ }
+
+ return '';
+}
+
+sub __column_comment {
+ my $self = shift;
+
+ if (my $code = $self->can('_column_comment')) {
+ return $self->_filter_comment($self->$code(@_));
+ }
+
+ return '';
+}
+
# Stores a POD documentation
sub _pod {
my ($self, $class, $stmt) = @_;
sub _unregister_source_for_table {
my ($self, $table) = @_;
- eval {
+ try {
local $@;
my $schema = $self->schema;
# in older DBIC it's a private method
contain multiple entries per table for the original and normalized table
names, as above in L</monikers>.
+=head1 COLUMN ACCESSOR COLLISIONS
+
+Occasionally you may have a column name that collides with a perl method, such
+as C<can>. In such cases, the default action is to set the C<accessor> of the
+column spec to C<undef>.
+
+You can then name the accessor yourself by placing code such as the following
+below the md5:
+
+ __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
+
+Another option is to use the L</col_collision_map> option.
+
+=head1 RELATIONSHIP NAME COLLISIONS
+
+In very rare cases, you may get a collision between a generated relationship
+name and a method in your Result class, for example if you have a foreign key
+called C<belongs_to>.
+
+This is a problem because relationship names are also relationship accessor
+methods in L<DBIx::Class>.
+
+The default behavior is to append C<_rel> to the relationship name and print
+out a warning that refers to this text.
+
+You can also control the renaming with the L</rel_collision_map> option.
+
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader>
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff