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. By default table
177 comments are appended to the C<NAME> section of the documentation. You can
178 force a C<DESCRIPTION> section to be generated with the comment instead, or
179 choose the length threshold at which the comment is forced into the
182 pod_comment_mode => 'name' # default behaviour
183 pod_comment_mode => 'description' # force creation of DESCRIPTION section
184 pod_comment_mode => 'auto' # use description if length > pod_comment_spillover_length
186 =head2 pod_comment_spillover_length
188 When pod_comment_mode is set to C<auto>, this is the length of the comment at
189 which it will be forced into a separate description section.
193 =head2 relationship_attrs
195 Hashref of attributes to pass to each generated relationship, listed
196 by type. Also supports relationship type 'all', containing options to
197 pass to all generated relationships. Attributes set for more specific
198 relationship types override those set in 'all'.
202 relationship_attrs => {
203 all => { cascade_delete => 0 },
204 has_many => { cascade_delete => 1 },
207 will set the C<cascade_delete> option to 0 for all generated relationships,
208 except for C<has_many>, which will have cascade_delete as 1.
210 NOTE: this option is not supported if v4 backward-compatible naming is
211 set either globally (naming => 'v4') or just for relationships.
215 If set to true, each constructive L<DBIx::Class> statement the loader
216 decides to execute will be C<warn>-ed before execution.
220 Set the name of the schema to load (schema in the sense that your database
221 vendor means it). Does not currently support loading more than one schema
226 Only load tables matching regex. Best specified as a qr// regex.
230 Exclude tables matching regex. Best specified as a qr// regex.
234 Overrides the default table name to moniker translation. Can be either
235 a hashref of table keys and moniker values, or a coderef for a translator
236 function taking a single scalar table name argument and returning
237 a scalar moniker. If the hash entry does not exist, or the function
238 returns a false value, the code falls back to default behavior
241 The default behavior is to singularize the table name, and: C<join '', map
242 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
243 split up the table name into chunks anywhere a non-alpha-numeric character
244 occurs, change the case of first letter of each chunk to upper case, and put
245 the chunks back together. Examples:
247 Table Name | Moniker Name
248 ---------------------------
250 luser_group | LuserGroup
251 luser-opts | LuserOpt
253 =head2 inflect_plural
255 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
256 if hash key does not exist or coderef returns false), but acts as a map
257 for pluralizing relationship names. The default behavior is to utilize
258 L<Lingua::EN::Inflect::Number/to_PL>.
260 =head2 inflect_singular
262 As L</inflect_plural> above, but for singularizing relationship names.
263 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
265 =head2 schema_base_class
267 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
269 =head2 result_base_class
271 Base class for your table classes (aka result classes). Defaults to
274 =head2 additional_base_classes
276 List of additional base classes all of your table classes will use.
278 =head2 left_base_classes
280 List of additional base classes all of your table classes will use
281 that need to be leftmost.
283 =head2 additional_classes
285 List of additional classes which all of your table classes will use.
289 List of additional components to be loaded into all of your table
290 classes. A good example would be C<ResultSetManager>.
292 =head2 resultset_components
294 List of additional ResultSet components to be loaded into your table
295 classes. A good example would be C<AlwaysRS>. Component
296 C<ResultSetManager> will be automatically added to the above
297 C<components> list if this option is set.
299 =head2 use_namespaces
301 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
304 Generate result class names suitable for
305 L<DBIx::Class::Schema/load_namespaces> and call that instead of
306 L<DBIx::Class::Schema/load_classes>. When using this option you can also
307 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
308 C<resultset_namespace>, C<default_resultset_class>), and they will be added
309 to the call (and the generated result class names adjusted appropriately).
311 =head2 dump_directory
313 This option is designed to be a tool to help you transition from this
314 loader to a manually-defined schema when you decide it's time to do so.
316 The value of this option is a perl libdir pathname. Within
317 that directory this module will create a baseline manual
318 L<DBIx::Class::Schema> module set, based on what it creates at runtime
321 The created schema class will have the same classname as the one on
322 which you are setting this option (and the ResultSource classes will be
323 based on this name as well).
325 Normally you wouldn't hard-code this setting in your schema class, as it
326 is meant for one-time manual usage.
328 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
329 recommended way to access this functionality.
331 =head2 dump_overwrite
333 Deprecated. See L</really_erase_my_files> below, which does *not* mean
334 the same thing as the old C<dump_overwrite> setting from previous releases.
336 =head2 really_erase_my_files
338 Default false. If true, Loader will unconditionally delete any existing
339 files before creating the new ones from scratch when dumping a schema to disk.
341 The default behavior is instead to only replace the top portion of the
342 file, up to and including the final stanza which contains
343 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
344 leaving any customizations you placed after that as they were.
346 When C<really_erase_my_files> is not set, if the output file already exists,
347 but the aforementioned final stanza is not found, or the checksum
348 contained there does not match the generated contents, Loader will
349 croak and not touch the file.
351 You should really be using version control on your schema classes (and all
352 of the rest of your code for that matter). Don't blame me if a bug in this
353 code wipes something out when it shouldn't have, you've been warned.
355 =head2 overwrite_modifications
357 Default false. If false, when updating existing files, Loader will
358 refuse to modify any Loader-generated code that has been modified
359 since its last run (as determined by the checksum Loader put in its
362 If true, Loader will discard any manual modifications that have been
363 made to Loader-generated code.
365 Again, you should be using version control on your schema classes. Be
366 careful with this option.
370 None of these methods are intended for direct invocation by regular
371 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
372 can also be found via standard L<DBIx::Class::Schema> methods somehow.
376 use constant CURRENT_V => 'v5';
378 # ensure that a peice of object data is a valid arrayref, creating
379 # an empty one or encapsulating whatever's there.
380 sub _ensure_arrayref {
385 $self->{$_} = [ $self->{$_} ]
386 unless ref $self->{$_} eq 'ARRAY';
392 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
393 by L<DBIx::Class::Schema::Loader>.
398 my ( $class, %args ) = @_;
400 my $self = { %args };
402 bless $self => $class;
404 $self->_ensure_arrayref(qw/additional_classes
405 additional_base_classes
411 push(@{$self->{components}}, 'ResultSetManager')
412 if @{$self->{resultset_components}};
414 $self->{monikers} = {};
415 $self->{classes} = {};
416 $self->{_upgrading_classes} = {};
418 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
419 $self->{schema} ||= $self->{schema_class};
421 croak "dump_overwrite is deprecated. Please read the"
422 . " DBIx::Class::Schema::Loader::Base documentation"
423 if $self->{dump_overwrite};
425 $self->{dynamic} = ! $self->{dump_directory};
426 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
431 $self->{dump_directory} ||= $self->{temp_directory};
433 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
434 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
436 if ((not ref $self->naming) && defined $self->naming) {
437 my $naming_ver = $self->naming;
439 relationships => $naming_ver,
440 monikers => $naming_ver,
445 for (values %{ $self->naming }) {
446 $_ = CURRENT_V if $_ eq 'current';
449 $self->{naming} ||= {};
451 $self->_check_back_compat;
453 $self->use_namespaces(1) unless defined $self->use_namespaces;
454 $self->generate_pod(1) unless defined $self->generate_pod;
455 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
456 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
461 sub _check_back_compat {
464 # dynamic schemas will always be in 0.04006 mode, unless overridden
465 if ($self->dynamic) {
466 # just in case, though no one is likely to dump a dynamic schema
467 $self->schema_version_to_dump('0.04006');
469 if (not %{ $self->naming }) {
470 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
472 Dynamic schema detected, will run in 0.04006 mode.
474 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
475 to disable this warning.
477 Also consider setting 'use_namespaces => 1' if/when upgrading.
479 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
484 $self->_upgrading_from('v4');
487 $self->naming->{relationships} ||= 'v4';
488 $self->naming->{monikers} ||= 'v4';
490 if ($self->use_namespaces) {
491 $self->_upgrading_from_load_classes(1);
494 $self->use_namespaces(0);
500 # otherwise check if we need backcompat mode for a static schema
501 my $filename = $self->_get_dump_filename($self->schema_class);
502 return unless -e $filename;
504 open(my $fh, '<', $filename)
505 or croak "Cannot open '$filename' for reading: $!";
507 my $load_classes = 0;
508 my $result_namespace = '';
511 if (/^__PACKAGE__->load_classes;/) {
513 } elsif (/result_namespace => '([^']+)'/) {
514 $result_namespace = $1;
515 } elsif (my ($real_ver) =
516 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
518 if ($load_classes && (not defined $self->use_namespaces)) {
519 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
521 'load_classes;' static schema detected, turning off 'use_namespaces'.
523 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
524 variable to disable this warning.
526 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
529 $self->use_namespaces(0);
531 elsif ($load_classes && $self->use_namespaces) {
532 $self->_upgrading_from_load_classes(1);
534 elsif ((not $load_classes) && defined $self->use_namespaces
535 && (not $self->use_namespaces)) {
536 $self->_downgrading_to_load_classes(
537 $result_namespace || 'Result'
540 elsif ((not defined $self->use_namespaces)
541 || $self->use_namespaces) {
542 if (not $self->result_namespace) {
543 $self->result_namespace($result_namespace || 'Result');
545 elsif ($result_namespace ne $self->result_namespace) {
546 $self->_rewriting_result_namespace(
547 $result_namespace || 'Result'
552 # XXX when we go past .0 this will need fixing
553 my ($v) = $real_ver =~ /([1-9])/;
556 last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
558 if (not %{ $self->naming }) {
559 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
561 Version $real_ver static schema detected, turning on backcompat mode.
563 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
564 to disable this warning.
566 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
571 $self->_upgrading_from($v);
575 $self->naming->{relationships} ||= $v;
576 $self->naming->{monikers} ||= $v;
578 $self->schema_version_to_dump($real_ver);
586 sub _find_file_in_inc {
587 my ($self, $file) = @_;
589 foreach my $prefix (@INC) {
590 my $fullpath = File::Spec->catfile($prefix, $file);
591 return $fullpath if -f $fullpath
592 and Cwd::abs_path($fullpath) ne
593 (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
600 my ($self, $class) = @_;
602 my $class_path = $class;
603 $class_path =~ s{::}{/}g;
604 $class_path .= '.pm';
609 sub _find_class_in_inc {
610 my ($self, $class) = @_;
612 return $self->_find_file_in_inc($self->_class_path($class));
618 return $self->_upgrading_from
619 || $self->_upgrading_from_load_classes
620 || $self->_downgrading_to_load_classes
621 || $self->_rewriting_result_namespace
625 sub _rewrite_old_classnames {
626 my ($self, $code) = @_;
628 return $code unless $self->_rewriting;
630 my %old_classes = reverse %{ $self->_upgrading_classes };
632 my $re = join '|', keys %old_classes;
635 $code =~ s/$re/$old_classes{$1} || $1/eg;
641 my ($self, $class) = @_;
643 return if $self->{skip_load_external};
645 # so that we don't load our own classes, under any circumstances
646 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
648 my $real_inc_path = $self->_find_class_in_inc($class);
650 my $old_class = $self->_upgrading_classes->{$class}
651 if $self->_rewriting;
653 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
654 if $old_class && $old_class ne $class;
656 return unless $real_inc_path || $old_real_inc_path;
658 if ($real_inc_path) {
659 # If we make it to here, we loaded an external definition
660 warn qq/# Loaded external class definition for '$class'\n/
663 open(my $fh, '<', $real_inc_path)
664 or croak "Failed to open '$real_inc_path' for reading: $!";
665 my $code = do { local $/; <$fh> };
667 or croak "Failed to close $real_inc_path: $!";
668 $code = $self->_rewrite_old_classnames($code);
670 if ($self->dynamic) { # load the class too
671 # kill redefined warnings
672 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
673 local $SIG{__WARN__} = sub {
675 unless $_[0] =~ /^Subroutine \S+ redefined/;
681 $self->_ext_stmt($class,
682 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
683 .qq|# They are now part of the custom portion of this file\n|
684 .qq|# for you to hand-edit. If you do not either delete\n|
685 .qq|# this section or remove that file from \@INC, this section\n|
686 .qq|# will be repeated redundantly when you re-create this\n|
687 .qq|# file again via Loader! See skip_load_external to disable\n|
688 .qq|# this feature.\n|
691 $self->_ext_stmt($class, $code);
692 $self->_ext_stmt($class,
693 qq|# End of lines loaded from '$real_inc_path' |
697 if ($old_real_inc_path) {
698 open(my $fh, '<', $old_real_inc_path)
699 or croak "Failed to open '$old_real_inc_path' for reading: $!";
700 $self->_ext_stmt($class, <<"EOF");
702 # These lines were loaded from '$old_real_inc_path',
703 # based on the Result class name that would have been created by an 0.04006
704 # version of the Loader. For a static schema, this happens only once during
705 # upgrade. See skip_load_external to disable this feature.
709 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
711 $code = $self->_rewrite_old_classnames($code);
713 if ($self->dynamic) {
716 Detected external content in '$old_real_inc_path', a class name that would have
717 been used by an 0.04006 version of the Loader.
719 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
720 new name of the Result.
722 # kill redefined warnings
723 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
724 local $SIG{__WARN__} = sub {
726 unless $_[0] =~ /^Subroutine \S+ redefined/;
733 $self->_ext_stmt($class, $code);
734 $self->_ext_stmt($class,
735 qq|# End of lines loaded from '$old_real_inc_path' |
742 Does the actual schema-construction work.
749 $self->_load_tables($self->_tables_list);
756 Rescan the database for newly added tables. Does
757 not process drops or changes. Returns a list of
758 the newly added table monikers.
760 The schema argument should be the schema class
761 or object to be affected. It should probably
762 be derived from the original schema_class used
768 my ($self, $schema) = @_;
770 $self->{schema} = $schema;
771 $self->_relbuilder->{schema} = $schema;
774 my @current = $self->_tables_list;
775 foreach my $table ($self->_tables_list) {
776 if(!exists $self->{_tables}->{$table}) {
777 push(@created, $table);
781 my $loaded = $self->_load_tables(@created);
783 return map { $self->monikers->{$_} } @$loaded;
787 no warnings 'uninitialized';
790 return if $self->{skip_relationships};
792 if ($self->naming->{relationships} eq 'v4') {
793 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
794 return $self->{relbuilder} ||=
795 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
796 $self->schema, $self->inflect_plural, $self->inflect_singular
800 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
802 $self->inflect_plural,
803 $self->inflect_singular,
804 $self->relationship_attrs,
809 my ($self, @tables) = @_;
811 # First, use _tables_list with constraint and exclude
812 # to get a list of tables to operate on
814 my $constraint = $self->constraint;
815 my $exclude = $self->exclude;
817 @tables = grep { /$constraint/ } @tables if $constraint;
818 @tables = grep { ! /$exclude/ } @tables if $exclude;
820 # Save the new tables to the tables list
822 $self->{_tables}->{$_} = 1;
825 $self->_make_src_class($_) for @tables;
826 $self->_setup_src_meta($_) for @tables;
828 if(!$self->skip_relationships) {
829 # The relationship loader needs a working schema
831 local $self->{dump_directory} = $self->{temp_directory};
832 $self->_reload_classes(\@tables);
833 $self->_load_relationships($_) for @tables;
836 # Remove that temp dir from INC so it doesn't get reloaded
837 @INC = grep $_ ne $self->dump_directory, @INC;
840 $self->_load_external($_)
841 for map { $self->classes->{$_} } @tables;
843 # Reload without unloading first to preserve any symbols from external
845 $self->_reload_classes(\@tables, 0);
847 # Drop temporary cache
848 delete $self->{_cache};
853 sub _reload_classes {
854 my ($self, $tables, $unload) = @_;
856 my @tables = @$tables;
857 $unload = 1 unless defined $unload;
859 # so that we don't repeat custom sections
860 @INC = grep $_ ne $self->dump_directory, @INC;
862 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
864 unshift @INC, $self->dump_directory;
867 my %have_source = map { $_ => $self->schema->source($_) }
868 $self->schema->sources;
870 for my $table (@tables) {
871 my $moniker = $self->monikers->{$table};
872 my $class = $self->classes->{$table};
875 no warnings 'redefine';
876 local *Class::C3::reinitialize = sub {};
879 Class::Unload->unload($class) if $unload;
880 my ($source, $resultset_class);
882 ($source = $have_source{$moniker})
883 && ($resultset_class = $source->resultset_class)
884 && ($resultset_class ne 'DBIx::Class::ResultSet')
886 my $has_file = Class::Inspector->loaded_filename($resultset_class);
887 Class::Unload->unload($resultset_class) if $unload;
888 $self->_reload_class($resultset_class) if $has_file;
890 $self->_reload_class($class);
892 push @to_register, [$moniker, $class];
895 Class::C3->reinitialize;
897 $self->schema->register_class(@$_);
901 # We use this instead of ensure_class_loaded when there are package symbols we
904 my ($self, $class) = @_;
906 my $class_path = $self->_class_path($class);
907 delete $INC{ $class_path };
909 # kill redefined warnings
910 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
911 local $SIG{__WARN__} = sub {
913 unless $_[0] =~ /^Subroutine \S+ redefined/;
915 eval "require $class;";
918 sub _get_dump_filename {
919 my ($self, $class) = (@_);
922 return $self->dump_directory . q{/} . $class . q{.pm};
925 sub _ensure_dump_subdirs {
926 my ($self, $class) = (@_);
928 my @name_parts = split(/::/, $class);
929 pop @name_parts; # we don't care about the very last element,
930 # which is a filename
932 my $dir = $self->dump_directory;
935 mkdir($dir) or croak "mkdir('$dir') failed: $!";
937 last if !@name_parts;
938 $dir = File::Spec->catdir($dir, shift @name_parts);
943 my ($self, @classes) = @_;
945 my $schema_class = $self->schema_class;
946 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
948 my $target_dir = $self->dump_directory;
949 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
950 unless $self->{dynamic} or $self->{quiet};
953 qq|package $schema_class;\n\n|
954 . qq|# Created by DBIx::Class::Schema::Loader\n|
955 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
956 . qq|use strict;\nuse warnings;\n\n|
957 . qq|use base '$schema_base_class';\n\n|;
959 if ($self->use_namespaces) {
960 $schema_text .= qq|__PACKAGE__->load_namespaces|;
961 my $namespace_options;
962 for my $attr (qw(result_namespace
964 default_resultset_class)) {
966 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
969 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
970 $schema_text .= qq|;\n|;
973 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
977 local $self->{version_to_dump} = $self->schema_version_to_dump;
978 $self->_write_classfile($schema_class, $schema_text, 1);
981 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
983 foreach my $src_class (@classes) {
985 qq|package $src_class;\n\n|
986 . qq|# Created by DBIx::Class::Schema::Loader\n|
987 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
988 . qq|use strict;\nuse warnings;\n\n|
989 . qq|use base '$result_base_class';\n\n|;
991 $self->_write_classfile($src_class, $src_text);
994 # remove Result dir if downgrading from use_namespaces, and there are no
996 if (my $result_ns = $self->_downgrading_to_load_classes
997 || $self->_rewriting_result_namespace) {
998 my $result_namespace = $self->_result_namespace(
1003 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1004 $result_dir = $self->dump_directory . '/' . $result_dir;
1006 unless (my @files = glob "$result_dir/*") {
1011 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1016 my ($self, $version, $ts) = @_;
1017 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1020 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1023 sub _write_classfile {
1024 my ($self, $class, $text, $is_schema) = @_;
1026 my $filename = $self->_get_dump_filename($class);
1027 $self->_ensure_dump_subdirs($class);
1029 if (-f $filename && $self->really_erase_my_files) {
1030 warn "Deleting existing file '$filename' due to "
1031 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1035 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1037 if (my $old_class = $self->_upgrading_classes->{$class}) {
1038 my $old_filename = $self->_get_dump_filename($old_class);
1040 my ($old_custom_content) = $self->_get_custom_content(
1041 $old_class, $old_filename, 0 # do not add default comment
1044 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1046 if ($old_custom_content) {
1048 "\n" . $old_custom_content . "\n" . $custom_content;
1051 unlink $old_filename;
1054 $custom_content = $self->_rewrite_old_classnames($custom_content);
1057 for @{$self->{_dump_storage}->{$class} || []};
1059 # Check and see if the dump is infact differnt
1063 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1066 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1067 return unless $self->_upgrading_from && $is_schema;
1071 $text .= $self->_sig_comment(
1072 $self->version_to_dump,
1073 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1076 open(my $fh, '>', $filename)
1077 or croak "Cannot open '$filename' for writing: $!";
1079 # Write the top half and its MD5 sum
1080 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1082 # Write out anything loaded via external partial class file in @INC
1084 for @{$self->{_ext_storage}->{$class} || []};
1086 # Write out any custom content the user has added
1087 print $fh $custom_content;
1090 or croak "Error closing '$filename': $!";
1093 sub _default_custom_content {
1094 return qq|\n\n# You can replace this text with custom|
1095 . qq| content, and it will be preserved on regeneration|
1099 sub _get_custom_content {
1100 my ($self, $class, $filename, $add_default) = @_;
1102 $add_default = 1 unless defined $add_default;
1104 return ($self->_default_custom_content) if ! -f $filename;
1106 open(my $fh, '<', $filename)
1107 or croak "Cannot open '$filename' for reading: $!";
1110 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1113 my ($md5, $ts, $ver);
1115 if(!$md5 && /$mark_re/) {
1119 # Pull out the previous version and timestamp
1120 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1123 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"
1124 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1133 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1134 . " it does not appear to have been generated by Loader"
1137 # Default custom content:
1138 $buffer ||= $self->_default_custom_content if $add_default;
1140 return ($buffer, $md5, $ver, $ts);
1148 warn "$target: use $_;" if $self->debug;
1149 $self->_raw_stmt($target, "use $_;");
1156 my $schema_class = $self->schema_class;
1158 my $blist = join(q{ }, @_);
1159 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1160 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1163 sub _result_namespace {
1164 my ($self, $schema_class, $ns) = @_;
1165 my @result_namespace;
1167 if ($ns =~ /^\+(.*)/) {
1168 # Fully qualified namespace
1169 @result_namespace = ($1)
1172 # Relative namespace
1173 @result_namespace = ($schema_class, $ns);
1176 return wantarray ? @result_namespace : join '::', @result_namespace;
1179 # Create class with applicable bases, setup monikers, etc
1180 sub _make_src_class {
1181 my ($self, $table) = @_;
1183 my $schema = $self->schema;
1184 my $schema_class = $self->schema_class;
1186 my $table_moniker = $self->_table2moniker($table);
1187 my @result_namespace = ($schema_class);
1188 if ($self->use_namespaces) {
1189 my $result_namespace = $self->result_namespace || 'Result';
1190 @result_namespace = $self->_result_namespace(
1195 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1197 if ((my $upgrading_v = $self->_upgrading_from)
1198 || $self->_rewriting) {
1199 local $self->naming->{monikers} = $upgrading_v
1202 my @result_namespace = @result_namespace;
1203 if ($self->_upgrading_from_load_classes) {
1204 @result_namespace = ($schema_class);
1206 elsif (my $ns = $self->_downgrading_to_load_classes) {
1207 @result_namespace = $self->_result_namespace(
1212 elsif ($ns = $self->_rewriting_result_namespace) {
1213 @result_namespace = $self->_result_namespace(
1219 my $old_class = join(q{::}, @result_namespace,
1220 $self->_table2moniker($table));
1222 $self->_upgrading_classes->{$table_class} = $old_class
1223 unless $table_class eq $old_class;
1226 my $table_normalized = lc $table;
1227 $self->classes->{$table} = $table_class;
1228 $self->classes->{$table_normalized} = $table_class;
1229 $self->monikers->{$table} = $table_moniker;
1230 $self->monikers->{$table_normalized} = $table_moniker;
1232 $self->_use ($table_class, @{$self->additional_classes});
1233 $self->_inject($table_class, @{$self->left_base_classes});
1235 if (my @components = @{ $self->components }) {
1236 $self->_dbic_stmt($table_class, 'load_components', @components);
1239 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1240 if @{$self->resultset_components};
1241 $self->_inject($table_class, @{$self->additional_base_classes});
1244 # Set up metadata (cols, pks, etc)
1245 sub _setup_src_meta {
1246 my ($self, $table) = @_;
1248 my $schema = $self->schema;
1249 my $schema_class = $self->schema_class;
1251 my $table_class = $self->classes->{$table};
1252 my $table_moniker = $self->monikers->{$table};
1254 my $table_name = $table;
1255 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1257 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1258 $table_name = \ $self->_quote_table_name($table_name);
1261 $self->_dbic_stmt($table_class,'table',$table_name);
1263 my $cols = $self->_table_columns($table);
1265 eval { $col_info = $self->_columns_info_for($table) };
1267 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1270 if ($self->_is_case_sensitive) {
1271 for my $col (keys %$col_info) {
1272 $col_info->{$col}{accessor} = lc $col
1273 if $col ne lc($col);
1276 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1279 my $fks = $self->_table_fk_info($table);
1281 for my $fkdef (@$fks) {
1282 for my $col (@{ $fkdef->{local_columns} }) {
1283 $col_info->{$col}{is_foreign_key} = 1;
1289 map { $_, ($col_info->{$_}||{}) } @$cols
1293 my %uniq_tag; # used to eliminate duplicate uniqs
1295 my $pks = $self->_table_pk_info($table) || [];
1296 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1297 : carp("$table has no primary key");
1298 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1300 my $uniqs = $self->_table_uniq_info($table) || [];
1302 my ($name, $cols) = @$_;
1303 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1304 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1311 Returns a sorted list of loaded tables, using the original database table
1319 return keys %{$self->_tables};
1322 # Make a moniker from a table
1323 sub _default_table2moniker {
1324 no warnings 'uninitialized';
1325 my ($self, $table) = @_;
1327 if ($self->naming->{monikers} eq 'v4') {
1328 return join '', map ucfirst, split /[\W_]+/, lc $table;
1331 return join '', map ucfirst, split /[\W_]+/,
1332 Lingua::EN::Inflect::Number::to_S(lc $table);
1335 sub _table2moniker {
1336 my ( $self, $table ) = @_;
1340 if( ref $self->moniker_map eq 'HASH' ) {
1341 $moniker = $self->moniker_map->{$table};
1343 elsif( ref $self->moniker_map eq 'CODE' ) {
1344 $moniker = $self->moniker_map->($table);
1347 $moniker ||= $self->_default_table2moniker($table);
1352 sub _load_relationships {
1353 my ($self, $table) = @_;
1355 my $tbl_fk_info = $self->_table_fk_info($table);
1356 foreach my $fkdef (@$tbl_fk_info) {
1357 $fkdef->{remote_source} =
1358 $self->monikers->{delete $fkdef->{remote_table}};
1360 my $tbl_uniq_info = $self->_table_uniq_info($table);
1362 my $local_moniker = $self->monikers->{$table};
1363 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1365 foreach my $src_class (sort keys %$rel_stmts) {
1366 my $src_stmts = $rel_stmts->{$src_class};
1367 foreach my $stmt (@$src_stmts) {
1368 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1373 # Overload these in driver class:
1375 # Returns an arrayref of column names
1376 sub _table_columns { croak "ABSTRACT METHOD" }
1378 # Returns arrayref of pk col names
1379 sub _table_pk_info { croak "ABSTRACT METHOD" }
1381 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1382 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1384 # Returns an arrayref of foreign key constraints, each
1385 # being a hashref with 3 keys:
1386 # local_columns (arrayref), remote_columns (arrayref), remote_table
1387 sub _table_fk_info { croak "ABSTRACT METHOD" }
1389 # Returns an array of lower case table names
1390 sub _tables_list { croak "ABSTRACT METHOD" }
1392 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1398 # generate the pod for this statement, storing it with $self->_pod
1399 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1401 my $args = dump(@_);
1402 $args = '(' . $args . ')' if @_ < 2;
1403 my $stmt = $method . $args . q{;};
1405 warn qq|$class\->$stmt\n| if $self->debug;
1406 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1410 # generates the accompanying pod for a DBIC class method statement,
1411 # storing it with $self->_pod
1417 if ( $method eq 'table' ) {
1419 my $pcm = $self->pod_comment_mode;
1420 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1421 if ( $self->can('_table_comment') ) {
1422 $comment = $self->_table_comment($table);
1423 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1424 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1425 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1427 $self->_pod( $class, "=head1 NAME" );
1428 my $table_descr = $class;
1429 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1430 $self->{_class2table}{ $class } = $table;
1431 $self->_pod( $class, $table_descr );
1432 if ($comment and $comment_in_desc) {
1433 $self->_pod( $class, "=head1 DESCRIPTION" );
1434 $self->_pod( $class, $comment );
1436 $self->_pod_cut( $class );
1437 } elsif ( $method eq 'add_columns' ) {
1438 $self->_pod( $class, "=head1 ACCESSORS" );
1439 my $col_counter = 0;
1441 while( my ($name,$attrs) = splice @cols,0,2 ) {
1443 $self->_pod( $class, '=head2 ' . $name );
1444 $self->_pod( $class,
1446 my $s = $attrs->{$_};
1447 $s = !defined $s ? 'undef' :
1448 length($s) == 0 ? '(empty string)' :
1452 } sort keys %$attrs,
1455 if( $self->can('_column_comment')
1456 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1458 $self->_pod( $class, $comment );
1461 $self->_pod_cut( $class );
1462 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1463 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1464 my ( $accessor, $rel_class ) = @_;
1465 $self->_pod( $class, "=head2 $accessor" );
1466 $self->_pod( $class, 'Type: ' . $method );
1467 $self->_pod( $class, "Related object: L<$rel_class>" );
1468 $self->_pod_cut( $class );
1469 $self->{_relations_started} { $class } = 1;
1473 # Stores a POD documentation
1475 my ($self, $class, $stmt) = @_;
1476 $self->_raw_stmt( $class, "\n" . $stmt );
1480 my ($self, $class ) = @_;
1481 $self->_raw_stmt( $class, "\n=cut\n" );
1484 # Store a raw source line for a class (for dumping purposes)
1486 my ($self, $class, $stmt) = @_;
1487 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1490 # Like above, but separately for the externally loaded stuff
1492 my ($self, $class, $stmt) = @_;
1493 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1496 sub _quote_table_name {
1497 my ($self, $table) = @_;
1499 my $qt = $self->schema->storage->sql_maker->quote_char;
1501 return $table unless $qt;
1504 return $qt->[0] . $table . $qt->[1];
1507 return $qt . $table . $qt;
1510 sub _is_case_sensitive { 0 }
1512 # remove the dump dir from @INC on destruction
1516 @INC = grep $_ ne $self->dump_directory, @INC;
1521 Returns a hashref of loaded table to moniker mappings. There will
1522 be two entries for each table, the original name and the "normalized"
1523 name, in the case that the two are different (such as databases
1524 that like uppercase table names, or preserve your original mixed-case
1525 definitions, or what-have-you).
1529 Returns a hashref of table to class mappings. In some cases it will
1530 contain multiple entries per table for the original and normalized table
1531 names, as above in L</monikers>.
1535 L<DBIx::Class::Schema::Loader>
1539 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1543 This library is free software; you can redistribute it and/or modify it under
1544 the same terms as Perl itself.