use Class::Inspector ();
use Scalar::Util 'looks_like_number';
use File::Slurp 'slurp';
-use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed/;
+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 namespace::clean;
-our $VERSION = '0.07001';
+our $VERSION = '0.07002';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
pod_comment_mode
pod_comment_spillover_length
preserve_case
+ col_collision_map
/);
=head1 NAME
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,
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' }
+
=head1 METHODS
None of these methods are intended for direct invocation by regular
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.\nYou are missing: %s.\n",
- "Moose, MooseX::NonMoose and namespace::autoclean",
+ 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->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;
}
# 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;
+ $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
}
my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
$code = $self->_rewrite_old_classnames($code);
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;
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/;
+ eval {
+ eval_without_redefine_warnings ("require $class");
};
- eval "require $class;";
die "Failed to reload class $class: $@" if $@;
}
$custom_content .= $self->_default_custom_content;
}
}
+ 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);
sub _default_custom_content {
my $self = shift;
my $default = qq|\n\n# You can replace this text with custom|
- . qq| content, and it will be preserved on regeneration|;
+ . qq| code or comments, and it will be preserved on regeneration|;
if ($self->use_moose) {
$default .= $self->_default_moose_custom_content;
}
}
sub _resolve_col_accessor_collisions {
- my ($self, $col_info) = @_;
+ my ($self, $table, $col_info) = @_;
my $base = $self->result_base_class || 'DBIx::Class::Core';
my @components = map "DBIx::Class::$_", @{ $self->components || [] };
+ my $table_name = ref $table ? $$table : $table;
+
my @methods;
for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
die $@ if $@;
push @methods, @{ Class::Inspector->methods($class) || [] };
+ push @methods, @{ Class::Inspector->methods('UNIVERSAL') || [] };
}
my %methods;
next if $accessor eq 'id'; # special case (very common column)
if (exists $methods{$accessor}) {
- $info->{accessor} = undef;
+ 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;
+ }
}
}
}
$col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
}
- $self->_resolve_col_accessor_collisions($col_info);
+ $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
my $fks = $self->_table_fk_info($table);
} 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) ? 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)) {
- $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)$/ ) {
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 SEE ALSO
L<DBIx::Class::Schema::Loader>
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff