use DBIx::Class::Schema::Loader::RelBuilder;
use Data::Dump qw/ dump /;
use POSIX qw//;
+use File::Spec qw//;
+use Digest::MD5 qw//;
require DBIx::Class;
+our $VERSION = '0.03999_01';
+
__PACKAGE__->mk_ro_accessors(qw/
schema
schema_class
left_base_classes
components
resultset_components
- relationships
+ skip_relationships
moniker_map
inflect_singular
inflect_plural
dump_directory
dump_overwrite
- legacy_default_inflections
-
db_schema
_tables
classes
These constructor options are the base options for
L<DBIx::Class::Schema::Loader/loader_opts>. Available constructor options are:
-=head2 relationships
+=head2 skip_relationships
-Try to automatically detect/setup has_a and has_many relationships.
+Skip setting up relationships. The default is to attempt the loading
+of relationships.
=head2 debug
C<ResultSetManager> will be automatically added to the above
C<components> list if this option is set.
-=head2 legacy_default_inflections
-
-Setting this option changes the default fallback for L</inflect_plural> to
-utilize L<Lingua::EN::Inflect/PL>, and L</inflect_singular> to a no-op.
-Those choices produce substandard results, but might be necessary to support
-your existing code if you started developing on a version prior to 0.03 and
-don't wish to go around updating all your relationship names to the new
-defaults.
-
-This option will continue to be supported until at least version 0.05xxx,
-but may dissappear sometime thereafter. It is recommended that you update
-your code to use the newer-style inflections when you have the time.
-
=head2 dump_directory
This option is designed to be a tool to help you transition from this
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
-based on this name as well). Therefore it is wise to note that if you
-point the C<dump_directory> option of a schema class at the live libdir
-where that class is currently located, it will overwrite itself with a
-manual version of itself. This might be a really good or bad thing
-depending on your situation and perspective.
+based on this name as well).
Normally you wouldn't hard-code this setting in your schema class, as it
is meant for one-time manual usage.
=head2 dump_overwrite
-If set to a true value, the dumping code will overwrite existing files.
-The default is false, which means the dumping code will die if it encounters
-an existing file.
-
-=head1 DEPRECATED CONSTRUCTOR OPTIONS
-
-B<These will be removed in version 0.04000 !!!>
+Default false. If true, Loader will unconditionally delete any existing
+files before creating the new ones from scratch when dumping a schema to disk.
-=head2 inflect_map
+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!>
+leaving any customizations you placed after that as they were.
-Equivalent to L</inflect_plural>.
-
-=head2 inflect
-
-Equivalent to L</inflect_plural>.
-
-=head2 connect_info, dsn, user, password, options
-
-You connect these schemas the same way you would any L<DBIx::Class::Schema>,
-which is by calling either C<connect> or C<connection> on a schema class
-or object. These options are only supported via the deprecated
-C<load_from_connection> interface, which is also being removed in 0.04000.
+When C<dump_overwrite> is not set, if the output file already exists,
+but the aforementioned final stanza is not found, or the checksum
+contained there does not match the generated contents, Loader will
+croak and not touch the file.
=head1 METHODS
$self->{monikers} = {};
$self->{classes} = {};
- # Support deprecated arguments
- for(qw/inflect_map inflect/) {
- warn "Argument $_ is deprecated in favor of 'inflect_plural'"
- . ", and will be removed in 0.04000"
- if $self->{$_};
- }
- $self->{inflect_plural} ||= $self->{inflect_map} || $self->{inflect};
-
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$self->{schema} ||= $self->{schema_class};
sub _load_external {
my $self = shift;
- foreach my $table_class (values %{$self->classes}) {
- $table_class->require;
+ my $abs_dump_dir;
+
+ $abs_dump_dir = File::Spec->rel2abs($self->dump_directory)
+ if $self->dump_directory;
+
+ foreach my $class ($self->schema_class, values %{$self->classes}) {
+ $class->require;
if($@ && $@ !~ /^Can't locate /) {
croak "Failed to load external class definition"
- . " for '$table_class': $@";
+ . " for '$class': $@";
}
next if $@; # "Can't locate" error
# If we make it to here, we loaded an external definition
- warn qq/# Loaded external class definition for '$table_class'\n/
+ warn qq/# Loaded external class definition for '$class'\n/
if $self->debug;
- if($self->dump_directory) {
- my $class_path = $table_class;
+ if($abs_dump_dir) {
+ my $class_path = $class;
$class_path =~ s{::}{/}g;
$class_path .= '.pm';
- my $filename = $INC{$class_path};
+ my $filename = File::Spec->rel2abs($INC{$class_path});
croak 'Failed to locate actual external module file for '
- . "'$table_class'"
+ . "'$class'"
if !$filename;
+ # XXX this should be done MUCH EARLIER, do not require dump_dir files!!!
+ next if($filename =~ /^$abs_dump_dir/);
open(my $fh, '<', $filename)
or croak "Failed to open $filename for reading: $!";
- $self->_raw_stmt($table_class,
- q|# These lines loaded from user-supplied external file: |
+ $self->_ext_stmt($class,
+ qq|# These lines were loaded from '$filename' found in \@INC.|
+ .q|# They are now part of the custom portion of this file|
+ .q|# for you to hand-edit. If you do not either delete|
+ .q|# this section or remove that file from @INC, this section|
+ .q|# will be repeated redundantly when you re-create this|
+ .q|# file again via Loader!|
);
while(<$fh>) {
chomp;
- $self->_raw_stmt($table_class, $_);
+ $self->_ext_stmt($class, $_);
}
- $self->_raw_stmt($table_class,
- q|# End of lines loaded from user-supplied external file |
+ $self->_ext_stmt($class,
+ q|# End of lines loaded from '$filename' |
);
close($fh)
or croak "Failed to close $filename: $!";
my $self = shift;
$self->_load_classes;
- $self->_load_relationships if $self->relationships;
+ $self->_load_relationships if ! $self->skip_relationships;
$self->_load_external;
$self->_dump_to_dir if $self->dump_directory;
my ($self, $class) = (@_);
my @name_parts = split(/::/, $class);
- pop @name_parts;
+ pop @name_parts; # we don't care about the very last element,
+ # which is a filename
+
my $dir = $self->dump_directory;
- foreach (@name_parts) {
- $dir .= q{/} . $_;
- if(! -d $dir) {
+ while (1) {
+ if(!-d $dir) {
mkdir($dir) or croak "mkdir('$dir') failed: $!";
}
+ last if !@name_parts;
+ $dir = File::Spec->catdir($dir, shift @name_parts);
}
}
warn "Dumping manual schema for $schema_class to directory $target_dir ...\n";
- if(! -d $target_dir) {
- mkdir($target_dir) or croak "mkdir('$target_dir') failed: $!";
- }
+ my $schema_text =
+ qq|package $schema_class;\n\n|
+ . qq|use strict;\nuse warnings;\n\n|
+ . qq|use base 'DBIx::Class::Schema';\n\n|
+ . qq|__PACKAGE__->load_classes;\n|;
- my $verstr = $DBIx::Class::Schema::Loader::VERSION;
- my $datestr = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime);
- my $tagline = qq|# Created by DBIx::Class::Schema::Loader v$verstr @ $datestr|;
-
- $self->_ensure_dump_subdirs($schema_class);
-
- my $schema_fn = $self->_get_dump_filename($schema_class);
- croak "$schema_fn exists, will not overwrite"
- if -f $schema_fn && !$self->dump_overwrite;
- open(my $schema_fh, '>', $schema_fn)
- or croak "Cannot open $schema_fn for writing: $!";
- print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|;
- print $schema_fh qq|use strict;\nuse warnings;\n\n|;
- print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|;
- print $schema_fh qq|__PACKAGE__->load_classes;\n|;
- print $schema_fh qq|\n1;\n\n|;
- close($schema_fh)
- or croak "Cannot close $schema_fn: $!";
+ $self->_write_classfile($schema_class, $schema_text);
foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
- $self->_ensure_dump_subdirs($src_class);
- my $src_fn = $self->_get_dump_filename($src_class);
- croak "$src_fn exists, will not overwrite"
- if -f $src_fn && !$self->dump_overwrite;
- open(my $src_fh, '>', $src_fn)
- or croak "Cannot open $src_fn for writing: $!";
- print $src_fh qq|package $src_class;\n\n$tagline\n\n|;
- print $src_fh qq|use strict;\nuse warnings;\n\n|;
- print $src_fh qq|use base 'DBIx::Class';\n\n|;
- print $src_fh qq|$_\n|
- for @{$self->{_dump_storage}->{$src_class}};
- print $src_fh qq|\n1;\n\n|;
- close($src_fh)
- or croak "Cannot close $src_fn: $!";
+ my $src_text =
+ qq|package $src_class;\n\n|
+ . qq|use strict;\nuse warnings;\n\n|
+ . qq|use base 'DBIx::Class';\n\n|;
+
+ $self->_write_classfile($src_class, $src_text);
}
warn "Schema dump completed.\n";
}
+sub _write_classfile {
+ my ($self, $class, $text) = @_;
+
+ my $filename = $self->_get_dump_filename($class);
+ $self->_ensure_dump_subdirs($class);
+
+ if (-f $filename && $self->dump_overwrite) {
+ warn "Deleting existing file '$filename' due to "
+ . "'dump_overwrite' setting\n";
+ unlink($filename);
+ }
+
+ my $custom_content = $self->_get_custom_content($filename);
+
+ $custom_content ||= qq|\n# You can replace this text with custom|
+ . qq| content, and it will be preserved on regeneration|
+ . qq|\n1;\n|;
+
+ $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:|;
+
+ open(my $fh, '>', $filename)
+ or croak "Cannot open '$filename' for writing: $!";
+
+ # Write the top half and its MD5 sum
+ print $fh $text . Digest::MD5::md5_base64($text) . "\n\n";
+
+ # Write out anything loaded via external partial class file in @INC
+ print $fh qq|$_\n|
+ for @{$self->{_ext_storage}->{$class} || []};
+
+ print $fh $custom_content;
+
+ close($fh)
+ or croak "Cannot close '$filename': $!";
+}
+
+sub _get_custom_content {
+ my ($self, $class, $filename) = @_;
+
+ return if ! -f $filename;
+ open(my $fh, '<', $filename)
+ or croak "Cannot open '$filename' for reading: $!";
+
+ my $mark_re =
+ /^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n/;
+
+ my $found = 0;
+ my $buffer = '';
+ while(<$fh>) {
+ if(!$found && /$mark_re/) {
+ $found = 1;
+ $buffer .= $1;
+ $checksum = $2;
+ croak "Checksum mismatch in '$filename'"
+ if Digest::MD5::md5_base64($buffer) ne $checksum;
+
+ $buffer = '';
+ }
+ else {
+ $buffer .= $_;
+ }
+ }
+
+ croak "Cannot not overwrite '$filename' without 'dump_overwrite',"
+ " it does not appear to have been generated by Loader";
+ if !$found;
+
+ return $buffer;
+}
+
sub _use {
my $self = shift;
my $target = shift;
+ my $evalstr;
foreach (@_) {
- $_->require or croak ($_ . "->require: $@");
+ warn "$target: use $_;" if $self->debug;
$self->_raw_stmt($target, "use $_;");
- warn "$target: use $_" if $self->debug;
- eval "package $target; use $_;";
- croak "use $_: $@" if $@;
+ $_->require or croak ($_ . "->require: $@");
+ $evalstr .= "package $target; use $_;";
}
+ eval $evalstr if $evalstr;
+ croak $@ if $@;
}
sub _inject {
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 @_;
- warn "$target: use base qw/ $blist /" if $self->debug && @_;
foreach (@_) {
$_->require or croak ($_ . "->require: $@");
$schema_class->inject_base($target, $_);
my $cols = $self->_table_columns($table);
my $col_info;
- eval { $col_info = $schema->storage->columns_info_for($table) };
+ eval { $col_info = $self->_columns_info_for($table) };
if($@) {
$self->_dbic_stmt($table_class,'add_columns',@$cols);
}
else {
- my %cols_hash;
- foreach my $col (@$cols) {
- $cols_hash{$col} = \%{($col_info->{$col})};
- }
- $self->_dbic_stmt($table_class,'add_columns',%cols_hash);
+ my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
+ $self->_dbic_stmt(
+ $table_class,
+ 'add_columns',
+ map { $_, ($col_info_lc{$_}||{}) } @$cols
+ );
}
my $pks = $self->_table_pk_info($table) || [];
push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory;
}
+# Like above, but separately for the externally loaded stuff
+sub _ext_stmt {
+ my ($self, $class, $stmt) = @_;
+ push(@{$self->{_ext_storage}->{$class}}, $stmt) if $self->dump_directory;
+}
+
=head2 monikers
Returns a hashref of loaded table to moniker mappings. There will
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff