1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use DBIx::Class::Schema::Loader::RelBuilder;
9 use Data::Dump qw/ dump /;
14 use Lingua::EN::Inflect::Number qw//;
19 our $VERSION = '0.04999_14';
21 __PACKAGE__->mk_group_ro_accessors('simple', qw/
28 additional_base_classes
42 default_resultset_class
45 overwrite_modifications
59 __PACKAGE__->mk_group_accessors('simple', qw/
61 schema_version_to_dump
63 _upgrading_from_load_classes
64 _downgrading_to_load_classes
65 _rewriting_result_namespace
70 pod_comment_spillover_length
75 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
79 See L<DBIx::Class::Schema::Loader>
83 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
84 classes, and implements the common functionality between them.
86 =head1 CONSTRUCTOR OPTIONS
88 These constructor options are the base options for
89 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
91 =head2 skip_relationships
93 Skip setting up relationships. The default is to attempt the loading
96 =head2 skip_load_external
98 Skip loading of other classes in @INC. The default is to merge all other classes
99 with the same name found in @INC into the schema file we are creating.
103 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
104 relationship names and singularized Results, unless you're overwriting an
105 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
106 which case the backward compatible RelBuilder will be activated, and
107 singularization will be turned off.
113 will disable the backward-compatible RelBuilder and use
114 the new-style relationship names along with singularized Results, even when
115 overwriting a dump made with an earlier version.
117 The option also takes a hashref:
119 naming => { relationships => 'v5', monikers => 'v4' }
127 How to name relationship accessors.
131 How to name Result classes.
141 Latest default style, whatever that happens to be.
145 Version 0.05XXX style.
149 Version 0.04XXX style.
153 Dynamic schemas will always default to the 0.04XXX relationship names and won't
154 singularize Results for backward compatibility, to activate the new RelBuilder
155 and singularization put this in your C<Schema.pm> file:
157 __PACKAGE__->naming('current');
159 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
160 next major version upgrade:
162 __PACKAGE__->naming('v5');
166 By default POD will be generated for columns and relationships, using database
167 metadata for the text if available and supported.
169 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
170 supported for Postgres right now.
172 Set this to C<0> to turn off all POD generation.
174 =head2 pod_comment_mode
176 Controls where table comments appear in the generated POD. Smaller table
177 comments are appended to the C<NAME> section of the documentation, and larger
178 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
179 section to be generated with the comment always, only use C<NAME>, or choose
180 the length threshold at which the comment is forced into the description.
186 Use C<NAME> section only.
190 Force C<DESCRIPTION> always.
194 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
199 =head2 pod_comment_spillover_length
201 When pod_comment_mode is set to C<auto>, this is the length of the comment at
202 which it will be forced into a separate description section.
206 =head2 relationship_attrs
208 Hashref of attributes to pass to each generated relationship, listed
209 by type. Also supports relationship type 'all', containing options to
210 pass to all generated relationships. Attributes set for more specific
211 relationship types override those set in 'all'.
215 relationship_attrs => {
216 all => { cascade_delete => 0 },
217 has_many => { cascade_delete => 1 },
220 will set the C<cascade_delete> option to 0 for all generated relationships,
221 except for C<has_many>, which will have cascade_delete as 1.
223 NOTE: this option is not supported if v4 backward-compatible naming is
224 set either globally (naming => 'v4') or just for relationships.
228 If set to true, each constructive L<DBIx::Class> statement the loader
229 decides to execute will be C<warn>-ed before execution.
233 Set the name of the schema to load (schema in the sense that your database
234 vendor means it). Does not currently support loading more than one schema
239 Only load tables matching regex. Best specified as a qr// regex.
243 Exclude tables matching regex. Best specified as a qr// regex.
247 Overrides the default table name to moniker translation. Can be either
248 a hashref of table keys and moniker values, or a coderef for a translator
249 function taking a single scalar table name argument and returning
250 a scalar moniker. If the hash entry does not exist, or the function
251 returns a false value, the code falls back to default behavior
254 The default behavior is to singularize the table name, and: C<join '', map
255 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
256 split up the table name into chunks anywhere a non-alpha-numeric character
257 occurs, change the case of first letter of each chunk to upper case, and put
258 the chunks back together. Examples:
260 Table Name | Moniker Name
261 ---------------------------
263 luser_group | LuserGroup
264 luser-opts | LuserOpt
266 =head2 inflect_plural
268 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
269 if hash key does not exist or coderef returns false), but acts as a map
270 for pluralizing relationship names. The default behavior is to utilize
271 L<Lingua::EN::Inflect::Number/to_PL>.
273 =head2 inflect_singular
275 As L</inflect_plural> above, but for singularizing relationship names.
276 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
278 =head2 schema_base_class
280 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
282 =head2 result_base_class
284 Base class for your table classes (aka result classes). Defaults to
287 =head2 additional_base_classes
289 List of additional base classes all of your table classes will use.
291 =head2 left_base_classes
293 List of additional base classes all of your table classes will use
294 that need to be leftmost.
296 =head2 additional_classes
298 List of additional classes which all of your table classes will use.
302 List of additional components to be loaded into all of your table
303 classes. A good example would be C<ResultSetManager>.
305 =head2 resultset_components
307 List of additional ResultSet components to be loaded into your table
308 classes. A good example would be C<AlwaysRS>. Component
309 C<ResultSetManager> will be automatically added to the above
310 C<components> list if this option is set.
312 =head2 use_namespaces
314 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
317 Generate result class names suitable for
318 L<DBIx::Class::Schema/load_namespaces> and call that instead of
319 L<DBIx::Class::Schema/load_classes>. When using this option you can also
320 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
321 C<resultset_namespace>, C<default_resultset_class>), and they will be added
322 to the call (and the generated result class names adjusted appropriately).
324 =head2 dump_directory
326 This option is designed to be a tool to help you transition from this
327 loader to a manually-defined schema when you decide it's time to do so.
329 The value of this option is a perl libdir pathname. Within
330 that directory this module will create a baseline manual
331 L<DBIx::Class::Schema> module set, based on what it creates at runtime
334 The created schema class will have the same classname as the one on
335 which you are setting this option (and the ResultSource classes will be
336 based on this name as well).
338 Normally you wouldn't hard-code this setting in your schema class, as it
339 is meant for one-time manual usage.
341 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
342 recommended way to access this functionality.
344 =head2 dump_overwrite
346 Deprecated. See L</really_erase_my_files> below, which does *not* mean
347 the same thing as the old C<dump_overwrite> setting from previous releases.
349 =head2 really_erase_my_files
351 Default false. If true, Loader will unconditionally delete any existing
352 files before creating the new ones from scratch when dumping a schema to disk.
354 The default behavior is instead to only replace the top portion of the
355 file, up to and including the final stanza which contains
356 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
357 leaving any customizations you placed after that as they were.
359 When C<really_erase_my_files> is not set, if the output file already exists,
360 but the aforementioned final stanza is not found, or the checksum
361 contained there does not match the generated contents, Loader will
362 croak and not touch the file.
364 You should really be using version control on your schema classes (and all
365 of the rest of your code for that matter). Don't blame me if a bug in this
366 code wipes something out when it shouldn't have, you've been warned.
368 =head2 overwrite_modifications
370 Default false. If false, when updating existing files, Loader will
371 refuse to modify any Loader-generated code that has been modified
372 since its last run (as determined by the checksum Loader put in its
375 If true, Loader will discard any manual modifications that have been
376 made to Loader-generated code.
378 Again, you should be using version control on your schema classes. Be
379 careful with this option.
383 None of these methods are intended for direct invocation by regular
384 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
385 can also be found via standard L<DBIx::Class::Schema> methods somehow.
389 use constant CURRENT_V => 'v5';
391 # ensure that a peice of object data is a valid arrayref, creating
392 # an empty one or encapsulating whatever's there.
393 sub _ensure_arrayref {
398 $self->{$_} = [ $self->{$_} ]
399 unless ref $self->{$_} eq 'ARRAY';
405 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
406 by L<DBIx::Class::Schema::Loader>.
411 my ( $class, %args ) = @_;
413 my $self = { %args };
415 bless $self => $class;
417 $self->_ensure_arrayref(qw/additional_classes
418 additional_base_classes
424 push(@{$self->{components}}, 'ResultSetManager')
425 if @{$self->{resultset_components}};
427 $self->{monikers} = {};
428 $self->{classes} = {};
429 $self->{_upgrading_classes} = {};
431 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
432 $self->{schema} ||= $self->{schema_class};
434 croak "dump_overwrite is deprecated. Please read the"
435 . " DBIx::Class::Schema::Loader::Base documentation"
436 if $self->{dump_overwrite};
438 $self->{dynamic} = ! $self->{dump_directory};
439 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
444 $self->{dump_directory} ||= $self->{temp_directory};
446 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
447 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
449 if ((not ref $self->naming) && defined $self->naming) {
450 my $naming_ver = $self->naming;
452 relationships => $naming_ver,
453 monikers => $naming_ver,
458 for (values %{ $self->naming }) {
459 $_ = CURRENT_V if $_ eq 'current';
462 $self->{naming} ||= {};
464 $self->_check_back_compat;
466 $self->use_namespaces(1) unless defined $self->use_namespaces;
467 $self->generate_pod(1) unless defined $self->generate_pod;
468 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
469 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
474 sub _check_back_compat {
477 # dynamic schemas will always be in 0.04006 mode, unless overridden
478 if ($self->dynamic) {
479 # just in case, though no one is likely to dump a dynamic schema
480 $self->schema_version_to_dump('0.04006');
482 if (not %{ $self->naming }) {
483 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
485 Dynamic schema detected, will run in 0.04006 mode.
487 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
488 to disable this warning.
490 Also consider setting 'use_namespaces => 1' if/when upgrading.
492 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
497 $self->_upgrading_from('v4');
500 $self->naming->{relationships} ||= 'v4';
501 $self->naming->{monikers} ||= 'v4';
503 if ($self->use_namespaces) {
504 $self->_upgrading_from_load_classes(1);
507 $self->use_namespaces(0);
513 # otherwise check if we need backcompat mode for a static schema
514 my $filename = $self->_get_dump_filename($self->schema_class);
515 return unless -e $filename;
517 open(my $fh, '<', $filename)
518 or croak "Cannot open '$filename' for reading: $!";
520 my $load_classes = 0;
521 my $result_namespace = '';
524 if (/^__PACKAGE__->load_classes;/) {
526 } elsif (/result_namespace => '([^']+)'/) {
527 $result_namespace = $1;
528 } elsif (my ($real_ver) =
529 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
531 if ($load_classes && (not defined $self->use_namespaces)) {
532 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
534 'load_classes;' static schema detected, turning off 'use_namespaces'.
536 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
537 variable to disable this warning.
539 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
542 $self->use_namespaces(0);
544 elsif ($load_classes && $self->use_namespaces) {
545 $self->_upgrading_from_load_classes(1);
547 elsif ((not $load_classes) && defined $self->use_namespaces
548 && (not $self->use_namespaces)) {
549 $self->_downgrading_to_load_classes(
550 $result_namespace || 'Result'
553 elsif ((not defined $self->use_namespaces)
554 || $self->use_namespaces) {
555 if (not $self->result_namespace) {
556 $self->result_namespace($result_namespace || 'Result');
558 elsif ($result_namespace ne $self->result_namespace) {
559 $self->_rewriting_result_namespace(
560 $result_namespace || 'Result'
565 # XXX when we go past .0 this will need fixing
566 my ($v) = $real_ver =~ /([1-9])/;
569 last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
571 if (not %{ $self->naming }) {
572 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
574 Version $real_ver static schema detected, turning on backcompat mode.
576 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
577 to disable this warning.
579 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
584 $self->_upgrading_from($v);
588 $self->naming->{relationships} ||= $v;
589 $self->naming->{monikers} ||= $v;
591 $self->schema_version_to_dump($real_ver);
599 sub _find_file_in_inc {
600 my ($self, $file) = @_;
602 foreach my $prefix (@INC) {
603 my $fullpath = File::Spec->catfile($prefix, $file);
604 return $fullpath if -f $fullpath
605 and Cwd::abs_path($fullpath) ne
606 (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
613 my ($self, $class) = @_;
615 my $class_path = $class;
616 $class_path =~ s{::}{/}g;
617 $class_path .= '.pm';
622 sub _find_class_in_inc {
623 my ($self, $class) = @_;
625 return $self->_find_file_in_inc($self->_class_path($class));
631 return $self->_upgrading_from
632 || $self->_upgrading_from_load_classes
633 || $self->_downgrading_to_load_classes
634 || $self->_rewriting_result_namespace
638 sub _rewrite_old_classnames {
639 my ($self, $code) = @_;
641 return $code unless $self->_rewriting;
643 my %old_classes = reverse %{ $self->_upgrading_classes };
645 my $re = join '|', keys %old_classes;
648 $code =~ s/$re/$old_classes{$1} || $1/eg;
654 my ($self, $class) = @_;
656 return if $self->{skip_load_external};
658 # so that we don't load our own classes, under any circumstances
659 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
661 my $real_inc_path = $self->_find_class_in_inc($class);
663 my $old_class = $self->_upgrading_classes->{$class}
664 if $self->_rewriting;
666 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
667 if $old_class && $old_class ne $class;
669 return unless $real_inc_path || $old_real_inc_path;
671 if ($real_inc_path) {
672 # If we make it to here, we loaded an external definition
673 warn qq/# Loaded external class definition for '$class'\n/
676 open(my $fh, '<', $real_inc_path)
677 or croak "Failed to open '$real_inc_path' for reading: $!";
678 my $code = do { local $/; <$fh> };
680 or croak "Failed to close $real_inc_path: $!";
681 $code = $self->_rewrite_old_classnames($code);
683 if ($self->dynamic) { # load the class too
684 # kill redefined warnings
685 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
686 local $SIG{__WARN__} = sub {
688 unless $_[0] =~ /^Subroutine \S+ redefined/;
694 $self->_ext_stmt($class,
695 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
696 .qq|# They are now part of the custom portion of this file\n|
697 .qq|# for you to hand-edit. If you do not either delete\n|
698 .qq|# this section or remove that file from \@INC, this section\n|
699 .qq|# will be repeated redundantly when you re-create this\n|
700 .qq|# file again via Loader! See skip_load_external to disable\n|
701 .qq|# this feature.\n|
704 $self->_ext_stmt($class, $code);
705 $self->_ext_stmt($class,
706 qq|# End of lines loaded from '$real_inc_path' |
710 if ($old_real_inc_path) {
711 open(my $fh, '<', $old_real_inc_path)
712 or croak "Failed to open '$old_real_inc_path' for reading: $!";
713 $self->_ext_stmt($class, <<"EOF");
715 # These lines were loaded from '$old_real_inc_path',
716 # based on the Result class name that would have been created by an 0.04006
717 # version of the Loader. For a static schema, this happens only once during
718 # upgrade. See skip_load_external to disable this feature.
722 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
724 $code = $self->_rewrite_old_classnames($code);
726 if ($self->dynamic) {
729 Detected external content in '$old_real_inc_path', a class name that would have
730 been used by an 0.04006 version of the Loader.
732 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
733 new name of the Result.
735 # kill redefined warnings
736 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
737 local $SIG{__WARN__} = sub {
739 unless $_[0] =~ /^Subroutine \S+ redefined/;
746 $self->_ext_stmt($class, $code);
747 $self->_ext_stmt($class,
748 qq|# End of lines loaded from '$old_real_inc_path' |
755 Does the actual schema-construction work.
762 $self->_load_tables($self->_tables_list);
769 Rescan the database for newly added tables. Does
770 not process drops or changes. Returns a list of
771 the newly added table monikers.
773 The schema argument should be the schema class
774 or object to be affected. It should probably
775 be derived from the original schema_class used
781 my ($self, $schema) = @_;
783 $self->{schema} = $schema;
784 $self->_relbuilder->{schema} = $schema;
787 my @current = $self->_tables_list;
788 foreach my $table ($self->_tables_list) {
789 if(!exists $self->{_tables}->{$table}) {
790 push(@created, $table);
794 my $loaded = $self->_load_tables(@created);
796 return map { $self->monikers->{$_} } @$loaded;
800 no warnings 'uninitialized';
803 return if $self->{skip_relationships};
805 if ($self->naming->{relationships} eq 'v4') {
806 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
807 return $self->{relbuilder} ||=
808 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
809 $self->schema, $self->inflect_plural, $self->inflect_singular
813 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
815 $self->inflect_plural,
816 $self->inflect_singular,
817 $self->relationship_attrs,
822 my ($self, @tables) = @_;
824 # First, use _tables_list with constraint and exclude
825 # to get a list of tables to operate on
827 my $constraint = $self->constraint;
828 my $exclude = $self->exclude;
830 @tables = grep { /$constraint/ } @tables if $constraint;
831 @tables = grep { ! /$exclude/ } @tables if $exclude;
833 # Save the new tables to the tables list
835 $self->{_tables}->{$_} = 1;
838 $self->_make_src_class($_) for @tables;
839 $self->_setup_src_meta($_) for @tables;
841 if(!$self->skip_relationships) {
842 # The relationship loader needs a working schema
844 local $self->{dump_directory} = $self->{temp_directory};
845 $self->_reload_classes(\@tables);
846 $self->_load_relationships($_) for @tables;
849 # Remove that temp dir from INC so it doesn't get reloaded
850 @INC = grep $_ ne $self->dump_directory, @INC;
853 $self->_load_external($_)
854 for map { $self->classes->{$_} } @tables;
856 # Reload without unloading first to preserve any symbols from external
858 $self->_reload_classes(\@tables, 0);
860 # Drop temporary cache
861 delete $self->{_cache};
866 sub _reload_classes {
867 my ($self, $tables, $unload) = @_;
869 my @tables = @$tables;
870 $unload = 1 unless defined $unload;
872 # so that we don't repeat custom sections
873 @INC = grep $_ ne $self->dump_directory, @INC;
875 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
877 unshift @INC, $self->dump_directory;
880 my %have_source = map { $_ => $self->schema->source($_) }
881 $self->schema->sources;
883 for my $table (@tables) {
884 my $moniker = $self->monikers->{$table};
885 my $class = $self->classes->{$table};
888 no warnings 'redefine';
889 local *Class::C3::reinitialize = sub {};
892 Class::Unload->unload($class) if $unload;
893 my ($source, $resultset_class);
895 ($source = $have_source{$moniker})
896 && ($resultset_class = $source->resultset_class)
897 && ($resultset_class ne 'DBIx::Class::ResultSet')
899 my $has_file = Class::Inspector->loaded_filename($resultset_class);
900 Class::Unload->unload($resultset_class) if $unload;
901 $self->_reload_class($resultset_class) if $has_file;
903 $self->_reload_class($class);
905 push @to_register, [$moniker, $class];
908 Class::C3->reinitialize;
910 $self->schema->register_class(@$_);
914 # We use this instead of ensure_class_loaded when there are package symbols we
917 my ($self, $class) = @_;
919 my $class_path = $self->_class_path($class);
920 delete $INC{ $class_path };
922 # kill redefined warnings
923 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
924 local $SIG{__WARN__} = sub {
926 unless $_[0] =~ /^Subroutine \S+ redefined/;
928 eval "require $class;";
931 sub _get_dump_filename {
932 my ($self, $class) = (@_);
935 return $self->dump_directory . q{/} . $class . q{.pm};
938 sub _ensure_dump_subdirs {
939 my ($self, $class) = (@_);
941 my @name_parts = split(/::/, $class);
942 pop @name_parts; # we don't care about the very last element,
943 # which is a filename
945 my $dir = $self->dump_directory;
948 mkdir($dir) or croak "mkdir('$dir') failed: $!";
950 last if !@name_parts;
951 $dir = File::Spec->catdir($dir, shift @name_parts);
956 my ($self, @classes) = @_;
958 my $schema_class = $self->schema_class;
959 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
961 my $target_dir = $self->dump_directory;
962 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
963 unless $self->{dynamic} or $self->{quiet};
966 qq|package $schema_class;\n\n|
967 . qq|# Created by DBIx::Class::Schema::Loader\n|
968 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
969 . qq|use strict;\nuse warnings;\n\n|
970 . qq|use base '$schema_base_class';\n\n|;
972 if ($self->use_namespaces) {
973 $schema_text .= qq|__PACKAGE__->load_namespaces|;
974 my $namespace_options;
975 for my $attr (qw(result_namespace
977 default_resultset_class)) {
979 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
982 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
983 $schema_text .= qq|;\n|;
986 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
990 local $self->{version_to_dump} = $self->schema_version_to_dump;
991 $self->_write_classfile($schema_class, $schema_text, 1);
994 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
996 foreach my $src_class (@classes) {
998 qq|package $src_class;\n\n|
999 . qq|# Created by DBIx::Class::Schema::Loader\n|
1000 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1001 . qq|use strict;\nuse warnings;\n\n|
1002 . qq|use base '$result_base_class';\n\n|;
1004 $self->_write_classfile($src_class, $src_text);
1007 # remove Result dir if downgrading from use_namespaces, and there are no
1009 if (my $result_ns = $self->_downgrading_to_load_classes
1010 || $self->_rewriting_result_namespace) {
1011 my $result_namespace = $self->_result_namespace(
1016 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1017 $result_dir = $self->dump_directory . '/' . $result_dir;
1019 unless (my @files = glob "$result_dir/*") {
1024 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1029 my ($self, $version, $ts) = @_;
1030 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1033 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1036 sub _write_classfile {
1037 my ($self, $class, $text, $is_schema) = @_;
1039 my $filename = $self->_get_dump_filename($class);
1040 $self->_ensure_dump_subdirs($class);
1042 if (-f $filename && $self->really_erase_my_files) {
1043 warn "Deleting existing file '$filename' due to "
1044 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1048 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1050 if (my $old_class = $self->_upgrading_classes->{$class}) {
1051 my $old_filename = $self->_get_dump_filename($old_class);
1053 my ($old_custom_content) = $self->_get_custom_content(
1054 $old_class, $old_filename, 0 # do not add default comment
1057 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1059 if ($old_custom_content) {
1061 "\n" . $old_custom_content . "\n" . $custom_content;
1064 unlink $old_filename;
1067 $custom_content = $self->_rewrite_old_classnames($custom_content);
1070 for @{$self->{_dump_storage}->{$class} || []};
1072 # Check and see if the dump is infact differnt
1076 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1079 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1080 return unless $self->_upgrading_from && $is_schema;
1084 $text .= $self->_sig_comment(
1085 $self->version_to_dump,
1086 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1089 open(my $fh, '>', $filename)
1090 or croak "Cannot open '$filename' for writing: $!";
1092 # Write the top half and its MD5 sum
1093 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1095 # Write out anything loaded via external partial class file in @INC
1097 for @{$self->{_ext_storage}->{$class} || []};
1099 # Write out any custom content the user has added
1100 print $fh $custom_content;
1103 or croak "Error closing '$filename': $!";
1106 sub _default_custom_content {
1107 return qq|\n\n# You can replace this text with custom|
1108 . qq| content, and it will be preserved on regeneration|
1112 sub _get_custom_content {
1113 my ($self, $class, $filename, $add_default) = @_;
1115 $add_default = 1 unless defined $add_default;
1117 return ($self->_default_custom_content) if ! -f $filename;
1119 open(my $fh, '<', $filename)
1120 or croak "Cannot open '$filename' for reading: $!";
1123 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1126 my ($md5, $ts, $ver);
1128 if(!$md5 && /$mark_re/) {
1132 # Pull out the previous version and timestamp
1133 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1136 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"
1137 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1146 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1147 . " it does not appear to have been generated by Loader"
1150 # Default custom content:
1151 $buffer ||= $self->_default_custom_content if $add_default;
1153 return ($buffer, $md5, $ver, $ts);
1161 warn "$target: use $_;" if $self->debug;
1162 $self->_raw_stmt($target, "use $_;");
1169 my $schema_class = $self->schema_class;
1171 my $blist = join(q{ }, @_);
1172 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1173 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1176 sub _result_namespace {
1177 my ($self, $schema_class, $ns) = @_;
1178 my @result_namespace;
1180 if ($ns =~ /^\+(.*)/) {
1181 # Fully qualified namespace
1182 @result_namespace = ($1)
1185 # Relative namespace
1186 @result_namespace = ($schema_class, $ns);
1189 return wantarray ? @result_namespace : join '::', @result_namespace;
1192 # Create class with applicable bases, setup monikers, etc
1193 sub _make_src_class {
1194 my ($self, $table) = @_;
1196 my $schema = $self->schema;
1197 my $schema_class = $self->schema_class;
1199 my $table_moniker = $self->_table2moniker($table);
1200 my @result_namespace = ($schema_class);
1201 if ($self->use_namespaces) {
1202 my $result_namespace = $self->result_namespace || 'Result';
1203 @result_namespace = $self->_result_namespace(
1208 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1210 if ((my $upgrading_v = $self->_upgrading_from)
1211 || $self->_rewriting) {
1212 local $self->naming->{monikers} = $upgrading_v
1215 my @result_namespace = @result_namespace;
1216 if ($self->_upgrading_from_load_classes) {
1217 @result_namespace = ($schema_class);
1219 elsif (my $ns = $self->_downgrading_to_load_classes) {
1220 @result_namespace = $self->_result_namespace(
1225 elsif ($ns = $self->_rewriting_result_namespace) {
1226 @result_namespace = $self->_result_namespace(
1232 my $old_class = join(q{::}, @result_namespace,
1233 $self->_table2moniker($table));
1235 $self->_upgrading_classes->{$table_class} = $old_class
1236 unless $table_class eq $old_class;
1239 my $table_normalized = lc $table;
1240 $self->classes->{$table} = $table_class;
1241 $self->classes->{$table_normalized} = $table_class;
1242 $self->monikers->{$table} = $table_moniker;
1243 $self->monikers->{$table_normalized} = $table_moniker;
1245 $self->_use ($table_class, @{$self->additional_classes});
1246 $self->_inject($table_class, @{$self->left_base_classes});
1248 if (my @components = @{ $self->components }) {
1249 $self->_dbic_stmt($table_class, 'load_components', @components);
1252 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1253 if @{$self->resultset_components};
1254 $self->_inject($table_class, @{$self->additional_base_classes});
1257 # Set up metadata (cols, pks, etc)
1258 sub _setup_src_meta {
1259 my ($self, $table) = @_;
1261 my $schema = $self->schema;
1262 my $schema_class = $self->schema_class;
1264 my $table_class = $self->classes->{$table};
1265 my $table_moniker = $self->monikers->{$table};
1267 my $table_name = $table;
1268 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1270 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1271 $table_name = \ $self->_quote_table_name($table_name);
1274 $self->_dbic_stmt($table_class,'table',$table_name);
1276 my $cols = $self->_table_columns($table);
1278 eval { $col_info = $self->_columns_info_for($table) };
1280 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1283 if ($self->_is_case_sensitive) {
1284 for my $col (keys %$col_info) {
1285 $col_info->{$col}{accessor} = lc $col
1286 if $col ne lc($col);
1289 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1292 my $fks = $self->_table_fk_info($table);
1294 for my $fkdef (@$fks) {
1295 for my $col (@{ $fkdef->{local_columns} }) {
1296 $col_info->{$col}{is_foreign_key} = 1;
1302 map { $_, ($col_info->{$_}||{}) } @$cols
1306 my %uniq_tag; # used to eliminate duplicate uniqs
1308 my $pks = $self->_table_pk_info($table) || [];
1309 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1310 : carp("$table has no primary key");
1311 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1313 my $uniqs = $self->_table_uniq_info($table) || [];
1315 my ($name, $cols) = @$_;
1316 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1317 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1324 Returns a sorted list of loaded tables, using the original database table
1332 return keys %{$self->_tables};
1335 # Make a moniker from a table
1336 sub _default_table2moniker {
1337 no warnings 'uninitialized';
1338 my ($self, $table) = @_;
1340 if ($self->naming->{monikers} eq 'v4') {
1341 return join '', map ucfirst, split /[\W_]+/, lc $table;
1344 return join '', map ucfirst, split /[\W_]+/,
1345 Lingua::EN::Inflect::Number::to_S(lc $table);
1348 sub _table2moniker {
1349 my ( $self, $table ) = @_;
1353 if( ref $self->moniker_map eq 'HASH' ) {
1354 $moniker = $self->moniker_map->{$table};
1356 elsif( ref $self->moniker_map eq 'CODE' ) {
1357 $moniker = $self->moniker_map->($table);
1360 $moniker ||= $self->_default_table2moniker($table);
1365 sub _load_relationships {
1366 my ($self, $table) = @_;
1368 my $tbl_fk_info = $self->_table_fk_info($table);
1369 foreach my $fkdef (@$tbl_fk_info) {
1370 $fkdef->{remote_source} =
1371 $self->monikers->{delete $fkdef->{remote_table}};
1373 my $tbl_uniq_info = $self->_table_uniq_info($table);
1375 my $local_moniker = $self->monikers->{$table};
1376 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1378 foreach my $src_class (sort keys %$rel_stmts) {
1379 my $src_stmts = $rel_stmts->{$src_class};
1380 foreach my $stmt (@$src_stmts) {
1381 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1386 # Overload these in driver class:
1388 # Returns an arrayref of column names
1389 sub _table_columns { croak "ABSTRACT METHOD" }
1391 # Returns arrayref of pk col names
1392 sub _table_pk_info { croak "ABSTRACT METHOD" }
1394 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1395 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1397 # Returns an arrayref of foreign key constraints, each
1398 # being a hashref with 3 keys:
1399 # local_columns (arrayref), remote_columns (arrayref), remote_table
1400 sub _table_fk_info { croak "ABSTRACT METHOD" }
1402 # Returns an array of lower case table names
1403 sub _tables_list { croak "ABSTRACT METHOD" }
1405 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1411 # generate the pod for this statement, storing it with $self->_pod
1412 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1414 my $args = dump(@_);
1415 $args = '(' . $args . ')' if @_ < 2;
1416 my $stmt = $method . $args . q{;};
1418 warn qq|$class\->$stmt\n| if $self->debug;
1419 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1423 # generates the accompanying pod for a DBIC class method statement,
1424 # storing it with $self->_pod
1430 if ( $method eq 'table' ) {
1432 my $pcm = $self->pod_comment_mode;
1433 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1434 if ( $self->can('_table_comment') ) {
1435 $comment = $self->_table_comment($table);
1436 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1437 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1438 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1440 $self->_pod( $class, "=head1 NAME" );
1441 my $table_descr = $class;
1442 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1443 $self->{_class2table}{ $class } = $table;
1444 $self->_pod( $class, $table_descr );
1445 if ($comment and $comment_in_desc) {
1446 $self->_pod( $class, "=head1 DESCRIPTION" );
1447 $self->_pod( $class, $comment );
1449 $self->_pod_cut( $class );
1450 } elsif ( $method eq 'add_columns' ) {
1451 $self->_pod( $class, "=head1 ACCESSORS" );
1452 my $col_counter = 0;
1454 while( my ($name,$attrs) = splice @cols,0,2 ) {
1456 $self->_pod( $class, '=head2 ' . $name );
1457 $self->_pod( $class,
1459 my $s = $attrs->{$_};
1460 $s = !defined $s ? 'undef' :
1461 length($s) == 0 ? '(empty string)' :
1465 } sort keys %$attrs,
1468 if( $self->can('_column_comment')
1469 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1471 $self->_pod( $class, $comment );
1474 $self->_pod_cut( $class );
1475 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1476 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1477 my ( $accessor, $rel_class ) = @_;
1478 $self->_pod( $class, "=head2 $accessor" );
1479 $self->_pod( $class, 'Type: ' . $method );
1480 $self->_pod( $class, "Related object: L<$rel_class>" );
1481 $self->_pod_cut( $class );
1482 $self->{_relations_started} { $class } = 1;
1486 # Stores a POD documentation
1488 my ($self, $class, $stmt) = @_;
1489 $self->_raw_stmt( $class, "\n" . $stmt );
1493 my ($self, $class ) = @_;
1494 $self->_raw_stmt( $class, "\n=cut\n" );
1497 # Store a raw source line for a class (for dumping purposes)
1499 my ($self, $class, $stmt) = @_;
1500 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1503 # Like above, but separately for the externally loaded stuff
1505 my ($self, $class, $stmt) = @_;
1506 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1509 sub _quote_table_name {
1510 my ($self, $table) = @_;
1512 my $qt = $self->schema->storage->sql_maker->quote_char;
1514 return $table unless $qt;
1517 return $qt->[0] . $table . $qt->[1];
1520 return $qt . $table . $qt;
1523 sub _is_case_sensitive { 0 }
1525 # remove the dump dir from @INC on destruction
1529 @INC = grep $_ ne $self->dump_directory, @INC;
1534 Returns a hashref of loaded table to moniker mappings. There will
1535 be two entries for each table, the original name and the "normalized"
1536 name, in the case that the two are different (such as databases
1537 that like uppercase table names, or preserve your original mixed-case
1538 definitions, or what-have-you).
1542 Returns a hashref of table to class mappings. In some cases it will
1543 contain multiple entries per table for the original and normalized table
1544 names, as above in L</monikers>.
1548 L<DBIx::Class::Schema::Loader>
1552 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1556 This library is free software; you can redistribute it and/or modify it under
1557 the same terms as Perl itself.