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 # abs_path throws on Windows for nonexistant files
606 and eval { Cwd::abs_path($fullpath) } ne
607 (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
614 my ($self, $class) = @_;
616 my $class_path = $class;
617 $class_path =~ s{::}{/}g;
618 $class_path .= '.pm';
623 sub _find_class_in_inc {
624 my ($self, $class) = @_;
626 return $self->_find_file_in_inc($self->_class_path($class));
632 return $self->_upgrading_from
633 || $self->_upgrading_from_load_classes
634 || $self->_downgrading_to_load_classes
635 || $self->_rewriting_result_namespace
639 sub _rewrite_old_classnames {
640 my ($self, $code) = @_;
642 return $code unless $self->_rewriting;
644 my %old_classes = reverse %{ $self->_upgrading_classes };
646 my $re = join '|', keys %old_classes;
649 $code =~ s/$re/$old_classes{$1} || $1/eg;
655 my ($self, $class) = @_;
657 return if $self->{skip_load_external};
659 # so that we don't load our own classes, under any circumstances
660 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
662 my $real_inc_path = $self->_find_class_in_inc($class);
664 my $old_class = $self->_upgrading_classes->{$class}
665 if $self->_rewriting;
667 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
668 if $old_class && $old_class ne $class;
670 return unless $real_inc_path || $old_real_inc_path;
672 if ($real_inc_path) {
673 # If we make it to here, we loaded an external definition
674 warn qq/# Loaded external class definition for '$class'\n/
677 open(my $fh, '<', $real_inc_path)
678 or croak "Failed to open '$real_inc_path' for reading: $!";
679 my $code = do { local $/; <$fh> };
681 or croak "Failed to close $real_inc_path: $!";
682 $code = $self->_rewrite_old_classnames($code);
684 if ($self->dynamic) { # load the class too
685 # kill redefined warnings
686 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
687 local $SIG{__WARN__} = sub {
689 unless $_[0] =~ /^Subroutine \S+ redefined/;
695 $self->_ext_stmt($class,
696 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
697 .qq|# They are now part of the custom portion of this file\n|
698 .qq|# for you to hand-edit. If you do not either delete\n|
699 .qq|# this section or remove that file from \@INC, this section\n|
700 .qq|# will be repeated redundantly when you re-create this\n|
701 .qq|# file again via Loader! See skip_load_external to disable\n|
702 .qq|# this feature.\n|
705 $self->_ext_stmt($class, $code);
706 $self->_ext_stmt($class,
707 qq|# End of lines loaded from '$real_inc_path' |
711 if ($old_real_inc_path) {
712 open(my $fh, '<', $old_real_inc_path)
713 or croak "Failed to open '$old_real_inc_path' for reading: $!";
714 $self->_ext_stmt($class, <<"EOF");
716 # These lines were loaded from '$old_real_inc_path',
717 # based on the Result class name that would have been created by an 0.04006
718 # version of the Loader. For a static schema, this happens only once during
719 # upgrade. See skip_load_external to disable this feature.
723 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
725 $code = $self->_rewrite_old_classnames($code);
727 if ($self->dynamic) {
730 Detected external content in '$old_real_inc_path', a class name that would have
731 been used by an 0.04006 version of the Loader.
733 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
734 new name of the Result.
736 # kill redefined warnings
737 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
738 local $SIG{__WARN__} = sub {
740 unless $_[0] =~ /^Subroutine \S+ redefined/;
747 $self->_ext_stmt($class, $code);
748 $self->_ext_stmt($class,
749 qq|# End of lines loaded from '$old_real_inc_path' |
756 Does the actual schema-construction work.
763 $self->_load_tables($self->_tables_list);
770 Rescan the database for newly added tables. Does
771 not process drops or changes. Returns a list of
772 the newly added table monikers.
774 The schema argument should be the schema class
775 or object to be affected. It should probably
776 be derived from the original schema_class used
782 my ($self, $schema) = @_;
784 $self->{schema} = $schema;
785 $self->_relbuilder->{schema} = $schema;
788 my @current = $self->_tables_list;
789 foreach my $table ($self->_tables_list) {
790 if(!exists $self->{_tables}->{$table}) {
791 push(@created, $table);
795 my $loaded = $self->_load_tables(@created);
797 return map { $self->monikers->{$_} } @$loaded;
801 no warnings 'uninitialized';
804 return if $self->{skip_relationships};
806 if ($self->naming->{relationships} eq 'v4') {
807 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
808 return $self->{relbuilder} ||=
809 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
810 $self->schema, $self->inflect_plural, $self->inflect_singular
814 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
816 $self->inflect_plural,
817 $self->inflect_singular,
818 $self->relationship_attrs,
823 my ($self, @tables) = @_;
825 # First, use _tables_list with constraint and exclude
826 # to get a list of tables to operate on
828 my $constraint = $self->constraint;
829 my $exclude = $self->exclude;
831 @tables = grep { /$constraint/ } @tables if $constraint;
832 @tables = grep { ! /$exclude/ } @tables if $exclude;
834 # Save the new tables to the tables list
836 $self->{_tables}->{$_} = 1;
839 $self->_make_src_class($_) for @tables;
840 $self->_setup_src_meta($_) for @tables;
842 if(!$self->skip_relationships) {
843 # The relationship loader needs a working schema
845 local $self->{dump_directory} = $self->{temp_directory};
846 $self->_reload_classes(\@tables);
847 $self->_load_relationships($_) for @tables;
850 # Remove that temp dir from INC so it doesn't get reloaded
851 @INC = grep $_ ne $self->dump_directory, @INC;
854 $self->_load_external($_)
855 for map { $self->classes->{$_} } @tables;
857 # Reload without unloading first to preserve any symbols from external
859 $self->_reload_classes(\@tables, 0);
861 # Drop temporary cache
862 delete $self->{_cache};
867 sub _reload_classes {
868 my ($self, $tables, $unload) = @_;
870 my @tables = @$tables;
871 $unload = 1 unless defined $unload;
873 # so that we don't repeat custom sections
874 @INC = grep $_ ne $self->dump_directory, @INC;
876 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
878 unshift @INC, $self->dump_directory;
881 my %have_source = map { $_ => $self->schema->source($_) }
882 $self->schema->sources;
884 for my $table (@tables) {
885 my $moniker = $self->monikers->{$table};
886 my $class = $self->classes->{$table};
889 no warnings 'redefine';
890 local *Class::C3::reinitialize = sub {};
893 Class::Unload->unload($class) if $unload;
894 my ($source, $resultset_class);
896 ($source = $have_source{$moniker})
897 && ($resultset_class = $source->resultset_class)
898 && ($resultset_class ne 'DBIx::Class::ResultSet')
900 my $has_file = Class::Inspector->loaded_filename($resultset_class);
901 Class::Unload->unload($resultset_class) if $unload;
902 $self->_reload_class($resultset_class) if $has_file;
904 $self->_reload_class($class);
906 push @to_register, [$moniker, $class];
909 Class::C3->reinitialize;
911 $self->schema->register_class(@$_);
915 # We use this instead of ensure_class_loaded when there are package symbols we
918 my ($self, $class) = @_;
920 my $class_path = $self->_class_path($class);
921 delete $INC{ $class_path };
923 # kill redefined warnings
924 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
925 local $SIG{__WARN__} = sub {
927 unless $_[0] =~ /^Subroutine \S+ redefined/;
929 eval "require $class;";
932 sub _get_dump_filename {
933 my ($self, $class) = (@_);
936 return $self->dump_directory . q{/} . $class . q{.pm};
939 sub _ensure_dump_subdirs {
940 my ($self, $class) = (@_);
942 my @name_parts = split(/::/, $class);
943 pop @name_parts; # we don't care about the very last element,
944 # which is a filename
946 my $dir = $self->dump_directory;
949 mkdir($dir) or croak "mkdir('$dir') failed: $!";
951 last if !@name_parts;
952 $dir = File::Spec->catdir($dir, shift @name_parts);
957 my ($self, @classes) = @_;
959 my $schema_class = $self->schema_class;
960 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
962 my $target_dir = $self->dump_directory;
963 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
964 unless $self->{dynamic} or $self->{quiet};
967 qq|package $schema_class;\n\n|
968 . qq|# Created by DBIx::Class::Schema::Loader\n|
969 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
970 . qq|use strict;\nuse warnings;\n\n|
971 . qq|use base '$schema_base_class';\n\n|;
973 if ($self->use_namespaces) {
974 $schema_text .= qq|__PACKAGE__->load_namespaces|;
975 my $namespace_options;
976 for my $attr (qw(result_namespace
978 default_resultset_class)) {
980 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
983 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
984 $schema_text .= qq|;\n|;
987 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
991 local $self->{version_to_dump} = $self->schema_version_to_dump;
992 $self->_write_classfile($schema_class, $schema_text, 1);
995 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
997 foreach my $src_class (@classes) {
999 qq|package $src_class;\n\n|
1000 . qq|# Created by DBIx::Class::Schema::Loader\n|
1001 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1002 . qq|use strict;\nuse warnings;\n\n|
1003 . qq|use base '$result_base_class';\n\n|;
1005 $self->_write_classfile($src_class, $src_text);
1008 # remove Result dir if downgrading from use_namespaces, and there are no
1010 if (my $result_ns = $self->_downgrading_to_load_classes
1011 || $self->_rewriting_result_namespace) {
1012 my $result_namespace = $self->_result_namespace(
1017 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1018 $result_dir = $self->dump_directory . '/' . $result_dir;
1020 unless (my @files = glob "$result_dir/*") {
1025 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1030 my ($self, $version, $ts) = @_;
1031 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1034 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1037 sub _write_classfile {
1038 my ($self, $class, $text, $is_schema) = @_;
1040 my $filename = $self->_get_dump_filename($class);
1041 $self->_ensure_dump_subdirs($class);
1043 if (-f $filename && $self->really_erase_my_files) {
1044 warn "Deleting existing file '$filename' due to "
1045 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1049 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1051 if (my $old_class = $self->_upgrading_classes->{$class}) {
1052 my $old_filename = $self->_get_dump_filename($old_class);
1054 my ($old_custom_content) = $self->_get_custom_content(
1055 $old_class, $old_filename, 0 # do not add default comment
1058 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1060 if ($old_custom_content) {
1062 "\n" . $old_custom_content . "\n" . $custom_content;
1065 unlink $old_filename;
1068 $custom_content = $self->_rewrite_old_classnames($custom_content);
1071 for @{$self->{_dump_storage}->{$class} || []};
1073 # Check and see if the dump is infact differnt
1077 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1080 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1081 return unless $self->_upgrading_from && $is_schema;
1085 $text .= $self->_sig_comment(
1086 $self->version_to_dump,
1087 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1090 open(my $fh, '>', $filename)
1091 or croak "Cannot open '$filename' for writing: $!";
1093 # Write the top half and its MD5 sum
1094 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1096 # Write out anything loaded via external partial class file in @INC
1098 for @{$self->{_ext_storage}->{$class} || []};
1100 # Write out any custom content the user has added
1101 print $fh $custom_content;
1104 or croak "Error closing '$filename': $!";
1107 sub _default_custom_content {
1108 return qq|\n\n# You can replace this text with custom|
1109 . qq| content, and it will be preserved on regeneration|
1113 sub _get_custom_content {
1114 my ($self, $class, $filename, $add_default) = @_;
1116 $add_default = 1 unless defined $add_default;
1118 return ($self->_default_custom_content) if ! -f $filename;
1120 open(my $fh, '<', $filename)
1121 or croak "Cannot open '$filename' for reading: $!";
1124 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1127 my ($md5, $ts, $ver);
1129 if(!$md5 && /$mark_re/) {
1133 # Pull out the previous version and timestamp
1134 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1137 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"
1138 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1147 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1148 . " it does not appear to have been generated by Loader"
1151 # Default custom content:
1152 $buffer ||= $self->_default_custom_content if $add_default;
1154 return ($buffer, $md5, $ver, $ts);
1162 warn "$target: use $_;" if $self->debug;
1163 $self->_raw_stmt($target, "use $_;");
1170 my $schema_class = $self->schema_class;
1172 my $blist = join(q{ }, @_);
1173 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1174 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1177 sub _result_namespace {
1178 my ($self, $schema_class, $ns) = @_;
1179 my @result_namespace;
1181 if ($ns =~ /^\+(.*)/) {
1182 # Fully qualified namespace
1183 @result_namespace = ($1)
1186 # Relative namespace
1187 @result_namespace = ($schema_class, $ns);
1190 return wantarray ? @result_namespace : join '::', @result_namespace;
1193 # Create class with applicable bases, setup monikers, etc
1194 sub _make_src_class {
1195 my ($self, $table) = @_;
1197 my $schema = $self->schema;
1198 my $schema_class = $self->schema_class;
1200 my $table_moniker = $self->_table2moniker($table);
1201 my @result_namespace = ($schema_class);
1202 if ($self->use_namespaces) {
1203 my $result_namespace = $self->result_namespace || 'Result';
1204 @result_namespace = $self->_result_namespace(
1209 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1211 if ((my $upgrading_v = $self->_upgrading_from)
1212 || $self->_rewriting) {
1213 local $self->naming->{monikers} = $upgrading_v
1216 my @result_namespace = @result_namespace;
1217 if ($self->_upgrading_from_load_classes) {
1218 @result_namespace = ($schema_class);
1220 elsif (my $ns = $self->_downgrading_to_load_classes) {
1221 @result_namespace = $self->_result_namespace(
1226 elsif ($ns = $self->_rewriting_result_namespace) {
1227 @result_namespace = $self->_result_namespace(
1233 my $old_class = join(q{::}, @result_namespace,
1234 $self->_table2moniker($table));
1236 $self->_upgrading_classes->{$table_class} = $old_class
1237 unless $table_class eq $old_class;
1240 my $table_normalized = lc $table;
1241 $self->classes->{$table} = $table_class;
1242 $self->classes->{$table_normalized} = $table_class;
1243 $self->monikers->{$table} = $table_moniker;
1244 $self->monikers->{$table_normalized} = $table_moniker;
1246 $self->_use ($table_class, @{$self->additional_classes});
1247 $self->_inject($table_class, @{$self->left_base_classes});
1249 if (my @components = @{ $self->components }) {
1250 $self->_dbic_stmt($table_class, 'load_components', @components);
1253 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1254 if @{$self->resultset_components};
1255 $self->_inject($table_class, @{$self->additional_base_classes});
1258 # Set up metadata (cols, pks, etc)
1259 sub _setup_src_meta {
1260 my ($self, $table) = @_;
1262 my $schema = $self->schema;
1263 my $schema_class = $self->schema_class;
1265 my $table_class = $self->classes->{$table};
1266 my $table_moniker = $self->monikers->{$table};
1268 my $table_name = $table;
1269 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1271 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1272 $table_name = \ $self->_quote_table_name($table_name);
1275 $self->_dbic_stmt($table_class,'table',$table_name);
1277 my $cols = $self->_table_columns($table);
1279 eval { $col_info = $self->_columns_info_for($table) };
1281 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1284 if ($self->_is_case_sensitive) {
1285 for my $col (keys %$col_info) {
1286 $col_info->{$col}{accessor} = lc $col
1287 if $col ne lc($col);
1290 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1293 my $fks = $self->_table_fk_info($table);
1295 for my $fkdef (@$fks) {
1296 for my $col (@{ $fkdef->{local_columns} }) {
1297 $col_info->{$col}{is_foreign_key} = 1;
1303 map { $_, ($col_info->{$_}||{}) } @$cols
1307 my %uniq_tag; # used to eliminate duplicate uniqs
1309 my $pks = $self->_table_pk_info($table) || [];
1310 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1311 : carp("$table has no primary key");
1312 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1314 my $uniqs = $self->_table_uniq_info($table) || [];
1316 my ($name, $cols) = @$_;
1317 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1318 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1325 Returns a sorted list of loaded tables, using the original database table
1333 return keys %{$self->_tables};
1336 # Make a moniker from a table
1337 sub _default_table2moniker {
1338 no warnings 'uninitialized';
1339 my ($self, $table) = @_;
1341 if ($self->naming->{monikers} eq 'v4') {
1342 return join '', map ucfirst, split /[\W_]+/, lc $table;
1345 return join '', map ucfirst, split /[\W_]+/,
1346 Lingua::EN::Inflect::Number::to_S(lc $table);
1349 sub _table2moniker {
1350 my ( $self, $table ) = @_;
1354 if( ref $self->moniker_map eq 'HASH' ) {
1355 $moniker = $self->moniker_map->{$table};
1357 elsif( ref $self->moniker_map eq 'CODE' ) {
1358 $moniker = $self->moniker_map->($table);
1361 $moniker ||= $self->_default_table2moniker($table);
1366 sub _load_relationships {
1367 my ($self, $table) = @_;
1369 my $tbl_fk_info = $self->_table_fk_info($table);
1370 foreach my $fkdef (@$tbl_fk_info) {
1371 $fkdef->{remote_source} =
1372 $self->monikers->{delete $fkdef->{remote_table}};
1374 my $tbl_uniq_info = $self->_table_uniq_info($table);
1376 my $local_moniker = $self->monikers->{$table};
1377 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1379 foreach my $src_class (sort keys %$rel_stmts) {
1380 my $src_stmts = $rel_stmts->{$src_class};
1381 foreach my $stmt (@$src_stmts) {
1382 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1387 # Overload these in driver class:
1389 # Returns an arrayref of column names
1390 sub _table_columns { croak "ABSTRACT METHOD" }
1392 # Returns arrayref of pk col names
1393 sub _table_pk_info { croak "ABSTRACT METHOD" }
1395 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1396 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1398 # Returns an arrayref of foreign key constraints, each
1399 # being a hashref with 3 keys:
1400 # local_columns (arrayref), remote_columns (arrayref), remote_table
1401 sub _table_fk_info { croak "ABSTRACT METHOD" }
1403 # Returns an array of lower case table names
1404 sub _tables_list { croak "ABSTRACT METHOD" }
1406 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1412 # generate the pod for this statement, storing it with $self->_pod
1413 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1415 my $args = dump(@_);
1416 $args = '(' . $args . ')' if @_ < 2;
1417 my $stmt = $method . $args . q{;};
1419 warn qq|$class\->$stmt\n| if $self->debug;
1420 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1424 # generates the accompanying pod for a DBIC class method statement,
1425 # storing it with $self->_pod
1431 if ( $method eq 'table' ) {
1433 my $pcm = $self->pod_comment_mode;
1434 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1435 if ( $self->can('_table_comment') ) {
1436 $comment = $self->_table_comment($table);
1437 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1438 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1439 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1441 $self->_pod( $class, "=head1 NAME" );
1442 my $table_descr = $class;
1443 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1444 $self->{_class2table}{ $class } = $table;
1445 $self->_pod( $class, $table_descr );
1446 if ($comment and $comment_in_desc) {
1447 $self->_pod( $class, "=head1 DESCRIPTION" );
1448 $self->_pod( $class, $comment );
1450 $self->_pod_cut( $class );
1451 } elsif ( $method eq 'add_columns' ) {
1452 $self->_pod( $class, "=head1 ACCESSORS" );
1453 my $col_counter = 0;
1455 while( my ($name,$attrs) = splice @cols,0,2 ) {
1457 $self->_pod( $class, '=head2 ' . $name );
1458 $self->_pod( $class,
1460 my $s = $attrs->{$_};
1461 $s = !defined $s ? 'undef' :
1462 length($s) == 0 ? '(empty string)' :
1466 } sort keys %$attrs,
1469 if( $self->can('_column_comment')
1470 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1472 $self->_pod( $class, $comment );
1475 $self->_pod_cut( $class );
1476 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1477 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1478 my ( $accessor, $rel_class ) = @_;
1479 $self->_pod( $class, "=head2 $accessor" );
1480 $self->_pod( $class, 'Type: ' . $method );
1481 $self->_pod( $class, "Related object: L<$rel_class>" );
1482 $self->_pod_cut( $class );
1483 $self->{_relations_started} { $class } = 1;
1487 # Stores a POD documentation
1489 my ($self, $class, $stmt) = @_;
1490 $self->_raw_stmt( $class, "\n" . $stmt );
1494 my ($self, $class ) = @_;
1495 $self->_raw_stmt( $class, "\n=cut\n" );
1498 # Store a raw source line for a class (for dumping purposes)
1500 my ($self, $class, $stmt) = @_;
1501 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1504 # Like above, but separately for the externally loaded stuff
1506 my ($self, $class, $stmt) = @_;
1507 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1510 sub _quote_table_name {
1511 my ($self, $table) = @_;
1513 my $qt = $self->schema->storage->sql_maker->quote_char;
1515 return $table unless $qt;
1518 return $qt->[0] . $table . $qt->[1];
1521 return $qt . $table . $qt;
1524 sub _is_case_sensitive { 0 }
1526 # remove the dump dir from @INC on destruction
1530 @INC = grep $_ ne $self->dump_directory, @INC;
1535 Returns a hashref of loaded table to moniker mappings. There will
1536 be two entries for each table, the original name and the "normalized"
1537 name, in the case that the two are different (such as databases
1538 that like uppercase table names, or preserve your original mixed-case
1539 definitions, or what-have-you).
1543 Returns a hashref of table to class mappings. In some cases it will
1544 contain multiple entries per table for the original and normalized table
1545 names, as above in L</monikers>.
1549 L<DBIx::Class::Schema::Loader>
1553 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1557 This library is free software; you can redistribute it and/or modify it under
1558 the same terms as Perl itself.