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('inherited', qw/
28 additional_base_classes
43 default_resultset_class
57 __PACKAGE__->mk_group_accessors('inherited', qw/
59 schema_version_to_dump
65 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
69 See L<DBIx::Class::Schema::Loader>
73 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
74 classes, and implements the common functionality between them.
76 =head1 CONSTRUCTOR OPTIONS
78 These constructor options are the base options for
79 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
81 =head2 skip_relationships
83 Skip setting up relationships. The default is to attempt the loading
88 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
89 relationship names and singularized Results, unless you're overwriting an
90 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
91 which case the backward compatible RelBuilder will be activated, and
92 singularization will be turned off.
98 will disable the backward-compatible RelBuilder and use
99 the new-style relationship names along with singularized Results, even when
100 overwriting a dump made with an earlier version.
102 The option also takes a hashref:
104 naming => { relationships => 'v5', monikers => 'v4' }
112 How to name relationship accessors.
116 How to name Result classes.
126 Latest default style, whatever that happens to be.
130 Version 0.05XXX style.
134 Version 0.04XXX style.
138 Dynamic schemas will always default to the 0.04XXX relationship names and won't
139 singularize Results for backward compatibility, to activate the new RelBuilder
140 and singularization put this in your C<Schema.pm> file:
142 __PACKAGE__->naming('current');
144 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
145 next major version upgrade:
147 __PACKAGE__->naming('v5');
151 If set to true, each constructive L<DBIx::Class> statement the loader
152 decides to execute will be C<warn>-ed before execution.
156 Set the name of the schema to load (schema in the sense that your database
157 vendor means it). Does not currently support loading more than one schema
162 Only load tables matching regex. Best specified as a qr// regex.
166 Exclude tables matching regex. Best specified as a qr// regex.
170 Overrides the default table name to moniker translation. Can be either
171 a hashref of table keys and moniker values, or a coderef for a translator
172 function taking a single scalar table name argument and returning
173 a scalar moniker. If the hash entry does not exist, or the function
174 returns a false value, the code falls back to default behavior
177 The default behavior is to singularize the table name, and: C<join '', map
178 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
179 split up the table name into chunks anywhere a non-alpha-numeric character
180 occurs, change the case of first letter of each chunk to upper case, and put
181 the chunks back together. Examples:
183 Table Name | Moniker Name
184 ---------------------------
186 luser_group | LuserGroup
187 luser-opts | LuserOpts
189 =head2 inflect_plural
191 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
192 if hash key does not exist or coderef returns false), but acts as a map
193 for pluralizing relationship names. The default behavior is to utilize
194 L<Lingua::EN::Inflect::Number/to_PL>.
196 =head2 inflect_singular
198 As L</inflect_plural> above, but for singularizing relationship names.
199 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
201 =head2 schema_base_class
203 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
205 =head2 result_base_class
207 Base class for your table classes (aka result classes). Defaults to
210 =head2 additional_base_classes
212 List of additional base classes all of your table classes will use.
214 =head2 left_base_classes
216 List of additional base classes all of your table classes will use
217 that need to be leftmost.
219 =head2 additional_classes
221 List of additional classes which all of your table classes will use.
225 List of additional components to be loaded into all of your table
226 classes. A good example would be C<ResultSetManager>.
228 =head2 resultset_components
230 List of additional ResultSet components to be loaded into your table
231 classes. A good example would be C<AlwaysRS>. Component
232 C<ResultSetManager> will be automatically added to the above
233 C<components> list if this option is set.
235 =head2 use_namespaces
237 Generate result class names suitable for
238 L<DBIx::Class::Schema/load_namespaces> and call that instead of
239 L<DBIx::Class::Schema/load_classes>. When using this option you can also
240 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
241 C<resultset_namespace>, C<default_resultset_class>), and they will be added
242 to the call (and the generated result class names adjusted appropriately).
244 =head2 dump_directory
246 This option is designed to be a tool to help you transition from this
247 loader to a manually-defined schema when you decide it's time to do so.
249 The value of this option is a perl libdir pathname. Within
250 that directory this module will create a baseline manual
251 L<DBIx::Class::Schema> module set, based on what it creates at runtime
254 The created schema class will have the same classname as the one on
255 which you are setting this option (and the ResultSource classes will be
256 based on this name as well).
258 Normally you wouldn't hard-code this setting in your schema class, as it
259 is meant for one-time manual usage.
261 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
262 recommended way to access this functionality.
264 =head2 dump_overwrite
266 Deprecated. See L</really_erase_my_files> below, which does *not* mean
267 the same thing as the old C<dump_overwrite> setting from previous releases.
269 =head2 really_erase_my_files
271 Default false. If true, Loader will unconditionally delete any existing
272 files before creating the new ones from scratch when dumping a schema to disk.
274 The default behavior is instead to only replace the top portion of the
275 file, up to and including the final stanza which contains
276 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
277 leaving any customizations you placed after that as they were.
279 When C<really_erase_my_files> is not set, if the output file already exists,
280 but the aforementioned final stanza is not found, or the checksum
281 contained there does not match the generated contents, Loader will
282 croak and not touch the file.
284 You should really be using version control on your schema classes (and all
285 of the rest of your code for that matter). Don't blame me if a bug in this
286 code wipes something out when it shouldn't have, you've been warned.
290 None of these methods are intended for direct invocation by regular
291 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
292 can also be found via standard L<DBIx::Class::Schema> methods somehow.
296 use constant CURRENT_V => 'v5';
298 # ensure that a peice of object data is a valid arrayref, creating
299 # an empty one or encapsulating whatever's there.
300 sub _ensure_arrayref {
305 $self->{$_} = [ $self->{$_} ]
306 unless ref $self->{$_} eq 'ARRAY';
312 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
313 by L<DBIx::Class::Schema::Loader>.
318 my ( $class, %args ) = @_;
320 my $self = { %args };
322 bless $self => $class;
324 $self->_ensure_arrayref(qw/additional_classes
325 additional_base_classes
331 push(@{$self->{components}}, 'ResultSetManager')
332 if @{$self->{resultset_components}};
334 $self->{monikers} = {};
335 $self->{classes} = {};
336 $self->{_upgrading_classes} = {};
338 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
339 $self->{schema} ||= $self->{schema_class};
341 croak "dump_overwrite is deprecated. Please read the"
342 . " DBIx::Class::Schema::Loader::Base documentation"
343 if $self->{dump_overwrite};
345 $self->{dynamic} = ! $self->{dump_directory};
346 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
351 $self->{dump_directory} ||= $self->{temp_directory};
353 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
354 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
356 if ((not ref $self->naming) && defined $self->naming) {
357 my $naming_ver = $self->naming;
359 relationships => $naming_ver,
360 monikers => $naming_ver,
365 for (values %{ $self->naming }) {
366 $_ = CURRENT_V if $_ eq 'current';
369 $self->{naming} ||= {};
371 $self->_check_back_compat;
376 sub _check_back_compat {
379 # dynamic schemas will always be in 0.04006 mode, unless overridden
380 if ($self->dynamic) {
381 # just in case, though no one is likely to dump a dynamic schema
382 $self->schema_version_to_dump('0.04006');
384 if (not %{ $self->naming }) {
385 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
387 Dynamic schema detected, will run in 0.04006 mode.
389 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
390 to disable this warning.
392 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
397 $self->_upgrading_from('v4');
400 $self->naming->{relationships} ||= 'v4';
401 $self->naming->{monikers} ||= 'v4';
406 # otherwise check if we need backcompat mode for a static schema
407 my $filename = $self->_get_dump_filename($self->schema_class);
408 return unless -e $filename;
410 open(my $fh, '<', $filename)
411 or croak "Cannot open '$filename' for reading: $!";
414 if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
417 # XXX when we go past .0 this will need fixing
418 my ($v) = $real_ver =~ /([1-9])/;
421 last if $v eq CURRENT_V || $real_ver =~ /^0\.04999/;
423 if (not %{ $self->naming }) {
424 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
426 Version $real_ver static schema detected, turning on backcompat mode.
428 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
429 to disable this warning.
431 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
436 $self->_upgrading_from($v);
439 $self->naming->{relationships} ||= $v;
440 $self->naming->{monikers} ||= $v;
442 $self->schema_version_to_dump($real_ver);
450 sub _find_file_in_inc {
451 my ($self, $file) = @_;
453 foreach my $prefix (@INC) {
454 my $fullpath = File::Spec->catfile($prefix, $file);
455 return $fullpath if -f $fullpath
456 and Cwd::abs_path($fullpath) ne
457 (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
464 my ($self, $class) = @_;
466 my $class_path = $class;
467 $class_path =~ s{::}{/}g;
468 $class_path .= '.pm';
473 sub _find_class_in_inc {
474 my ($self, $class) = @_;
476 return $self->_find_file_in_inc($self->_class_path($class));
480 my ($self, $class) = @_;
482 # so that we don't load our own classes, under any circumstances
483 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
485 my $real_inc_path = $self->_find_class_in_inc($class);
487 my $old_class = $self->_upgrading_classes->{$class}
488 if $self->_upgrading_from;
490 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
491 if $old_class && $old_class ne $class;
493 return unless $real_inc_path || $old_real_inc_path;
495 if ($real_inc_path) {
496 # If we make it to here, we loaded an external definition
497 warn qq/# Loaded external class definition for '$class'\n/
500 open(my $fh, '<', $real_inc_path)
501 or croak "Failed to open '$real_inc_path' for reading: $!";
502 $self->_ext_stmt($class,
503 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
504 .qq|# They are now part of the custom portion of this file\n|
505 .qq|# for you to hand-edit. If you do not either delete\n|
506 .qq|# this section or remove that file from \@INC, this section\n|
507 .qq|# will be repeated redundantly when you re-create this\n|
508 .qq|# file again via Loader!\n|
512 $self->_ext_stmt($class, $_);
514 $self->_ext_stmt($class,
515 qq|# End of lines loaded from '$real_inc_path' |
518 or croak "Failed to close $real_inc_path: $!";
520 if ($self->dynamic) { # load the class too
521 # kill redefined warnings
522 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
523 local $SIG{__WARN__} = sub {
525 unless $_[0] =~ /^Subroutine \S+ redefined/;
532 if ($old_real_inc_path) {
533 open(my $fh, '<', $old_real_inc_path)
534 or croak "Failed to open '$old_real_inc_path' for reading: $!";
535 $self->_ext_stmt($class, <<"EOF");
537 # These lines were loaded from '$old_real_inc_path', based on the Result class
538 # name that would have been created by an 0.04006 version of the Loader. For a
539 # static schema, this happens only once during upgrade.
541 if ($self->dynamic) {
544 Detected external content in '$old_real_inc_path', a class name that would have
545 been used by an 0.04006 version of the Loader.
547 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
548 new name of the Result.
550 # kill redefined warnings
551 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
552 local $SIG{__WARN__} = sub {
554 unless $_[0] =~ /^Subroutine \S+ redefined/;
557 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
559 $code =~ s/$old_class/$class/g;
566 $self->_ext_stmt($class, $_);
568 $self->_ext_stmt($class,
569 qq|# End of lines loaded from '$old_real_inc_path' |
573 or croak "Failed to close $old_real_inc_path: $!";
579 Does the actual schema-construction work.
586 $self->_load_tables($self->_tables_list);
593 Rescan the database for newly added tables. Does
594 not process drops or changes. Returns a list of
595 the newly added table monikers.
597 The schema argument should be the schema class
598 or object to be affected. It should probably
599 be derived from the original schema_class used
605 my ($self, $schema) = @_;
607 $self->{schema} = $schema;
608 $self->_relbuilder->{schema} = $schema;
611 my @current = $self->_tables_list;
612 foreach my $table ($self->_tables_list) {
613 if(!exists $self->{_tables}->{$table}) {
614 push(@created, $table);
618 my $loaded = $self->_load_tables(@created);
620 return map { $self->monikers->{$_} } @$loaded;
624 no warnings 'uninitialized';
627 return if $self->{skip_relationships};
629 if ($self->naming->{relationships} eq 'v4') {
630 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
631 return $self->{relbuilder} ||=
632 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
633 $self->schema, $self->inflect_plural, $self->inflect_singular
637 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
638 $self->schema, $self->inflect_plural, $self->inflect_singular
643 my ($self, @tables) = @_;
645 # First, use _tables_list with constraint and exclude
646 # to get a list of tables to operate on
648 my $constraint = $self->constraint;
649 my $exclude = $self->exclude;
651 @tables = grep { /$constraint/ } @tables if $constraint;
652 @tables = grep { ! /$exclude/ } @tables if $exclude;
654 # Save the new tables to the tables list
656 $self->{_tables}->{$_} = 1;
659 $self->_make_src_class($_) for @tables;
660 $self->_setup_src_meta($_) for @tables;
662 if(!$self->skip_relationships) {
663 # The relationship loader needs a working schema
665 local $self->{dump_directory} = $self->{temp_directory};
666 $self->_reload_classes(\@tables);
667 $self->_load_relationships($_) for @tables;
670 # Remove that temp dir from INC so it doesn't get reloaded
671 @INC = grep $_ ne $self->dump_directory, @INC;
674 $self->_load_external($_)
675 for map { $self->classes->{$_} } @tables;
677 # Reload without unloading first to preserve any symbols from external
679 $self->_reload_classes(\@tables, 0);
681 # Drop temporary cache
682 delete $self->{_cache};
687 sub _reload_classes {
688 my ($self, $tables, $unload) = @_;
690 my @tables = @$tables;
691 $unload = 1 unless defined $unload;
693 # so that we don't repeat custom sections
694 @INC = grep $_ ne $self->dump_directory, @INC;
696 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
698 unshift @INC, $self->dump_directory;
701 my %have_source = map { $_ => $self->schema->source($_) }
702 $self->schema->sources;
704 for my $table (@tables) {
705 my $moniker = $self->monikers->{$table};
706 my $class = $self->classes->{$table};
709 no warnings 'redefine';
710 local *Class::C3::reinitialize = sub {};
713 Class::Unload->unload($class) if $unload;
714 my ($source, $resultset_class);
716 ($source = $have_source{$moniker})
717 && ($resultset_class = $source->resultset_class)
718 && ($resultset_class ne 'DBIx::Class::ResultSet')
720 my $has_file = Class::Inspector->loaded_filename($resultset_class);
721 Class::Unload->unload($resultset_class) if $unload;
722 $self->_reload_class($resultset_class) if $has_file;
724 $self->_reload_class($class);
726 push @to_register, [$moniker, $class];
729 Class::C3->reinitialize;
731 $self->schema->register_class(@$_);
735 # We use this instead of ensure_class_loaded when there are package symbols we
738 my ($self, $class) = @_;
740 my $class_path = $self->_class_path($class);
741 delete $INC{ $class_path };
743 # kill redefined warnings
744 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
745 local $SIG{__WARN__} = sub {
747 unless $_[0] =~ /^Subroutine \S+ redefined/;
749 eval "require $class;";
752 sub _get_dump_filename {
753 my ($self, $class) = (@_);
756 return $self->dump_directory . q{/} . $class . q{.pm};
759 sub _ensure_dump_subdirs {
760 my ($self, $class) = (@_);
762 my @name_parts = split(/::/, $class);
763 pop @name_parts; # we don't care about the very last element,
764 # which is a filename
766 my $dir = $self->dump_directory;
769 mkdir($dir) or croak "mkdir('$dir') failed: $!";
771 last if !@name_parts;
772 $dir = File::Spec->catdir($dir, shift @name_parts);
777 my ($self, @classes) = @_;
779 my $schema_class = $self->schema_class;
780 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
782 my $target_dir = $self->dump_directory;
783 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
784 unless $self->{dynamic} or $self->{quiet};
787 qq|package $schema_class;\n\n|
788 . qq|# Created by DBIx::Class::Schema::Loader\n|
789 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
790 . qq|use strict;\nuse warnings;\n\n|
791 . qq|use base '$schema_base_class';\n\n|;
793 if ($self->use_namespaces) {
794 $schema_text .= qq|__PACKAGE__->load_namespaces|;
795 my $namespace_options;
796 for my $attr (qw(result_namespace
798 default_resultset_class)) {
800 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
803 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
804 $schema_text .= qq|;\n|;
807 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
811 local $self->{version_to_dump} = $self->schema_version_to_dump;
812 $self->_write_classfile($schema_class, $schema_text);
815 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
817 foreach my $src_class (@classes) {
819 qq|package $src_class;\n\n|
820 . qq|# Created by DBIx::Class::Schema::Loader\n|
821 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
822 . qq|use strict;\nuse warnings;\n\n|
823 . qq|use base '$result_base_class';\n\n|;
825 $self->_write_classfile($src_class, $src_text);
828 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
833 my ($self, $version, $ts) = @_;
834 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
837 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
840 sub _write_classfile {
841 my ($self, $class, $text) = @_;
843 my $filename = $self->_get_dump_filename($class);
844 $self->_ensure_dump_subdirs($class);
846 if (-f $filename && $self->really_erase_my_files) {
847 warn "Deleting existing file '$filename' due to "
848 . "'really_erase_my_files' setting\n" unless $self->{quiet};
852 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
854 if ($self->_upgrading_from) {
855 my $old_class = $self->_upgrading_classes->{$class};
857 if ($old_class && ($old_class ne $class)) {
858 my $old_filename = $self->_get_dump_filename($old_class);
860 my ($old_custom_content) = $self->_get_custom_content(
861 $old_class, $old_filename, 0 # do not add default comment
864 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
866 if ($old_custom_content) {
868 "\n" . $old_custom_content . "\n" . $custom_content;
871 unlink $old_filename;
876 for @{$self->{_dump_storage}->{$class} || []};
878 # Check and see if the dump is infact differnt
882 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
885 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
890 $text .= $self->_sig_comment(
891 $self->version_to_dump,
892 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
895 open(my $fh, '>', $filename)
896 or croak "Cannot open '$filename' for writing: $!";
898 # Write the top half and its MD5 sum
899 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
901 # Write out anything loaded via external partial class file in @INC
903 for @{$self->{_ext_storage}->{$class} || []};
905 # Write out any custom content the user has added
906 print $fh $custom_content;
909 or croak "Error closing '$filename': $!";
912 sub _default_custom_content {
913 return qq|\n\n# You can replace this text with custom|
914 . qq| content, and it will be preserved on regeneration|
918 sub _get_custom_content {
919 my ($self, $class, $filename, $add_default) = @_;
921 $add_default = 1 unless defined $add_default;
923 return ($self->_default_custom_content) if ! -f $filename;
925 open(my $fh, '<', $filename)
926 or croak "Cannot open '$filename' for reading: $!";
929 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
932 my ($md5, $ts, $ver);
934 if(!$md5 && /$mark_re/) {
938 # Pull out the previous version and timestamp
939 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
942 croak "Checksum mismatch in '$filename'"
943 if Digest::MD5::md5_base64($buffer) ne $md5;
952 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
953 . " it does not appear to have been generated by Loader"
956 # Default custom content:
957 $buffer ||= $self->_default_custom_content if $add_default;
959 return ($buffer, $md5, $ver, $ts);
967 warn "$target: use $_;" if $self->debug;
968 $self->_raw_stmt($target, "use $_;");
975 my $schema_class = $self->schema_class;
977 my $blist = join(q{ }, @_);
978 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
979 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
982 # Create class with applicable bases, setup monikers, etc
983 sub _make_src_class {
984 my ($self, $table) = @_;
986 my $schema = $self->schema;
987 my $schema_class = $self->schema_class;
989 my $table_moniker = $self->_table2moniker($table);
990 my @result_namespace = ($schema_class);
991 if ($self->use_namespaces) {
992 my $result_namespace = $self->result_namespace || 'Result';
993 if ($result_namespace =~ /^\+(.*)/) {
994 # Fully qualified namespace
995 @result_namespace = ($1)
999 push @result_namespace, $result_namespace;
1002 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1004 if (my $upgrading_v = $self->_upgrading_from) {
1005 local $self->naming->{monikers} = $upgrading_v;
1007 my $old_class = join(q{::}, @result_namespace,
1008 $self->_table2moniker($table));
1010 $self->_upgrading_classes->{$table_class} = $old_class;
1013 my $table_normalized = lc $table;
1014 $self->classes->{$table} = $table_class;
1015 $self->classes->{$table_normalized} = $table_class;
1016 $self->monikers->{$table} = $table_moniker;
1017 $self->monikers->{$table_normalized} = $table_moniker;
1019 $self->_use ($table_class, @{$self->additional_classes});
1020 $self->_inject($table_class, @{$self->left_base_classes});
1022 if (my @components = @{ $self->components }) {
1023 $self->_dbic_stmt($table_class, 'load_components', @components);
1026 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1027 if @{$self->resultset_components};
1028 $self->_inject($table_class, @{$self->additional_base_classes});
1031 # Set up metadata (cols, pks, etc)
1032 sub _setup_src_meta {
1033 my ($self, $table) = @_;
1035 my $schema = $self->schema;
1036 my $schema_class = $self->schema_class;
1038 my $table_class = $self->classes->{$table};
1039 my $table_moniker = $self->monikers->{$table};
1041 my $table_name = $table;
1042 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1044 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1045 $table_name = \ $self->_quote_table_name($table_name);
1048 $self->_dbic_stmt($table_class,'table',$table_name);
1050 my $cols = $self->_table_columns($table);
1052 eval { $col_info = $self->_columns_info_for($table) };
1054 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1057 if ($self->_is_case_sensitive) {
1058 for my $col (keys %$col_info) {
1059 $col_info->{$col}{accessor} = lc $col
1060 if $col ne lc($col);
1063 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1066 my $fks = $self->_table_fk_info($table);
1068 for my $fkdef (@$fks) {
1069 for my $col (@{ $fkdef->{local_columns} }) {
1070 $col_info->{$col}{is_foreign_key} = 1;
1076 map { $_, ($col_info->{$_}||{}) } @$cols
1080 my %uniq_tag; # used to eliminate duplicate uniqs
1082 my $pks = $self->_table_pk_info($table) || [];
1083 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1084 : carp("$table has no primary key");
1085 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1087 my $uniqs = $self->_table_uniq_info($table) || [];
1089 my ($name, $cols) = @$_;
1090 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1091 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1098 Returns a sorted list of loaded tables, using the original database table
1106 return keys %{$self->_tables};
1109 # Make a moniker from a table
1110 sub _default_table2moniker {
1111 no warnings 'uninitialized';
1112 my ($self, $table) = @_;
1114 if ($self->naming->{monikers} eq 'v4') {
1115 return join '', map ucfirst, split /[\W_]+/, lc $table;
1118 return join '', map ucfirst, split /[\W_]+/,
1119 Lingua::EN::Inflect::Number::to_S(lc $table);
1122 sub _table2moniker {
1123 my ( $self, $table ) = @_;
1127 if( ref $self->moniker_map eq 'HASH' ) {
1128 $moniker = $self->moniker_map->{$table};
1130 elsif( ref $self->moniker_map eq 'CODE' ) {
1131 $moniker = $self->moniker_map->($table);
1134 $moniker ||= $self->_default_table2moniker($table);
1139 sub _load_relationships {
1140 my ($self, $table) = @_;
1142 my $tbl_fk_info = $self->_table_fk_info($table);
1143 foreach my $fkdef (@$tbl_fk_info) {
1144 $fkdef->{remote_source} =
1145 $self->monikers->{delete $fkdef->{remote_table}};
1147 my $tbl_uniq_info = $self->_table_uniq_info($table);
1149 my $local_moniker = $self->monikers->{$table};
1150 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1152 foreach my $src_class (sort keys %$rel_stmts) {
1153 my $src_stmts = $rel_stmts->{$src_class};
1154 foreach my $stmt (@$src_stmts) {
1155 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1160 # Overload these in driver class:
1162 # Returns an arrayref of column names
1163 sub _table_columns { croak "ABSTRACT METHOD" }
1165 # Returns arrayref of pk col names
1166 sub _table_pk_info { croak "ABSTRACT METHOD" }
1168 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1169 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1171 # Returns an arrayref of foreign key constraints, each
1172 # being a hashref with 3 keys:
1173 # local_columns (arrayref), remote_columns (arrayref), remote_table
1174 sub _table_fk_info { croak "ABSTRACT METHOD" }
1176 # Returns an array of lower case table names
1177 sub _tables_list { croak "ABSTRACT METHOD" }
1179 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1184 if ( $method eq 'table' ) {
1186 $self->_pod( $class, "=head1 NAME" );
1187 my $table_descr = $class;
1188 if ( $self->can('_table_comment') ) {
1189 my $comment = $self->_table_comment($table);
1190 $table_descr .= " - " . $comment if $comment;
1192 $self->{_class2table}{ $class } = $table;
1193 $self->_pod( $class, $table_descr );
1194 $self->_pod_cut( $class );
1195 } elsif ( $method eq 'add_columns' ) {
1196 $self->_pod( $class, "=head1 ACCESSORS" );
1201 $self->_pod( $class, '=head2 ' . $_ );
1203 $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1 ) if $self->can('_column_comment');
1204 $self->_pod( $class, $comment ) if $comment;
1206 $self->_pod_cut( $class );
1207 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1208 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1209 my ( $accessor, $rel_class ) = @_;
1210 $self->_pod( $class, "=head2 $accessor" );
1211 $self->_pod( $class, 'Type: ' . $method );
1212 $self->_pod( $class, "Related object: L<$rel_class>" );
1213 $self->_pod_cut( $class );
1214 $self->{_relations_started} { $class } = 1;
1216 my $args = dump(@_);
1217 $args = '(' . $args . ')' if @_ < 2;
1218 my $stmt = $method . $args . q{;};
1220 warn qq|$class\->$stmt\n| if $self->debug;
1221 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1225 # Stores a POD documentation
1227 my ($self, $class, $stmt) = @_;
1228 $self->_raw_stmt( $class, "\n" . $stmt );
1232 my ($self, $class ) = @_;
1233 $self->_raw_stmt( $class, "\n=cut\n" );
1237 # Store a raw source line for a class (for dumping purposes)
1239 my ($self, $class, $stmt) = @_;
1240 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1243 # Like above, but separately for the externally loaded stuff
1245 my ($self, $class, $stmt) = @_;
1246 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1249 sub _quote_table_name {
1250 my ($self, $table) = @_;
1252 my $qt = $self->schema->storage->sql_maker->quote_char;
1254 return $table unless $qt;
1257 return $qt->[0] . $table . $qt->[1];
1260 return $qt . $table . $qt;
1263 sub _is_case_sensitive { 0 }
1265 # remove the dump dir from @INC on destruction
1269 @INC = grep $_ ne $self->dump_directory, @INC;
1274 Returns a hashref of loaded table to moniker mappings. There will
1275 be two entries for each table, the original name and the "normalized"
1276 name, in the case that the two are different (such as databases
1277 that like uppercase table names, or preserve your original mixed-case
1278 definitions, or what-have-you).
1282 Returns a hashref of table to class mappings. In some cases it will
1283 contain multiple entries per table for the original and normalized table
1284 names, as above in L</monikers>.
1288 L<DBIx::Class::Schema::Loader>
1292 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1296 This library is free software; you can redistribute it and/or modify it under
1297 the same terms as Perl itself.