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 DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
21 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
24 use Encode qw/encode/;
25 use List::MoreUtils 'all';
28 our $VERSION = '0.07010';
30 __PACKAGE__->mk_group_ro_accessors('simple', qw/
37 additional_base_classes
53 default_resultset_class
58 overwrite_modifications
85 __PACKAGE__->mk_group_accessors('simple', qw/
87 schema_version_to_dump
89 _upgrading_from_load_classes
90 _downgrading_to_load_classes
91 _rewriting_result_namespace
96 pod_comment_spillover_length
102 result_components_map
104 datetime_undef_if_invalid
105 _result_class_methods
109 my $CURRENT_V = 'v7';
112 schema_components schema_base_class result_base_class
113 additional_base_classes left_base_classes additional_classes components
118 my $CRLF = "\x0d\x0a";
122 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
126 See L<DBIx::Class::Schema::Loader>
130 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
131 classes, and implements the common functionality between them.
133 =head1 CONSTRUCTOR OPTIONS
135 These constructor options are the base options for
136 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
138 =head2 skip_relationships
140 Skip setting up relationships. The default is to attempt the loading
143 =head2 skip_load_external
145 Skip loading of other classes in @INC. The default is to merge all other classes
146 with the same name found in @INC into the schema file we are creating.
150 Static schemas (ones dumped to disk) will, by default, use the new-style
151 relationship names and singularized Results, unless you're overwriting an
152 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
153 which case the backward compatible RelBuilder will be activated, and the
154 appropriate monikerization used.
160 will disable the backward-compatible RelBuilder and use
161 the new-style relationship names along with singularized Results, even when
162 overwriting a dump made with an earlier version.
164 The option also takes a hashref:
166 naming => { relationships => 'v7', monikers => 'v7' }
174 How to name relationship accessors.
178 How to name Result classes.
180 =item column_accessors
182 How to name column accessors in Result classes.
192 Latest style, whatever that happens to be.
196 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
200 Monikers singularized as whole words, C<might_have> relationships for FKs on
201 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
203 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
208 All monikers and relationships are inflected using
209 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
210 from relationship names.
212 In general, there is very little difference between v5 and v6 schemas.
216 This mode is identical to C<v6> mode, except that monikerization of CamelCase
217 table names is also done correctly.
219 CamelCase column names in case-preserving mode will also be handled correctly
220 for relationship name inflection. See L</preserve_case>.
222 In this mode, CamelCase L</column_accessors> are normalized based on case
223 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
225 If you don't have any CamelCase table or column names, you can upgrade without
226 breaking any of your code.
230 For L</monikers>, this option does not inflect the table names but makes
231 monikers based on the actual name. For L</column_accessors> this option does
232 not normalize CamelCase column names to lowercase column accessors, but makes
233 accessors that are the same names as the columns (with any non-\w chars
234 replaced with underscores.)
238 For L</monikers>, singularizes the names using the most current inflector. This
239 is the same as setting the option to L</current>.
243 For L</monikers>, pluralizes the names, using the most current inflector.
247 Dynamic schemas will always default to the 0.04XXX relationship names and won't
248 singularize Results for backward compatibility, to activate the new RelBuilder
249 and singularization put this in your C<Schema.pm> file:
251 __PACKAGE__->naming('current');
253 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
254 next major version upgrade:
256 __PACKAGE__->naming('v7');
260 If true, will not print the usual C<Dumping manual schema ... Schema dump
261 completed.> messages. Does not affect warnings (except for warnings related to
262 L</really_erase_my_files>.)
266 By default POD will be generated for columns and relationships, using database
267 metadata for the text if available and supported.
269 Comment metadata can be stored in two ways.
271 The first is that you can create two tables named C<table_comments> and
272 C<column_comments> respectively. They both need to have columns named
273 C<table_name> and C<comment_text>. The second one needs to have a column
274 named C<column_name>. Then data stored in these tables will be used as a
275 source of metadata about tables and comments.
277 (If you wish you can change the name of these tables with the parameters
278 L</table_comments_table> and L</column_comments_table>.)
280 As a fallback you can use built-in commenting mechanisms. Currently this is
281 only supported for PostgreSQL, Oracle and MySQL. To create comments in
282 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
283 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
284 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
285 restricts the length of comments, and also does not handle complex Unicode
288 Set this to C<0> to turn off all POD generation.
290 =head2 pod_comment_mode
292 Controls where table comments appear in the generated POD. Smaller table
293 comments are appended to the C<NAME> section of the documentation, and larger
294 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
295 section to be generated with the comment always, only use C<NAME>, or choose
296 the length threshold at which the comment is forced into the description.
302 Use C<NAME> section only.
306 Force C<DESCRIPTION> always.
310 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
315 =head2 pod_comment_spillover_length
317 When pod_comment_mode is set to C<auto>, this is the length of the comment at
318 which it will be forced into a separate description section.
322 =head2 table_comments_table
324 The table to look for comments about tables in. By default C<table_comments>.
325 See L</generate_pod> for details.
327 =head2 column_comments_table
329 The table to look for comments about columns in. By default C<column_comments>.
330 See L</generate_pod> for details.
332 =head2 relationship_attrs
334 Hashref of attributes to pass to each generated relationship, listed
335 by type. Also supports relationship type 'all', containing options to
336 pass to all generated relationships. Attributes set for more specific
337 relationship types override those set in 'all'.
341 relationship_attrs => {
342 belongs_to => { is_deferrable => 0 },
345 use this to turn off DEFERRABLE on your foreign key constraints.
349 If set to true, each constructive L<DBIx::Class> statement the loader
350 decides to execute will be C<warn>-ed before execution.
354 Set the name of the schema to load (schema in the sense that your database
355 vendor means it). Does not currently support loading more than one schema
360 Only load tables matching regex. Best specified as a qr// regex.
364 Exclude tables matching regex. Best specified as a qr// regex.
368 Overrides the default table name to moniker translation. Can be either
369 a hashref of table keys and moniker values, or a coderef for a translator
370 function taking a single scalar table name argument and returning
371 a scalar moniker. If the hash entry does not exist, or the function
372 returns a false value, the code falls back to default behavior
375 The default behavior is to split on case transition and non-alphanumeric
376 boundaries, singularize the resulting phrase, then join the titlecased words
379 Table Name | Moniker Name
380 ---------------------------------
382 luser_group | LuserGroup
383 luser-opts | LuserOpt
384 stations_visited | StationVisited
385 routeChange | RouteChange
387 =head2 col_accessor_map
389 Same as moniker_map, but for column accessor names. If a coderef is
390 passed, the code is called with arguments of
392 the name of the column in the underlying database,
393 default accessor name that DBICSL would ordinarily give this column,
395 table_class => name of the DBIC class we are building,
396 table_moniker => calculated moniker for this table (after moniker_map if present),
397 table_name => name of the database table,
398 full_table_name => schema-qualified name of the database table (RDBMS specific),
399 schema_class => name of the schema class we are building,
400 column_info => hashref of column info (data_type, is_nullable, etc),
405 Similar in idea to moniker_map, but different in the details. It can be
406 a hashref or a code ref.
408 If it is a hashref, keys can be either the default relationship name, or the
409 moniker. The keys that are the default relationship name should map to the
410 name you want to change the relationship to. Keys that are monikers should map
411 to hashes mapping relationship names to their translation. You can do both at
412 once, and the more specific moniker version will be picked up first. So, for
413 instance, you could have
422 and relationships that would have been named C<bar> will now be named C<baz>
423 except that in the table whose moniker is C<Foo> it will be named C<blat>.
425 If it is a coderef, the argument passed will be a hashref of this form:
428 name => default relationship name,
429 type => the relationship type eg: C<has_many>,
430 local_class => name of the DBIC class we are building,
431 local_moniker => moniker of the DBIC class we are building,
432 local_columns => columns in this table in the relationship,
433 remote_class => name of the DBIC class we are related to,
434 remote_moniker => moniker of the DBIC class we are related to,
435 remote_columns => columns in the other table in the relationship,
438 DBICSL will try to use the value returned as the relationship name.
440 =head2 inflect_plural
442 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
443 if hash key does not exist or coderef returns false), but acts as a map
444 for pluralizing relationship names. The default behavior is to utilize
445 L<Lingua::EN::Inflect::Phrase/to_PL>.
447 =head2 inflect_singular
449 As L</inflect_plural> above, but for singularizing relationship names.
450 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
452 =head2 schema_base_class
454 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
456 =head2 result_base_class
458 Base class for your table classes (aka result classes). Defaults to
461 =head2 additional_base_classes
463 List of additional base classes all of your table classes will use.
465 =head2 left_base_classes
467 List of additional base classes all of your table classes will use
468 that need to be leftmost.
470 =head2 additional_classes
472 List of additional classes which all of your table classes will use.
474 =head2 schema_components
476 List of components to load into the Schema class.
480 List of additional components to be loaded into all of your Result
481 classes. A good example would be
482 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
484 =head2 result_components_map
486 A hashref of moniker keys and component values. Unlike L</components>, which
487 loads the given components into every Result class, this option allows you to
488 load certain components for specified Result classes. For example:
490 result_components_map => {
491 StationVisited => '+YourApp::Schema::Component::StationVisited',
493 '+YourApp::Schema::Component::RouteChange',
494 'InflateColumn::DateTime',
498 You may use this in conjunction with L</components>.
502 List of L<Moose> roles to be applied to all of your Result classes.
504 =head2 result_roles_map
506 A hashref of moniker keys and role values. Unlike L</result_roles>, which
507 applies the given roles to every Result class, this option allows you to apply
508 certain roles for specified Result classes. For example:
510 result_roles_map => {
512 'YourApp::Role::Building',
513 'YourApp::Role::Destination',
515 RouteChange => 'YourApp::Role::TripEvent',
518 You may use this in conjunction with L</result_roles>.
520 =head2 use_namespaces
522 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
525 Generate result class names suitable for
526 L<DBIx::Class::Schema/load_namespaces> and call that instead of
527 L<DBIx::Class::Schema/load_classes>. When using this option you can also
528 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
529 C<resultset_namespace>, C<default_resultset_class>), and they will be added
530 to the call (and the generated result class names adjusted appropriately).
532 =head2 dump_directory
534 The value of this option is a perl libdir pathname. Within
535 that directory this module will create a baseline manual
536 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
538 The created schema class will have the same classname as the one on
539 which you are setting this option (and the ResultSource classes will be
540 based on this name as well).
542 Normally you wouldn't hard-code this setting in your schema class, as it
543 is meant for one-time manual usage.
545 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
546 recommended way to access this functionality.
548 =head2 dump_overwrite
550 Deprecated. See L</really_erase_my_files> below, which does *not* mean
551 the same thing as the old C<dump_overwrite> setting from previous releases.
553 =head2 really_erase_my_files
555 Default false. If true, Loader will unconditionally delete any existing
556 files before creating the new ones from scratch when dumping a schema to disk.
558 The default behavior is instead to only replace the top portion of the
559 file, up to and including the final stanza which contains
560 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
561 leaving any customizations you placed after that as they were.
563 When C<really_erase_my_files> is not set, if the output file already exists,
564 but the aforementioned final stanza is not found, or the checksum
565 contained there does not match the generated contents, Loader will
566 croak and not touch the file.
568 You should really be using version control on your schema classes (and all
569 of the rest of your code for that matter). Don't blame me if a bug in this
570 code wipes something out when it shouldn't have, you've been warned.
572 =head2 overwrite_modifications
574 Default false. If false, when updating existing files, Loader will
575 refuse to modify any Loader-generated code that has been modified
576 since its last run (as determined by the checksum Loader put in its
579 If true, Loader will discard any manual modifications that have been
580 made to Loader-generated code.
582 Again, you should be using version control on your schema classes. Be
583 careful with this option.
585 =head2 custom_column_info
587 Hook for adding extra attributes to the
588 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
590 Must be a coderef that returns a hashref with the extra attributes.
592 Receives the table name, column name and column_info.
596 custom_column_info => sub {
597 my ($table_name, $column_name, $column_info) = @_;
599 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
600 return { is_snoopy => 1 };
604 This attribute can also be used to set C<inflate_datetime> on a non-datetime
605 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
607 =head2 datetime_timezone
609 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
610 columns with the DATE/DATETIME/TIMESTAMP data_types.
612 =head2 datetime_locale
614 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
615 columns with the DATE/DATETIME/TIMESTAMP data_types.
617 =head2 datetime_undef_if_invalid
619 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
620 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
623 The default is recommended to deal with data such as C<00/00/00> which
624 sometimes ends up in such columns in MySQL.
628 File in Perl format, which should return a HASH reference, from which to read
633 Usually column names are lowercased, to make them easier to work with in
634 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
637 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
638 case-sensitive collation will turn this option on unconditionally.
640 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
643 =head2 qualify_objects
645 Set to true to prepend the L</db_schema> to table names for C<<
646 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
650 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
651 L<namespace::autoclean>. The default content after the md5 sum also makes the
654 It is safe to upgrade your existing Schema to this option.
656 =head2 col_collision_map
658 This option controls how accessors for column names which collide with perl
659 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
661 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
662 strings which are compiled to regular expressions that map to
663 L<sprintf|perlfunc/sprintf> formats.
667 col_collision_map => 'column_%s'
669 col_collision_map => { '(.*)' => 'column_%s' }
671 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
673 =head2 rel_collision_map
675 Works just like L</col_collision_map>, but for relationship names/accessors
676 rather than column names/accessors.
678 The default is to just append C<_rel> to the relationship name, see
679 L</RELATIONSHIP NAME COLLISIONS>.
681 =head2 uniq_to_primary
683 Automatically promotes the largest unique constraints with non-nullable columns
684 on tables to primary keys, assuming there is only one largest unique
687 =head2 filter_generated_text
689 An optional hook that lets you filter the generated text for various classes through
690 a function that change it in any way that you want. The function will receive the class
691 and text, and returns the new text to use instead. For instance you could add
692 custom comment, run C<perltidy>, or do anything else that you want.
694 If this exists but fails to return text matching C</package/>, no file will be generated.
696 filter_generated_base => sub {
697 my ($class, $text) = @_;
704 None of these methods are intended for direct invocation by regular
705 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
706 L<DBIx::Class::Schema::Loader>.
710 # ensure that a peice of object data is a valid arrayref, creating
711 # an empty one or encapsulating whatever's there.
712 sub _ensure_arrayref {
717 $self->{$_} = [ $self->{$_} ]
718 unless ref $self->{$_} eq 'ARRAY';
724 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
725 by L<DBIx::Class::Schema::Loader>.
730 my ( $class, %args ) = @_;
732 if (exists $args{column_accessor_map}) {
733 $args{col_accessor_map} = delete $args{column_accessor_map};
736 my $self = { %args };
738 # don't lose undef options
739 for (values %$self) {
740 $_ = 0 unless defined $_;
743 bless $self => $class;
745 if (my $config_file = $self->config_file) {
746 my $config_opts = do $config_file;
748 croak "Error reading config from $config_file: $@" if $@;
750 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
752 while (my ($k, $v) = each %$config_opts) {
753 $self->{$k} = $v unless exists $self->{$k};
757 if (defined $self->{result_component_map}) {
758 if (defined $self->result_components_map) {
759 croak "Specify only one of result_components_map or result_component_map";
761 $self->result_components_map($self->{result_component_map})
764 if (defined $self->{result_role_map}) {
765 if (defined $self->result_roles_map) {
766 croak "Specify only one of result_roles_map or result_role_map";
768 $self->result_roles_map($self->{result_role_map})
771 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
772 if ((not defined $self->use_moose) || (not $self->use_moose))
773 && ((defined $self->result_roles) || (defined $self->result_roles_map));
775 $self->_ensure_arrayref(qw/schema_components
777 additional_base_classes
783 $self->_validate_class_args;
785 croak "result_components_map must be a hash"
786 if defined $self->result_components_map
787 && ref $self->result_components_map ne 'HASH';
789 if ($self->result_components_map) {
790 my %rc_map = %{ $self->result_components_map };
791 foreach my $moniker (keys %rc_map) {
792 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
794 $self->result_components_map(\%rc_map);
797 $self->result_components_map({});
799 $self->_validate_result_components_map;
801 croak "result_roles_map must be a hash"
802 if defined $self->result_roles_map
803 && ref $self->result_roles_map ne 'HASH';
805 if ($self->result_roles_map) {
806 my %rr_map = %{ $self->result_roles_map };
807 foreach my $moniker (keys %rr_map) {
808 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
810 $self->result_roles_map(\%rr_map);
812 $self->result_roles_map({});
814 $self->_validate_result_roles_map;
816 if ($self->use_moose) {
817 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
818 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
819 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
823 $self->{monikers} = {};
824 $self->{tables} = {};
825 $self->{class_to_table} = {};
826 $self->{classes} = {};
827 $self->{_upgrading_classes} = {};
829 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
830 $self->{schema} ||= $self->{schema_class};
831 $self->{table_comments_table} ||= 'table_comments';
832 $self->{column_comments_table} ||= 'column_comments';
834 croak "dump_overwrite is deprecated. Please read the"
835 . " DBIx::Class::Schema::Loader::Base documentation"
836 if $self->{dump_overwrite};
838 $self->{dynamic} = ! $self->{dump_directory};
839 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
844 $self->{dump_directory} ||= $self->{temp_directory};
846 $self->real_dump_directory($self->{dump_directory});
848 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
849 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
851 if (not defined $self->naming) {
852 $self->naming_set(0);
855 $self->naming_set(1);
858 if ((not ref $self->naming) && defined $self->naming) {
859 my $naming_ver = $self->naming;
861 relationships => $naming_ver,
862 monikers => $naming_ver,
863 column_accessors => $naming_ver,
868 for (values %{ $self->naming }) {
869 $_ = $CURRENT_V if $_ eq 'current';
872 $self->{naming} ||= {};
874 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
875 croak 'custom_column_info must be a CODE ref';
878 $self->_check_back_compat;
880 $self->use_namespaces(1) unless defined $self->use_namespaces;
881 $self->generate_pod(1) unless defined $self->generate_pod;
882 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
883 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
885 if (my $col_collision_map = $self->col_collision_map) {
886 if (my $reftype = ref $col_collision_map) {
887 if ($reftype ne 'HASH') {
888 croak "Invalid type $reftype for option 'col_collision_map'";
892 $self->col_collision_map({ '(.*)' => $col_collision_map });
896 if (my $rel_collision_map = $self->rel_collision_map) {
897 if (my $reftype = ref $rel_collision_map) {
898 if ($reftype ne 'HASH') {
899 croak "Invalid type $reftype for option 'rel_collision_map'";
903 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
907 if (defined(my $rel_name_map = $self->rel_name_map)) {
908 my $reftype = ref $rel_name_map;
909 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
910 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
917 sub _check_back_compat {
920 # dynamic schemas will always be in 0.04006 mode, unless overridden
921 if ($self->dynamic) {
922 # just in case, though no one is likely to dump a dynamic schema
923 $self->schema_version_to_dump('0.04006');
925 if (not $self->naming_set) {
926 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
928 Dynamic schema detected, will run in 0.04006 mode.
930 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
931 to disable this warning.
933 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
938 $self->_upgrading_from('v4');
941 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
942 $self->use_namespaces(1);
945 $self->naming->{relationships} ||= 'v4';
946 $self->naming->{monikers} ||= 'v4';
948 if ($self->use_namespaces) {
949 $self->_upgrading_from_load_classes(1);
952 $self->use_namespaces(0);
958 # otherwise check if we need backcompat mode for a static schema
959 my $filename = $self->get_dump_filename($self->schema_class);
960 return unless -e $filename;
962 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
963 $self->_parse_generated_file($filename);
965 return unless $old_ver;
967 # determine if the existing schema was dumped with use_moose => 1
968 if (! defined $self->use_moose) {
969 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
972 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
974 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
975 my $ds = eval $result_namespace;
977 Could not eval expression '$result_namespace' for result_namespace from
980 $result_namespace = $ds || '';
982 if ($load_classes && (not defined $self->use_namespaces)) {
983 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
985 'load_classes;' static schema detected, turning off 'use_namespaces'.
987 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
988 variable to disable this warning.
990 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
993 $self->use_namespaces(0);
995 elsif ($load_classes && $self->use_namespaces) {
996 $self->_upgrading_from_load_classes(1);
998 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
999 $self->_downgrading_to_load_classes(
1000 $result_namespace || 'Result'
1003 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1004 if (not $self->result_namespace) {
1005 $self->result_namespace($result_namespace || 'Result');
1007 elsif ($result_namespace ne $self->result_namespace) {
1008 $self->_rewriting_result_namespace(
1009 $result_namespace || 'Result'
1014 # XXX when we go past .0 this will need fixing
1015 my ($v) = $old_ver =~ /([1-9])/;
1018 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1020 if (not %{ $self->naming }) {
1021 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1023 Version $old_ver static schema detected, turning on backcompat mode.
1025 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1026 to disable this warning.
1028 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1030 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1031 from version 0.04006.
1034 $self->naming->{relationships} ||= $v;
1035 $self->naming->{monikers} ||= $v;
1036 $self->naming->{column_accessors} ||= $v;
1038 $self->schema_version_to_dump($old_ver);
1041 $self->_upgrading_from($v);
1045 sub _validate_class_args {
1048 foreach my $k (@CLASS_ARGS) {
1049 next unless $self->$k;
1051 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1052 $self->_validate_classes($k, \@classes);
1056 sub _validate_result_components_map {
1059 foreach my $classes (values %{ $self->result_components_map }) {
1060 $self->_validate_classes('result_components_map', $classes);
1064 sub _validate_result_roles_map {
1067 foreach my $classes (values %{ $self->result_roles_map }) {
1068 $self->_validate_classes('result_roles_map', $classes);
1072 sub _validate_classes {
1075 my $classes = shift;
1077 # make a copy to not destroy original
1078 my @classes = @$classes;
1080 foreach my $c (@classes) {
1081 # components default to being under the DBIx::Class namespace unless they
1082 # are preceeded with a '+'
1083 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1084 $c = 'DBIx::Class::' . $c;
1087 # 1 == installed, 0 == not installed, undef == invalid classname
1088 my $installed = Class::Inspector->installed($c);
1089 if ( defined($installed) ) {
1090 if ( $installed == 0 ) {
1091 croak qq/$c, as specified in the loader option "$key", is not installed/;
1094 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1100 sub _find_file_in_inc {
1101 my ($self, $file) = @_;
1103 foreach my $prefix (@INC) {
1104 my $fullpath = File::Spec->catfile($prefix, $file);
1105 return $fullpath if -f $fullpath
1106 # abs_path throws on Windows for nonexistant files
1107 and (try { Cwd::abs_path($fullpath) }) ne
1108 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1114 sub _find_class_in_inc {
1115 my ($self, $class) = @_;
1117 return $self->_find_file_in_inc(class_path($class));
1123 return $self->_upgrading_from
1124 || $self->_upgrading_from_load_classes
1125 || $self->_downgrading_to_load_classes
1126 || $self->_rewriting_result_namespace
1130 sub _rewrite_old_classnames {
1131 my ($self, $code) = @_;
1133 return $code unless $self->_rewriting;
1135 my %old_classes = reverse %{ $self->_upgrading_classes };
1137 my $re = join '|', keys %old_classes;
1138 $re = qr/\b($re)\b/;
1140 $code =~ s/$re/$old_classes{$1} || $1/eg;
1145 sub _load_external {
1146 my ($self, $class) = @_;
1148 return if $self->{skip_load_external};
1150 # so that we don't load our own classes, under any circumstances
1151 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1153 my $real_inc_path = $self->_find_class_in_inc($class);
1155 my $old_class = $self->_upgrading_classes->{$class}
1156 if $self->_rewriting;
1158 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1159 if $old_class && $old_class ne $class;
1161 return unless $real_inc_path || $old_real_inc_path;
1163 if ($real_inc_path) {
1164 # If we make it to here, we loaded an external definition
1165 warn qq/# Loaded external class definition for '$class'\n/
1168 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1170 if ($self->dynamic) { # load the class too
1171 eval_package_without_redefine_warnings($class, $code);
1174 $self->_ext_stmt($class,
1175 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1176 .qq|# They are now part of the custom portion of this file\n|
1177 .qq|# for you to hand-edit. If you do not either delete\n|
1178 .qq|# this section or remove that file from \@INC, this section\n|
1179 .qq|# will be repeated redundantly when you re-create this\n|
1180 .qq|# file again via Loader! See skip_load_external to disable\n|
1181 .qq|# this feature.\n|
1184 $self->_ext_stmt($class, $code);
1185 $self->_ext_stmt($class,
1186 qq|# End of lines loaded from '$real_inc_path' |
1190 if ($old_real_inc_path) {
1191 my $code = slurp_file $old_real_inc_path;
1193 $self->_ext_stmt($class, <<"EOF");
1195 # These lines were loaded from '$old_real_inc_path',
1196 # based on the Result class name that would have been created by an older
1197 # version of the Loader. For a static schema, this happens only once during
1198 # upgrade. See skip_load_external to disable this feature.
1201 $code = $self->_rewrite_old_classnames($code);
1203 if ($self->dynamic) {
1206 Detected external content in '$old_real_inc_path', a class name that would have
1207 been used by an older version of the Loader.
1209 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1210 new name of the Result.
1212 eval_package_without_redefine_warnings($class, $code);
1216 $self->_ext_stmt($class, $code);
1217 $self->_ext_stmt($class,
1218 qq|# End of lines loaded from '$old_real_inc_path' |
1225 Does the actual schema-construction work.
1232 $self->_load_tables(
1233 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1241 Rescan the database for changes. Returns a list of the newly added table
1244 The schema argument should be the schema class or object to be affected. It
1245 should probably be derived from the original schema_class used during L</load>.
1250 my ($self, $schema) = @_;
1252 $self->{schema} = $schema;
1253 $self->_relbuilder->{schema} = $schema;
1256 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1258 foreach my $table (@current) {
1259 if(!exists $self->{_tables}->{$table}) {
1260 push(@created, $table);
1265 @current{@current} = ();
1266 foreach my $table (keys %{ $self->{_tables} }) {
1267 if (not exists $current{$table}) {
1268 $self->_unregister_source_for_table($table);
1272 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1274 my $loaded = $self->_load_tables(@current);
1276 return map { $self->monikers->{$_} } @created;
1282 return if $self->{skip_relationships};
1284 return $self->{relbuilder} ||= do {
1286 no warnings 'uninitialized';
1287 my $relbuilder_suff =
1293 ->{ $self->naming->{relationships}};
1295 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1296 $self->ensure_class_loaded($relbuilder_class);
1297 $relbuilder_class->new( $self );
1303 my ($self, @tables) = @_;
1305 # Save the new tables to the tables list
1307 $self->{_tables}->{$_} = 1;
1310 $self->_make_src_class($_) for @tables;
1312 # sanity-check for moniker clashes
1313 my $inverse_moniker_idx;
1314 for (keys %{$self->monikers}) {
1315 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1319 for (keys %$inverse_moniker_idx) {
1320 my $tables = $inverse_moniker_idx->{$_};
1322 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1323 join (', ', map { "'$_'" } @$tables),
1330 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1331 . 'Either change the naming style, or supply an explicit moniker_map: '
1332 . join ('; ', @clashes)
1338 $self->_setup_src_meta($_) for @tables;
1340 if(!$self->skip_relationships) {
1341 # The relationship loader needs a working schema
1342 local $self->{quiet} = 1;
1343 local $self->{dump_directory} = $self->{temp_directory};
1344 $self->_reload_classes(\@tables);
1345 $self->_load_relationships(\@tables);
1347 # Remove that temp dir from INC so it doesn't get reloaded
1348 @INC = grep $_ ne $self->dump_directory, @INC;
1351 $self->_load_roles($_) for @tables;
1353 $self->_load_external($_)
1354 for map { $self->classes->{$_} } @tables;
1356 # Reload without unloading first to preserve any symbols from external
1358 $self->_reload_classes(\@tables, { unload => 0 });
1360 # Drop temporary cache
1361 delete $self->{_cache};
1366 sub _reload_classes {
1367 my ($self, $tables, $opts) = @_;
1369 my @tables = @$tables;
1371 my $unload = $opts->{unload};
1372 $unload = 1 unless defined $unload;
1374 # so that we don't repeat custom sections
1375 @INC = grep $_ ne $self->dump_directory, @INC;
1377 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1379 unshift @INC, $self->dump_directory;
1382 my %have_source = map { $_ => $self->schema->source($_) }
1383 $self->schema->sources;
1385 for my $table (@tables) {
1386 my $moniker = $self->monikers->{$table};
1387 my $class = $self->classes->{$table};
1390 no warnings 'redefine';
1391 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1394 if (my $mc = $self->_moose_metaclass($class)) {
1397 Class::Unload->unload($class) if $unload;
1398 my ($source, $resultset_class);
1400 ($source = $have_source{$moniker})
1401 && ($resultset_class = $source->resultset_class)
1402 && ($resultset_class ne 'DBIx::Class::ResultSet')
1404 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1405 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1408 Class::Unload->unload($resultset_class) if $unload;
1409 $self->_reload_class($resultset_class) if $has_file;
1411 $self->_reload_class($class);
1413 push @to_register, [$moniker, $class];
1416 Class::C3->reinitialize;
1417 for (@to_register) {
1418 $self->schema->register_class(@$_);
1422 sub _moose_metaclass {
1423 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1427 my $mc = try { Class::MOP::class_of($class) }
1430 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1433 # We use this instead of ensure_class_loaded when there are package symbols we
1436 my ($self, $class) = @_;
1438 delete $INC{ +class_path($class) };
1441 eval_package_without_redefine_warnings ($class, "require $class");
1444 my $source = slurp_file $self->_get_dump_filename($class);
1445 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1449 sub _get_dump_filename {
1450 my ($self, $class) = (@_);
1452 $class =~ s{::}{/}g;
1453 return $self->dump_directory . q{/} . $class . q{.pm};
1456 =head2 get_dump_filename
1460 Returns the full path to the file for a class that the class has been or will
1461 be dumped to. This is a file in a temp dir for a dynamic schema.
1465 sub get_dump_filename {
1466 my ($self, $class) = (@_);
1468 local $self->{dump_directory} = $self->real_dump_directory;
1470 return $self->_get_dump_filename($class);
1473 sub _ensure_dump_subdirs {
1474 my ($self, $class) = (@_);
1476 my @name_parts = split(/::/, $class);
1477 pop @name_parts; # we don't care about the very last element,
1478 # which is a filename
1480 my $dir = $self->dump_directory;
1483 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1485 last if !@name_parts;
1486 $dir = File::Spec->catdir($dir, shift @name_parts);
1491 my ($self, @classes) = @_;
1493 my $schema_class = $self->schema_class;
1494 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1496 my $target_dir = $self->dump_directory;
1497 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1498 unless $self->dynamic or $self->quiet;
1501 qq|package $schema_class;\n\n|
1502 . qq|# Created by DBIx::Class::Schema::Loader\n|
1503 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1505 if ($self->use_moose) {
1506 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1509 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1512 my @schema_components = @{ $self->schema_components || [] };
1514 if (@schema_components) {
1515 my $schema_components = dump @schema_components;
1516 $schema_components = "($schema_components)" if @schema_components == 1;
1518 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1521 if ($self->use_namespaces) {
1522 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1523 my $namespace_options;
1525 my @attr = qw/resultset_namespace default_resultset_class/;
1527 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1529 for my $attr (@attr) {
1531 my $code = dumper_squashed $self->$attr;
1532 $namespace_options .= qq| $attr => $code,\n|
1535 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1536 $schema_text .= qq|;\n|;
1539 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1543 local $self->{version_to_dump} = $self->schema_version_to_dump;
1544 $self->_write_classfile($schema_class, $schema_text, 1);
1547 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1549 foreach my $src_class (@classes) {
1551 qq|package $src_class;\n\n|
1552 . qq|# Created by DBIx::Class::Schema::Loader\n|
1553 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1555 $src_text .= $self->_make_pod_heading($src_class);
1557 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1559 $src_text .= $self->_base_class_pod($result_base_class)
1560 unless $result_base_class eq 'DBIx::Class::Core';
1562 if ($self->use_moose) {
1563 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1565 # these options 'use base' which is compile time
1566 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1567 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1570 $src_text .= qq|\nextends '$result_base_class';\n|;
1574 $src_text .= qq|use base '$result_base_class';\n|;
1577 $self->_write_classfile($src_class, $src_text);
1580 # remove Result dir if downgrading from use_namespaces, and there are no
1582 if (my $result_ns = $self->_downgrading_to_load_classes
1583 || $self->_rewriting_result_namespace) {
1584 my $result_namespace = $self->_result_namespace(
1589 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1590 $result_dir = $self->dump_directory . '/' . $result_dir;
1592 unless (my @files = glob "$result_dir/*") {
1597 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1602 my ($self, $version, $ts) = @_;
1603 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1606 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1609 sub _write_classfile {
1610 my ($self, $class, $text, $is_schema) = @_;
1612 my $filename = $self->_get_dump_filename($class);
1613 $self->_ensure_dump_subdirs($class);
1615 if (-f $filename && $self->really_erase_my_files) {
1616 warn "Deleting existing file '$filename' due to "
1617 . "'really_erase_my_files' setting\n" unless $self->quiet;
1621 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1622 = $self->_parse_generated_file($filename);
1624 if (! $old_gen && -f $filename) {
1625 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1626 . " it does not appear to have been generated by Loader"
1629 my $custom_content = $old_custom || '';
1631 # prepend extra custom content from a *renamed* class (singularization effect)
1632 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1633 my $old_filename = $self->_get_dump_filename($renamed_class);
1635 if (-f $old_filename) {
1636 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1638 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1640 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1643 unlink $old_filename;
1647 $custom_content ||= $self->_default_custom_content($is_schema);
1649 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1650 # If there is already custom content, which does not have the Moose content, add it.
1651 if ($self->use_moose) {
1653 my $non_moose_custom_content = do {
1654 local $self->{use_moose} = 0;
1655 $self->_default_custom_content;
1658 if ($custom_content eq $non_moose_custom_content) {
1659 $custom_content = $self->_default_custom_content($is_schema);
1661 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1662 $custom_content .= $self->_default_custom_content($is_schema);
1665 elsif (defined $self->use_moose && $old_gen) {
1666 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'
1667 if $old_gen =~ /use \s+ MooseX?\b/x;
1670 $custom_content = $self->_rewrite_old_classnames($custom_content);
1673 for @{$self->{_dump_storage}->{$class} || []};
1675 if ($self->{filter_generated_text}) {
1676 $text = $self->{filter_generated_text}->($class, $text);
1677 if (not $text or not $text =~ /package/) {
1678 warn("$class skipped due to filter") if $self->debug;
1683 # Check and see if the dump is in fact different
1687 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1688 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1689 return unless $self->_upgrading_from && $is_schema;
1693 $text .= $self->_sig_comment(
1694 $self->version_to_dump,
1695 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1698 open(my $fh, '>:encoding(UTF-8)', $filename)
1699 or croak "Cannot open '$filename' for writing: $!";
1701 # Write the top half and its MD5 sum
1702 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1704 # Write out anything loaded via external partial class file in @INC
1706 for @{$self->{_ext_storage}->{$class} || []};
1708 # Write out any custom content the user has added
1709 print $fh $custom_content;
1712 or croak "Error closing '$filename': $!";
1715 sub _default_moose_custom_content {
1716 my ($self, $is_schema) = @_;
1718 if (not $is_schema) {
1719 return qq|\n__PACKAGE__->meta->make_immutable;|;
1722 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1725 sub _default_custom_content {
1726 my ($self, $is_schema) = @_;
1727 my $default = qq|\n\n# You can replace this text with custom|
1728 . qq| code or comments, and it will be preserved on regeneration|;
1729 if ($self->use_moose) {
1730 $default .= $self->_default_moose_custom_content($is_schema);
1732 $default .= qq|\n1;\n|;
1736 sub _parse_generated_file {
1737 my ($self, $fn) = @_;
1739 return unless -f $fn;
1741 open(my $fh, '<:encoding(UTF-8)', $fn)
1742 or croak "Cannot open '$fn' for reading: $!";
1745 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
1747 my ($md5, $ts, $ver, $gen);
1753 # Pull out the version and timestamp from the line above
1754 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
1757 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"
1758 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1767 my $custom = do { local $/; <$fh> }
1771 $custom =~ s/$CRLF|$LF/\n/g;
1775 return ($gen, $md5, $ver, $ts, $custom);
1783 warn "$target: use $_;" if $self->debug;
1784 $self->_raw_stmt($target, "use $_;");
1792 my $blist = join(q{ }, @_);
1794 return unless $blist;
1796 warn "$target: use base qw/$blist/;" if $self->debug;
1797 $self->_raw_stmt($target, "use base qw/$blist/;");
1804 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1806 return unless $rlist;
1808 warn "$target: with $rlist;" if $self->debug;
1809 $self->_raw_stmt($target, "\nwith $rlist;");
1812 sub _result_namespace {
1813 my ($self, $schema_class, $ns) = @_;
1814 my @result_namespace;
1816 $ns = $ns->[0] if ref $ns;
1818 if ($ns =~ /^\+(.*)/) {
1819 # Fully qualified namespace
1820 @result_namespace = ($1)
1823 # Relative namespace
1824 @result_namespace = ($schema_class, $ns);
1827 return wantarray ? @result_namespace : join '::', @result_namespace;
1830 # Create class with applicable bases, setup monikers, etc
1831 sub _make_src_class {
1832 my ($self, $table) = @_;
1834 my $schema = $self->schema;
1835 my $schema_class = $self->schema_class;
1837 my $table_moniker = $self->_table2moniker($table);
1838 my @result_namespace = ($schema_class);
1839 if ($self->use_namespaces) {
1840 my $result_namespace = $self->result_namespace || 'Result';
1841 @result_namespace = $self->_result_namespace(
1846 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1848 if ((my $upgrading_v = $self->_upgrading_from)
1849 || $self->_rewriting) {
1850 local $self->naming->{monikers} = $upgrading_v
1853 my @result_namespace = @result_namespace;
1854 if ($self->_upgrading_from_load_classes) {
1855 @result_namespace = ($schema_class);
1857 elsif (my $ns = $self->_downgrading_to_load_classes) {
1858 @result_namespace = $self->_result_namespace(
1863 elsif ($ns = $self->_rewriting_result_namespace) {
1864 @result_namespace = $self->_result_namespace(
1870 my $old_class = join(q{::}, @result_namespace,
1871 $self->_table2moniker($table));
1873 $self->_upgrading_classes->{$table_class} = $old_class
1874 unless $table_class eq $old_class;
1877 $self->classes->{$table} = $table_class;
1878 $self->monikers->{$table} = $table_moniker;
1879 $self->tables->{$table_moniker} = $table;
1880 $self->class_to_table->{$table_class} = $table;
1882 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1884 $self->_use ($table_class, @{$self->additional_classes});
1886 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1888 $self->_inject($table_class, @{$self->left_base_classes});
1890 my @components = @{ $self->components || [] };
1892 push @components, @{ $self->result_components_map->{$table_moniker} }
1893 if exists $self->result_components_map->{$table_moniker};
1895 my @fq_components = @components;
1896 foreach my $component (@fq_components) {
1897 if ($component !~ s/^\+//) {
1898 $component = "DBIx::Class::$component";
1902 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1904 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1906 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1908 $self->_inject($table_class, @{$self->additional_base_classes});
1911 sub _is_result_class_method {
1912 my ($self, $name, $table_name) = @_;
1914 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1916 $self->_result_class_methods({})
1917 if not defined $self->_result_class_methods;
1919 if (not exists $self->_result_class_methods->{$table_moniker}) {
1920 my (@methods, %methods);
1921 my $base = $self->result_base_class || 'DBIx::Class::Core';
1923 my @components = @{ $self->components || [] };
1925 push @components, @{ $self->result_components_map->{$table_moniker} }
1926 if exists $self->result_components_map->{$table_moniker};
1928 for my $c (@components) {
1929 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1932 my @roles = @{ $self->result_roles || [] };
1934 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1935 if exists $self->result_roles_map->{$table_moniker};
1937 for my $class ($base, @components,
1938 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1939 $self->ensure_class_loaded($class);
1941 push @methods, @{ Class::Inspector->methods($class) || [] };
1944 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1946 @methods{@methods} = ();
1948 $self->_result_class_methods->{$table_moniker} = \%methods;
1950 my $result_methods = $self->_result_class_methods->{$table_moniker};
1952 return exists $result_methods->{$name};
1955 sub _resolve_col_accessor_collisions {
1956 my ($self, $table, $col_info) = @_;
1958 my $table_name = ref $table ? $$table : $table;
1960 while (my ($col, $info) = each %$col_info) {
1961 my $accessor = $info->{accessor} || $col;
1963 next if $accessor eq 'id'; # special case (very common column)
1965 if ($self->_is_result_class_method($accessor, $table_name)) {
1968 if (my $map = $self->col_collision_map) {
1969 for my $re (keys %$map) {
1970 if (my @matches = $col =~ /$re/) {
1971 $info->{accessor} = sprintf $map->{$re}, @matches;
1979 Column '$col' in table '$table_name' collides with an inherited method.
1980 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1982 $info->{accessor} = undef;
1988 # use the same logic to run moniker_map, col_accessor_map
1990 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1992 my $default_ident = $default_code->( $ident, @extra );
1994 if( $map && ref $map eq 'HASH' ) {
1995 $new_ident = $map->{ $ident };
1997 elsif( $map && ref $map eq 'CODE' ) {
1998 $new_ident = $map->( $ident, $default_ident, @extra );
2001 $new_ident ||= $default_ident;
2006 sub _default_column_accessor_name {
2007 my ( $self, $column_name ) = @_;
2009 my $accessor_name = $column_name;
2010 $accessor_name =~ s/\W+/_/g;
2012 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
2013 # older naming just lc'd the col accessor and that's all.
2014 return lc $accessor_name;
2016 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
2017 return $accessor_name;
2020 return join '_', map lc, split_name $column_name;
2023 sub _make_column_accessor_name {
2024 my ($self, $column_name, $column_context_info ) = @_;
2026 my $accessor = $self->_run_user_map(
2027 $self->col_accessor_map,
2028 sub { $self->_default_column_accessor_name( shift ) },
2030 $column_context_info,
2037 my ($self, $identifier) = @_;
2039 my $qt = $self->schema->storage->sql_maker->quote_char || '';
2042 return $qt->[0] . $identifier . $qt->[1];
2045 return "${qt}${identifier}${qt}";
2048 # Set up metadata (cols, pks, etc)
2049 sub _setup_src_meta {
2050 my ($self, $table) = @_;
2052 my $schema = $self->schema;
2053 my $schema_class = $self->schema_class;
2055 my $table_class = $self->classes->{$table};
2056 my $table_moniker = $self->monikers->{$table};
2058 my $table_name = $table;
2060 my $sql_maker = $self->schema->storage->sql_maker;
2061 my $name_sep = $sql_maker->name_sep;
2063 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
2064 $table_name = \ $self->_quote($table_name);
2067 my $full_table_name = ($self->qualify_objects ?
2068 ($self->_quote($self->db_schema) . '.') : '')
2069 . (ref $table_name ? $$table_name : $table_name);
2071 # be careful to not create refs Data::Dump can "optimize"
2072 $full_table_name = \do {"".$full_table_name} if ref $table_name;
2074 $self->_dbic_stmt($table_class, 'table', $full_table_name);
2076 my $cols = $self->_table_columns($table);
2077 my $col_info = $self->__columns_info_for($table);
2079 ### generate all the column accessor names
2080 while (my ($col, $info) = each %$col_info) {
2081 # hashref of other info that could be used by
2082 # user-defined accessor map functions
2084 table_class => $table_class,
2085 table_moniker => $table_moniker,
2086 table_name => $table_name,
2087 full_table_name => $full_table_name,
2088 schema_class => $schema_class,
2089 column_info => $info,
2092 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2095 $self->_resolve_col_accessor_collisions($table, $col_info);
2097 # prune any redundant accessor names
2098 while (my ($col, $info) = each %$col_info) {
2099 no warnings 'uninitialized';
2100 delete $info->{accessor} if $info->{accessor} eq $col;
2103 my $fks = $self->_table_fk_info($table);
2105 foreach my $fkdef (@$fks) {
2106 for my $col (@{ $fkdef->{local_columns} }) {
2107 $col_info->{$col}{is_foreign_key} = 1;
2111 my $pks = $self->_table_pk_info($table) || [];
2113 my %uniq_tag; # used to eliminate duplicate uniqs
2115 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2117 my $uniqs = $self->_table_uniq_info($table) || [];
2120 foreach my $uniq (@$uniqs) {
2121 my ($name, $cols) = @$uniq;
2122 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2123 push @uniqs, [$name, $cols];
2126 my @non_nullable_uniqs = grep {
2127 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2130 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2131 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2132 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2134 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2135 my @keys = map $_->[1], @by_colnum;
2139 # remove the uniq from list
2140 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2146 foreach my $pkcol (@$pks) {
2147 $col_info->{$pkcol}{is_nullable} = 0;
2153 map { $_, ($col_info->{$_}||{}) } @$cols
2156 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2159 foreach my $uniq (@uniqs) {
2160 my ($name, $cols) = @$uniq;
2161 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2165 sub __columns_info_for {
2166 my ($self, $table) = @_;
2168 my $result = $self->_columns_info_for($table);
2170 while (my ($col, $info) = each %$result) {
2171 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2172 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2174 $result->{$col} = $info;
2182 Returns a sorted list of loaded tables, using the original database table
2190 return keys %{$self->_tables};
2193 # Make a moniker from a table
2194 sub _default_table2moniker {
2195 no warnings 'uninitialized';
2196 my ($self, $table) = @_;
2198 if ($self->naming->{monikers} eq 'v4') {
2199 return join '', map ucfirst, split /[\W_]+/, lc $table;
2201 elsif ($self->naming->{monikers} eq 'v5') {
2202 return join '', map ucfirst, split /[\W_]+/,
2203 Lingua::EN::Inflect::Number::to_S(lc $table);
2205 elsif ($self->naming->{monikers} eq 'v6') {
2206 (my $as_phrase = lc $table) =~ s/_+/ /g;
2207 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2209 return join '', map ucfirst, split /\W+/, $inflected;
2212 my @words = map lc, split_name $table;
2213 my $as_phrase = join ' ', @words;
2215 my $inflected = $self->naming->{monikers} eq 'plural' ?
2216 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2218 $self->naming->{monikers} eq 'preserve' ?
2221 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2223 return join '', map ucfirst, split /\W+/, $inflected;
2226 sub _table2moniker {
2227 my ( $self, $table ) = @_;
2229 $self->_run_user_map(
2231 sub { $self->_default_table2moniker( shift ) },
2236 sub _load_relationships {
2237 my ($self, $tables) = @_;
2241 foreach my $table (@$tables) {
2242 my $tbl_fk_info = $self->_table_fk_info($table);
2243 foreach my $fkdef (@$tbl_fk_info) {
2244 $fkdef->{remote_source} =
2245 $self->monikers->{delete $fkdef->{remote_table}};
2247 my $tbl_uniq_info = $self->_table_uniq_info($table);
2249 my $local_moniker = $self->monikers->{$table};
2251 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2254 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2256 foreach my $src_class (sort keys %$rel_stmts) {
2258 my @src_stmts = map $_->[1],
2259 sort { $a->[0] cmp $b->[0] }
2260 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2262 foreach my $stmt (@src_stmts) {
2263 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2269 my ($self, $table) = @_;
2271 my $table_moniker = $self->monikers->{$table};
2272 my $table_class = $self->classes->{$table};
2274 my @roles = @{ $self->result_roles || [] };
2275 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2276 if exists $self->result_roles_map->{$table_moniker};
2279 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2281 $self->_with($table_class, @roles);
2285 # Overload these in driver class:
2287 # Returns an arrayref of column names
2288 sub _table_columns { croak "ABSTRACT METHOD" }
2290 # Returns arrayref of pk col names
2291 sub _table_pk_info { croak "ABSTRACT METHOD" }
2293 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2294 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2296 # Returns an arrayref of foreign key constraints, each
2297 # being a hashref with 3 keys:
2298 # local_columns (arrayref), remote_columns (arrayref), remote_table
2299 sub _table_fk_info { croak "ABSTRACT METHOD" }
2301 # Returns an array of lower case table names
2302 sub _tables_list { croak "ABSTRACT METHOD" }
2304 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2310 # generate the pod for this statement, storing it with $self->_pod
2311 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2313 my $args = dump(@_);
2314 $args = '(' . $args . ')' if @_ < 2;
2315 my $stmt = $method . $args . q{;};
2317 warn qq|$class\->$stmt\n| if $self->debug;
2318 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2322 sub _make_pod_heading {
2323 my ($self, $class) = @_;
2325 return '' if not $self->generate_pod;
2327 my $table = $self->class_to_table->{$class};
2330 my $pcm = $self->pod_comment_mode;
2331 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2332 $comment = $self->__table_comment($table);
2333 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2334 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2335 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2337 $pod .= "=head1 NAME\n\n";
2339 my $table_descr = $class;
2340 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2342 $pod .= "$table_descr\n\n";
2344 if ($comment and $comment_in_desc) {
2345 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2352 # generates the accompanying pod for a DBIC class method statement,
2353 # storing it with $self->_pod
2359 if ($method eq 'table') {
2361 $table = $$table if ref $table eq 'SCALAR';
2362 $self->_pod($class, "=head1 TABLE: C<$table>");
2363 $self->_pod_cut($class);
2365 elsif ( $method eq 'add_columns' ) {
2366 $self->_pod( $class, "=head1 ACCESSORS" );
2367 my $col_counter = 0;
2369 while( my ($name,$attrs) = splice @cols,0,2 ) {
2371 $self->_pod( $class, '=head2 ' . $name );
2372 $self->_pod( $class,
2374 my $s = $attrs->{$_};
2375 $s = !defined $s ? 'undef' :
2376 length($s) == 0 ? '(empty string)' :
2377 ref($s) eq 'SCALAR' ? $$s :
2378 ref($s) ? dumper_squashed $s :
2379 looks_like_number($s) ? $s : qq{'$s'};
2382 } sort keys %$attrs,
2384 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2385 $self->_pod( $class, $comment );
2388 $self->_pod_cut( $class );
2389 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2390 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2391 my ( $accessor, $rel_class ) = @_;
2392 $self->_pod( $class, "=head2 $accessor" );
2393 $self->_pod( $class, 'Type: ' . $method );
2394 $self->_pod( $class, "Related object: L<$rel_class>" );
2395 $self->_pod_cut( $class );
2396 $self->{_relations_started} { $class } = 1;
2398 elsif ($method eq 'add_unique_constraint') {
2399 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2400 unless $self->{_uniqs_started}{$class};
2402 my ($name, $cols) = @_;
2404 $self->_pod($class, "=head2 C<$name>");
2405 $self->_pod($class, '=over 4');
2407 foreach my $col (@$cols) {
2408 $self->_pod($class, "=item \* L</$col>");
2411 $self->_pod($class, '=back');
2412 $self->_pod_cut($class);
2414 $self->{_uniqs_started}{$class} = 1;
2416 elsif ($method eq 'set_primary_key') {
2417 $self->_pod($class, "=head1 PRIMARY KEY");
2418 $self->_pod($class, '=over 4');
2420 foreach my $col (@_) {
2421 $self->_pod($class, "=item \* L</$col>");
2424 $self->_pod($class, '=back');
2425 $self->_pod_cut($class);
2429 sub _pod_class_list {
2430 my ($self, $class, $title, @classes) = @_;
2432 return unless @classes && $self->generate_pod;
2434 $self->_pod($class, "=head1 $title");
2435 $self->_pod($class, '=over 4');
2437 foreach my $link (@classes) {
2438 $self->_pod($class, "=item * L<$link>");
2441 $self->_pod($class, '=back');
2442 $self->_pod_cut($class);
2445 sub _base_class_pod {
2446 my ($self, $base_class) = @_;
2448 return unless $self->generate_pod;
2451 =head1 BASE CLASS: L<$base_class>
2458 sub _filter_comment {
2459 my ($self, $txt) = @_;
2461 $txt = '' if not defined $txt;
2463 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2468 sub __table_comment {
2471 if (my $code = $self->can('_table_comment')) {
2472 return $self->_filter_comment($self->$code(@_));
2478 sub __column_comment {
2481 if (my $code = $self->can('_column_comment')) {
2482 return $self->_filter_comment($self->$code(@_));
2488 # Stores a POD documentation
2490 my ($self, $class, $stmt) = @_;
2491 $self->_raw_stmt( $class, "\n" . $stmt );
2495 my ($self, $class ) = @_;
2496 $self->_raw_stmt( $class, "\n=cut\n" );
2499 # Store a raw source line for a class (for dumping purposes)
2501 my ($self, $class, $stmt) = @_;
2502 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2505 # Like above, but separately for the externally loaded stuff
2507 my ($self, $class, $stmt) = @_;
2508 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2511 sub _custom_column_info {
2512 my ( $self, $table_name, $column_name, $column_info ) = @_;
2514 if (my $code = $self->custom_column_info) {
2515 return $code->($table_name, $column_name, $column_info) || {};
2520 sub _datetime_column_info {
2521 my ( $self, $table_name, $column_name, $column_info ) = @_;
2523 my $type = $column_info->{data_type} || '';
2524 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2525 or ($type =~ /date|timestamp/i)) {
2526 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2527 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2533 my ($self, $name) = @_;
2535 return $self->preserve_case ? $name : lc($name);
2539 my ($self, $name) = @_;
2541 return $self->preserve_case ? $name : uc($name);
2544 sub _unregister_source_for_table {
2545 my ($self, $table) = @_;
2549 my $schema = $self->schema;
2550 # in older DBIC it's a private method
2551 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2552 $schema->$unregister($self->_table2moniker($table));
2553 delete $self->monikers->{$table};
2554 delete $self->classes->{$table};
2555 delete $self->_upgrading_classes->{$table};
2556 delete $self->{_tables}{$table};
2560 # remove the dump dir from @INC on destruction
2564 @INC = grep $_ ne $self->dump_directory, @INC;
2569 Returns a hashref of loaded table to moniker mappings. There will
2570 be two entries for each table, the original name and the "normalized"
2571 name, in the case that the two are different (such as databases
2572 that like uppercase table names, or preserve your original mixed-case
2573 definitions, or what-have-you).
2577 Returns a hashref of table to class mappings. In some cases it will
2578 contain multiple entries per table for the original and normalized table
2579 names, as above in L</monikers>.
2581 =head1 COLUMN ACCESSOR COLLISIONS
2583 Occasionally you may have a column name that collides with a perl method, such
2584 as C<can>. In such cases, the default action is to set the C<accessor> of the
2585 column spec to C<undef>.
2587 You can then name the accessor yourself by placing code such as the following
2590 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2592 Another option is to use the L</col_collision_map> option.
2594 =head1 RELATIONSHIP NAME COLLISIONS
2596 In very rare cases, you may get a collision between a generated relationship
2597 name and a method in your Result class, for example if you have a foreign key
2598 called C<belongs_to>.
2600 This is a problem because relationship names are also relationship accessor
2601 methods in L<DBIx::Class>.
2603 The default behavior is to append C<_rel> to the relationship name and print
2604 out a warning that refers to this text.
2606 You can also control the renaming with the L</rel_collision_map> option.
2610 L<DBIx::Class::Schema::Loader>
2614 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2618 This library is free software; you can redistribute it and/or modify it under
2619 the same terms as Perl itself.
2624 # vim:et sts=4 sw=4 tw=0: