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.07002';
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
96 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
100 See L<DBIx::Class::Schema::Loader>
104 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
105 classes, and implements the common functionality between them.
107 =head1 CONSTRUCTOR OPTIONS
109 These constructor options are the base options for
110 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
112 =head2 skip_relationships
114 Skip setting up relationships. The default is to attempt the loading
117 =head2 skip_load_external
119 Skip loading of other classes in @INC. The default is to merge all other classes
120 with the same name found in @INC into the schema file we are creating.
124 Static schemas (ones dumped to disk) will, by default, use the new-style
125 relationship names and singularized Results, unless you're overwriting an
126 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
127 which case the backward compatible RelBuilder will be activated, and the
128 appropriate monikerization used.
134 will disable the backward-compatible RelBuilder and use
135 the new-style relationship names along with singularized Results, even when
136 overwriting a dump made with an earlier version.
138 The option also takes a hashref:
140 naming => { relationships => 'v7', monikers => 'v7' }
148 How to name relationship accessors.
152 How to name Result classes.
154 =item column_accessors
156 How to name column accessors in Result classes.
166 Latest style, whatever that happens to be.
170 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
174 Monikers singularized as whole words, C<might_have> relationships for FKs on
175 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
177 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
182 All monikers and relationships are inflected using
183 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
184 from relationship names.
186 In general, there is very little difference between v5 and v6 schemas.
190 This mode is identical to C<v6> mode, except that monikerization of CamelCase
191 table names is also done correctly.
193 CamelCase column names in case-preserving mode will also be handled correctly
194 for relationship name inflection. See L</preserve_case>.
196 In this mode, CamelCase L</column_accessors> are normalized based on case
197 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
199 If you don't have any CamelCase table or column names, you can upgrade without
200 breaking any of your code.
204 Dynamic schemas will always default to the 0.04XXX relationship names and won't
205 singularize Results for backward compatibility, to activate the new RelBuilder
206 and singularization put this in your C<Schema.pm> file:
208 __PACKAGE__->naming('current');
210 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
211 next major version upgrade:
213 __PACKAGE__->naming('v7');
217 By default POD will be generated for columns and relationships, using database
218 metadata for the text if available and supported.
220 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
221 supported for Postgres right now.
223 Set this to C<0> to turn off all POD generation.
225 =head2 pod_comment_mode
227 Controls where table comments appear in the generated POD. Smaller table
228 comments are appended to the C<NAME> section of the documentation, and larger
229 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
230 section to be generated with the comment always, only use C<NAME>, or choose
231 the length threshold at which the comment is forced into the description.
237 Use C<NAME> section only.
241 Force C<DESCRIPTION> always.
245 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
250 =head2 pod_comment_spillover_length
252 When pod_comment_mode is set to C<auto>, this is the length of the comment at
253 which it will be forced into a separate description section.
257 =head2 relationship_attrs
259 Hashref of attributes to pass to each generated relationship, listed
260 by type. Also supports relationship type 'all', containing options to
261 pass to all generated relationships. Attributes set for more specific
262 relationship types override those set in 'all'.
266 relationship_attrs => {
267 belongs_to => { is_deferrable => 0 },
270 use this to turn off DEFERRABLE on your foreign key constraints.
274 If set to true, each constructive L<DBIx::Class> statement the loader
275 decides to execute will be C<warn>-ed before execution.
279 Set the name of the schema to load (schema in the sense that your database
280 vendor means it). Does not currently support loading more than one schema
285 Only load tables matching regex. Best specified as a qr// regex.
289 Exclude tables matching regex. Best specified as a qr// regex.
293 Overrides the default table name to moniker translation. Can be either
294 a hashref of table keys and moniker values, or a coderef for a translator
295 function taking a single scalar table name argument and returning
296 a scalar moniker. If the hash entry does not exist, or the function
297 returns a false value, the code falls back to default behavior
300 The default behavior is to split on case transition and non-alphanumeric
301 boundaries, singularize the resulting phrase, then join the titlecased words
304 Table Name | Moniker Name
305 ---------------------------------
307 luser_group | LuserGroup
308 luser-opts | LuserOpt
309 stations_visited | StationVisited
310 routeChange | RouteChange
312 =head2 column_accessor_map
314 Same as moniker_map, but for column accessor names. If a coderef is
315 passed, the code is called with arguments of
317 the name of the column in the underlying database,
318 default accessor name that DBICSL would ordinarily give this column,
320 table_class => name of the DBIC class we are building,
321 table_moniker => calculated moniker for this table (after moniker_map if present),
322 table_name => name of the database table,
323 full_table_name => schema-qualified name of the database table (RDBMS specific),
324 schema_class => name of the schema class we are building,
325 column_info => hashref of column info (data_type, is_nullable, etc),
328 =head2 inflect_plural
330 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
331 if hash key does not exist or coderef returns false), but acts as a map
332 for pluralizing relationship names. The default behavior is to utilize
333 L<Lingua::EN::Inflect::Phrase/to_PL>.
335 =head2 inflect_singular
337 As L</inflect_plural> above, but for singularizing relationship names.
338 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
340 =head2 schema_base_class
342 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
344 =head2 result_base_class
346 Base class for your table classes (aka result classes). Defaults to
349 =head2 additional_base_classes
351 List of additional base classes all of your table classes will use.
353 =head2 left_base_classes
355 List of additional base classes all of your table classes will use
356 that need to be leftmost.
358 =head2 additional_classes
360 List of additional classes which all of your table classes will use.
364 List of additional components to be loaded into all of your table
365 classes. A good example would be
366 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
368 =head2 use_namespaces
370 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
373 Generate result class names suitable for
374 L<DBIx::Class::Schema/load_namespaces> and call that instead of
375 L<DBIx::Class::Schema/load_classes>. When using this option you can also
376 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
377 C<resultset_namespace>, C<default_resultset_class>), and they will be added
378 to the call (and the generated result class names adjusted appropriately).
380 =head2 dump_directory
382 The value of this option is a perl libdir pathname. Within
383 that directory this module will create a baseline manual
384 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
386 The created schema class will have the same classname as the one on
387 which you are setting this option (and the ResultSource classes will be
388 based on this name as well).
390 Normally you wouldn't hard-code this setting in your schema class, as it
391 is meant for one-time manual usage.
393 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
394 recommended way to access this functionality.
396 =head2 dump_overwrite
398 Deprecated. See L</really_erase_my_files> below, which does *not* mean
399 the same thing as the old C<dump_overwrite> setting from previous releases.
401 =head2 really_erase_my_files
403 Default false. If true, Loader will unconditionally delete any existing
404 files before creating the new ones from scratch when dumping a schema to disk.
406 The default behavior is instead to only replace the top portion of the
407 file, up to and including the final stanza which contains
408 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
409 leaving any customizations you placed after that as they were.
411 When C<really_erase_my_files> is not set, if the output file already exists,
412 but the aforementioned final stanza is not found, or the checksum
413 contained there does not match the generated contents, Loader will
414 croak and not touch the file.
416 You should really be using version control on your schema classes (and all
417 of the rest of your code for that matter). Don't blame me if a bug in this
418 code wipes something out when it shouldn't have, you've been warned.
420 =head2 overwrite_modifications
422 Default false. If false, when updating existing files, Loader will
423 refuse to modify any Loader-generated code that has been modified
424 since its last run (as determined by the checksum Loader put in its
427 If true, Loader will discard any manual modifications that have been
428 made to Loader-generated code.
430 Again, you should be using version control on your schema classes. Be
431 careful with this option.
433 =head2 custom_column_info
435 Hook for adding extra attributes to the
436 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
438 Must be a coderef that returns a hashref with the extra attributes.
440 Receives the table name, column name and column_info.
444 custom_column_info => sub {
445 my ($table_name, $column_name, $column_info) = @_;
447 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
448 return { is_snoopy => 1 };
452 This attribute can also be used to set C<inflate_datetime> on a non-datetime
453 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
455 =head2 datetime_timezone
457 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
458 columns with the DATE/DATETIME/TIMESTAMP data_types.
460 =head2 datetime_locale
462 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
463 columns with the DATE/DATETIME/TIMESTAMP data_types.
465 =head2 datetime_undef_if_invalid
467 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
468 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
471 The default is recommended to deal with data such as C<00/00/00> which
472 sometimes ends up in such columns in MySQL.
476 File in Perl format, which should return a HASH reference, from which to read
481 Usually column names are lowercased, to make them easier to work with in
482 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
485 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
486 case-sensitive collation will turn this option on unconditionally.
488 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
491 =head2 qualify_objects
493 Set to true to prepend the L</db_schema> to table names for C<<
494 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
498 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
499 L<namespace::autoclean>. The default content after the md5 sum also makes the
502 It is safe to upgrade your existing Schema to this option.
504 =head2 col_collision_map
506 This option controls how accessors for column names which collide with perl
507 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
509 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
510 strings which are compiled to regular expressions that map to
511 L<sprintf|perlfunc/sprintf> formats.
515 col_collision_map => 'column_%s'
517 col_collision_map => { '(.*)' => 'column_%s' }
519 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
521 =head2 rel_collision_map
523 Works just like L</col_collision_map>, but for relationship names/accessors
524 rather than column names/accessors.
526 The default is to just append C<_rel> to the relationship name, see
527 L</RELATIONSHIP NAME COLLISIONS>.
531 None of these methods are intended for direct invocation by regular
532 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
533 L<DBIx::Class::Schema::Loader>.
537 my $CURRENT_V = 'v7';
540 schema_base_class result_base_class additional_base_classes
541 left_base_classes additional_classes components
544 # ensure that a peice of object data is a valid arrayref, creating
545 # an empty one or encapsulating whatever's there.
546 sub _ensure_arrayref {
551 $self->{$_} = [ $self->{$_} ]
552 unless ref $self->{$_} eq 'ARRAY';
558 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
559 by L<DBIx::Class::Schema::Loader>.
564 my ( $class, %args ) = @_;
566 my $self = { %args };
568 # don't lose undef options
569 for (values %$self) {
570 $_ = 0 unless defined $_;
573 bless $self => $class;
575 if (my $config_file = $self->config_file) {
576 my $config_opts = do $config_file;
578 croak "Error reading config from $config_file: $@" if $@;
580 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
582 while (my ($k, $v) = each %$config_opts) {
583 $self->{$k} = $v unless exists $self->{$k};
587 $self->_ensure_arrayref(qw/additional_classes
588 additional_base_classes
593 $self->_validate_class_args;
595 if ($self->use_moose) {
596 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
597 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
598 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
602 $self->{monikers} = {};
603 $self->{classes} = {};
604 $self->{_upgrading_classes} = {};
606 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
607 $self->{schema} ||= $self->{schema_class};
609 croak "dump_overwrite is deprecated. Please read the"
610 . " DBIx::Class::Schema::Loader::Base documentation"
611 if $self->{dump_overwrite};
613 $self->{dynamic} = ! $self->{dump_directory};
614 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
619 $self->{dump_directory} ||= $self->{temp_directory};
621 $self->real_dump_directory($self->{dump_directory});
623 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
624 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
626 if ((not ref $self->naming) && defined $self->naming) {
627 my $naming_ver = $self->naming;
629 relationships => $naming_ver,
630 monikers => $naming_ver,
631 column_accessors => $naming_ver,
636 for (values %{ $self->naming }) {
637 $_ = $CURRENT_V if $_ eq 'current';
640 $self->{naming} ||= {};
642 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
643 croak 'custom_column_info must be a CODE ref';
646 $self->_check_back_compat;
648 $self->use_namespaces(1) unless defined $self->use_namespaces;
649 $self->generate_pod(1) unless defined $self->generate_pod;
650 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
651 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
653 if (my $col_collision_map = $self->col_collision_map) {
654 if (my $reftype = ref $col_collision_map) {
655 if ($reftype ne 'HASH') {
656 croak "Invalid type $reftype for option 'col_collision_map'";
660 $self->col_collision_map({ '(.*)' => $col_collision_map });
667 sub _check_back_compat {
670 # dynamic schemas will always be in 0.04006 mode, unless overridden
671 if ($self->dynamic) {
672 # just in case, though no one is likely to dump a dynamic schema
673 $self->schema_version_to_dump('0.04006');
675 if (not %{ $self->naming }) {
676 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
678 Dynamic schema detected, will run in 0.04006 mode.
680 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
681 to disable this warning.
683 Also consider setting 'use_namespaces => 1' if/when upgrading.
685 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
690 $self->_upgrading_from('v4');
693 $self->naming->{relationships} ||= 'v4';
694 $self->naming->{monikers} ||= 'v4';
696 if ($self->use_namespaces) {
697 $self->_upgrading_from_load_classes(1);
700 $self->use_namespaces(0);
706 # otherwise check if we need backcompat mode for a static schema
707 my $filename = $self->_get_dump_filename($self->schema_class);
708 return unless -e $filename;
710 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
711 $self->_parse_generated_file($filename);
713 return unless $old_ver;
715 # determine if the existing schema was dumped with use_moose => 1
716 if (! defined $self->use_moose) {
717 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
720 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
721 my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
723 if ($load_classes && (not defined $self->use_namespaces)) {
724 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
726 'load_classes;' static schema detected, turning off 'use_namespaces'.
728 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
729 variable to disable this warning.
731 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
734 $self->use_namespaces(0);
736 elsif ($load_classes && $self->use_namespaces) {
737 $self->_upgrading_from_load_classes(1);
739 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
740 $self->_downgrading_to_load_classes(
741 $result_namespace || 'Result'
744 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
745 if (not $self->result_namespace) {
746 $self->result_namespace($result_namespace || 'Result');
748 elsif ($result_namespace ne $self->result_namespace) {
749 $self->_rewriting_result_namespace(
750 $result_namespace || 'Result'
755 # XXX when we go past .0 this will need fixing
756 my ($v) = $old_ver =~ /([1-9])/;
759 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
761 if (not %{ $self->naming }) {
762 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
764 Version $old_ver static schema detected, turning on backcompat mode.
766 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
767 to disable this warning.
769 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
771 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
772 from version 0.04006.
775 $self->naming->{relationships} ||= $v;
776 $self->naming->{monikers} ||= $v;
777 $self->naming->{column_accessors} ||= $v;
779 $self->schema_version_to_dump($old_ver);
782 $self->_upgrading_from($v);
786 sub _validate_class_args {
790 foreach my $k (@CLASS_ARGS) {
791 next unless $self->$k;
793 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
794 foreach my $c (@classes) {
795 # components default to being under the DBIx::Class namespace unless they
796 # are preceeded with a '+'
797 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
798 $c = 'DBIx::Class::' . $c;
801 # 1 == installed, 0 == not installed, undef == invalid classname
802 my $installed = Class::Inspector->installed($c);
803 if ( defined($installed) ) {
804 if ( $installed == 0 ) {
805 croak qq/$c, as specified in the loader option "$k", is not installed/;
808 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
814 sub _find_file_in_inc {
815 my ($self, $file) = @_;
817 foreach my $prefix (@INC) {
818 my $fullpath = File::Spec->catfile($prefix, $file);
819 return $fullpath if -f $fullpath
820 # abs_path throws on Windows for nonexistant files
821 and (try { Cwd::abs_path($fullpath) }) ne
822 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
829 my ($self, $class) = @_;
831 my $class_path = $class;
832 $class_path =~ s{::}{/}g;
833 $class_path .= '.pm';
838 sub _find_class_in_inc {
839 my ($self, $class) = @_;
841 return $self->_find_file_in_inc($self->_class_path($class));
847 return $self->_upgrading_from
848 || $self->_upgrading_from_load_classes
849 || $self->_downgrading_to_load_classes
850 || $self->_rewriting_result_namespace
854 sub _rewrite_old_classnames {
855 my ($self, $code) = @_;
857 return $code unless $self->_rewriting;
859 my %old_classes = reverse %{ $self->_upgrading_classes };
861 my $re = join '|', keys %old_classes;
864 $code =~ s/$re/$old_classes{$1} || $1/eg;
870 my ($self, $class) = @_;
872 return if $self->{skip_load_external};
874 # so that we don't load our own classes, under any circumstances
875 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
877 my $real_inc_path = $self->_find_class_in_inc($class);
879 my $old_class = $self->_upgrading_classes->{$class}
880 if $self->_rewriting;
882 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
883 if $old_class && $old_class ne $class;
885 return unless $real_inc_path || $old_real_inc_path;
887 if ($real_inc_path) {
888 # If we make it to here, we loaded an external definition
889 warn qq/# Loaded external class definition for '$class'\n/
892 my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
894 if ($self->dynamic) { # load the class too
895 eval_without_redefine_warnings($code);
898 $self->_ext_stmt($class,
899 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
900 .qq|# They are now part of the custom portion of this file\n|
901 .qq|# for you to hand-edit. If you do not either delete\n|
902 .qq|# this section or remove that file from \@INC, this section\n|
903 .qq|# will be repeated redundantly when you re-create this\n|
904 .qq|# file again via Loader! See skip_load_external to disable\n|
905 .qq|# this feature.\n|
908 $self->_ext_stmt($class, $code);
909 $self->_ext_stmt($class,
910 qq|# End of lines loaded from '$real_inc_path' |
914 if ($old_real_inc_path) {
915 my $code = slurp $old_real_inc_path;
917 $self->_ext_stmt($class, <<"EOF");
919 # These lines were loaded from '$old_real_inc_path',
920 # based on the Result class name that would have been created by an older
921 # version of the Loader. For a static schema, this happens only once during
922 # upgrade. See skip_load_external to disable this feature.
925 $code = $self->_rewrite_old_classnames($code);
927 if ($self->dynamic) {
930 Detected external content in '$old_real_inc_path', a class name that would have
931 been used by an older version of the Loader.
933 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
934 new name of the Result.
936 eval_without_redefine_warnings($code);
940 $self->_ext_stmt($class, $code);
941 $self->_ext_stmt($class,
942 qq|# End of lines loaded from '$old_real_inc_path' |
949 Does the actual schema-construction work.
957 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
965 Rescan the database for changes. Returns a list of the newly added table
968 The schema argument should be the schema class or object to be affected. It
969 should probably be derived from the original schema_class used during L</load>.
974 my ($self, $schema) = @_;
976 $self->{schema} = $schema;
977 $self->_relbuilder->{schema} = $schema;
980 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
982 foreach my $table (@current) {
983 if(!exists $self->{_tables}->{$table}) {
984 push(@created, $table);
989 @current{@current} = ();
990 foreach my $table (keys %{ $self->{_tables} }) {
991 if (not exists $current{$table}) {
992 $self->_unregister_source_for_table($table);
996 delete $self->{_dump_storage};
997 delete $self->{_relations_started};
999 my $loaded = $self->_load_tables(@current);
1001 return map { $self->monikers->{$_} } @created;
1007 return if $self->{skip_relationships};
1009 return $self->{relbuilder} ||= do {
1011 no warnings 'uninitialized';
1012 my $relbuilder_suff =
1018 ->{ $self->naming->{relationships}};
1020 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1021 load_class $relbuilder_class;
1022 $relbuilder_class->new( $self );
1028 my ($self, @tables) = @_;
1030 # Save the new tables to the tables list
1032 $self->{_tables}->{$_} = 1;
1035 $self->_make_src_class($_) for @tables;
1037 # sanity-check for moniker clashes
1038 my $inverse_moniker_idx;
1039 for (keys %{$self->monikers}) {
1040 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1044 for (keys %$inverse_moniker_idx) {
1045 my $tables = $inverse_moniker_idx->{$_};
1047 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1048 join (', ', map { "'$_'" } @$tables),
1055 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1056 . 'Either change the naming style, or supply an explicit moniker_map: '
1057 . join ('; ', @clashes)
1063 $self->_setup_src_meta($_) for @tables;
1065 if(!$self->skip_relationships) {
1066 # The relationship loader needs a working schema
1068 local $self->{dump_directory} = $self->{temp_directory};
1069 $self->_reload_classes(\@tables);
1070 $self->_load_relationships($_) for @tables;
1071 $self->_relbuilder->cleanup;
1074 # Remove that temp dir from INC so it doesn't get reloaded
1075 @INC = grep $_ ne $self->dump_directory, @INC;
1078 $self->_load_external($_)
1079 for map { $self->classes->{$_} } @tables;
1081 # Reload without unloading first to preserve any symbols from external
1083 $self->_reload_classes(\@tables, { unload => 0 });
1085 # Drop temporary cache
1086 delete $self->{_cache};
1091 sub _reload_classes {
1092 my ($self, $tables, $opts) = @_;
1094 my @tables = @$tables;
1096 my $unload = $opts->{unload};
1097 $unload = 1 unless defined $unload;
1099 # so that we don't repeat custom sections
1100 @INC = grep $_ ne $self->dump_directory, @INC;
1102 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1104 unshift @INC, $self->dump_directory;
1107 my %have_source = map { $_ => $self->schema->source($_) }
1108 $self->schema->sources;
1110 for my $table (@tables) {
1111 my $moniker = $self->monikers->{$table};
1112 my $class = $self->classes->{$table};
1115 no warnings 'redefine';
1116 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1119 if (my $mc = $self->_moose_metaclass($class)) {
1122 Class::Unload->unload($class) if $unload;
1123 my ($source, $resultset_class);
1125 ($source = $have_source{$moniker})
1126 && ($resultset_class = $source->resultset_class)
1127 && ($resultset_class ne 'DBIx::Class::ResultSet')
1129 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1130 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1133 Class::Unload->unload($resultset_class) if $unload;
1134 $self->_reload_class($resultset_class) if $has_file;
1136 $self->_reload_class($class);
1138 push @to_register, [$moniker, $class];
1141 Class::C3->reinitialize;
1142 for (@to_register) {
1143 $self->schema->register_class(@$_);
1147 sub _moose_metaclass {
1148 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1152 my $mc = try { Class::MOP::class_of($class) }
1155 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1158 # We use this instead of ensure_class_loaded when there are package symbols we
1161 my ($self, $class) = @_;
1163 my $class_path = $self->_class_path($class);
1164 delete $INC{ $class_path };
1166 # kill redefined warnings
1168 eval_without_redefine_warnings ("require $class");
1171 my $source = slurp $self->_get_dump_filename($class);
1172 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1176 sub _get_dump_filename {
1177 my ($self, $class) = (@_);
1179 $class =~ s{::}{/}g;
1180 return $self->dump_directory . q{/} . $class . q{.pm};
1183 =head2 get_dump_filename
1187 Returns the full path to the file for a class that the class has been or will
1188 be dumped to. This is a file in a temp dir for a dynamic schema.
1192 sub get_dump_filename {
1193 my ($self, $class) = (@_);
1195 local $self->{dump_directory} = $self->real_dump_directory;
1197 return $self->_get_dump_filename($class);
1200 sub _ensure_dump_subdirs {
1201 my ($self, $class) = (@_);
1203 my @name_parts = split(/::/, $class);
1204 pop @name_parts; # we don't care about the very last element,
1205 # which is a filename
1207 my $dir = $self->dump_directory;
1210 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1212 last if !@name_parts;
1213 $dir = File::Spec->catdir($dir, shift @name_parts);
1218 my ($self, @classes) = @_;
1220 my $schema_class = $self->schema_class;
1221 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1223 my $target_dir = $self->dump_directory;
1224 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1225 unless $self->{dynamic} or $self->{quiet};
1228 qq|package $schema_class;\n\n|
1229 . qq|# Created by DBIx::Class::Schema::Loader\n|
1230 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1232 if ($self->use_moose) {
1233 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1236 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1239 if ($self->use_namespaces) {
1240 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1241 my $namespace_options;
1243 my @attr = qw/resultset_namespace default_resultset_class/;
1245 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1247 for my $attr (@attr) {
1249 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1252 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1253 $schema_text .= qq|;\n|;
1256 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1260 local $self->{version_to_dump} = $self->schema_version_to_dump;
1261 $self->_write_classfile($schema_class, $schema_text, 1);
1264 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1266 foreach my $src_class (@classes) {
1268 qq|package $src_class;\n\n|
1269 . qq|# Created by DBIx::Class::Schema::Loader\n|
1270 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1271 . qq|use strict;\nuse warnings;\n\n|;
1272 if ($self->use_moose) {
1273 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1275 # these options 'use base' which is compile time
1276 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1277 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1280 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1284 $src_text .= qq|use base '$result_base_class';\n\n|;
1286 $self->_write_classfile($src_class, $src_text);
1289 # remove Result dir if downgrading from use_namespaces, and there are no
1291 if (my $result_ns = $self->_downgrading_to_load_classes
1292 || $self->_rewriting_result_namespace) {
1293 my $result_namespace = $self->_result_namespace(
1298 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1299 $result_dir = $self->dump_directory . '/' . $result_dir;
1301 unless (my @files = glob "$result_dir/*") {
1306 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1311 my ($self, $version, $ts) = @_;
1312 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1315 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1318 sub _write_classfile {
1319 my ($self, $class, $text, $is_schema) = @_;
1321 my $filename = $self->_get_dump_filename($class);
1322 $self->_ensure_dump_subdirs($class);
1324 if (-f $filename && $self->really_erase_my_files) {
1325 warn "Deleting existing file '$filename' due to "
1326 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1330 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1331 = $self->_parse_generated_file($filename);
1333 if (! $old_gen && -f $filename) {
1334 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1335 . " it does not appear to have been generated by Loader"
1338 my $custom_content = $old_custom || '';
1340 # prepend extra custom content from a *renamed* class (singularization effect)
1341 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1342 my $old_filename = $self->_get_dump_filename($renamed_class);
1344 if (-f $old_filename) {
1345 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1347 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1349 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1352 unlink $old_filename;
1356 $custom_content ||= $self->_default_custom_content($is_schema);
1358 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1359 # If there is already custom content, which does not have the Moose content, add it.
1360 if ($self->use_moose) {
1362 my $non_moose_custom_content = do {
1363 local $self->{use_moose} = 0;
1364 $self->_default_custom_content;
1367 if ($custom_content eq $non_moose_custom_content) {
1368 $custom_content = $self->_default_custom_content($is_schema);
1370 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1371 $custom_content .= $self->_default_custom_content($is_schema);
1374 elsif (defined $self->use_moose && $old_gen) {
1375 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'
1376 if $old_gen =~ /use \s+ MooseX?\b/x;
1379 $custom_content = $self->_rewrite_old_classnames($custom_content);
1382 for @{$self->{_dump_storage}->{$class} || []};
1384 # Check and see if the dump is infact differnt
1388 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1389 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1390 return unless $self->_upgrading_from && $is_schema;
1394 $text .= $self->_sig_comment(
1395 $self->version_to_dump,
1396 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1399 open(my $fh, '>', $filename)
1400 or croak "Cannot open '$filename' for writing: $!";
1402 # Write the top half and its MD5 sum
1403 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1405 # Write out anything loaded via external partial class file in @INC
1407 for @{$self->{_ext_storage}->{$class} || []};
1409 # Write out any custom content the user has added
1410 print $fh $custom_content;
1413 or croak "Error closing '$filename': $!";
1416 sub _default_moose_custom_content {
1417 my ($self, $is_schema) = @_;
1419 if (not $is_schema) {
1420 return qq|\n__PACKAGE__->meta->make_immutable;|;
1423 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1426 sub _default_custom_content {
1427 my ($self, $is_schema) = @_;
1428 my $default = qq|\n\n# You can replace this text with custom|
1429 . qq| code or comments, and it will be preserved on regeneration|;
1430 if ($self->use_moose) {
1431 $default .= $self->_default_moose_custom_content($is_schema);
1433 $default .= qq|\n1;\n|;
1437 sub _parse_generated_file {
1438 my ($self, $fn) = @_;
1440 return unless -f $fn;
1442 open(my $fh, '<', $fn)
1443 or croak "Cannot open '$fn' for reading: $!";
1446 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1448 my ($md5, $ts, $ver, $gen);
1454 # Pull out the version and timestamp from the line above
1455 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1458 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"
1459 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1468 my $custom = do { local $/; <$fh> }
1473 return ($gen, $md5, $ver, $ts, $custom);
1481 warn "$target: use $_;" if $self->debug;
1482 $self->_raw_stmt($target, "use $_;");
1490 my $blist = join(q{ }, @_);
1492 return unless $blist;
1494 warn "$target: use base qw/$blist/;" if $self->debug;
1495 $self->_raw_stmt($target, "use base qw/$blist/;");
1498 sub _result_namespace {
1499 my ($self, $schema_class, $ns) = @_;
1500 my @result_namespace;
1502 if ($ns =~ /^\+(.*)/) {
1503 # Fully qualified namespace
1504 @result_namespace = ($1)
1507 # Relative namespace
1508 @result_namespace = ($schema_class, $ns);
1511 return wantarray ? @result_namespace : join '::', @result_namespace;
1514 # Create class with applicable bases, setup monikers, etc
1515 sub _make_src_class {
1516 my ($self, $table) = @_;
1518 my $schema = $self->schema;
1519 my $schema_class = $self->schema_class;
1521 my $table_moniker = $self->_table2moniker($table);
1522 my @result_namespace = ($schema_class);
1523 if ($self->use_namespaces) {
1524 my $result_namespace = $self->result_namespace || 'Result';
1525 @result_namespace = $self->_result_namespace(
1530 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1532 if ((my $upgrading_v = $self->_upgrading_from)
1533 || $self->_rewriting) {
1534 local $self->naming->{monikers} = $upgrading_v
1537 my @result_namespace = @result_namespace;
1538 if ($self->_upgrading_from_load_classes) {
1539 @result_namespace = ($schema_class);
1541 elsif (my $ns = $self->_downgrading_to_load_classes) {
1542 @result_namespace = $self->_result_namespace(
1547 elsif ($ns = $self->_rewriting_result_namespace) {
1548 @result_namespace = $self->_result_namespace(
1554 my $old_class = join(q{::}, @result_namespace,
1555 $self->_table2moniker($table));
1557 $self->_upgrading_classes->{$table_class} = $old_class
1558 unless $table_class eq $old_class;
1561 # this was a bad idea, should be ok now without it
1562 # my $table_normalized = lc $table;
1563 # $self->classes->{$table_normalized} = $table_class;
1564 # $self->monikers->{$table_normalized} = $table_moniker;
1566 $self->classes->{$table} = $table_class;
1567 $self->monikers->{$table} = $table_moniker;
1569 $self->_use ($table_class, @{$self->additional_classes});
1570 $self->_inject($table_class, @{$self->left_base_classes});
1572 if (my @components = @{ $self->components }) {
1573 $self->_dbic_stmt($table_class, 'load_components', @components);
1576 $self->_inject($table_class, @{$self->additional_base_classes});
1582 sub _is_result_class_method {
1583 my ($self, $name) = @_;
1585 %result_methods || do {
1587 my $base = $self->result_base_class || 'DBIx::Class::Core';
1588 my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
1590 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1593 push @methods, @{ Class::Inspector->methods($class) || [] };
1596 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1598 @result_methods{@methods} = ();
1601 $result_methods{meta} = undef;
1604 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: