1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Fast 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_ro_accessors(qw/
28 additional_base_classes
43 default_resultset_class
56 __PACKAGE__->mk_accessors(qw/
58 schema_version_to_dump
63 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
67 See L<DBIx::Class::Schema::Loader>
71 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
72 classes, and implements the common functionality between them.
74 =head1 CONSTRUCTOR OPTIONS
76 These constructor options are the base options for
77 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
79 =head2 skip_relationships
81 Skip setting up relationships. The default is to attempt the loading
86 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
87 relationship names and singularized Results, unless you're overwriting an
88 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
89 which case the backward compatible RelBuilder will be activated, and
90 singularization will be turned off.
96 will disable the backward-compatible RelBuilder and use
97 the new-style relationship names along with singularized Results, even when
98 overwriting a dump made with an earlier version.
100 The option also takes a hashref:
102 naming => { relationships => 'v5', monikers => 'v4' }
110 How to name relationship accessors.
114 How to name Result classes.
124 Latest default style, whatever that happens to be.
128 Version 0.05XXX style.
132 Version 0.04XXX style.
136 Dynamic schemas will always default to the 0.04XXX relationship names and won't
137 singularize Results for backward compatibility, to activate the new RelBuilder
138 and singularization put this in your C<Schema.pm> file:
140 __PACKAGE__->naming('current');
142 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
143 next major version upgrade:
145 __PACKAGE__->naming('v5');
149 If set to true, each constructive L<DBIx::Class> statement the loader
150 decides to execute will be C<warn>-ed before execution.
154 Set the name of the schema to load (schema in the sense that your database
155 vendor means it). Does not currently support loading more than one schema
160 Only load tables matching regex. Best specified as a qr// regex.
164 Exclude tables matching regex. Best specified as a qr// regex.
168 Overrides the default table name to moniker translation. Can be either
169 a hashref of table keys and moniker values, or a coderef for a translator
170 function taking a single scalar table name argument and returning
171 a scalar moniker. If the hash entry does not exist, or the function
172 returns a false value, the code falls back to default behavior
175 The default behavior is to singularize the table name, and: C<join '', map
176 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
177 split up the table name into chunks anywhere a non-alpha-numeric character
178 occurs, change the case of first letter of each chunk to upper case, and put
179 the chunks back together. Examples:
181 Table Name | Moniker Name
182 ---------------------------
184 luser_group | LuserGroup
185 luser-opts | LuserOpts
187 =head2 inflect_plural
189 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
190 if hash key does not exist or coderef returns false), but acts as a map
191 for pluralizing relationship names. The default behavior is to utilize
192 L<Lingua::EN::Inflect::Number/to_PL>.
194 =head2 inflect_singular
196 As L</inflect_plural> above, but for singularizing relationship names.
197 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
199 =head2 schema_base_class
201 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
203 =head2 result_base_class
205 Base class for your table classes (aka result classes). Defaults to
208 =head2 additional_base_classes
210 List of additional base classes all of your table classes will use.
212 =head2 left_base_classes
214 List of additional base classes all of your table classes will use
215 that need to be leftmost.
217 =head2 additional_classes
219 List of additional classes which all of your table classes will use.
223 List of additional components to be loaded into all of your table
224 classes. A good example would be C<ResultSetManager>.
226 =head2 resultset_components
228 List of additional ResultSet components to be loaded into your table
229 classes. A good example would be C<AlwaysRS>. Component
230 C<ResultSetManager> will be automatically added to the above
231 C<components> list if this option is set.
233 =head2 use_namespaces
235 Generate result class names suitable for
236 L<DBIx::Class::Schema/load_namespaces> and call that instead of
237 L<DBIx::Class::Schema/load_classes>. When using this option you can also
238 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
239 C<resultset_namespace>, C<default_resultset_class>), and they will be added
240 to the call (and the generated result class names adjusted appropriately).
242 =head2 dump_directory
244 This option is designed to be a tool to help you transition from this
245 loader to a manually-defined schema when you decide it's time to do so.
247 The value of this option is a perl libdir pathname. Within
248 that directory this module will create a baseline manual
249 L<DBIx::Class::Schema> module set, based on what it creates at runtime
252 The created schema class will have the same classname as the one on
253 which you are setting this option (and the ResultSource classes will be
254 based on this name as well).
256 Normally you wouldn't hard-code this setting in your schema class, as it
257 is meant for one-time manual usage.
259 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
260 recommended way to access this functionality.
262 =head2 dump_overwrite
264 Deprecated. See L</really_erase_my_files> below, which does *not* mean
265 the same thing as the old C<dump_overwrite> setting from previous releases.
267 =head2 really_erase_my_files
269 Default false. If true, Loader will unconditionally delete any existing
270 files before creating the new ones from scratch when dumping a schema to disk.
272 The default behavior is instead to only replace the top portion of the
273 file, up to and including the final stanza which contains
274 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
275 leaving any customizations you placed after that as they were.
277 When C<really_erase_my_files> is not set, if the output file already exists,
278 but the aforementioned final stanza is not found, or the checksum
279 contained there does not match the generated contents, Loader will
280 croak and not touch the file.
282 You should really be using version control on your schema classes (and all
283 of the rest of your code for that matter). Don't blame me if a bug in this
284 code wipes something out when it shouldn't have, you've been warned.
288 None of these methods are intended for direct invocation by regular
289 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
290 can also be found via standard L<DBIx::Class::Schema> methods somehow.
294 use constant CURRENT_V => 'v5';
296 # ensure that a peice of object data is a valid arrayref, creating
297 # an empty one or encapsulating whatever's there.
298 sub _ensure_arrayref {
303 $self->{$_} = [ $self->{$_} ]
304 unless ref $self->{$_} eq 'ARRAY';
310 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
311 by L<DBIx::Class::Schema::Loader>.
316 my ( $class, %args ) = @_;
318 my $self = { %args };
320 bless $self => $class;
322 $self->_ensure_arrayref(qw/additional_classes
323 additional_base_classes
329 push(@{$self->{components}}, 'ResultSetManager')
330 if @{$self->{resultset_components}};
332 $self->{monikers} = {};
333 $self->{classes} = {};
335 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
336 $self->{schema} ||= $self->{schema_class};
338 croak "dump_overwrite is deprecated. Please read the"
339 . " DBIx::Class::Schema::Loader::Base documentation"
340 if $self->{dump_overwrite};
342 $self->{dynamic} = ! $self->{dump_directory};
343 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
348 $self->{dump_directory} ||= $self->{temp_directory};
350 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
351 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
353 if ((not ref $self->naming) && defined $self->naming) {
354 my $naming_ver = $self->naming;
356 relationships => $naming_ver,
357 monikers => $naming_ver,
362 for (values %{ $self->naming }) {
363 $_ = CURRENT_V if $_ eq 'current';
366 $self->{naming} ||= {};
368 $self->_check_back_compat;
373 sub _check_back_compat {
376 # dynamic schemas will always be in 0.04006 mode, unless overridden
377 if ($self->dynamic) {
378 # just in case, though no one is likely to dump a dynamic schema
379 $self->schema_version_to_dump('0.04006');
381 if (not %{ $self->naming }) {
382 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
384 Dynamic schema detected, will run in 0.04006 mode.
386 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
387 to disable this warning.
389 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
394 $self->naming->{relationships} ||= 'v4';
395 $self->naming->{monikers} ||= 'v4';
400 # otherwise check if we need backcompat mode for a static schema
401 my $filename = $self->_get_dump_filename($self->schema_class);
402 return unless -e $filename;
404 open(my $fh, '<', $filename)
405 or croak "Cannot open '$filename' for reading: $!";
408 if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
411 # XXX when we go past .0 this will need fixing
412 my ($v) = $real_ver =~ /([1-9])/;
415 last if $v eq CURRENT_V;
417 if (not %{ $self->naming }) {
418 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
420 Version $real_ver static schema detected, turning on backcompat mode.
422 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
423 to disable this warning.
425 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
430 $self->naming->{relationships} ||= $v;
431 $self->naming->{monikers} ||= $v;
433 $self->schema_version_to_dump($real_ver);
441 sub _find_file_in_inc {
442 my ($self, $file) = @_;
444 foreach my $prefix (@INC) {
445 my $fullpath = File::Spec->catfile($prefix, $file);
446 return $fullpath if -f $fullpath
447 and Cwd::abs_path($fullpath) ne
448 Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
455 my ($self, $class) = @_;
457 my $class_path = $class;
458 $class_path =~ s{::}{/}g;
459 $class_path .= '.pm';
464 sub _find_class_in_inc {
465 my ($self, $class) = @_;
467 return $self->_find_file_in_inc($self->_class_path($class));
471 my ($self, $class) = @_;
473 my $real_inc_path = $self->_find_class_in_inc($class);
475 return if !$real_inc_path;
477 # If we make it to here, we loaded an external definition
478 warn qq/# Loaded external class definition for '$class'\n/
481 open(my $fh, '<', $real_inc_path)
482 or croak "Failed to open '$real_inc_path' for reading: $!";
483 $self->_ext_stmt($class,
484 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
485 .qq|# They are now part of the custom portion of this file\n|
486 .qq|# for you to hand-edit. If you do not either delete\n|
487 .qq|# this section or remove that file from \@INC, this section\n|
488 .qq|# will be repeated redundantly when you re-create this\n|
489 .qq|# file again via Loader!\n|
493 $self->_ext_stmt($class, $_);
495 $self->_ext_stmt($class,
496 qq|# End of lines loaded from '$real_inc_path' |
499 or croak "Failed to close $real_inc_path: $!";
501 if ($self->dynamic) { # load the class too
502 # turn off redefined warnings
503 local $SIG{__WARN__} = sub {};
511 Does the actual schema-construction work.
518 $self->_load_tables($self->_tables_list);
525 Rescan the database for newly added tables. Does
526 not process drops or changes. Returns a list of
527 the newly added table monikers.
529 The schema argument should be the schema class
530 or object to be affected. It should probably
531 be derived from the original schema_class used
537 my ($self, $schema) = @_;
539 $self->{schema} = $schema;
540 $self->_relbuilder->{schema} = $schema;
543 my @current = $self->_tables_list;
544 foreach my $table ($self->_tables_list) {
545 if(!exists $self->{_tables}->{$table}) {
546 push(@created, $table);
550 my $loaded = $self->_load_tables(@created);
552 return map { $self->monikers->{$_} } @$loaded;
556 no warnings 'uninitialized';
559 return if $self->{skip_relationships};
561 if ($self->naming->{relationships} eq 'v4') {
562 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
563 return $self->{relbuilder} ||=
564 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
565 $self->schema, $self->inflect_plural, $self->inflect_singular
569 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new(
570 $self->schema, $self->inflect_plural, $self->inflect_singular
575 my ($self, @tables) = @_;
577 # First, use _tables_list with constraint and exclude
578 # to get a list of tables to operate on
580 my $constraint = $self->constraint;
581 my $exclude = $self->exclude;
583 @tables = grep { /$constraint/ } @tables if $constraint;
584 @tables = grep { ! /$exclude/ } @tables if $exclude;
586 # Save the new tables to the tables list
588 $self->{_tables}->{$_} = 1;
591 $self->_make_src_class($_) for @tables;
592 $self->_setup_src_meta($_) for @tables;
594 if(!$self->skip_relationships) {
595 # The relationship loader needs a working schema
597 local $self->{dump_directory} = $self->{temp_directory};
598 $self->_reload_classes(\@tables);
599 $self->_load_relationships($_) for @tables;
602 # Remove that temp dir from INC so it doesn't get reloaded
603 @INC = grep { $_ ne $self->{dump_directory} } @INC;
606 $self->_load_external($_)
607 for map { $self->classes->{$_} } @tables;
609 # Reload without unloading first to preserve any symbols from external
611 $self->_reload_classes(\@tables, 0);
613 # Drop temporary cache
614 delete $self->{_cache};
619 sub _reload_classes {
620 my ($self, $tables, $unload) = @_;
622 my @tables = @$tables;
623 $unload = 1 unless defined $unload;
625 # so that we don't repeat custom sections
626 @INC = grep $_ ne $self->dump_directory, @INC;
628 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
630 unshift @INC, $self->dump_directory;
633 my %have_source = map { $_ => $self->schema->source($_) }
634 $self->schema->sources;
636 for my $table (@tables) {
637 my $moniker = $self->monikers->{$table};
638 my $class = $self->classes->{$table};
641 no warnings 'redefine';
642 local *Class::C3::reinitialize = sub {};
645 Class::Unload->unload($class) if $unload;
646 my ($source, $resultset_class);
648 ($source = $have_source{$moniker})
649 && ($resultset_class = $source->resultset_class)
650 && ($resultset_class ne 'DBIx::Class::ResultSet')
652 my $has_file = Class::Inspector->loaded_filename($resultset_class);
653 Class::Unload->unload($resultset_class) if $unload;
654 $self->_reload_class($resultset_class) if $has_file;
656 $self->_reload_class($class);
658 push @to_register, [$moniker, $class];
661 Class::C3->reinitialize;
663 $self->schema->register_class(@$_);
667 # We use this instead of ensure_class_loaded when there are package symbols we
670 my ($self, $class) = @_;
672 my $class_path = $self->_class_path($class);
673 delete $INC{ $class_path };
674 eval "require $class;";
677 sub _get_dump_filename {
678 my ($self, $class) = (@_);
681 return $self->dump_directory . q{/} . $class . q{.pm};
684 sub _ensure_dump_subdirs {
685 my ($self, $class) = (@_);
687 my @name_parts = split(/::/, $class);
688 pop @name_parts; # we don't care about the very last element,
689 # which is a filename
691 my $dir = $self->dump_directory;
694 mkdir($dir) or croak "mkdir('$dir') failed: $!";
696 last if !@name_parts;
697 $dir = File::Spec->catdir($dir, shift @name_parts);
702 my ($self, @classes) = @_;
704 my $schema_class = $self->schema_class;
705 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
707 my $target_dir = $self->dump_directory;
708 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
709 unless $self->{dynamic} or $self->{quiet};
712 qq|package $schema_class;\n\n|
713 . qq|# Created by DBIx::Class::Schema::Loader\n|
714 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
715 . qq|use strict;\nuse warnings;\n\n|
716 . qq|use base '$schema_base_class';\n\n|;
718 if ($self->use_namespaces) {
719 $schema_text .= qq|__PACKAGE__->load_namespaces|;
720 my $namespace_options;
721 for my $attr (qw(result_namespace
723 default_resultset_class)) {
725 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
728 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
729 $schema_text .= qq|;\n|;
732 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
736 local $self->{version_to_dump} = $self->schema_version_to_dump;
737 $self->_write_classfile($schema_class, $schema_text);
740 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
742 foreach my $src_class (@classes) {
744 qq|package $src_class;\n\n|
745 . qq|# Created by DBIx::Class::Schema::Loader\n|
746 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
747 . qq|use strict;\nuse warnings;\n\n|
748 . qq|use base '$result_base_class';\n\n|;
750 $self->_write_classfile($src_class, $src_text);
753 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
758 my ($self, $version, $ts) = @_;
759 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
762 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
765 sub _write_classfile {
766 my ($self, $class, $text) = @_;
768 my $filename = $self->_get_dump_filename($class);
769 $self->_ensure_dump_subdirs($class);
771 if (-f $filename && $self->really_erase_my_files) {
772 warn "Deleting existing file '$filename' due to "
773 . "'really_erase_my_files' setting\n" unless $self->{quiet};
777 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
780 for @{$self->{_dump_storage}->{$class} || []};
782 # Check and see if the dump is infact differnt
786 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
789 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
794 $text .= $self->_sig_comment(
795 $self->version_to_dump,
796 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
799 open(my $fh, '>', $filename)
800 or croak "Cannot open '$filename' for writing: $!";
802 # Write the top half and its MD5 sum
803 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
805 # Write out anything loaded via external partial class file in @INC
807 for @{$self->{_ext_storage}->{$class} || []};
809 # Write out any custom content the user has added
810 print $fh $custom_content;
813 or croak "Error closing '$filename': $!";
816 sub _default_custom_content {
817 return qq|\n\n# You can replace this text with custom|
818 . qq| content, and it will be preserved on regeneration|
822 sub _get_custom_content {
823 my ($self, $class, $filename) = @_;
825 return ($self->_default_custom_content) if ! -f $filename;
827 open(my $fh, '<', $filename)
828 or croak "Cannot open '$filename' for reading: $!";
831 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
834 my ($md5, $ts, $ver);
836 if(!$md5 && /$mark_re/) {
840 # Pull out the previous version and timestamp
841 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
844 croak "Checksum mismatch in '$filename'"
845 if Digest::MD5::md5_base64($buffer) ne $md5;
854 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
855 . " it does not appear to have been generated by Loader"
858 # Default custom content:
859 $buffer ||= $self->_default_custom_content;
861 return ($buffer, $md5, $ver, $ts);
869 warn "$target: use $_;" if $self->debug;
870 $self->_raw_stmt($target, "use $_;");
877 my $schema_class = $self->schema_class;
879 my $blist = join(q{ }, @_);
880 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
881 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
884 # Create class with applicable bases, setup monikers, etc
885 sub _make_src_class {
886 my ($self, $table) = @_;
888 my $schema = $self->schema;
889 my $schema_class = $self->schema_class;
891 my $table_moniker = $self->_table2moniker($table);
892 my @result_namespace = ($schema_class);
893 if ($self->use_namespaces) {
894 my $result_namespace = $self->result_namespace || 'Result';
895 if ($result_namespace =~ /^\+(.*)/) {
896 # Fully qualified namespace
897 @result_namespace = ($1)
901 push @result_namespace, $result_namespace;
904 my $table_class = join(q{::}, @result_namespace, $table_moniker);
906 my $table_normalized = lc $table;
907 $self->classes->{$table} = $table_class;
908 $self->classes->{$table_normalized} = $table_class;
909 $self->monikers->{$table} = $table_moniker;
910 $self->monikers->{$table_normalized} = $table_moniker;
912 $self->_use ($table_class, @{$self->additional_classes});
913 $self->_inject($table_class, @{$self->left_base_classes});
915 if (my @components = @{ $self->components }) {
916 $self->_dbic_stmt($table_class, 'load_components', @components);
919 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
920 if @{$self->resultset_components};
921 $self->_inject($table_class, @{$self->additional_base_classes});
924 # Set up metadata (cols, pks, etc)
925 sub _setup_src_meta {
926 my ($self, $table) = @_;
928 my $schema = $self->schema;
929 my $schema_class = $self->schema_class;
931 my $table_class = $self->classes->{$table};
932 my $table_moniker = $self->monikers->{$table};
934 my $table_name = $table;
935 my $name_sep = $self->schema->storage->sql_maker->name_sep;
937 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
938 $table_name = \ $self->_quote_table_name($table_name);
941 $self->_dbic_stmt($table_class,'table',$table_name);
943 my $cols = $self->_table_columns($table);
945 eval { $col_info = $self->_columns_info_for($table) };
947 $self->_dbic_stmt($table_class,'add_columns',@$cols);
950 if ($self->_is_case_sensitive) {
951 for my $col (keys %$col_info) {
952 $col_info->{$col}{accessor} = lc $col
956 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
959 my $fks = $self->_table_fk_info($table);
961 for my $fkdef (@$fks) {
962 for my $col (@{ $fkdef->{local_columns} }) {
963 $col_info->{$col}{is_foreign_key} = 1;
969 map { $_, ($col_info->{$_}||{}) } @$cols
973 my %uniq_tag; # used to eliminate duplicate uniqs
975 my $pks = $self->_table_pk_info($table) || [];
976 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
977 : carp("$table has no primary key");
978 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
980 my $uniqs = $self->_table_uniq_info($table) || [];
982 my ($name, $cols) = @$_;
983 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
984 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
991 Returns a sorted list of loaded tables, using the original database table
999 return keys %{$self->_tables};
1002 # Make a moniker from a table
1003 sub _default_table2moniker {
1004 no warnings 'uninitialized';
1005 my ($self, $table) = @_;
1007 if ($self->naming->{monikers} eq 'v4') {
1008 return join '', map ucfirst, split /[\W_]+/, lc $table;
1011 return join '', map ucfirst, split /[\W_]+/,
1012 Lingua::EN::Inflect::Number::to_S(lc $table);
1015 sub _table2moniker {
1016 my ( $self, $table ) = @_;
1020 if( ref $self->moniker_map eq 'HASH' ) {
1021 $moniker = $self->moniker_map->{$table};
1023 elsif( ref $self->moniker_map eq 'CODE' ) {
1024 $moniker = $self->moniker_map->($table);
1027 $moniker ||= $self->_default_table2moniker($table);
1032 sub _load_relationships {
1033 my ($self, $table) = @_;
1035 my $tbl_fk_info = $self->_table_fk_info($table);
1036 foreach my $fkdef (@$tbl_fk_info) {
1037 $fkdef->{remote_source} =
1038 $self->monikers->{delete $fkdef->{remote_table}};
1040 my $tbl_uniq_info = $self->_table_uniq_info($table);
1042 my $local_moniker = $self->monikers->{$table};
1043 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1045 foreach my $src_class (sort keys %$rel_stmts) {
1046 my $src_stmts = $rel_stmts->{$src_class};
1047 foreach my $stmt (@$src_stmts) {
1048 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1053 # Overload these in driver class:
1055 # Returns an arrayref of column names
1056 sub _table_columns { croak "ABSTRACT METHOD" }
1058 # Returns arrayref of pk col names
1059 sub _table_pk_info { croak "ABSTRACT METHOD" }
1061 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1062 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1064 # Returns an arrayref of foreign key constraints, each
1065 # being a hashref with 3 keys:
1066 # local_columns (arrayref), remote_columns (arrayref), remote_table
1067 sub _table_fk_info { croak "ABSTRACT METHOD" }
1069 # Returns an array of lower case table names
1070 sub _tables_list { croak "ABSTRACT METHOD" }
1072 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1077 if ( $method eq 'table' ) {
1079 $self->_pod( $class, "=head1 NAME" );
1080 my $table_descr = $class;
1081 if ( $self->can('_table_comment') ) {
1082 my $comment = $self->_table_comment($table);
1083 $table_descr .= " - " . $comment if $comment;
1085 $self->{_class2table}{ $class } = $table;
1086 $self->_pod( $class, $table_descr );
1087 $self->_pod_cut( $class );
1088 } elsif ( $method eq 'add_columns' ) {
1089 $self->_pod( $class, "=head1 ACCESSORS" );
1094 $self->_pod( $class, '=head2 ' . $_ );
1096 $comment = $self->_column_comment( $self->{_class2table}{$class}, ($i - 1) / 2 + 1 ) if $self->can('_column_comment');
1097 $self->_pod( $class, $comment ) if $comment;
1099 $self->_pod_cut( $class );
1100 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1101 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1102 my ( $accessor, $rel_class ) = @_;
1103 $self->_pod( $class, "=head2 $accessor" );
1104 $self->_pod( $class, 'Type: ' . $method );
1105 $self->_pod( $class, "Related object: L<$rel_class>" );
1106 $self->_pod_cut( $class );
1107 $self->{_relations_started} { $class } = 1;
1109 my $args = dump(@_);
1110 $args = '(' . $args . ')' if @_ < 2;
1111 my $stmt = $method . $args . q{;};
1113 warn qq|$class\->$stmt\n| if $self->debug;
1114 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1118 # Stores a POD documentation
1120 my ($self, $class, $stmt) = @_;
1121 $self->_raw_stmt( $class, "\n" . $stmt );
1125 my ($self, $class ) = @_;
1126 $self->_raw_stmt( $class, "\n=cut\n" );
1130 # Store a raw source line for a class (for dumping purposes)
1132 my ($self, $class, $stmt) = @_;
1133 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1136 # Like above, but separately for the externally loaded stuff
1138 my ($self, $class, $stmt) = @_;
1139 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1142 sub _quote_table_name {
1143 my ($self, $table) = @_;
1145 my $qt = $self->schema->storage->sql_maker->quote_char;
1147 return $table unless $qt;
1150 return $qt->[0] . $table . $qt->[1];
1153 return $qt . $table . $qt;
1156 sub _is_case_sensitive { 0 }
1160 Returns a hashref of loaded table to moniker mappings. There will
1161 be two entries for each table, the original name and the "normalized"
1162 name, in the case that the two are different (such as databases
1163 that like uppercase table names, or preserve your original mixed-case
1164 definitions, or what-have-you).
1168 Returns a hashref of table to class mappings. In some cases it will
1169 contain multiple entries per table for the original and normalized table
1170 names, as above in L</monikers>.
1174 L<DBIx::Class::Schema::Loader>
1178 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1182 This library is free software; you can redistribute it and/or modify it under
1183 the same terms as Perl itself.