X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=03a302186cd5e6b9331f0dafc017a8033293874e;hb=1fa1884903b09903ce89a3814e41bac9e91eea9d;hp=516a402039f7d96b54f3a3a560f8ec913df03a9e;hpb=ffc705f30a24e37a4bcbe81a1d26b1556232efec;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index 516a402..03a3021 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -2,7 +2,7 @@ package DBIx::Class::Schema::Loader::Base; use strict; use warnings; -use base qw/Class::Accessor::Fast Class::C3::Componentised/; +use base qw/Class::Accessor::Grouped Class::C3::Componentised/; use Class::C3; use Carp::Clan qw/^DBIx::Class/; use DBIx::Class::Schema::Loader::RelBuilder; @@ -16,9 +16,9 @@ use File::Temp qw//; use Class::Unload; require DBIx::Class; -our $VERSION = '0.04999_12'; +our $VERSION = '0.04999_13'; -__PACKAGE__->mk_ro_accessors(qw/ +__PACKAGE__->mk_group_ro_accessors('simple', qw/ schema schema_class @@ -30,6 +30,7 @@ __PACKAGE__->mk_ro_accessors(qw/ components resultset_components skip_relationships + skip_load_external moniker_map inflect_singular inflect_plural @@ -43,6 +44,9 @@ __PACKAGE__->mk_ro_accessors(qw/ default_resultset_class schema_base_class result_base_class + overwrite_modifications + + relationship_attrs db_schema _tables @@ -51,9 +55,10 @@ __PACKAGE__->mk_ro_accessors(qw/ monikers dynamic naming - /); +/); + -__PACKAGE__->mk_accessors(qw/ +__PACKAGE__->mk_group_accessors('simple', qw/ version_to_dump schema_version_to_dump _upgrading_from @@ -82,6 +87,11 @@ L. Available constructor options ar Skip setting up relationships. The default is to attempt the loading of relationships. +=head2 skip_load_external + +Skip loading of other classes in @INC. The default is to merge all other classes +with the same name found in @INC into the schema file we are creating. + =head2 naming Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX @@ -145,6 +155,26 @@ next major version upgrade: __PACKAGE__->naming('v5'); +=head2 relationship_attrs + +Hashref of attributes to pass to each generated relationship, listed +by type. Also supports relationship type 'all', containing options to +pass to all generated relationships. Attributes set for more specific +relationship types override those set in 'all'. + +For example: + + relationship_attrs => { + all => { cascade_delete => 0 }, + has_many => { cascade_delete => 1 }, + }, + +will set the C option to 0 for all generated relationships, +except for C, which will have cascade_delete as 1. + +NOTE: this option is not supported if v4 backward-compatible naming is +set either globally (naming => 'v4') or just for relationships. + =head2 debug If set to true, each constructive L statement the loader @@ -284,6 +314,19 @@ You should really be using version control on your schema classes (and all of the rest of your code for that matter). Don't blame me if a bug in this code wipes something out when it shouldn't have, you've been warned. +=head2 overwrite_modifications + +Default false. If false, when updating existing files, Loader will +refuse to modify any Loader-generated code that has been modified +since its last run (as determined by the checksum Loader put in its +comment lines). + +If true, Loader will discard any manual modifications that have been +made to Loader-generated code. + +Again, you should be using version control on your schema classes. Be +careful with this option. + =head1 METHODS None of these methods are intended for direct invocation by regular @@ -417,7 +460,7 @@ EOF my ($v) = $real_ver =~ /([1-9])/; $v = "v$v"; - last if $v eq CURRENT_V; + last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/; if (not %{ $self->naming }) { warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; @@ -453,7 +496,7 @@ sub _find_file_in_inc { my $fullpath = File::Spec->catfile($prefix, $file); return $fullpath if -f $fullpath and Cwd::abs_path($fullpath) ne - Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || ''; + (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || ''); } return; @@ -475,9 +518,26 @@ sub _find_class_in_inc { return $self->_find_file_in_inc($self->_class_path($class)); } +sub _rewrite_old_classnames { + my ($self, $code) = @_; + + return $code unless $self->_upgrading_from; + + my %old_classes = reverse %{ $self->_upgrading_classes }; + + my $re = join '|', keys %old_classes; + $re = qr/\b($re)\b/; + + $code =~ s/$re/$old_classes{$1}/eg; + + return $code; +} + sub _load_external { my ($self, $class) = @_; + return if $self->{skip_load_external}; + # so that we don't load our own classes, under any circumstances local *INC = [ grep $_ ne $self->dump_directory, @INC ]; @@ -498,6 +558,22 @@ sub _load_external { 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); + + 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 $@; + } + $self->_ext_stmt($class, qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n| .qq|# They are now part of the custom portion of this file\n| @@ -506,24 +582,11 @@ sub _load_external { .qq|# will be repeated redundantly when you re-create this\n| .qq|# file again via Loader!\n| ); - while(<$fh>) { - chomp; - $self->_ext_stmt($class, $_); - } + chomp $code; + $self->_ext_stmt($class, $code); $self->_ext_stmt($class, qq|# End of lines loaded from '$real_inc_path' | ); - close($fh) - or croak "Failed to close $real_inc_path: $!"; - - if ($self->dynamic) { # load the class too - # kill redefined warnings - local $SIG{__WARN__} = sub { - warn @_ unless $_[0] =~ /^Subroutine \S+ redefined/; - }; - do $real_inc_path; - die $@ if $@; - } } if ($old_real_inc_path) { @@ -531,10 +594,17 @@ sub _load_external { or croak "Failed to open '$old_real_inc_path' for reading: $!"; $self->_ext_stmt($class, <<"EOF"); -# These lines were loaded from '$old_real_inc_path', based on the Result class -# name that would have been created by an 0.04006 version of the Loader. For a -# static schema, this happens only once during upgrade. +# These lines were loaded from '$old_real_inc_path', +# based on the Result class name that would have been created by an 0.04006 +# version of the Loader. For a static schema, this happens only once during +# upgrade. EOF + + my $code = do { + local ($/, @ARGV) = (undef, $old_real_inc_path); <> + }; + $code = $self->_rewrite_old_classnames($code); + if ($self->dynamic) { warn <<"EOF"; @@ -545,27 +615,20 @@ been used by an 0.04006 version of the Loader. new name of the Result. EOF # kill redefined warnings + my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; local $SIG{__WARN__} = sub { - warn @_ unless $_[0] =~ /^Subroutine \S+ redefined/; + $warn_handler->(@_) + unless $_[0] =~ /^Subroutine \S+ redefined/; }; - my $code = do { - local ($/, @ARGV) = (undef, $old_real_inc_path); <> - }; - $code =~ s/$old_class/$class/g; eval $code; die $@ if $@; } - while(<$fh>) { - chomp; - $self->_ext_stmt($class, $_); - } + chomp $code; + $self->_ext_stmt($class, $code); $self->_ext_stmt($class, qq|# End of lines loaded from '$old_real_inc_path' | ); - - close($fh) - or croak "Failed to close $old_real_inc_path: $!"; } } @@ -629,8 +692,11 @@ sub _relbuilder { ); } - $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new( - $self->schema, $self->inflect_plural, $self->inflect_singular + $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new ( + $self->schema, + $self->inflect_plural, + $self->inflect_singular, + $self->relationship_attrs, ); } @@ -736,10 +802,11 @@ sub _reload_class { delete $INC{ $class_path }; # kill redefined warnings + my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; local $SIG{__WARN__} = sub { - warn @_ unless $_[0] =~ /^Subroutine \S+ redefined/; + $warn_handler->(@_) + unless $_[0] =~ /^Subroutine \S+ redefined/; }; - eval "require $class;"; } @@ -866,6 +933,8 @@ sub _write_classfile { } } + $custom_content = $self->_rewrite_old_classnames($custom_content); + $text .= qq|$_\n| for @{$self->{_dump_storage}->{$class} || []}; @@ -933,8 +1002,8 @@ sub _get_custom_content { ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s; $buffer .= $line; - croak "Checksum mismatch in '$filename'" - if Digest::MD5::md5_base64($buffer) ne $md5; + 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; $buffer = ''; } @@ -1172,9 +1241,29 @@ sub _tables_list { croak "ABSTRACT METHOD" } # Execute a constructive DBIC class method, with debug/dump_to_dir hooks. sub _dbic_stmt { - my $self = shift; - my $class = shift; + my $self = shift; + my $class = shift; my $method = shift; + + # generate the pod for this statement, storing it with $self->_pod + $self->_make_pod( $class, $method, @_ ); + + my $args = dump(@_); + $args = '(' . $args . ')' if @_ < 2; + my $stmt = $method . $args . q{;}; + + warn qq|$class\->$stmt\n| if $self->debug; + $self->_raw_stmt($class, '__PACKAGE__->' . $stmt); + return; +} + +# generates the accompanying pod for a DBIC class method statement, +# storing it with $self->_pod +sub _make_pod { + my $self = shift; + my $class = shift; + my $method = shift; + if ( $method eq 'table' ) { my ($table) = @_; $self->_pod( $class, "=head1 NAME" ); @@ -1188,14 +1277,27 @@ sub _dbic_stmt { $self->_pod_cut( $class ); } elsif ( $method eq 'add_columns' ) { $self->_pod( $class, "=head1 ACCESSORS" ); - my $i = 0; - foreach ( @_ ) { - $i++; - next unless $i % 2; - $self->_pod( $class, '=head2 ' . $_ ); - my $comment; - $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1 ) if $self->can('_column_comment'); - $self->_pod( $class, $comment ) if $comment; + my $col_counter = 0; + my @cols = @_; + while( my ($name,$attrs) = splice @cols,0,2 ) { + $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)' : + $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_cut( $class ); } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) { @@ -1207,13 +1309,6 @@ sub _dbic_stmt { $self->_pod_cut( $class ); $self->{_relations_started} { $class } = 1; } - my $args = dump(@_); - $args = '(' . $args . ')' if @_ < 2; - my $stmt = $method . $args . q{;}; - - warn qq|$class\->$stmt\n| if $self->debug; - $self->_raw_stmt($class, '__PACKAGE__->' . $stmt); - return; } # Stores a POD documentation