use Class::Unload;
require DBIx::Class;
-our $VERSION = '0.04999_07';
+our $VERSION = '0.04999_12';
__PACKAGE__->mk_ro_accessors(qw/
schema
=head2 result_base_class
-Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
+Base class for your table classes (aka result classes). Defaults to
+'DBIx::Class::Core'.
=head2 additional_base_classes
if $self->{dump_overwrite};
$self->{dynamic} = ! $self->{dump_directory};
- $self->{dump_directory} ||= File::Temp::tempdir( 'dbicXXXX',
+ $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
TMPDIR => 1,
CLEANUP => 1,
);
+ $self->{dump_directory} ||= $self->{temp_directory};
+
$self->{relbuilder} = DBIx::Class::Schema::Loader::RelBuilder->new(
$self->schema, $self->inflect_plural, $self->inflect_singular
) if !$self->{skip_relationships};
if(!$self->skip_relationships) {
# The relationship loader needs a working schema
$self->{quiet} = 1;
+ local $self->{dump_directory} = $self->{temp_directory};
$self->_reload_classes(@tables);
$self->_load_relationships($_) for @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_external($_)
sub _reload_classes {
my ($self, @tables) = @_;
+ # so that we don't repeat custom sections
+ @INC = grep $_ ne $self->dump_directory, @INC;
+
$self->_dump_to_dir(map { $self->classes->{$_} } @tables);
unshift @INC, $self->dump_directory;
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|;
$self->_write_classfile($schema_class, $schema_text);
- my $result_base_class = $self->result_base_class || 'DBIx::Class';
+ my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
foreach my $src_class (@classes) {
my $src_text =
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|;
}
+sub _sig_comment {
+ my ($self, $version, $ts) = @_;
+ return qq|\n\n# Created by DBIx::Class::Schema::Loader|
+ . qq| v| . $version
+ . q| @ | . $ts
+ . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
+}
+
sub _write_classfile {
my ($self, $class, $text) = @_;
unlink($filename);
}
- my $custom_content = $self->_get_custom_content($class, $filename);
- $custom_content ||= qq|\n\n# You can replace this text with custom|
- . qq| content, and it will be preserved on regeneration|
- . qq|\n1;\n|;
+ my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
$text .= qq|$_\n|
for @{$self->{_dump_storage}->{$class} || []};
- $text .= qq|\n\n# Created by DBIx::Class::Schema::Loader|
- . qq| v| . $DBIx::Class::Schema::Loader::VERSION
- . q| @ | . POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
- . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
+ # Check and see if the dump is infact differnt
+
+ 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;
+ }
+ }
+
+ $text .= $self->_sig_comment(
+ $DBIx::Class::Schema::Loader::VERSION,
+ POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
+ );
open(my $fh, '>', $filename)
or croak "Cannot open '$filename' for writing: $!";
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 _get_custom_content {
my ($self, $class, $filename) = @_;
- return if ! -f $filename;
+ return ($self->_default_custom_content) if ! -f $filename;
+
open(my $fh, '<', $filename)
or croak "Cannot open '$filename' for reading: $!";
my $mark_re =
qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
- my $found = 0;
my $buffer = '';
+ my ($md5, $ts, $ver);
while(<$fh>) {
- if(!$found && /$mark_re/) {
- $found = 1;
- $buffer .= $1;
+ if(!$md5 && /$mark_re/) {
+ $md5 = $2;
+ my $line = $1;
+
+ # Pull out the previous version and timestamp
+ ($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 $2;
+ if Digest::MD5::md5_base64($buffer) ne $md5;
$buffer = '';
}
croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
. " it does not appear to have been generated by Loader"
- if !$found;
+ if !$md5;
+
+ # Default custom content:
+ $buffer ||= $self->_default_custom_content;
- return $buffer;
+ return ($buffer, $md5, $ver, $ts);
}
sub _use {
$self->_use ($table_class, @{$self->additional_classes});
$self->_inject($table_class, @{$self->left_base_classes});
- $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, 'Core');
+ if (my @components = @{ $self->components }) {
+ $self->_dbic_stmt($table_class, 'load_components', @components);
+ }
$self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
if @{$self->resultset_components};
my $self = shift;
my $class = shift;
my $method = shift;
-
+ if ( $method eq 'table' ) {
+ my ($table) = @_;
+ $self->_pod( $class, "=head1 NAME" );
+ my $table_descr = $class;
+ if ( $self->can('_table_comment') ) {
+ my $comment = $self->_table_comment($table);
+ $table_descr .= " - " . $comment if $comment;
+ }
+ $self->{_class2table}{ $class } = $table;
+ $self->_pod( $class, $table_descr );
+ $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;
+ }
+ $self->_pod_cut( $class );
+ } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
+ $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
+ my ( $accessor, $rel_class ) = @_;
+ $self->_pod( $class, "=head2 $accessor" );
+ $self->_pod( $class, 'Type: ' . $method );
+ $self->_pod( $class, "Related object: L<$rel_class>" );
+ $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
+sub _pod {
+ my ($self, $class, $stmt) = @_;
+ $self->_raw_stmt( $class, "\n" . $stmt );
+}
+
+sub _pod_cut {
+ my ($self, $class ) = @_;
+ $self->_raw_stmt( $class, "\n=cut\n" );
}
+
# Store a raw source line for a class (for dumping purposes)
sub _raw_stmt {
my ($self, $class, $stmt) = @_;
L<DBIx::Class::Schema::Loader>
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
=cut
1;