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_12';
21 __PACKAGE__->mk_group_ro_accessors('simple', qw/
28 additional_base_classes
44 default_resultset_class
47 overwrite_modifications
59 __PACKAGE__->mk_group_accessors('simple', qw/
61 schema_version_to_dump
67 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
71 See L<DBIx::Class::Schema::Loader>
75 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
76 classes, and implements the common functionality between them.
78 =head1 CONSTRUCTOR OPTIONS
80 These constructor options are the base options for
81 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
83 =head2 skip_relationships
85 Skip setting up relationships. The default is to attempt the loading
88 =head2 skip_load_external
90 Skip loading of other classes in @INC. The default is to merge all other classes
91 with the same name found in @INC into the schema file we are creating.
95 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
96 relationship names and singularized Results, unless you're overwriting an
97 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
98 which case the backward compatible RelBuilder will be activated, and
99 singularization will be turned off.
105 will disable the backward-compatible RelBuilder and use
106 the new-style relationship names along with singularized Results, even when
107 overwriting a dump made with an earlier version.
109 The option also takes a hashref:
111 naming => { relationships => 'v5', monikers => 'v4' }
119 How to name relationship accessors.
123 How to name Result classes.
133 Latest default style, whatever that happens to be.
137 Version 0.05XXX style.
141 Version 0.04XXX style.
145 Dynamic schemas will always default to the 0.04XXX relationship names and won't
146 singularize Results for backward compatibility, to activate the new RelBuilder
147 and singularization put this in your C<Schema.pm> file:
149 __PACKAGE__->naming('current');
151 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
152 next major version upgrade:
154 __PACKAGE__->naming('v5');
158 If set to true, each constructive L<DBIx::Class> statement the loader
159 decides to execute will be C<warn>-ed before execution.
163 Set the name of the schema to load (schema in the sense that your database
164 vendor means it). Does not currently support loading more than one schema
169 Only load tables matching regex. Best specified as a qr// regex.
173 Exclude tables matching regex. Best specified as a qr// regex.
177 Overrides the default table name to moniker translation. Can be either
178 a hashref of table keys and moniker values, or a coderef for a translator
179 function taking a single scalar table name argument and returning
180 a scalar moniker. If the hash entry does not exist, or the function
181 returns a false value, the code falls back to default behavior
184 The default behavior is to singularize the table name, and: C<join '', map
185 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
186 split up the table name into chunks anywhere a non-alpha-numeric character
187 occurs, change the case of first letter of each chunk to upper case, and put
188 the chunks back together. Examples:
190 Table Name | Moniker Name
191 ---------------------------
193 luser_group | LuserGroup
194 luser-opts | LuserOpts
196 =head2 inflect_plural
198 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
199 if hash key does not exist or coderef returns false), but acts as a map
200 for pluralizing relationship names. The default behavior is to utilize
201 L<Lingua::EN::Inflect::Number/to_PL>.
203 =head2 inflect_singular
205 As L</inflect_plural> above, but for singularizing relationship names.
206 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
208 =head2 schema_base_class
210 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
212 =head2 result_base_class
214 Base class for your table classes (aka result classes). Defaults to
217 =head2 additional_base_classes
219 List of additional base classes all of your table classes will use.
221 =head2 left_base_classes
223 List of additional base classes all of your table classes will use
224 that need to be leftmost.
226 =head2 additional_classes
228 List of additional classes which all of your table classes will use.
232 List of additional components to be loaded into all of your table
233 classes. A good example would be C<ResultSetManager>.
235 =head2 resultset_components
237 List of additional ResultSet components to be loaded into your table
238 classes. A good example would be C<AlwaysRS>. Component
239 C<ResultSetManager> will be automatically added to the above
240 C<components> list if this option is set.
242 =head2 use_namespaces
244 Generate result class names suitable for
245 L<DBIx::Class::Schema/load_namespaces> and call that instead of
246 L<DBIx::Class::Schema/load_classes>. When using this option you can also
247 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
248 C<resultset_namespace>, C<default_resultset_class>), and they will be added
249 to the call (and the generated result class names adjusted appropriately).
251 =head2 dump_directory
253 This option is designed to be a tool to help you transition from this
254 loader to a manually-defined schema when you decide it's time to do so.
256 The value of this option is a perl libdir pathname. Within
257 that directory this module will create a baseline manual
258 L<DBIx::Class::Schema> module set, based on what it creates at runtime
261 The created schema class will have the same classname as the one on
262 which you are setting this option (and the ResultSource classes will be
263 based on this name as well).
265 Normally you wouldn't hard-code this setting in your schema class, as it
266 is meant for one-time manual usage.
268 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
269 recommended way to access this functionality.
271 =head2 dump_overwrite
273 Deprecated. See L</really_erase_my_files> below, which does *not* mean
274 the same thing as the old C<dump_overwrite> setting from previous releases.
276 =head2 really_erase_my_files
278 Default false. If true, Loader will unconditionally delete any existing
279 files before creating the new ones from scratch when dumping a schema to disk.
281 The default behavior is instead to only replace the top portion of the
282 file, up to and including the final stanza which contains
283 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
284 leaving any customizations you placed after that as they were.
286 When C<really_erase_my_files> is not set, if the output file already exists,
287 but the aforementioned final stanza is not found, or the checksum
288 contained there does not match the generated contents, Loader will
289 croak and not touch the file.
291 You should really be using version control on your schema classes (and all
292 of the rest of your code for that matter). Don't blame me if a bug in this
293 code wipes something out when it shouldn't have, you've been warned.
295 =head2 overwrite_modifications
297 Default false. If false, when updating existing files, Loader will
298 refuse to modify any Loader-generated code that has been modified
299 since its last run (as determined by the checksum Loader put in its
302 If true, Loader will discard any manual modifications that have been
303 made to Loader-generated code.
305 Again, you should be using version control on your schema classes. Be
306 careful with this option.
310 None of these methods are intended for direct invocation by regular
311 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
312 can also be found via standard L<DBIx::Class::Schema> methods somehow.
316 use constant CURRENT_V => 'v5';
318 # ensure that a peice of object data is a valid arrayref, creating
319 # an empty one or encapsulating whatever's there.
320 sub _ensure_arrayref {
325 $self->{$_} = [ $self->{$_} ]
326 unless ref $self->{$_} eq 'ARRAY';
332 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
333 by L<DBIx::Class::Schema::Loader>.
338 my ( $class, %args ) = @_;
340 my $self = { %args };
342 bless $self => $class;
344 $self->_ensure_arrayref(qw/additional_classes
345 additional_base_classes
351 push(@{$self->{components}}, 'ResultSetManager')
352 if @{$self->{resultset_components}};
354 $self->{monikers} = {};
355 $self->{classes} = {};
356 $self->{_upgrading_classes} = {};
358 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
359 $self->{schema} ||= $self->{schema_class};
361 croak "dump_overwrite is deprecated. Please read the"
362 . " DBIx::Class::Schema::Loader::Base documentation"
363 if $self->{dump_overwrite};
365 $self->{dynamic} = ! $self->{dump_directory};
366 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
371 $self->{dump_directory} ||= $self->{temp_directory};
373 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
374 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
376 if ((not ref $self->naming) && defined $self->naming) {
377 my $naming_ver = $self->naming;
379 relationships => $naming_ver,
380 monikers => $naming_ver,
385 for (values %{ $self->naming }) {
386 $_ = CURRENT_V if $_ eq 'current';
389 $self->{naming} ||= {};
391 $self->_check_back_compat;
396 sub _check_back_compat {
399 # dynamic schemas will always be in 0.04006 mode, unless overridden
400 if ($self->dynamic) {
401 # just in case, though no one is likely to dump a dynamic schema
402 $self->schema_version_to_dump('0.04006');
404 if (not %{ $self->naming }) {
405 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
407 Dynamic schema detected, will run in 0.04006 mode.
409 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
410 to disable this warning.
412 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
417 $self->_upgrading_from('v4');
420 $self->naming->{relationships} ||= 'v4';
421 $self->naming->{monikers} ||= 'v4';
426 # otherwise check if we need backcompat mode for a static schema
427 my $filename = $self->_get_dump_filename($self->schema_class);
428 return unless -e $filename;
430 open(my $fh, '<', $filename)
431 or croak "Cannot open '$filename' for reading: $!";
434 if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
437 # XXX when we go past .0 this will need fixing
438 my ($v) = $real_ver =~ /([1-9])/;
441 last if $v eq CURRENT_V || $real_ver =~ /^0\.04999/;
443 if (not %{ $self->naming }) {
444 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
446 Version $real_ver static schema detected, turning on backcompat mode.
448 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
449 to disable this warning.
451 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
456 $self->_upgrading_from($v);
459 $self->naming->{relationships} ||= $v;
460 $self->naming->{monikers} ||= $v;
462 $self->schema_version_to_dump($real_ver);
470 sub _find_file_in_inc {
471 my ($self, $file) = @_;
473 foreach my $prefix (@INC) {
474 my $fullpath = File::Spec->catfile($prefix, $file);
475 return $fullpath if -f $fullpath
476 and Cwd::abs_path($fullpath) ne
477 (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
484 my ($self, $class) = @_;
486 my $class_path = $class;
487 $class_path =~ s{::}{/}g;
488 $class_path .= '.pm';
493 sub _find_class_in_inc {
494 my ($self, $class) = @_;
496 return $self->_find_file_in_inc($self->_class_path($class));
500 my ($self, $class) = @_;
502 return if $self->{skip_load_external};
504 # so that we don't load our own classes, under any circumstances
505 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
507 my $real_inc_path = $self->_find_class_in_inc($class);
509 my $old_class = $self->_upgrading_classes->{$class}
510 if $self->_upgrading_from;
512 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
513 if $old_class && $old_class ne $class;
515 return unless $real_inc_path || $old_real_inc_path;
517 if ($real_inc_path) {
518 # If we make it to here, we loaded an external definition
519 warn qq/# Loaded external class definition for '$class'\n/
522 open(my $fh, '<', $real_inc_path)
523 or croak "Failed to open '$real_inc_path' for reading: $!";
524 $self->_ext_stmt($class,
525 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
526 .qq|# They are now part of the custom portion of this file\n|
527 .qq|# for you to hand-edit. If you do not either delete\n|
528 .qq|# this section or remove that file from \@INC, this section\n|
529 .qq|# will be repeated redundantly when you re-create this\n|
530 .qq|# file again via Loader!\n|
534 $self->_ext_stmt($class, $_);
536 $self->_ext_stmt($class,
537 qq|# End of lines loaded from '$real_inc_path' |
540 or croak "Failed to close $real_inc_path: $!";
542 if ($self->dynamic) { # load the class too
543 # kill redefined warnings
544 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
545 local $SIG{__WARN__} = sub {
547 unless $_[0] =~ /^Subroutine \S+ redefined/;
554 if ($old_real_inc_path) {
555 open(my $fh, '<', $old_real_inc_path)
556 or croak "Failed to open '$old_real_inc_path' for reading: $!";
557 $self->_ext_stmt($class, <<"EOF");
559 # These lines were loaded from '$old_real_inc_path', based on the Result class
560 # name that would have been created by an 0.04006 version of the Loader. For a
561 # static schema, this happens only once during upgrade.
563 if ($self->dynamic) {
566 Detected external content in '$old_real_inc_path', a class name that would have
567 been used by an 0.04006 version of the Loader.
569 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
570 new name of the Result.
572 # kill redefined warnings
573 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
574 local $SIG{__WARN__} = sub {
576 unless $_[0] =~ /^Subroutine \S+ redefined/;
579 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
581 $code =~ s/$old_class/$class/g;
588 $self->_ext_stmt($class, $_);
590 $self->_ext_stmt($class,
591 qq|# End of lines loaded from '$old_real_inc_path' |
595 or croak "Failed to close $old_real_inc_path: $!";
601 Does the actual schema-construction work.
608 $self->_load_tables($self->_tables_list);
615 Rescan the database for newly added tables. Does
616 not process drops or changes. Returns a list of
617 the newly added table monikers.
619 The schema argument should be the schema class
620 or object to be affected. It should probably
621 be derived from the original schema_class used
627 my ($self, $schema) = @_;
629 $self->{schema} = $schema;
630 $self->_relbuilder->{schema} = $schema;
633 my @current = $self->_tables_list;
634 foreach my $table ($self->_tables_list) {
635 if(!exists $self->{_tables}->{$table}) {
636 push(@created, $table);
640 my $loaded = $self->_load_tables(@created);
642 return map { $self->monikers->{$_} } @$loaded;
646 no warnings 'uninitialized';
649 return if $self->{skip_relationships};
651 if ($self->naming->{relationships} eq 'v4') {
652 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
653 return $self->{relbuilder} ||=
654 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
655 $self->schema, $self->inflect_plural, $self->inflect_singular
659 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
660 $self->schema, $self->inflect_plural, $self->inflect_singular
665 my ($self, @tables) = @_;
667 # First, use _tables_list with constraint and exclude
668 # to get a list of tables to operate on
670 my $constraint = $self->constraint;
671 my $exclude = $self->exclude;
673 @tables = grep { /$constraint/ } @tables if $constraint;
674 @tables = grep { ! /$exclude/ } @tables if $exclude;
676 # Save the new tables to the tables list
678 $self->{_tables}->{$_} = 1;
681 $self->_make_src_class($_) for @tables;
682 $self->_setup_src_meta($_) for @tables;
684 if(!$self->skip_relationships) {
685 # The relationship loader needs a working schema
687 local $self->{dump_directory} = $self->{temp_directory};
688 $self->_reload_classes(\@tables);
689 $self->_load_relationships($_) for @tables;
692 # Remove that temp dir from INC so it doesn't get reloaded
693 @INC = grep $_ ne $self->dump_directory, @INC;
696 $self->_load_external($_)
697 for map { $self->classes->{$_} } @tables;
699 # Reload without unloading first to preserve any symbols from external
701 $self->_reload_classes(\@tables, 0);
703 # Drop temporary cache
704 delete $self->{_cache};
709 sub _reload_classes {
710 my ($self, $tables, $unload) = @_;
712 my @tables = @$tables;
713 $unload = 1 unless defined $unload;
715 # so that we don't repeat custom sections
716 @INC = grep $_ ne $self->dump_directory, @INC;
718 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
720 unshift @INC, $self->dump_directory;
723 my %have_source = map { $_ => $self->schema->source($_) }
724 $self->schema->sources;
726 for my $table (@tables) {
727 my $moniker = $self->monikers->{$table};
728 my $class = $self->classes->{$table};
731 no warnings 'redefine';
732 local *Class::C3::reinitialize = sub {};
735 Class::Unload->unload($class) if $unload;
736 my ($source, $resultset_class);
738 ($source = $have_source{$moniker})
739 && ($resultset_class = $source->resultset_class)
740 && ($resultset_class ne 'DBIx::Class::ResultSet')
742 my $has_file = Class::Inspector->loaded_filename($resultset_class);
743 Class::Unload->unload($resultset_class) if $unload;
744 $self->_reload_class($resultset_class) if $has_file;
746 $self->_reload_class($class);
748 push @to_register, [$moniker, $class];
751 Class::C3->reinitialize;
753 $self->schema->register_class(@$_);
757 # We use this instead of ensure_class_loaded when there are package symbols we
760 my ($self, $class) = @_;
762 my $class_path = $self->_class_path($class);
763 delete $INC{ $class_path };
765 # kill redefined warnings
766 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
767 local $SIG{__WARN__} = sub {
769 unless $_[0] =~ /^Subroutine \S+ redefined/;
771 eval "require $class;";
774 sub _get_dump_filename {
775 my ($self, $class) = (@_);
778 return $self->dump_directory . q{/} . $class . q{.pm};
781 sub _ensure_dump_subdirs {
782 my ($self, $class) = (@_);
784 my @name_parts = split(/::/, $class);
785 pop @name_parts; # we don't care about the very last element,
786 # which is a filename
788 my $dir = $self->dump_directory;
791 mkdir($dir) or croak "mkdir('$dir') failed: $!";
793 last if !@name_parts;
794 $dir = File::Spec->catdir($dir, shift @name_parts);
799 my ($self, @classes) = @_;
801 my $schema_class = $self->schema_class;
802 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
804 my $target_dir = $self->dump_directory;
805 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
806 unless $self->{dynamic} or $self->{quiet};
809 qq|package $schema_class;\n\n|
810 . qq|# Created by DBIx::Class::Schema::Loader\n|
811 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
812 . qq|use strict;\nuse warnings;\n\n|
813 . qq|use base '$schema_base_class';\n\n|;
815 if ($self->use_namespaces) {
816 $schema_text .= qq|__PACKAGE__->load_namespaces|;
817 my $namespace_options;
818 for my $attr (qw(result_namespace
820 default_resultset_class)) {
822 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
825 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
826 $schema_text .= qq|;\n|;
829 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
833 local $self->{version_to_dump} = $self->schema_version_to_dump;
834 $self->_write_classfile($schema_class, $schema_text);
837 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
839 foreach my $src_class (@classes) {
841 qq|package $src_class;\n\n|
842 . qq|# Created by DBIx::Class::Schema::Loader\n|
843 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
844 . qq|use strict;\nuse warnings;\n\n|
845 . qq|use base '$result_base_class';\n\n|;
847 $self->_write_classfile($src_class, $src_text);
850 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
855 my ($self, $version, $ts) = @_;
856 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
859 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
862 sub _write_classfile {
863 my ($self, $class, $text) = @_;
865 my $filename = $self->_get_dump_filename($class);
866 $self->_ensure_dump_subdirs($class);
868 if (-f $filename && $self->really_erase_my_files) {
869 warn "Deleting existing file '$filename' due to "
870 . "'really_erase_my_files' setting\n" unless $self->{quiet};
874 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
876 if ($self->_upgrading_from) {
877 my $old_class = $self->_upgrading_classes->{$class};
879 if ($old_class && ($old_class ne $class)) {
880 my $old_filename = $self->_get_dump_filename($old_class);
882 my ($old_custom_content) = $self->_get_custom_content(
883 $old_class, $old_filename, 0 # do not add default comment
886 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
888 if ($old_custom_content) {
890 "\n" . $old_custom_content . "\n" . $custom_content;
893 unlink $old_filename;
898 for @{$self->{_dump_storage}->{$class} || []};
900 # Check and see if the dump is infact differnt
904 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
907 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
912 $text .= $self->_sig_comment(
913 $self->version_to_dump,
914 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
917 open(my $fh, '>', $filename)
918 or croak "Cannot open '$filename' for writing: $!";
920 # Write the top half and its MD5 sum
921 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
923 # Write out anything loaded via external partial class file in @INC
925 for @{$self->{_ext_storage}->{$class} || []};
927 # Write out any custom content the user has added
928 print $fh $custom_content;
931 or croak "Error closing '$filename': $!";
934 sub _default_custom_content {
935 return qq|\n\n# You can replace this text with custom|
936 . qq| content, and it will be preserved on regeneration|
940 sub _get_custom_content {
941 my ($self, $class, $filename, $add_default) = @_;
943 $add_default = 1 unless defined $add_default;
945 return ($self->_default_custom_content) if ! -f $filename;
947 open(my $fh, '<', $filename)
948 or croak "Cannot open '$filename' for reading: $!";
951 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
954 my ($md5, $ts, $ver);
956 if(!$md5 && /$mark_re/) {
960 # Pull out the previous version and timestamp
961 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
964 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"
965 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
974 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
975 . " it does not appear to have been generated by Loader"
978 # Default custom content:
979 $buffer ||= $self->_default_custom_content if $add_default;
981 return ($buffer, $md5, $ver, $ts);
989 warn "$target: use $_;" if $self->debug;
990 $self->_raw_stmt($target, "use $_;");
997 my $schema_class = $self->schema_class;
999 my $blist = join(q{ }, @_);
1000 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1001 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1004 # Create class with applicable bases, setup monikers, etc
1005 sub _make_src_class {
1006 my ($self, $table) = @_;
1008 my $schema = $self->schema;
1009 my $schema_class = $self->schema_class;
1011 my $table_moniker = $self->_table2moniker($table);
1012 my @result_namespace = ($schema_class);
1013 if ($self->use_namespaces) {
1014 my $result_namespace = $self->result_namespace || 'Result';
1015 if ($result_namespace =~ /^\+(.*)/) {
1016 # Fully qualified namespace
1017 @result_namespace = ($1)
1020 # Relative namespace
1021 push @result_namespace, $result_namespace;
1024 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1026 if (my $upgrading_v = $self->_upgrading_from) {
1027 local $self->naming->{monikers} = $upgrading_v;
1029 my $old_class = join(q{::}, @result_namespace,
1030 $self->_table2moniker($table));
1032 $self->_upgrading_classes->{$table_class} = $old_class;
1035 my $table_normalized = lc $table;
1036 $self->classes->{$table} = $table_class;
1037 $self->classes->{$table_normalized} = $table_class;
1038 $self->monikers->{$table} = $table_moniker;
1039 $self->monikers->{$table_normalized} = $table_moniker;
1041 $self->_use ($table_class, @{$self->additional_classes});
1042 $self->_inject($table_class, @{$self->left_base_classes});
1044 if (my @components = @{ $self->components }) {
1045 $self->_dbic_stmt($table_class, 'load_components', @components);
1048 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1049 if @{$self->resultset_components};
1050 $self->_inject($table_class, @{$self->additional_base_classes});
1053 # Set up metadata (cols, pks, etc)
1054 sub _setup_src_meta {
1055 my ($self, $table) = @_;
1057 my $schema = $self->schema;
1058 my $schema_class = $self->schema_class;
1060 my $table_class = $self->classes->{$table};
1061 my $table_moniker = $self->monikers->{$table};
1063 my $table_name = $table;
1064 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1066 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1067 $table_name = \ $self->_quote_table_name($table_name);
1070 $self->_dbic_stmt($table_class,'table',$table_name);
1072 my $cols = $self->_table_columns($table);
1074 eval { $col_info = $self->_columns_info_for($table) };
1076 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1079 if ($self->_is_case_sensitive) {
1080 for my $col (keys %$col_info) {
1081 $col_info->{$col}{accessor} = lc $col
1082 if $col ne lc($col);
1085 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1088 my $fks = $self->_table_fk_info($table);
1090 for my $fkdef (@$fks) {
1091 for my $col (@{ $fkdef->{local_columns} }) {
1092 $col_info->{$col}{is_foreign_key} = 1;
1098 map { $_, ($col_info->{$_}||{}) } @$cols
1102 my %uniq_tag; # used to eliminate duplicate uniqs
1104 my $pks = $self->_table_pk_info($table) || [];
1105 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1106 : carp("$table has no primary key");
1107 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1109 my $uniqs = $self->_table_uniq_info($table) || [];
1111 my ($name, $cols) = @$_;
1112 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1113 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1120 Returns a sorted list of loaded tables, using the original database table
1128 return keys %{$self->_tables};
1131 # Make a moniker from a table
1132 sub _default_table2moniker {
1133 no warnings 'uninitialized';
1134 my ($self, $table) = @_;
1136 if ($self->naming->{monikers} eq 'v4') {
1137 return join '', map ucfirst, split /[\W_]+/, lc $table;
1140 return join '', map ucfirst, split /[\W_]+/,
1141 Lingua::EN::Inflect::Number::to_S(lc $table);
1144 sub _table2moniker {
1145 my ( $self, $table ) = @_;
1149 if( ref $self->moniker_map eq 'HASH' ) {
1150 $moniker = $self->moniker_map->{$table};
1152 elsif( ref $self->moniker_map eq 'CODE' ) {
1153 $moniker = $self->moniker_map->($table);
1156 $moniker ||= $self->_default_table2moniker($table);
1161 sub _load_relationships {
1162 my ($self, $table) = @_;
1164 my $tbl_fk_info = $self->_table_fk_info($table);
1165 foreach my $fkdef (@$tbl_fk_info) {
1166 $fkdef->{remote_source} =
1167 $self->monikers->{delete $fkdef->{remote_table}};
1169 my $tbl_uniq_info = $self->_table_uniq_info($table);
1171 my $local_moniker = $self->monikers->{$table};
1172 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1174 foreach my $src_class (sort keys %$rel_stmts) {
1175 my $src_stmts = $rel_stmts->{$src_class};
1176 foreach my $stmt (@$src_stmts) {
1177 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1182 # Overload these in driver class:
1184 # Returns an arrayref of column names
1185 sub _table_columns { croak "ABSTRACT METHOD" }
1187 # Returns arrayref of pk col names
1188 sub _table_pk_info { croak "ABSTRACT METHOD" }
1190 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1191 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1193 # Returns an arrayref of foreign key constraints, each
1194 # being a hashref with 3 keys:
1195 # local_columns (arrayref), remote_columns (arrayref), remote_table
1196 sub _table_fk_info { croak "ABSTRACT METHOD" }
1198 # Returns an array of lower case table names
1199 sub _tables_list { croak "ABSTRACT METHOD" }
1201 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1206 if ( $method eq 'table' ) {
1208 $self->_pod( $class, "=head1 NAME" );
1209 my $table_descr = $class;
1210 if ( $self->can('_table_comment') ) {
1211 my $comment = $self->_table_comment($table);
1212 $table_descr .= " - " . $comment if $comment;
1214 $self->{_class2table}{ $class } = $table;
1215 $self->_pod( $class, $table_descr );
1216 $self->_pod_cut( $class );
1217 } elsif ( $method eq 'add_columns' ) {
1218 $self->_pod( $class, "=head1 ACCESSORS" );
1223 $self->_pod( $class, '=head2 ' . $_ );
1225 $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1 ) if $self->can('_column_comment');
1226 $self->_pod( $class, $comment ) if $comment;
1228 $self->_pod_cut( $class );
1229 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1230 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1231 my ( $accessor, $rel_class ) = @_;
1232 $self->_pod( $class, "=head2 $accessor" );
1233 $self->_pod( $class, 'Type: ' . $method );
1234 $self->_pod( $class, "Related object: L<$rel_class>" );
1235 $self->_pod_cut( $class );
1236 $self->{_relations_started} { $class } = 1;
1238 my $args = dump(@_);
1239 $args = '(' . $args . ')' if @_ < 2;
1240 my $stmt = $method . $args . q{;};
1242 warn qq|$class\->$stmt\n| if $self->debug;
1243 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1247 # Stores a POD documentation
1249 my ($self, $class, $stmt) = @_;
1250 $self->_raw_stmt( $class, "\n" . $stmt );
1254 my ($self, $class ) = @_;
1255 $self->_raw_stmt( $class, "\n=cut\n" );
1259 # Store a raw source line for a class (for dumping purposes)
1261 my ($self, $class, $stmt) = @_;
1262 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1265 # Like above, but separately for the externally loaded stuff
1267 my ($self, $class, $stmt) = @_;
1268 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1271 sub _quote_table_name {
1272 my ($self, $table) = @_;
1274 my $qt = $self->schema->storage->sql_maker->quote_char;
1276 return $table unless $qt;
1279 return $qt->[0] . $table . $qt->[1];
1282 return $qt . $table . $qt;
1285 sub _is_case_sensitive { 0 }
1287 # remove the dump dir from @INC on destruction
1291 @INC = grep $_ ne $self->dump_directory, @INC;
1296 Returns a hashref of loaded table to moniker mappings. There will
1297 be two entries for each table, the original name and the "normalized"
1298 name, in the case that the two are different (such as databases
1299 that like uppercase table names, or preserve your original mixed-case
1300 definitions, or what-have-you).
1304 Returns a hashref of table to class mappings. In some cases it will
1305 contain multiple entries per table for the original and normalized table
1306 names, as above in L</monikers>.
1310 L<DBIx::Class::Schema::Loader>
1314 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1318 This library is free software; you can redistribute it and/or modify it under
1319 the same terms as Perl itself.