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=ea22c4f4e3411791fc746c069061ec95faa1a770;hpb=61b3350655e40b9f9f7ef3066ce4ce76dcb75107;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 ea22c4f..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,19 +44,24 @@ __PACKAGE__->mk_ro_accessors(qw/ default_resultset_class schema_base_class result_base_class + overwrite_modifications + + relationship_attrs db_schema _tables classes + _upgrading_classes monikers dynamic naming - _upgrading_from - /); +/); + -__PACKAGE__->mk_accessors(qw/ +__PACKAGE__->mk_group_accessors('simple', qw/ version_to_dump schema_version_to_dump + _upgrading_from /); =head1 NAME @@ -81,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 @@ -144,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 @@ -283,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 @@ -291,6 +335,8 @@ can also be found via standard L methods somehow. =cut +use constant CURRENT_V => 'v5'; + # ensure that a peice of object data is a valid arrayref, creating # an empty one or encapsulating whatever's there. sub _ensure_arrayref { @@ -329,6 +375,7 @@ sub new { $self->{monikers} = {}; $self->{classes} = {}; + $self->{_upgrading_classes} = {}; $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); $self->{schema} ||= $self->{schema_class}; @@ -348,7 +395,7 @@ sub new { $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION); $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION); - if (not ref $self->naming && defined $self->naming) { + if ((not ref $self->naming) && defined $self->naming) { my $naming_ver = $self->naming; $self->{naming} = { relationships => $naming_ver, @@ -356,6 +403,13 @@ sub new { }; } + if ($self->naming) { + for (values %{ $self->naming }) { + $_ = CURRENT_V if $_ eq 'current'; + } + } + $self->{naming} ||= {}; + $self->_check_back_compat; $self; @@ -369,6 +423,22 @@ sub _check_back_compat { # just in case, though no one is likely to dump a dynamic schema $self->schema_version_to_dump('0.04006'); + if (not %{ $self->naming }) { + warn <_upgrading_from('v4'); + } + $self->naming->{relationships} ||= 'v4'; $self->naming->{monikers} ||= 'v4'; @@ -386,15 +456,33 @@ sub _check_back_compat { if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) { my $real_ver = $1; - $self->schema_version_to_dump($real_ver); - # XXX when we go past .0 this will need fixing my ($v) = $real_ver =~ /([1-9])/; $v = "v$v"; + last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/; + + if (not %{ $self->naming }) { + warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; + +Version $real_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 for more +details. +EOF + } + else { + $self->_upgrading_from($v); + } + $self->naming->{relationships} ||= $v; $self->naming->{monikers} ||= $v; + $self->schema_version_to_dump($real_ver); + last; } } @@ -408,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; @@ -430,42 +518,117 @@ 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 ]; + my $real_inc_path = $self->_find_class_in_inc($class); - return if !$real_inc_path; - - # If we make it to here, we loaded an external definition - 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: $!"; - $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| - .qq|# for you to hand-edit. If you do not either delete\n| - .qq|# this section or remove that file from \@INC, this section\n| - .qq|# will be repeated redundantly when you re-create this\n| - .qq|# file again via Loader!\n| - ); - while(<$fh>) { - chomp; - $self->_ext_stmt($class, $_); + my $old_class = $self->_upgrading_classes->{$class} + if $self->_upgrading_from; + + my $old_real_inc_path = $self->_find_class_in_inc($old_class) + if $old_class && $old_class ne $class; + + return unless $real_inc_path || $old_real_inc_path; + + if ($real_inc_path) { + # If we make it to here, we loaded an external definition + 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); + + 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| + .qq|# for you to hand-edit. If you do not either delete\n| + .qq|# this section or remove that file from \@INC, this section\n| + .qq|# will be repeated redundantly when you re-create this\n| + .qq|# file again via Loader!\n| + ); + chomp $code; + $self->_ext_stmt($class, $code); + $self->_ext_stmt($class, + qq|# End of lines loaded from '$real_inc_path' | + ); } - $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 - # turn off redefined warnings - local $SIG{__WARN__} = sub {}; - do $real_inc_path; - die $@ if $@; + if ($old_real_inc_path) { + open(my $fh, '<', $old_real_inc_path) + 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. +EOF + + my $code = do { + local ($/, @ARGV) = (undef, $old_real_inc_path); <> + }; + $code = $self->_rewrite_old_classnames($code); + + if ($self->dynamic) { + warn <<"EOF"; + +Detected external content in '$old_real_inc_path', a class name that would have +been used by an 0.04006 version of the Loader. + +* 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 $@; + } + + chomp $code; + $self->_ext_stmt($class, $code); + $self->_ext_stmt($class, + qq|# End of lines loaded from '$old_real_inc_path' | + ); } } @@ -516,6 +679,7 @@ sub rescan { } sub _relbuilder { + no warnings 'uninitialized'; my ($self) = @_; return if $self->{skip_relationships}; @@ -528,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, ); } @@ -562,7 +729,7 @@ sub _load_tables { $self->{quiet} = 0; # Remove that temp dir from INC so it doesn't get reloaded - @INC = grep { $_ ne $self->{dump_directory} } @INC; + @INC = grep $_ ne $self->dump_directory, @INC; } $self->_load_external($_) @@ -633,6 +800,13 @@ sub _reload_class { my $class_path = $self->_class_path($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/; + }; eval "require $class;"; } @@ -738,6 +912,29 @@ sub _write_classfile { my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename); + if ($self->_upgrading_from) { + my $old_class = $self->_upgrading_classes->{$class}; + + if ($old_class && ($old_class ne $class)) { + my $old_filename = $self->_get_dump_filename($old_class); + + my ($old_custom_content) = $self->_get_custom_content( + $old_class, $old_filename, 0 # do not add default comment + ); + + $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//; + + if ($old_custom_content) { + $custom_content = + "\n" . $old_custom_content . "\n" . $custom_content; + } + + unlink $old_filename; + } + } + + $custom_content = $self->_rewrite_old_classnames($custom_content); + $text .= qq|$_\n| for @{$self->{_dump_storage}->{$class} || []}; @@ -782,7 +979,9 @@ sub _default_custom_content { } sub _get_custom_content { - my ($self, $class, $filename) = @_; + my ($self, $class, $filename, $add_default) = @_; + + $add_default = 1 unless defined $add_default; return ($self->_default_custom_content) if ! -f $filename; @@ -803,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 = ''; } @@ -818,7 +1017,7 @@ sub _get_custom_content { if !$md5; # Default custom content: - $buffer ||= $self->_default_custom_content; + $buffer ||= $self->_default_custom_content if $add_default; return ($buffer, $md5, $ver, $ts); } @@ -865,6 +1064,15 @@ sub _make_src_class { } my $table_class = join(q{::}, @result_namespace, $table_moniker); + if (my $upgrading_v = $self->_upgrading_from) { + local $self->naming->{monikers} = $upgrading_v; + + my $old_class = join(q{::}, @result_namespace, + $self->_table2moniker($table)); + + $self->_upgrading_classes->{$table_class} = $old_class; + } + my $table_normalized = lc $table; $self->classes->{$table} = $table_class; $self->classes->{$table_normalized} = $table_class; @@ -963,6 +1171,7 @@ sub tables { # Make a moniker from a table sub _default_table2moniker { + no warnings 'uninitialized'; my ($self, $table) = @_; if ($self->naming->{monikers} eq 'v4') { @@ -1032,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" ); @@ -1048,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)$/ ) { @@ -1067,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 @@ -1116,6 +1351,13 @@ sub _quote_table_name { sub _is_case_sensitive { 0 } +# remove the dump dir from @INC on destruction +sub DESTROY { + my $self = shift; + + @INC = grep $_ ne $self->dump_directory, @INC; +} + =head2 monikers Returns a hashref of loaded table to moniker mappings. There will