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//;
15 use Lingua::EN::Inflect::Phrase qw//;
18 use Class::Inspector ();
19 use Scalar::Util 'looks_like_number';
20 use File::Slurp 'slurp';
21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/;
22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
25 use Class::Load 'load_class';
28 our $VERSION = '0.07006';
30 __PACKAGE__->mk_group_ro_accessors('simple', qw/
37 additional_base_classes
52 default_resultset_class
56 overwrite_modifications
75 __PACKAGE__->mk_group_accessors('simple', qw/
77 schema_version_to_dump
79 _upgrading_from_load_classes
80 _downgrading_to_load_classes
81 _rewriting_result_namespace
86 pod_comment_spillover_length
91 datetime_undef_if_invalid
97 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
101 See L<DBIx::Class::Schema::Loader>
105 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
106 classes, and implements the common functionality between them.
108 =head1 CONSTRUCTOR OPTIONS
110 These constructor options are the base options for
111 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
113 =head2 skip_relationships
115 Skip setting up relationships. The default is to attempt the loading
118 =head2 skip_load_external
120 Skip loading of other classes in @INC. The default is to merge all other classes
121 with the same name found in @INC into the schema file we are creating.
125 Static schemas (ones dumped to disk) will, by default, use the new-style
126 relationship names and singularized Results, unless you're overwriting an
127 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
128 which case the backward compatible RelBuilder will be activated, and the
129 appropriate monikerization used.
135 will disable the backward-compatible RelBuilder and use
136 the new-style relationship names along with singularized Results, even when
137 overwriting a dump made with an earlier version.
139 The option also takes a hashref:
141 naming => { relationships => 'v7', monikers => 'v7' }
149 How to name relationship accessors.
153 How to name Result classes.
155 =item column_accessors
157 How to name column accessors in Result classes.
167 Latest style, whatever that happens to be.
171 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
175 Monikers singularized as whole words, C<might_have> relationships for FKs on
176 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
178 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
183 All monikers and relationships are inflected using
184 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
185 from relationship names.
187 In general, there is very little difference between v5 and v6 schemas.
191 This mode is identical to C<v6> mode, except that monikerization of CamelCase
192 table names is also done correctly.
194 CamelCase column names in case-preserving mode will also be handled correctly
195 for relationship name inflection. See L</preserve_case>.
197 In this mode, CamelCase L</column_accessors> are normalized based on case
198 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
200 If you don't have any CamelCase table or column names, you can upgrade without
201 breaking any of your code.
205 Dynamic schemas will always default to the 0.04XXX relationship names and won't
206 singularize Results for backward compatibility, to activate the new RelBuilder
207 and singularization put this in your C<Schema.pm> file:
209 __PACKAGE__->naming('current');
211 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
212 next major version upgrade:
214 __PACKAGE__->naming('v7');
218 By default POD will be generated for columns and relationships, using database
219 metadata for the text if available and supported.
221 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
222 supported for Postgres right now.
224 Set this to C<0> to turn off all POD generation.
226 =head2 pod_comment_mode
228 Controls where table comments appear in the generated POD. Smaller table
229 comments are appended to the C<NAME> section of the documentation, and larger
230 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
231 section to be generated with the comment always, only use C<NAME>, or choose
232 the length threshold at which the comment is forced into the description.
238 Use C<NAME> section only.
242 Force C<DESCRIPTION> always.
246 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
251 =head2 pod_comment_spillover_length
253 When pod_comment_mode is set to C<auto>, this is the length of the comment at
254 which it will be forced into a separate description section.
258 =head2 relationship_attrs
260 Hashref of attributes to pass to each generated relationship, listed
261 by type. Also supports relationship type 'all', containing options to
262 pass to all generated relationships. Attributes set for more specific
263 relationship types override those set in 'all'.
267 relationship_attrs => {
268 belongs_to => { is_deferrable => 0 },
271 use this to turn off DEFERRABLE on your foreign key constraints.
275 If set to true, each constructive L<DBIx::Class> statement the loader
276 decides to execute will be C<warn>-ed before execution.
280 Set the name of the schema to load (schema in the sense that your database
281 vendor means it). Does not currently support loading more than one schema
286 Only load tables matching regex. Best specified as a qr// regex.
290 Exclude tables matching regex. Best specified as a qr// regex.
294 Overrides the default table name to moniker translation. Can be either
295 a hashref of table keys and moniker values, or a coderef for a translator
296 function taking a single scalar table name argument and returning
297 a scalar moniker. If the hash entry does not exist, or the function
298 returns a false value, the code falls back to default behavior
301 The default behavior is to split on case transition and non-alphanumeric
302 boundaries, singularize the resulting phrase, then join the titlecased words
305 Table Name | Moniker Name
306 ---------------------------------
308 luser_group | LuserGroup
309 luser-opts | LuserOpt
310 stations_visited | StationVisited
311 routeChange | RouteChange
313 =head2 column_accessor_map
315 Same as moniker_map, but for column accessor names. If a coderef is
316 passed, the code is called with arguments of
318 the name of the column in the underlying database,
319 default accessor name that DBICSL would ordinarily give this column,
321 table_class => name of the DBIC class we are building,
322 table_moniker => calculated moniker for this table (after moniker_map if present),
323 table_name => name of the database table,
324 full_table_name => schema-qualified name of the database table (RDBMS specific),
325 schema_class => name of the schema class we are building,
326 column_info => hashref of column info (data_type, is_nullable, etc),
329 =head2 inflect_plural
331 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
332 if hash key does not exist or coderef returns false), but acts as a map
333 for pluralizing relationship names. The default behavior is to utilize
334 L<Lingua::EN::Inflect::Phrase/to_PL>.
336 =head2 inflect_singular
338 As L</inflect_plural> above, but for singularizing relationship names.
339 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
341 =head2 schema_base_class
343 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
345 =head2 result_base_class
347 Base class for your table classes (aka result classes). Defaults to
350 =head2 additional_base_classes
352 List of additional base classes all of your table classes will use.
354 =head2 left_base_classes
356 List of additional base classes all of your table classes will use
357 that need to be leftmost.
359 =head2 additional_classes
361 List of additional classes which all of your table classes will use.
365 List of additional components to be loaded into all of your table
366 classes. A good example would be
367 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
369 =head2 use_namespaces
371 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
374 Generate result class names suitable for
375 L<DBIx::Class::Schema/load_namespaces> and call that instead of
376 L<DBIx::Class::Schema/load_classes>. When using this option you can also
377 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
378 C<resultset_namespace>, C<default_resultset_class>), and they will be added
379 to the call (and the generated result class names adjusted appropriately).
381 =head2 dump_directory
383 The value of this option is a perl libdir pathname. Within
384 that directory this module will create a baseline manual
385 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
387 The created schema class will have the same classname as the one on
388 which you are setting this option (and the ResultSource classes will be
389 based on this name as well).
391 Normally you wouldn't hard-code this setting in your schema class, as it
392 is meant for one-time manual usage.
394 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
395 recommended way to access this functionality.
397 =head2 dump_overwrite
399 Deprecated. See L</really_erase_my_files> below, which does *not* mean
400 the same thing as the old C<dump_overwrite> setting from previous releases.
402 =head2 really_erase_my_files
404 Default false. If true, Loader will unconditionally delete any existing
405 files before creating the new ones from scratch when dumping a schema to disk.
407 The default behavior is instead to only replace the top portion of the
408 file, up to and including the final stanza which contains
409 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
410 leaving any customizations you placed after that as they were.
412 When C<really_erase_my_files> is not set, if the output file already exists,
413 but the aforementioned final stanza is not found, or the checksum
414 contained there does not match the generated contents, Loader will
415 croak and not touch the file.
417 You should really be using version control on your schema classes (and all
418 of the rest of your code for that matter). Don't blame me if a bug in this
419 code wipes something out when it shouldn't have, you've been warned.
421 =head2 overwrite_modifications
423 Default false. If false, when updating existing files, Loader will
424 refuse to modify any Loader-generated code that has been modified
425 since its last run (as determined by the checksum Loader put in its
428 If true, Loader will discard any manual modifications that have been
429 made to Loader-generated code.
431 Again, you should be using version control on your schema classes. Be
432 careful with this option.
434 =head2 custom_column_info
436 Hook for adding extra attributes to the
437 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
439 Must be a coderef that returns a hashref with the extra attributes.
441 Receives the table name, column name and column_info.
445 custom_column_info => sub {
446 my ($table_name, $column_name, $column_info) = @_;
448 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
449 return { is_snoopy => 1 };
453 This attribute can also be used to set C<inflate_datetime> on a non-datetime
454 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
456 =head2 datetime_timezone
458 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
459 columns with the DATE/DATETIME/TIMESTAMP data_types.
461 =head2 datetime_locale
463 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
464 columns with the DATE/DATETIME/TIMESTAMP data_types.
466 =head2 datetime_undef_if_invalid
468 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
469 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
472 The default is recommended to deal with data such as C<00/00/00> which
473 sometimes ends up in such columns in MySQL.
477 File in Perl format, which should return a HASH reference, from which to read
482 Usually column names are lowercased, to make them easier to work with in
483 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
486 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
487 case-sensitive collation will turn this option on unconditionally.
489 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
492 =head2 qualify_objects
494 Set to true to prepend the L</db_schema> to table names for C<<
495 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
499 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
500 L<namespace::autoclean>. The default content after the md5 sum also makes the
503 It is safe to upgrade your existing Schema to this option.
505 =head2 col_collision_map
507 This option controls how accessors for column names which collide with perl
508 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
510 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
511 strings which are compiled to regular expressions that map to
512 L<sprintf|perlfunc/sprintf> formats.
516 col_collision_map => 'column_%s'
518 col_collision_map => { '(.*)' => 'column_%s' }
520 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
522 =head2 rel_collision_map
524 Works just like L</col_collision_map>, but for relationship names/accessors
525 rather than column names/accessors.
527 The default is to just append C<_rel> to the relationship name, see
528 L</RELATIONSHIP NAME COLLISIONS>.
532 None of these methods are intended for direct invocation by regular
533 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
534 L<DBIx::Class::Schema::Loader>.
538 my $CURRENT_V = 'v7';
541 schema_base_class result_base_class additional_base_classes
542 left_base_classes additional_classes components
545 # ensure that a peice of object data is a valid arrayref, creating
546 # an empty one or encapsulating whatever's there.
547 sub _ensure_arrayref {
552 $self->{$_} = [ $self->{$_} ]
553 unless ref $self->{$_} eq 'ARRAY';
559 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
560 by L<DBIx::Class::Schema::Loader>.
565 my ( $class, %args ) = @_;
567 my $self = { %args };
569 # don't lose undef options
570 for (values %$self) {
571 $_ = 0 unless defined $_;
574 bless $self => $class;
576 if (my $config_file = $self->config_file) {
577 my $config_opts = do $config_file;
579 croak "Error reading config from $config_file: $@" if $@;
581 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
583 while (my ($k, $v) = each %$config_opts) {
584 $self->{$k} = $v unless exists $self->{$k};
588 $self->_ensure_arrayref(qw/additional_classes
589 additional_base_classes
594 $self->_validate_class_args;
596 if ($self->use_moose) {
597 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
598 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
599 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
603 $self->{monikers} = {};
604 $self->{classes} = {};
605 $self->{_upgrading_classes} = {};
607 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
608 $self->{schema} ||= $self->{schema_class};
610 croak "dump_overwrite is deprecated. Please read the"
611 . " DBIx::Class::Schema::Loader::Base documentation"
612 if $self->{dump_overwrite};
614 $self->{dynamic} = ! $self->{dump_directory};
615 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
620 $self->{dump_directory} ||= $self->{temp_directory};
622 $self->real_dump_directory($self->{dump_directory});
624 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
625 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
627 if ((not ref $self->naming) && defined $self->naming) {
628 my $naming_ver = $self->naming;
630 relationships => $naming_ver,
631 monikers => $naming_ver,
632 column_accessors => $naming_ver,
637 for (values %{ $self->naming }) {
638 $_ = $CURRENT_V if $_ eq 'current';
641 $self->{naming} ||= {};
643 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
644 croak 'custom_column_info must be a CODE ref';
647 $self->_check_back_compat;
649 $self->use_namespaces(1) unless defined $self->use_namespaces;
650 $self->generate_pod(1) unless defined $self->generate_pod;
651 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
652 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
654 if (my $col_collision_map = $self->col_collision_map) {
655 if (my $reftype = ref $col_collision_map) {
656 if ($reftype ne 'HASH') {
657 croak "Invalid type $reftype for option 'col_collision_map'";
661 $self->col_collision_map({ '(.*)' => $col_collision_map });
668 sub _check_back_compat {
671 # dynamic schemas will always be in 0.04006 mode, unless overridden
672 if ($self->dynamic) {
673 # just in case, though no one is likely to dump a dynamic schema
674 $self->schema_version_to_dump('0.04006');
676 if (not %{ $self->naming }) {
677 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
679 Dynamic schema detected, will run in 0.04006 mode.
681 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
682 to disable this warning.
684 Also consider setting 'use_namespaces => 1' if/when upgrading.
686 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
691 $self->_upgrading_from('v4');
694 $self->naming->{relationships} ||= 'v4';
695 $self->naming->{monikers} ||= 'v4';
697 if ($self->use_namespaces) {
698 $self->_upgrading_from_load_classes(1);
701 $self->use_namespaces(0);
707 # otherwise check if we need backcompat mode for a static schema
708 my $filename = $self->_get_dump_filename($self->schema_class);
709 return unless -e $filename;
711 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
712 $self->_parse_generated_file($filename);
714 return unless $old_ver;
716 # determine if the existing schema was dumped with use_moose => 1
717 if (! defined $self->use_moose) {
718 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
721 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
722 my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
724 if ($load_classes && (not defined $self->use_namespaces)) {
725 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
727 'load_classes;' static schema detected, turning off 'use_namespaces'.
729 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
730 variable to disable this warning.
732 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
735 $self->use_namespaces(0);
737 elsif ($load_classes && $self->use_namespaces) {
738 $self->_upgrading_from_load_classes(1);
740 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
741 $self->_downgrading_to_load_classes(
742 $result_namespace || 'Result'
745 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
746 if (not $self->result_namespace) {
747 $self->result_namespace($result_namespace || 'Result');
749 elsif ($result_namespace ne $self->result_namespace) {
750 $self->_rewriting_result_namespace(
751 $result_namespace || 'Result'
756 # XXX when we go past .0 this will need fixing
757 my ($v) = $old_ver =~ /([1-9])/;
760 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
762 if (not %{ $self->naming }) {
763 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
765 Version $old_ver static schema detected, turning on backcompat mode.
767 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
768 to disable this warning.
770 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
772 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
773 from version 0.04006.
776 $self->naming->{relationships} ||= $v;
777 $self->naming->{monikers} ||= $v;
778 $self->naming->{column_accessors} ||= $v;
780 $self->schema_version_to_dump($old_ver);
783 $self->_upgrading_from($v);
787 sub _validate_class_args {
791 foreach my $k (@CLASS_ARGS) {
792 next unless $self->$k;
794 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
795 foreach my $c (@classes) {
796 # components default to being under the DBIx::Class namespace unless they
797 # are preceeded with a '+'
798 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
799 $c = 'DBIx::Class::' . $c;
802 # 1 == installed, 0 == not installed, undef == invalid classname
803 my $installed = Class::Inspector->installed($c);
804 if ( defined($installed) ) {
805 if ( $installed == 0 ) {
806 croak qq/$c, as specified in the loader option "$k", is not installed/;
809 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
815 sub _find_file_in_inc {
816 my ($self, $file) = @_;
818 foreach my $prefix (@INC) {
819 my $fullpath = File::Spec->catfile($prefix, $file);
820 return $fullpath if -f $fullpath
821 # abs_path throws on Windows for nonexistant files
822 and (try { Cwd::abs_path($fullpath) }) ne
823 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
830 my ($self, $class) = @_;
832 my $class_path = $class;
833 $class_path =~ s{::}{/}g;
834 $class_path .= '.pm';
839 sub _find_class_in_inc {
840 my ($self, $class) = @_;
842 return $self->_find_file_in_inc($self->_class_path($class));
848 return $self->_upgrading_from
849 || $self->_upgrading_from_load_classes
850 || $self->_downgrading_to_load_classes
851 || $self->_rewriting_result_namespace
855 sub _rewrite_old_classnames {
856 my ($self, $code) = @_;
858 return $code unless $self->_rewriting;
860 my %old_classes = reverse %{ $self->_upgrading_classes };
862 my $re = join '|', keys %old_classes;
865 $code =~ s/$re/$old_classes{$1} || $1/eg;
871 my ($self, $class) = @_;
873 return if $self->{skip_load_external};
875 # so that we don't load our own classes, under any circumstances
876 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
878 my $real_inc_path = $self->_find_class_in_inc($class);
880 my $old_class = $self->_upgrading_classes->{$class}
881 if $self->_rewriting;
883 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
884 if $old_class && $old_class ne $class;
886 return unless $real_inc_path || $old_real_inc_path;
888 if ($real_inc_path) {
889 # If we make it to here, we loaded an external definition
890 warn qq/# Loaded external class definition for '$class'\n/
893 my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
895 if ($self->dynamic) { # load the class too
896 eval_without_redefine_warnings($code);
899 $self->_ext_stmt($class,
900 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
901 .qq|# They are now part of the custom portion of this file\n|
902 .qq|# for you to hand-edit. If you do not either delete\n|
903 .qq|# this section or remove that file from \@INC, this section\n|
904 .qq|# will be repeated redundantly when you re-create this\n|
905 .qq|# file again via Loader! See skip_load_external to disable\n|
906 .qq|# this feature.\n|
909 $self->_ext_stmt($class, $code);
910 $self->_ext_stmt($class,
911 qq|# End of lines loaded from '$real_inc_path' |
915 if ($old_real_inc_path) {
916 my $code = slurp $old_real_inc_path;
918 $self->_ext_stmt($class, <<"EOF");
920 # These lines were loaded from '$old_real_inc_path',
921 # based on the Result class name that would have been created by an older
922 # version of the Loader. For a static schema, this happens only once during
923 # upgrade. See skip_load_external to disable this feature.
926 $code = $self->_rewrite_old_classnames($code);
928 if ($self->dynamic) {
931 Detected external content in '$old_real_inc_path', a class name that would have
932 been used by an older version of the Loader.
934 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
935 new name of the Result.
937 eval_without_redefine_warnings($code);
941 $self->_ext_stmt($class, $code);
942 $self->_ext_stmt($class,
943 qq|# End of lines loaded from '$old_real_inc_path' |
950 Does the actual schema-construction work.
958 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
966 Rescan the database for changes. Returns a list of the newly added table
969 The schema argument should be the schema class or object to be affected. It
970 should probably be derived from the original schema_class used during L</load>.
975 my ($self, $schema) = @_;
977 $self->{schema} = $schema;
978 $self->_relbuilder->{schema} = $schema;
981 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
983 foreach my $table (@current) {
984 if(!exists $self->{_tables}->{$table}) {
985 push(@created, $table);
990 @current{@current} = ();
991 foreach my $table (keys %{ $self->{_tables} }) {
992 if (not exists $current{$table}) {
993 $self->_unregister_source_for_table($table);
997 delete $self->{_dump_storage};
998 delete $self->{_relations_started};
1000 my $loaded = $self->_load_tables(@current);
1002 return map { $self->monikers->{$_} } @created;
1008 return if $self->{skip_relationships};
1010 return $self->{relbuilder} ||= do {
1012 no warnings 'uninitialized';
1013 my $relbuilder_suff =
1019 ->{ $self->naming->{relationships}};
1021 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1022 load_class $relbuilder_class;
1023 $relbuilder_class->new( $self );
1029 my ($self, @tables) = @_;
1031 # Save the new tables to the tables list
1033 $self->{_tables}->{$_} = 1;
1036 $self->_make_src_class($_) for @tables;
1038 # sanity-check for moniker clashes
1039 my $inverse_moniker_idx;
1040 for (keys %{$self->monikers}) {
1041 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1045 for (keys %$inverse_moniker_idx) {
1046 my $tables = $inverse_moniker_idx->{$_};
1048 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1049 join (', ', map { "'$_'" } @$tables),
1056 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1057 . 'Either change the naming style, or supply an explicit moniker_map: '
1058 . join ('; ', @clashes)
1064 $self->_setup_src_meta($_) for @tables;
1066 if(!$self->skip_relationships) {
1067 # The relationship loader needs a working schema
1069 local $self->{dump_directory} = $self->{temp_directory};
1070 $self->_reload_classes(\@tables);
1071 $self->_load_relationships($_) for @tables;
1072 $self->_relbuilder->cleanup;
1075 # Remove that temp dir from INC so it doesn't get reloaded
1076 @INC = grep $_ ne $self->dump_directory, @INC;
1079 $self->_load_external($_)
1080 for map { $self->classes->{$_} } @tables;
1082 # Reload without unloading first to preserve any symbols from external
1084 $self->_reload_classes(\@tables, { unload => 0 });
1086 # Drop temporary cache
1087 delete $self->{_cache};
1092 sub _reload_classes {
1093 my ($self, $tables, $opts) = @_;
1095 my @tables = @$tables;
1097 my $unload = $opts->{unload};
1098 $unload = 1 unless defined $unload;
1100 # so that we don't repeat custom sections
1101 @INC = grep $_ ne $self->dump_directory, @INC;
1103 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1105 unshift @INC, $self->dump_directory;
1108 my %have_source = map { $_ => $self->schema->source($_) }
1109 $self->schema->sources;
1111 for my $table (@tables) {
1112 my $moniker = $self->monikers->{$table};
1113 my $class = $self->classes->{$table};
1116 no warnings 'redefine';
1117 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1120 if (my $mc = $self->_moose_metaclass($class)) {
1123 Class::Unload->unload($class) if $unload;
1124 my ($source, $resultset_class);
1126 ($source = $have_source{$moniker})
1127 && ($resultset_class = $source->resultset_class)
1128 && ($resultset_class ne 'DBIx::Class::ResultSet')
1130 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1131 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1134 Class::Unload->unload($resultset_class) if $unload;
1135 $self->_reload_class($resultset_class) if $has_file;
1137 $self->_reload_class($class);
1139 push @to_register, [$moniker, $class];
1142 Class::C3->reinitialize;
1143 for (@to_register) {
1144 $self->schema->register_class(@$_);
1148 sub _moose_metaclass {
1149 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1153 my $mc = try { Class::MOP::class_of($class) }
1156 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1159 # We use this instead of ensure_class_loaded when there are package symbols we
1162 my ($self, $class) = @_;
1164 my $class_path = $self->_class_path($class);
1165 delete $INC{ $class_path };
1167 # kill redefined warnings
1169 eval_without_redefine_warnings ("require $class");
1172 my $source = slurp $self->_get_dump_filename($class);
1173 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1177 sub _get_dump_filename {
1178 my ($self, $class) = (@_);
1180 $class =~ s{::}{/}g;
1181 return $self->dump_directory . q{/} . $class . q{.pm};
1184 =head2 get_dump_filename
1188 Returns the full path to the file for a class that the class has been or will
1189 be dumped to. This is a file in a temp dir for a dynamic schema.
1193 sub get_dump_filename {
1194 my ($self, $class) = (@_);
1196 local $self->{dump_directory} = $self->real_dump_directory;
1198 return $self->_get_dump_filename($class);
1201 sub _ensure_dump_subdirs {
1202 my ($self, $class) = (@_);
1204 my @name_parts = split(/::/, $class);
1205 pop @name_parts; # we don't care about the very last element,
1206 # which is a filename
1208 my $dir = $self->dump_directory;
1211 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1213 last if !@name_parts;
1214 $dir = File::Spec->catdir($dir, shift @name_parts);
1219 my ($self, @classes) = @_;
1221 my $schema_class = $self->schema_class;
1222 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1224 my $target_dir = $self->dump_directory;
1225 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1226 unless $self->{dynamic} or $self->{quiet};
1229 qq|package $schema_class;\n\n|
1230 . qq|# Created by DBIx::Class::Schema::Loader\n|
1231 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1233 if ($self->use_moose) {
1234 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1237 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1240 if ($self->use_namespaces) {
1241 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1242 my $namespace_options;
1244 my @attr = qw/resultset_namespace default_resultset_class/;
1246 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1248 for my $attr (@attr) {
1250 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1253 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1254 $schema_text .= qq|;\n|;
1257 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1261 local $self->{version_to_dump} = $self->schema_version_to_dump;
1262 $self->_write_classfile($schema_class, $schema_text, 1);
1265 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1267 foreach my $src_class (@classes) {
1269 qq|package $src_class;\n\n|
1270 . qq|# Created by DBIx::Class::Schema::Loader\n|
1271 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1272 . qq|use strict;\nuse warnings;\n\n|;
1273 if ($self->use_moose) {
1274 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1276 # these options 'use base' which is compile time
1277 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1278 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1281 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1285 $src_text .= qq|use base '$result_base_class';\n\n|;
1287 $self->_write_classfile($src_class, $src_text);
1290 # remove Result dir if downgrading from use_namespaces, and there are no
1292 if (my $result_ns = $self->_downgrading_to_load_classes
1293 || $self->_rewriting_result_namespace) {
1294 my $result_namespace = $self->_result_namespace(
1299 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1300 $result_dir = $self->dump_directory . '/' . $result_dir;
1302 unless (my @files = glob "$result_dir/*") {
1307 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1312 my ($self, $version, $ts) = @_;
1313 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1316 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1319 sub _write_classfile {
1320 my ($self, $class, $text, $is_schema) = @_;
1322 my $filename = $self->_get_dump_filename($class);
1323 $self->_ensure_dump_subdirs($class);
1325 if (-f $filename && $self->really_erase_my_files) {
1326 warn "Deleting existing file '$filename' due to "
1327 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1331 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1332 = $self->_parse_generated_file($filename);
1334 if (! $old_gen && -f $filename) {
1335 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1336 . " it does not appear to have been generated by Loader"
1339 my $custom_content = $old_custom || '';
1341 # prepend extra custom content from a *renamed* class (singularization effect)
1342 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1343 my $old_filename = $self->_get_dump_filename($renamed_class);
1345 if (-f $old_filename) {
1346 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1348 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1350 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1353 unlink $old_filename;
1357 $custom_content ||= $self->_default_custom_content($is_schema);
1359 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1360 # If there is already custom content, which does not have the Moose content, add it.
1361 if ($self->use_moose) {
1363 my $non_moose_custom_content = do {
1364 local $self->{use_moose} = 0;
1365 $self->_default_custom_content;
1368 if ($custom_content eq $non_moose_custom_content) {
1369 $custom_content = $self->_default_custom_content($is_schema);
1371 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1372 $custom_content .= $self->_default_custom_content($is_schema);
1375 elsif (defined $self->use_moose && $old_gen) {
1376 croak 'It is not possible to "downgrade" a schema that was loaded with use_moose => 1 to use_moose => 0, due to differing custom content'
1377 if $old_gen =~ /use \s+ MooseX?\b/x;
1380 $custom_content = $self->_rewrite_old_classnames($custom_content);
1383 for @{$self->{_dump_storage}->{$class} || []};
1385 # Check and see if the dump is infact differnt
1389 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1390 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1391 return unless $self->_upgrading_from && $is_schema;
1395 $text .= $self->_sig_comment(
1396 $self->version_to_dump,
1397 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1400 open(my $fh, '>', $filename)
1401 or croak "Cannot open '$filename' for writing: $!";
1403 # Write the top half and its MD5 sum
1404 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1406 # Write out anything loaded via external partial class file in @INC
1408 for @{$self->{_ext_storage}->{$class} || []};
1410 # Write out any custom content the user has added
1411 print $fh $custom_content;
1414 or croak "Error closing '$filename': $!";
1417 sub _default_moose_custom_content {
1418 my ($self, $is_schema) = @_;
1420 if (not $is_schema) {
1421 return qq|\n__PACKAGE__->meta->make_immutable;|;
1424 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1427 sub _default_custom_content {
1428 my ($self, $is_schema) = @_;
1429 my $default = qq|\n\n# You can replace this text with custom|
1430 . qq| code or comments, and it will be preserved on regeneration|;
1431 if ($self->use_moose) {
1432 $default .= $self->_default_moose_custom_content($is_schema);
1434 $default .= qq|\n1;\n|;
1438 sub _parse_generated_file {
1439 my ($self, $fn) = @_;
1441 return unless -f $fn;
1443 open(my $fh, '<', $fn)
1444 or croak "Cannot open '$fn' for reading: $!";
1447 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1449 my ($md5, $ts, $ver, $gen);
1455 # Pull out the version and timestamp from the line above
1456 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1459 croak "Checksum mismatch in '$fn', 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"
1460 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1469 my $custom = do { local $/; <$fh> }
1474 return ($gen, $md5, $ver, $ts, $custom);
1482 warn "$target: use $_;" if $self->debug;
1483 $self->_raw_stmt($target, "use $_;");
1491 my $blist = join(q{ }, @_);
1493 return unless $blist;
1495 warn "$target: use base qw/$blist/;" if $self->debug;
1496 $self->_raw_stmt($target, "use base qw/$blist/;");
1499 sub _result_namespace {
1500 my ($self, $schema_class, $ns) = @_;
1501 my @result_namespace;
1503 if ($ns =~ /^\+(.*)/) {
1504 # Fully qualified namespace
1505 @result_namespace = ($1)
1508 # Relative namespace
1509 @result_namespace = ($schema_class, $ns);
1512 return wantarray ? @result_namespace : join '::', @result_namespace;
1515 # Create class with applicable bases, setup monikers, etc
1516 sub _make_src_class {
1517 my ($self, $table) = @_;
1519 my $schema = $self->schema;
1520 my $schema_class = $self->schema_class;
1522 my $table_moniker = $self->_table2moniker($table);
1523 my @result_namespace = ($schema_class);
1524 if ($self->use_namespaces) {
1525 my $result_namespace = $self->result_namespace || 'Result';
1526 @result_namespace = $self->_result_namespace(
1531 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1533 if ((my $upgrading_v = $self->_upgrading_from)
1534 || $self->_rewriting) {
1535 local $self->naming->{monikers} = $upgrading_v
1538 my @result_namespace = @result_namespace;
1539 if ($self->_upgrading_from_load_classes) {
1540 @result_namespace = ($schema_class);
1542 elsif (my $ns = $self->_downgrading_to_load_classes) {
1543 @result_namespace = $self->_result_namespace(
1548 elsif ($ns = $self->_rewriting_result_namespace) {
1549 @result_namespace = $self->_result_namespace(
1555 my $old_class = join(q{::}, @result_namespace,
1556 $self->_table2moniker($table));
1558 $self->_upgrading_classes->{$table_class} = $old_class
1559 unless $table_class eq $old_class;
1562 # this was a bad idea, should be ok now without it
1563 # my $table_normalized = lc $table;
1564 # $self->classes->{$table_normalized} = $table_class;
1565 # $self->monikers->{$table_normalized} = $table_moniker;
1567 $self->classes->{$table} = $table_class;
1568 $self->monikers->{$table} = $table_moniker;
1570 $self->_use ($table_class, @{$self->additional_classes});
1571 $self->_inject($table_class, @{$self->left_base_classes});
1573 if (my @components = @{ $self->components }) {
1574 $self->_dbic_stmt($table_class, 'load_components', @components);
1577 $self->_inject($table_class, @{$self->additional_base_classes});
1580 sub _is_result_class_method {
1581 my ($self, $name) = @_;
1583 if (not $self->_result_class_methods) {
1584 my (@methods, %methods);
1585 my $base = $self->result_base_class || 'DBIx::Class::Core';
1586 my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
1588 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1591 push @methods, @{ Class::Inspector->methods($class) || [] };
1594 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1596 @methods{@methods} = ();
1599 $methods{meta} = undef;
1601 $self->_result_class_methods(\%methods);
1603 my $result_methods = $self->_result_class_methods;
1605 return exists $result_methods->{$name};
1608 sub _resolve_col_accessor_collisions {
1609 my ($self, $table, $col_info) = @_;
1611 my $table_name = ref $table ? $$table : $table;
1613 while (my ($col, $info) = each %$col_info) {
1614 my $accessor = $info->{accessor} || $col;
1616 next if $accessor eq 'id'; # special case (very common column)
1618 if ($self->_is_result_class_method($accessor)) {
1621 if (my $map = $self->col_collision_map) {
1622 for my $re (keys %$map) {
1623 if (my @matches = $col =~ /$re/) {
1624 $info->{accessor} = sprintf $map->{$re}, @matches;
1632 Column '$col' in table '$table_name' collides with an inherited method.
1633 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1635 $info->{accessor} = undef;
1641 # use the same logic to run moniker_map, column_accessor_map, and
1642 # relationship_name_map
1644 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1646 my $default_ident = $default_code->( $ident, @extra );
1648 if( $map && ref $map eq 'HASH' ) {
1649 $new_ident = $map->{ $ident };
1651 elsif( $map && ref $map eq 'CODE' ) {
1652 $new_ident = $map->( $ident, $default_ident, @extra );
1655 $new_ident ||= $default_ident;
1660 sub _default_column_accessor_name {
1661 my ( $self, $column_name ) = @_;
1663 my $accessor_name = $column_name;
1664 $accessor_name =~ s/\W+/_/g;
1666 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1667 # older naming just lc'd the col accessor and that's all.
1668 return lc $accessor_name;
1671 return join '_', map lc, split_name $column_name;
1675 sub _make_column_accessor_name {
1676 my ($self, $column_name, $column_context_info ) = @_;
1678 my $accessor = $self->_run_user_map(
1679 $self->column_accessor_map,
1680 sub { $self->_default_column_accessor_name( shift ) },
1682 $column_context_info,
1688 # Set up metadata (cols, pks, etc)
1689 sub _setup_src_meta {
1690 my ($self, $table) = @_;
1692 my $schema = $self->schema;
1693 my $schema_class = $self->schema_class;
1695 my $table_class = $self->classes->{$table};
1696 my $table_moniker = $self->monikers->{$table};
1698 my $table_name = $table;
1699 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1701 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1702 $table_name = \ $self->_quote_table_name($table_name);
1705 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1707 # be careful to not create refs Data::Dump can "optimize"
1708 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1710 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1712 my $cols = $self->_table_columns($table);
1713 my $col_info = $self->__columns_info_for($table);
1715 ### generate all the column accessor names
1716 while (my ($col, $info) = each %$col_info) {
1717 # hashref of other info that could be used by
1718 # user-defined accessor map functions
1720 table_class => $table_class,
1721 table_moniker => $table_moniker,
1722 table_name => $table_name,
1723 full_table_name => $full_table_name,
1724 schema_class => $schema_class,
1725 column_info => $info,
1728 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1731 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1733 # prune any redundant accessor names
1734 while (my ($col, $info) = each %$col_info) {
1735 no warnings 'uninitialized';
1736 delete $info->{accessor} if $info->{accessor} eq $col;
1739 my $fks = $self->_table_fk_info($table);
1741 foreach my $fkdef (@$fks) {
1742 for my $col (@{ $fkdef->{local_columns} }) {
1743 $col_info->{$col}{is_foreign_key} = 1;
1747 my $pks = $self->_table_pk_info($table) || [];
1749 foreach my $pkcol (@$pks) {
1750 $col_info->{$pkcol}{is_nullable} = 0;
1756 map { $_, ($col_info->{$_}||{}) } @$cols
1759 my %uniq_tag; # used to eliminate duplicate uniqs
1761 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1762 : carp("$table has no primary key");
1763 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1765 my $uniqs = $self->_table_uniq_info($table) || [];
1767 my ($name, $cols) = @$_;
1768 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1769 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1774 sub __columns_info_for {
1775 my ($self, $table) = @_;
1777 my $result = $self->_columns_info_for($table);
1779 while (my ($col, $info) = each %$result) {
1780 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1781 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1783 $result->{$col} = $info;
1791 Returns a sorted list of loaded tables, using the original database table
1799 return keys %{$self->_tables};
1802 # Make a moniker from a table
1803 sub _default_table2moniker {
1804 no warnings 'uninitialized';
1805 my ($self, $table) = @_;
1807 if ($self->naming->{monikers} eq 'v4') {
1808 return join '', map ucfirst, split /[\W_]+/, lc $table;
1810 elsif ($self->naming->{monikers} eq 'v5') {
1811 return join '', map ucfirst, split /[\W_]+/,
1812 Lingua::EN::Inflect::Number::to_S(lc $table);
1814 elsif ($self->naming->{monikers} eq 'v6') {
1815 (my $as_phrase = lc $table) =~ s/_+/ /g;
1816 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1818 return join '', map ucfirst, split /\W+/, $inflected;
1821 my @words = map lc, split_name $table;
1822 my $as_phrase = join ' ', @words;
1824 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1826 return join '', map ucfirst, split /\W+/, $inflected;
1829 sub _table2moniker {
1830 my ( $self, $table ) = @_;
1832 $self->_run_user_map(
1834 sub { $self->_default_table2moniker( shift ) },
1839 sub _load_relationships {
1840 my ($self, $table) = @_;
1842 my $tbl_fk_info = $self->_table_fk_info($table);
1843 foreach my $fkdef (@$tbl_fk_info) {
1844 $fkdef->{remote_source} =
1845 $self->monikers->{delete $fkdef->{remote_table}};
1847 my $tbl_uniq_info = $self->_table_uniq_info($table);
1849 my $local_moniker = $self->monikers->{$table};
1850 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1852 foreach my $src_class (sort keys %$rel_stmts) {
1853 my $src_stmts = $rel_stmts->{$src_class};
1854 foreach my $stmt (@$src_stmts) {
1855 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1860 # Overload these in driver class:
1862 # Returns an arrayref of column names
1863 sub _table_columns { croak "ABSTRACT METHOD" }
1865 # Returns arrayref of pk col names
1866 sub _table_pk_info { croak "ABSTRACT METHOD" }
1868 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1869 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1871 # Returns an arrayref of foreign key constraints, each
1872 # being a hashref with 3 keys:
1873 # local_columns (arrayref), remote_columns (arrayref), remote_table
1874 sub _table_fk_info { croak "ABSTRACT METHOD" }
1876 # Returns an array of lower case table names
1877 sub _tables_list { croak "ABSTRACT METHOD" }
1879 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1885 # generate the pod for this statement, storing it with $self->_pod
1886 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1888 my $args = dump(@_);
1889 $args = '(' . $args . ')' if @_ < 2;
1890 my $stmt = $method . $args . q{;};
1892 warn qq|$class\->$stmt\n| if $self->debug;
1893 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1897 # generates the accompanying pod for a DBIC class method statement,
1898 # storing it with $self->_pod
1904 if ( $method eq 'table' ) {
1906 my $pcm = $self->pod_comment_mode;
1907 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1908 $comment = $self->__table_comment($table);
1909 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1910 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1911 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1912 $self->_pod( $class, "=head1 NAME" );
1913 my $table_descr = $class;
1914 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1915 $self->{_class2table}{ $class } = $table;
1916 $self->_pod( $class, $table_descr );
1917 if ($comment and $comment_in_desc) {
1918 $self->_pod( $class, "=head1 DESCRIPTION" );
1919 $self->_pod( $class, $comment );
1921 $self->_pod_cut( $class );
1922 } elsif ( $method eq 'add_columns' ) {
1923 $self->_pod( $class, "=head1 ACCESSORS" );
1924 my $col_counter = 0;
1926 while( my ($name,$attrs) = splice @cols,0,2 ) {
1928 $self->_pod( $class, '=head2 ' . $name );
1929 $self->_pod( $class,
1931 my $s = $attrs->{$_};
1932 $s = !defined $s ? 'undef' :
1933 length($s) == 0 ? '(empty string)' :
1934 ref($s) eq 'SCALAR' ? $$s :
1935 ref($s) ? dumper_squashed $s :
1936 looks_like_number($s) ? $s : qq{'$s'};
1939 } sort keys %$attrs,
1941 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
1942 $self->_pod( $class, $comment );
1945 $self->_pod_cut( $class );
1946 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1947 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1948 my ( $accessor, $rel_class ) = @_;
1949 $self->_pod( $class, "=head2 $accessor" );
1950 $self->_pod( $class, 'Type: ' . $method );
1951 $self->_pod( $class, "Related object: L<$rel_class>" );
1952 $self->_pod_cut( $class );
1953 $self->{_relations_started} { $class } = 1;
1957 sub _filter_comment {
1958 my ($self, $txt) = @_;
1960 $txt = '' if not defined $txt;
1962 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1967 sub __table_comment {
1970 if (my $code = $self->can('_table_comment')) {
1971 return $self->_filter_comment($self->$code(@_));
1977 sub __column_comment {
1980 if (my $code = $self->can('_column_comment')) {
1981 return $self->_filter_comment($self->$code(@_));
1987 # Stores a POD documentation
1989 my ($self, $class, $stmt) = @_;
1990 $self->_raw_stmt( $class, "\n" . $stmt );
1994 my ($self, $class ) = @_;
1995 $self->_raw_stmt( $class, "\n=cut\n" );
1998 # Store a raw source line for a class (for dumping purposes)
2000 my ($self, $class, $stmt) = @_;
2001 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2004 # Like above, but separately for the externally loaded stuff
2006 my ($self, $class, $stmt) = @_;
2007 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2010 sub _quote_table_name {
2011 my ($self, $table) = @_;
2013 my $qt = $self->schema->storage->sql_maker->quote_char;
2015 return $table unless $qt;
2018 return $qt->[0] . $table . $qt->[1];
2021 return $qt . $table . $qt;
2024 sub _custom_column_info {
2025 my ( $self, $table_name, $column_name, $column_info ) = @_;
2027 if (my $code = $self->custom_column_info) {
2028 return $code->($table_name, $column_name, $column_info) || {};
2033 sub _datetime_column_info {
2034 my ( $self, $table_name, $column_name, $column_info ) = @_;
2036 my $type = $column_info->{data_type} || '';
2037 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2038 or ($type =~ /date|timestamp/i)) {
2039 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2040 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2046 my ($self, $name) = @_;
2048 return $self->preserve_case ? $name : lc($name);
2052 my ($self, $name) = @_;
2054 return $self->preserve_case ? $name : uc($name);
2057 sub _unregister_source_for_table {
2058 my ($self, $table) = @_;
2062 my $schema = $self->schema;
2063 # in older DBIC it's a private method
2064 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2065 $schema->$unregister($self->_table2moniker($table));
2066 delete $self->monikers->{$table};
2067 delete $self->classes->{$table};
2068 delete $self->_upgrading_classes->{$table};
2069 delete $self->{_tables}{$table};
2073 # remove the dump dir from @INC on destruction
2077 @INC = grep $_ ne $self->dump_directory, @INC;
2082 Returns a hashref of loaded table to moniker mappings. There will
2083 be two entries for each table, the original name and the "normalized"
2084 name, in the case that the two are different (such as databases
2085 that like uppercase table names, or preserve your original mixed-case
2086 definitions, or what-have-you).
2090 Returns a hashref of table to class mappings. In some cases it will
2091 contain multiple entries per table for the original and normalized table
2092 names, as above in L</monikers>.
2094 =head1 COLUMN ACCESSOR COLLISIONS
2096 Occasionally you may have a column name that collides with a perl method, such
2097 as C<can>. In such cases, the default action is to set the C<accessor> of the
2098 column spec to C<undef>.
2100 You can then name the accessor yourself by placing code such as the following
2103 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2105 Another option is to use the L</col_collision_map> option.
2107 =head1 RELATIONSHIP NAME COLLISIONS
2109 In very rare cases, you may get a collision between a generated relationship
2110 name and a method in your Result class, for example if you have a foreign key
2111 called C<belongs_to>.
2113 This is a problem because relationship names are also relationship accessor
2114 methods in L<DBIx::Class>.
2116 The default behavior is to append C<_rel> to the relationship name and print
2117 out a warning that refers to this text.
2119 You can also control the renaming with the L</rel_collision_map> option.
2123 L<DBIx::Class::Schema::Loader>
2127 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2131 This library is free software; you can redistribute it and/or modify it under
2132 the same terms as Perl itself.
2137 # vim:et sts=4 sw=4 tw=0: