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 decode/;
25 use List::MoreUtils 'all';
30 our $VERSION = '0.07010';
32 __PACKAGE__->mk_group_ro_accessors('simple', qw/
39 additional_base_classes
55 default_resultset_class
60 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
107 filter_generated_code
110 my $CURRENT_V = 'v7';
113 schema_components schema_base_class result_base_class
114 additional_base_classes left_base_classes additional_classes components
120 my $CRLF = "\x0d\x0a";
124 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
128 See L<DBIx::Class::Schema::Loader>
132 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
133 classes, and implements the common functionality between them.
135 =head1 CONSTRUCTOR OPTIONS
137 These constructor options are the base options for
138 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
140 =head2 skip_relationships
142 Skip setting up relationships. The default is to attempt the loading
145 =head2 skip_load_external
147 Skip loading of other classes in @INC. The default is to merge all other classes
148 with the same name found in @INC into the schema file we are creating.
152 Static schemas (ones dumped to disk) will, by default, use the new-style
153 relationship names and singularized Results, unless you're overwriting an
154 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
155 which case the backward compatible RelBuilder will be activated, and the
156 appropriate monikerization used.
162 will disable the backward-compatible RelBuilder and use
163 the new-style relationship names along with singularized Results, even when
164 overwriting a dump made with an earlier version.
166 The option also takes a hashref:
168 naming => { relationships => 'v7', monikers => 'v7' }
176 How to name relationship accessors.
180 How to name Result classes.
182 =item column_accessors
184 How to name column accessors in Result classes.
194 Latest style, whatever that happens to be.
198 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
202 Monikers singularized as whole words, C<might_have> relationships for FKs on
203 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
205 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
210 All monikers and relationships are inflected using
211 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
212 from relationship names.
214 In general, there is very little difference between v5 and v6 schemas.
218 This mode is identical to C<v6> mode, except that monikerization of CamelCase
219 table names is also done correctly.
221 CamelCase column names in case-preserving mode will also be handled correctly
222 for relationship name inflection. See L</preserve_case>.
224 In this mode, CamelCase L</column_accessors> are normalized based on case
225 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
227 If you don't have any CamelCase table or column names, you can upgrade without
228 breaking any of your code.
232 For L</monikers>, this option does not inflect the table names but makes
233 monikers based on the actual name. For L</column_accessors> this option does
234 not normalize CamelCase column names to lowercase column accessors, but makes
235 accessors that are the same names as the columns (with any non-\w chars
236 replaced with underscores.)
240 For L</monikers>, singularizes the names using the most current inflector. This
241 is the same as setting the option to L</current>.
245 For L</monikers>, pluralizes the names, using the most current inflector.
249 Dynamic schemas will always default to the 0.04XXX relationship names and won't
250 singularize Results for backward compatibility, to activate the new RelBuilder
251 and singularization put this in your C<Schema.pm> file:
253 __PACKAGE__->naming('current');
255 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
256 next major version upgrade:
258 __PACKAGE__->naming('v7');
262 If true, will not print the usual C<Dumping manual schema ... Schema dump
263 completed.> messages. Does not affect warnings (except for warnings related to
264 L</really_erase_my_files>.)
268 By default POD will be generated for columns and relationships, using database
269 metadata for the text if available and supported.
271 Comment metadata can be stored in two ways.
273 The first is that you can create two tables named C<table_comments> and
274 C<column_comments> respectively. They both need to have columns named
275 C<table_name> and C<comment_text>. The second one needs to have a column
276 named C<column_name>. Then data stored in these tables will be used as a
277 source of metadata about tables and comments.
279 (If you wish you can change the name of these tables with the parameters
280 L</table_comments_table> and L</column_comments_table>.)
282 As a fallback you can use built-in commenting mechanisms. Currently this is
283 only supported for PostgreSQL, Oracle and MySQL. To create comments in
284 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
285 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
286 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
287 restricts the length of comments, and also does not handle complex Unicode
290 Set this to C<0> to turn off all POD generation.
292 =head2 pod_comment_mode
294 Controls where table comments appear in the generated POD. Smaller table
295 comments are appended to the C<NAME> section of the documentation, and larger
296 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
297 section to be generated with the comment always, only use C<NAME>, or choose
298 the length threshold at which the comment is forced into the description.
304 Use C<NAME> section only.
308 Force C<DESCRIPTION> always.
312 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
317 =head2 pod_comment_spillover_length
319 When pod_comment_mode is set to C<auto>, this is the length of the comment at
320 which it will be forced into a separate description section.
324 =head2 table_comments_table
326 The table to look for comments about tables in. By default C<table_comments>.
327 See L</generate_pod> for details.
329 =head2 column_comments_table
331 The table to look for comments about columns in. By default C<column_comments>.
332 See L</generate_pod> for details.
334 =head2 relationship_attrs
336 Hashref of attributes to pass to each generated relationship, listed
337 by type. Also supports relationship type 'all', containing options to
338 pass to all generated relationships. Attributes set for more specific
339 relationship types override those set in 'all'.
343 relationship_attrs => {
344 belongs_to => { is_deferrable => 0 },
347 use this to turn off DEFERRABLE on your foreign key constraints.
351 If set to true, each constructive L<DBIx::Class> statement the loader
352 decides to execute will be C<warn>-ed before execution.
356 Set the name of the schema to load (schema in the sense that your database
357 vendor means it). Does not currently support loading more than one schema
362 Only load tables matching regex. Best specified as a qr// regex.
366 Exclude tables matching regex. Best specified as a qr// regex.
370 Overrides the default table name to moniker translation. Can be either
371 a hashref of table keys and moniker values, or a coderef for a translator
372 function taking a single scalar table name argument and returning
373 a scalar moniker. If the hash entry does not exist, or the function
374 returns a false value, the code falls back to default behavior
377 The default behavior is to split on case transition and non-alphanumeric
378 boundaries, singularize the resulting phrase, then join the titlecased words
381 Table Name | Moniker Name
382 ---------------------------------
384 luser_group | LuserGroup
385 luser-opts | LuserOpt
386 stations_visited | StationVisited
387 routeChange | RouteChange
389 =head2 col_accessor_map
391 Same as moniker_map, but for column accessor names. If a coderef is
392 passed, the code is called with arguments of
394 the name of the column in the underlying database,
395 default accessor name that DBICSL would ordinarily give this column,
397 table_class => name of the DBIC class we are building,
398 table_moniker => calculated moniker for this table (after moniker_map if present),
399 table_name => name of the database table,
400 full_table_name => schema-qualified name of the database table (RDBMS specific),
401 schema_class => name of the schema class we are building,
402 column_info => hashref of column info (data_type, is_nullable, etc),
407 Similar in idea to moniker_map, but different in the details. It can be
408 a hashref or a code ref.
410 If it is a hashref, keys can be either the default relationship name, or the
411 moniker. The keys that are the default relationship name should map to the
412 name you want to change the relationship to. Keys that are monikers should map
413 to hashes mapping relationship names to their translation. You can do both at
414 once, and the more specific moniker version will be picked up first. So, for
415 instance, you could have
424 and relationships that would have been named C<bar> will now be named C<baz>
425 except that in the table whose moniker is C<Foo> it will be named C<blat>.
427 If it is a coderef, the argument passed will be a hashref of this form:
430 name => default relationship name,
431 type => the relationship type eg: C<has_many>,
432 local_class => name of the DBIC class we are building,
433 local_moniker => moniker of the DBIC class we are building,
434 local_columns => columns in this table in the relationship,
435 remote_class => name of the DBIC class we are related to,
436 remote_moniker => moniker of the DBIC class we are related to,
437 remote_columns => columns in the other table in the relationship,
440 DBICSL will try to use the value returned as the relationship name.
442 =head2 inflect_plural
444 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
445 if hash key does not exist or coderef returns false), but acts as a map
446 for pluralizing relationship names. The default behavior is to utilize
447 L<Lingua::EN::Inflect::Phrase/to_PL>.
449 =head2 inflect_singular
451 As L</inflect_plural> above, but for singularizing relationship names.
452 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
454 =head2 schema_base_class
456 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
458 =head2 result_base_class
460 Base class for your table classes (aka result classes). Defaults to
463 =head2 additional_base_classes
465 List of additional base classes all of your table classes will use.
467 =head2 left_base_classes
469 List of additional base classes all of your table classes will use
470 that need to be leftmost.
472 =head2 additional_classes
474 List of additional classes which all of your table classes will use.
476 =head2 schema_components
478 List of components to load into the Schema class.
482 List of additional components to be loaded into all of your Result
483 classes. A good example would be
484 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
486 =head2 result_components_map
488 A hashref of moniker keys and component values. Unlike L</components>, which
489 loads the given components into every Result class, this option allows you to
490 load certain components for specified Result classes. For example:
492 result_components_map => {
493 StationVisited => '+YourApp::Schema::Component::StationVisited',
495 '+YourApp::Schema::Component::RouteChange',
496 'InflateColumn::DateTime',
500 You may use this in conjunction with L</components>.
504 List of L<Moose> roles to be applied to all of your Result classes.
506 =head2 result_roles_map
508 A hashref of moniker keys and role values. Unlike L</result_roles>, which
509 applies the given roles to every Result class, this option allows you to apply
510 certain roles for specified Result classes. For example:
512 result_roles_map => {
514 'YourApp::Role::Building',
515 'YourApp::Role::Destination',
517 RouteChange => 'YourApp::Role::TripEvent',
520 You may use this in conjunction with L</result_roles>.
522 =head2 use_namespaces
524 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
527 Generate result class names suitable for
528 L<DBIx::Class::Schema/load_namespaces> and call that instead of
529 L<DBIx::Class::Schema/load_classes>. When using this option you can also
530 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
531 C<resultset_namespace>, C<default_resultset_class>), and they will be added
532 to the call (and the generated result class names adjusted appropriately).
534 =head2 dump_directory
536 The value of this option is a perl libdir pathname. Within
537 that directory this module will create a baseline manual
538 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
540 The created schema class will have the same classname as the one on
541 which you are setting this option (and the ResultSource classes will be
542 based on this name as well).
544 Normally you wouldn't hard-code this setting in your schema class, as it
545 is meant for one-time manual usage.
547 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
548 recommended way to access this functionality.
550 =head2 dump_overwrite
552 Deprecated. See L</really_erase_my_files> below, which does *not* mean
553 the same thing as the old C<dump_overwrite> setting from previous releases.
555 =head2 really_erase_my_files
557 Default false. If true, Loader will unconditionally delete any existing
558 files before creating the new ones from scratch when dumping a schema to disk.
560 The default behavior is instead to only replace the top portion of the
561 file, up to and including the final stanza which contains
562 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
563 leaving any customizations you placed after that as they were.
565 When C<really_erase_my_files> is not set, if the output file already exists,
566 but the aforementioned final stanza is not found, or the checksum
567 contained there does not match the generated contents, Loader will
568 croak and not touch the file.
570 You should really be using version control on your schema classes (and all
571 of the rest of your code for that matter). Don't blame me if a bug in this
572 code wipes something out when it shouldn't have, you've been warned.
574 =head2 overwrite_modifications
576 Default false. If false, when updating existing files, Loader will
577 refuse to modify any Loader-generated code that has been modified
578 since its last run (as determined by the checksum Loader put in its
581 If true, Loader will discard any manual modifications that have been
582 made to Loader-generated code.
584 Again, you should be using version control on your schema classes. Be
585 careful with this option.
587 =head2 custom_column_info
589 Hook for adding extra attributes to the
590 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
592 Must be a coderef that returns a hashref with the extra attributes.
594 Receives the table name, column name and column_info.
598 custom_column_info => sub {
599 my ($table_name, $column_name, $column_info) = @_;
601 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
602 return { is_snoopy => 1 };
606 This attribute can also be used to set C<inflate_datetime> on a non-datetime
607 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
609 =head2 datetime_timezone
611 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
612 columns with the DATE/DATETIME/TIMESTAMP data_types.
614 =head2 datetime_locale
616 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
617 columns with the DATE/DATETIME/TIMESTAMP data_types.
619 =head2 datetime_undef_if_invalid
621 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
622 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
625 The default is recommended to deal with data such as C<00/00/00> which
626 sometimes ends up in such columns in MySQL.
630 File in Perl format, which should return a HASH reference, from which to read
635 Usually column names are lowercased, to make them easier to work with in
636 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
639 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
640 case-sensitive collation will turn this option on unconditionally.
642 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
645 =head2 qualify_objects
647 Set to true to prepend the L</db_schema> to table names for C<<
648 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
652 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
653 L<namespace::autoclean>. The default content after the md5 sum also makes the
656 It is safe to upgrade your existing Schema to this option.
658 =head2 col_collision_map
660 This option controls how accessors for column names which collide with perl
661 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
663 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
664 strings which are compiled to regular expressions that map to
665 L<sprintf|perlfunc/sprintf> formats.
669 col_collision_map => 'column_%s'
671 col_collision_map => { '(.*)' => 'column_%s' }
673 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
675 =head2 rel_collision_map
677 Works just like L</col_collision_map>, but for relationship names/accessors
678 rather than column names/accessors.
680 The default is to just append C<_rel> to the relationship name, see
681 L</RELATIONSHIP NAME COLLISIONS>.
683 =head2 uniq_to_primary
685 Automatically promotes the largest unique constraints with non-nullable columns
686 on tables to primary keys, assuming there is only one largest unique
689 =head2 filter_generated_code
691 An optional hook that lets you filter the generated text for various classes
692 through a function that change it in any way that you want. The function will
693 receive the type of file, C<schema> or C<result>, class and code; and returns
694 the new code to use instead. For instance you could add custom comments, or do
695 anything else that you want.
697 The option can also be set to a string, which is then used as a filter program,
700 If this exists but fails to return text matching C</\bpackage\b/>, no file will
703 filter_generated_code => sub {
704 my ($type, $class, $text) = @_;
711 None of these methods are intended for direct invocation by regular
712 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
713 L<DBIx::Class::Schema::Loader>.
717 # ensure that a peice of object data is a valid arrayref, creating
718 # an empty one or encapsulating whatever's there.
719 sub _ensure_arrayref {
724 $self->{$_} = [ $self->{$_} ]
725 unless ref $self->{$_} eq 'ARRAY';
731 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
732 by L<DBIx::Class::Schema::Loader>.
737 my ( $class, %args ) = @_;
739 if (exists $args{column_accessor_map}) {
740 $args{col_accessor_map} = delete $args{column_accessor_map};
743 my $self = { %args };
745 # don't lose undef options
746 for (values %$self) {
747 $_ = 0 unless defined $_;
750 bless $self => $class;
752 if (my $config_file = $self->config_file) {
753 my $config_opts = do $config_file;
755 croak "Error reading config from $config_file: $@" if $@;
757 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
759 while (my ($k, $v) = each %$config_opts) {
760 $self->{$k} = $v unless exists $self->{$k};
764 if (defined $self->{result_component_map}) {
765 if (defined $self->result_components_map) {
766 croak "Specify only one of result_components_map or result_component_map";
768 $self->result_components_map($self->{result_component_map})
771 if (defined $self->{result_role_map}) {
772 if (defined $self->result_roles_map) {
773 croak "Specify only one of result_roles_map or result_role_map";
775 $self->result_roles_map($self->{result_role_map})
778 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
779 if ((not defined $self->use_moose) || (not $self->use_moose))
780 && ((defined $self->result_roles) || (defined $self->result_roles_map));
782 $self->_ensure_arrayref(qw/schema_components
784 additional_base_classes
790 $self->_validate_class_args;
792 croak "result_components_map must be a hash"
793 if defined $self->result_components_map
794 && ref $self->result_components_map ne 'HASH';
796 if ($self->result_components_map) {
797 my %rc_map = %{ $self->result_components_map };
798 foreach my $moniker (keys %rc_map) {
799 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
801 $self->result_components_map(\%rc_map);
804 $self->result_components_map({});
806 $self->_validate_result_components_map;
808 croak "result_roles_map must be a hash"
809 if defined $self->result_roles_map
810 && ref $self->result_roles_map ne 'HASH';
812 if ($self->result_roles_map) {
813 my %rr_map = %{ $self->result_roles_map };
814 foreach my $moniker (keys %rr_map) {
815 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
817 $self->result_roles_map(\%rr_map);
819 $self->result_roles_map({});
821 $self->_validate_result_roles_map;
823 if ($self->use_moose) {
824 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
825 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
826 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
830 $self->{monikers} = {};
831 $self->{tables} = {};
832 $self->{class_to_table} = {};
833 $self->{classes} = {};
834 $self->{_upgrading_classes} = {};
836 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
837 $self->{schema} ||= $self->{schema_class};
838 $self->{table_comments_table} ||= 'table_comments';
839 $self->{column_comments_table} ||= 'column_comments';
841 croak "dump_overwrite is deprecated. Please read the"
842 . " DBIx::Class::Schema::Loader::Base documentation"
843 if $self->{dump_overwrite};
845 $self->{dynamic} = ! $self->{dump_directory};
846 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
851 $self->{dump_directory} ||= $self->{temp_directory};
853 $self->real_dump_directory($self->{dump_directory});
855 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
856 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
858 if (not defined $self->naming) {
859 $self->naming_set(0);
862 $self->naming_set(1);
865 if ((not ref $self->naming) && defined $self->naming) {
866 my $naming_ver = $self->naming;
868 relationships => $naming_ver,
869 monikers => $naming_ver,
870 column_accessors => $naming_ver,
875 for (values %{ $self->naming }) {
876 $_ = $CURRENT_V if $_ eq 'current';
879 $self->{naming} ||= {};
881 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
882 croak 'custom_column_info must be a CODE ref';
885 $self->_check_back_compat;
887 $self->use_namespaces(1) unless defined $self->use_namespaces;
888 $self->generate_pod(1) unless defined $self->generate_pod;
889 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
890 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
892 if (my $col_collision_map = $self->col_collision_map) {
893 if (my $reftype = ref $col_collision_map) {
894 if ($reftype ne 'HASH') {
895 croak "Invalid type $reftype for option 'col_collision_map'";
899 $self->col_collision_map({ '(.*)' => $col_collision_map });
903 if (my $rel_collision_map = $self->rel_collision_map) {
904 if (my $reftype = ref $rel_collision_map) {
905 if ($reftype ne 'HASH') {
906 croak "Invalid type $reftype for option 'rel_collision_map'";
910 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
914 if (defined(my $rel_name_map = $self->rel_name_map)) {
915 my $reftype = ref $rel_name_map;
916 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
917 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
921 if (defined(my $filter = $self->filter_generated_code)) {
922 my $reftype = ref $filter;
923 if ($reftype && $reftype ne 'CODE') {
924 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
931 sub _check_back_compat {
934 # dynamic schemas will always be in 0.04006 mode, unless overridden
935 if ($self->dynamic) {
936 # just in case, though no one is likely to dump a dynamic schema
937 $self->schema_version_to_dump('0.04006');
939 if (not $self->naming_set) {
940 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
942 Dynamic schema detected, will run in 0.04006 mode.
944 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
945 to disable this warning.
947 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
952 $self->_upgrading_from('v4');
955 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
956 $self->use_namespaces(1);
959 $self->naming->{relationships} ||= 'v4';
960 $self->naming->{monikers} ||= 'v4';
962 if ($self->use_namespaces) {
963 $self->_upgrading_from_load_classes(1);
966 $self->use_namespaces(0);
972 # otherwise check if we need backcompat mode for a static schema
973 my $filename = $self->get_dump_filename($self->schema_class);
974 return unless -e $filename;
976 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
977 $self->_parse_generated_file($filename);
979 return unless $old_ver;
981 # determine if the existing schema was dumped with use_moose => 1
982 if (! defined $self->use_moose) {
983 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
986 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
988 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
989 my $ds = eval $result_namespace;
991 Could not eval expression '$result_namespace' for result_namespace from
994 $result_namespace = $ds || '';
996 if ($load_classes && (not defined $self->use_namespaces)) {
997 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
999 'load_classes;' static schema detected, turning off 'use_namespaces'.
1001 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1002 variable to disable this warning.
1004 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1007 $self->use_namespaces(0);
1009 elsif ($load_classes && $self->use_namespaces) {
1010 $self->_upgrading_from_load_classes(1);
1012 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1013 $self->_downgrading_to_load_classes(
1014 $result_namespace || 'Result'
1017 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1018 if (not $self->result_namespace) {
1019 $self->result_namespace($result_namespace || 'Result');
1021 elsif ($result_namespace ne $self->result_namespace) {
1022 $self->_rewriting_result_namespace(
1023 $result_namespace || 'Result'
1028 # XXX when we go past .0 this will need fixing
1029 my ($v) = $old_ver =~ /([1-9])/;
1032 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1034 if (not %{ $self->naming }) {
1035 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1037 Version $old_ver static schema detected, turning on backcompat mode.
1039 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1040 to disable this warning.
1042 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1044 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1045 from version 0.04006.
1048 $self->naming->{relationships} ||= $v;
1049 $self->naming->{monikers} ||= $v;
1050 $self->naming->{column_accessors} ||= $v;
1052 $self->schema_version_to_dump($old_ver);
1055 $self->_upgrading_from($v);
1059 sub _validate_class_args {
1062 foreach my $k (@CLASS_ARGS) {
1063 next unless $self->$k;
1065 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1066 $self->_validate_classes($k, \@classes);
1070 sub _validate_result_components_map {
1073 foreach my $classes (values %{ $self->result_components_map }) {
1074 $self->_validate_classes('result_components_map', $classes);
1078 sub _validate_result_roles_map {
1081 foreach my $classes (values %{ $self->result_roles_map }) {
1082 $self->_validate_classes('result_roles_map', $classes);
1086 sub _validate_classes {
1089 my $classes = shift;
1091 # make a copy to not destroy original
1092 my @classes = @$classes;
1094 foreach my $c (@classes) {
1095 # components default to being under the DBIx::Class namespace unless they
1096 # are preceeded with a '+'
1097 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1098 $c = 'DBIx::Class::' . $c;
1101 # 1 == installed, 0 == not installed, undef == invalid classname
1102 my $installed = Class::Inspector->installed($c);
1103 if ( defined($installed) ) {
1104 if ( $installed == 0 ) {
1105 croak qq/$c, as specified in the loader option "$key", is not installed/;
1108 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1114 sub _find_file_in_inc {
1115 my ($self, $file) = @_;
1117 foreach my $prefix (@INC) {
1118 my $fullpath = File::Spec->catfile($prefix, $file);
1119 return $fullpath if -f $fullpath
1120 # abs_path throws on Windows for nonexistant files
1121 and (try { Cwd::abs_path($fullpath) }) ne
1122 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1128 sub _find_class_in_inc {
1129 my ($self, $class) = @_;
1131 return $self->_find_file_in_inc(class_path($class));
1137 return $self->_upgrading_from
1138 || $self->_upgrading_from_load_classes
1139 || $self->_downgrading_to_load_classes
1140 || $self->_rewriting_result_namespace
1144 sub _rewrite_old_classnames {
1145 my ($self, $code) = @_;
1147 return $code unless $self->_rewriting;
1149 my %old_classes = reverse %{ $self->_upgrading_classes };
1151 my $re = join '|', keys %old_classes;
1152 $re = qr/\b($re)\b/;
1154 $code =~ s/$re/$old_classes{$1} || $1/eg;
1159 sub _load_external {
1160 my ($self, $class) = @_;
1162 return if $self->{skip_load_external};
1164 # so that we don't load our own classes, under any circumstances
1165 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1167 my $real_inc_path = $self->_find_class_in_inc($class);
1169 my $old_class = $self->_upgrading_classes->{$class}
1170 if $self->_rewriting;
1172 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1173 if $old_class && $old_class ne $class;
1175 return unless $real_inc_path || $old_real_inc_path;
1177 if ($real_inc_path) {
1178 # If we make it to here, we loaded an external definition
1179 warn qq/# Loaded external class definition for '$class'\n/
1182 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1184 if ($self->dynamic) { # load the class too
1185 eval_package_without_redefine_warnings($class, $code);
1188 $self->_ext_stmt($class,
1189 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1190 .qq|# They are now part of the custom portion of this file\n|
1191 .qq|# for you to hand-edit. If you do not either delete\n|
1192 .qq|# this section or remove that file from \@INC, this section\n|
1193 .qq|# will be repeated redundantly when you re-create this\n|
1194 .qq|# file again via Loader! See skip_load_external to disable\n|
1195 .qq|# this feature.\n|
1198 $self->_ext_stmt($class, $code);
1199 $self->_ext_stmt($class,
1200 qq|# End of lines loaded from '$real_inc_path' |
1204 if ($old_real_inc_path) {
1205 my $code = slurp_file $old_real_inc_path;
1207 $self->_ext_stmt($class, <<"EOF");
1209 # These lines were loaded from '$old_real_inc_path',
1210 # based on the Result class name that would have been created by an older
1211 # version of the Loader. For a static schema, this happens only once during
1212 # upgrade. See skip_load_external to disable this feature.
1215 $code = $self->_rewrite_old_classnames($code);
1217 if ($self->dynamic) {
1220 Detected external content in '$old_real_inc_path', a class name that would have
1221 been used by an older version of the Loader.
1223 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1224 new name of the Result.
1226 eval_package_without_redefine_warnings($class, $code);
1230 $self->_ext_stmt($class, $code);
1231 $self->_ext_stmt($class,
1232 qq|# End of lines loaded from '$old_real_inc_path' |
1239 Does the actual schema-construction work.
1246 $self->_load_tables(
1247 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1255 Rescan the database for changes. Returns a list of the newly added table
1258 The schema argument should be the schema class or object to be affected. It
1259 should probably be derived from the original schema_class used during L</load>.
1264 my ($self, $schema) = @_;
1266 $self->{schema} = $schema;
1267 $self->_relbuilder->{schema} = $schema;
1270 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1272 foreach my $table (@current) {
1273 if(!exists $self->{_tables}->{$table}) {
1274 push(@created, $table);
1279 @current{@current} = ();
1280 foreach my $table (keys %{ $self->{_tables} }) {
1281 if (not exists $current{$table}) {
1282 $self->_unregister_source_for_table($table);
1286 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1288 my $loaded = $self->_load_tables(@current);
1290 return map { $self->monikers->{$_} } @created;
1296 return if $self->{skip_relationships};
1298 return $self->{relbuilder} ||= do {
1300 no warnings 'uninitialized';
1301 my $relbuilder_suff =
1307 ->{ $self->naming->{relationships}};
1309 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1310 $self->ensure_class_loaded($relbuilder_class);
1311 $relbuilder_class->new( $self );
1317 my ($self, @tables) = @_;
1319 # Save the new tables to the tables list
1321 $self->{_tables}->{$_} = 1;
1324 $self->_make_src_class($_) for @tables;
1326 # sanity-check for moniker clashes
1327 my $inverse_moniker_idx;
1328 for (keys %{$self->monikers}) {
1329 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1333 for (keys %$inverse_moniker_idx) {
1334 my $tables = $inverse_moniker_idx->{$_};
1336 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1337 join (', ', map { "'$_'" } @$tables),
1344 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1345 . 'Either change the naming style, or supply an explicit moniker_map: '
1346 . join ('; ', @clashes)
1352 $self->_setup_src_meta($_) for @tables;
1354 if(!$self->skip_relationships) {
1355 # The relationship loader needs a working schema
1356 local $self->{quiet} = 1;
1357 local $self->{dump_directory} = $self->{temp_directory};
1358 $self->_reload_classes(\@tables);
1359 $self->_load_relationships(\@tables);
1361 # Remove that temp dir from INC so it doesn't get reloaded
1362 @INC = grep $_ ne $self->dump_directory, @INC;
1365 $self->_load_roles($_) for @tables;
1367 $self->_load_external($_)
1368 for map { $self->classes->{$_} } @tables;
1370 # Reload without unloading first to preserve any symbols from external
1372 $self->_reload_classes(\@tables, { unload => 0 });
1374 # Drop temporary cache
1375 delete $self->{_cache};
1380 sub _reload_classes {
1381 my ($self, $tables, $opts) = @_;
1383 my @tables = @$tables;
1385 my $unload = $opts->{unload};
1386 $unload = 1 unless defined $unload;
1388 # so that we don't repeat custom sections
1389 @INC = grep $_ ne $self->dump_directory, @INC;
1391 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1393 unshift @INC, $self->dump_directory;
1396 my %have_source = map { $_ => $self->schema->source($_) }
1397 $self->schema->sources;
1399 for my $table (@tables) {
1400 my $moniker = $self->monikers->{$table};
1401 my $class = $self->classes->{$table};
1404 no warnings 'redefine';
1405 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1408 if (my $mc = $self->_moose_metaclass($class)) {
1411 Class::Unload->unload($class) if $unload;
1412 my ($source, $resultset_class);
1414 ($source = $have_source{$moniker})
1415 && ($resultset_class = $source->resultset_class)
1416 && ($resultset_class ne 'DBIx::Class::ResultSet')
1418 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1419 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1422 Class::Unload->unload($resultset_class) if $unload;
1423 $self->_reload_class($resultset_class) if $has_file;
1425 $self->_reload_class($class);
1427 push @to_register, [$moniker, $class];
1430 Class::C3->reinitialize;
1431 for (@to_register) {
1432 $self->schema->register_class(@$_);
1436 sub _moose_metaclass {
1437 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1441 my $mc = try { Class::MOP::class_of($class) }
1444 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1447 # We use this instead of ensure_class_loaded when there are package symbols we
1450 my ($self, $class) = @_;
1452 delete $INC{ +class_path($class) };
1455 eval_package_without_redefine_warnings ($class, "require $class");
1458 my $source = slurp_file $self->_get_dump_filename($class);
1459 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1463 sub _get_dump_filename {
1464 my ($self, $class) = (@_);
1466 $class =~ s{::}{/}g;
1467 return $self->dump_directory . q{/} . $class . q{.pm};
1470 =head2 get_dump_filename
1474 Returns the full path to the file for a class that the class has been or will
1475 be dumped to. This is a file in a temp dir for a dynamic schema.
1479 sub get_dump_filename {
1480 my ($self, $class) = (@_);
1482 local $self->{dump_directory} = $self->real_dump_directory;
1484 return $self->_get_dump_filename($class);
1487 sub _ensure_dump_subdirs {
1488 my ($self, $class) = (@_);
1490 my @name_parts = split(/::/, $class);
1491 pop @name_parts; # we don't care about the very last element,
1492 # which is a filename
1494 my $dir = $self->dump_directory;
1497 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1499 last if !@name_parts;
1500 $dir = File::Spec->catdir($dir, shift @name_parts);
1505 my ($self, @classes) = @_;
1507 my $schema_class = $self->schema_class;
1508 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1510 my $target_dir = $self->dump_directory;
1511 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1512 unless $self->dynamic or $self->quiet;
1515 qq|package $schema_class;\n\n|
1516 . qq|# Created by DBIx::Class::Schema::Loader\n|
1517 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1519 if ($self->use_moose) {
1520 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1523 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1526 my @schema_components = @{ $self->schema_components || [] };
1528 if (@schema_components) {
1529 my $schema_components = dump @schema_components;
1530 $schema_components = "($schema_components)" if @schema_components == 1;
1532 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1535 if ($self->use_namespaces) {
1536 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1537 my $namespace_options;
1539 my @attr = qw/resultset_namespace default_resultset_class/;
1541 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1543 for my $attr (@attr) {
1545 my $code = dumper_squashed $self->$attr;
1546 $namespace_options .= qq| $attr => $code,\n|
1549 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1550 $schema_text .= qq|;\n|;
1553 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1557 local $self->{version_to_dump} = $self->schema_version_to_dump;
1558 $self->_write_classfile($schema_class, $schema_text, 1);
1561 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1563 foreach my $src_class (@classes) {
1565 qq|package $src_class;\n\n|
1566 . qq|# Created by DBIx::Class::Schema::Loader\n|
1567 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1569 $src_text .= $self->_make_pod_heading($src_class);
1571 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1573 $src_text .= $self->_base_class_pod($result_base_class)
1574 unless $result_base_class eq 'DBIx::Class::Core';
1576 if ($self->use_moose) {
1577 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1579 # these options 'use base' which is compile time
1580 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1581 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1584 $src_text .= qq|\nextends '$result_base_class';\n|;
1588 $src_text .= qq|use base '$result_base_class';\n|;
1591 $self->_write_classfile($src_class, $src_text);
1594 # remove Result dir if downgrading from use_namespaces, and there are no
1596 if (my $result_ns = $self->_downgrading_to_load_classes
1597 || $self->_rewriting_result_namespace) {
1598 my $result_namespace = $self->_result_namespace(
1603 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1604 $result_dir = $self->dump_directory . '/' . $result_dir;
1606 unless (my @files = glob "$result_dir/*") {
1611 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1616 my ($self, $version, $ts) = @_;
1617 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1620 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1623 sub _write_classfile {
1624 my ($self, $class, $text, $is_schema) = @_;
1626 my $filename = $self->_get_dump_filename($class);
1627 $self->_ensure_dump_subdirs($class);
1629 if (-f $filename && $self->really_erase_my_files) {
1630 warn "Deleting existing file '$filename' due to "
1631 . "'really_erase_my_files' setting\n" unless $self->quiet;
1635 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1636 = $self->_parse_generated_file($filename);
1638 if (! $old_gen && -f $filename) {
1639 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1640 . " it does not appear to have been generated by Loader"
1643 my $custom_content = $old_custom || '';
1645 # prepend extra custom content from a *renamed* class (singularization effect)
1646 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1647 my $old_filename = $self->_get_dump_filename($renamed_class);
1649 if (-f $old_filename) {
1650 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1652 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1654 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1657 unlink $old_filename;
1661 $custom_content ||= $self->_default_custom_content($is_schema);
1663 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1664 # If there is already custom content, which does not have the Moose content, add it.
1665 if ($self->use_moose) {
1667 my $non_moose_custom_content = do {
1668 local $self->{use_moose} = 0;
1669 $self->_default_custom_content;
1672 if ($custom_content eq $non_moose_custom_content) {
1673 $custom_content = $self->_default_custom_content($is_schema);
1675 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1676 $custom_content .= $self->_default_custom_content($is_schema);
1679 elsif (defined $self->use_moose && $old_gen) {
1680 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'
1681 if $old_gen =~ /use \s+ MooseX?\b/x;
1684 $custom_content = $self->_rewrite_old_classnames($custom_content);
1687 for @{$self->{_dump_storage}->{$class} || []};
1689 if ($self->filter_generated_code) {
1690 my $filter = $self->filter_generated_code;
1692 if (ref $filter eq 'CODE') {
1694 ($is_schema ? 'schema' : 'result'),
1700 my ($out, $in) = (gensym, gensym);
1702 my $pid = open2($out, $in, $filter)
1703 or croak "Could not open pipe to $filter: $!";
1709 $text = decode('UTF-8', do { local $/; <$out> });
1711 $text =~ s/$CR?$LF/\n/g;
1715 my $exit_code = $? >> 8;
1717 if ($exit_code != 0) {
1718 croak "filter '$filter' exited non-zero: $exit_code";
1721 if (not $text or not $text =~ /\bpackage\b/) {
1722 warn("$class skipped due to filter") if $self->debug;
1727 # Check and see if the dump is in fact different
1731 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1732 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1733 return unless $self->_upgrading_from && $is_schema;
1737 $text .= $self->_sig_comment(
1738 $self->version_to_dump,
1739 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1742 open(my $fh, '>:encoding(UTF-8)', $filename)
1743 or croak "Cannot open '$filename' for writing: $!";
1745 # Write the top half and its MD5 sum
1746 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1748 # Write out anything loaded via external partial class file in @INC
1750 for @{$self->{_ext_storage}->{$class} || []};
1752 # Write out any custom content the user has added
1753 print $fh $custom_content;
1756 or croak "Error closing '$filename': $!";
1759 sub _default_moose_custom_content {
1760 my ($self, $is_schema) = @_;
1762 if (not $is_schema) {
1763 return qq|\n__PACKAGE__->meta->make_immutable;|;
1766 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1769 sub _default_custom_content {
1770 my ($self, $is_schema) = @_;
1771 my $default = qq|\n\n# You can replace this text with custom|
1772 . qq| code or comments, and it will be preserved on regeneration|;
1773 if ($self->use_moose) {
1774 $default .= $self->_default_moose_custom_content($is_schema);
1776 $default .= qq|\n1;\n|;
1780 sub _parse_generated_file {
1781 my ($self, $fn) = @_;
1783 return unless -f $fn;
1785 open(my $fh, '<:encoding(UTF-8)', $fn)
1786 or croak "Cannot open '$fn' for reading: $!";
1789 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
1791 my ($md5, $ts, $ver, $gen);
1797 # Pull out the version and timestamp from the line above
1798 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
1801 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"
1802 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1811 my $custom = do { local $/; <$fh> }
1815 $custom =~ s/$CRLF|$LF/\n/g;
1819 return ($gen, $md5, $ver, $ts, $custom);
1827 warn "$target: use $_;" if $self->debug;
1828 $self->_raw_stmt($target, "use $_;");
1836 my $blist = join(q{ }, @_);
1838 return unless $blist;
1840 warn "$target: use base qw/$blist/;" if $self->debug;
1841 $self->_raw_stmt($target, "use base qw/$blist/;");
1848 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1850 return unless $rlist;
1852 warn "$target: with $rlist;" if $self->debug;
1853 $self->_raw_stmt($target, "\nwith $rlist;");
1856 sub _result_namespace {
1857 my ($self, $schema_class, $ns) = @_;
1858 my @result_namespace;
1860 $ns = $ns->[0] if ref $ns;
1862 if ($ns =~ /^\+(.*)/) {
1863 # Fully qualified namespace
1864 @result_namespace = ($1)
1867 # Relative namespace
1868 @result_namespace = ($schema_class, $ns);
1871 return wantarray ? @result_namespace : join '::', @result_namespace;
1874 # Create class with applicable bases, setup monikers, etc
1875 sub _make_src_class {
1876 my ($self, $table) = @_;
1878 my $schema = $self->schema;
1879 my $schema_class = $self->schema_class;
1881 my $table_moniker = $self->_table2moniker($table);
1882 my @result_namespace = ($schema_class);
1883 if ($self->use_namespaces) {
1884 my $result_namespace = $self->result_namespace || 'Result';
1885 @result_namespace = $self->_result_namespace(
1890 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1892 if ((my $upgrading_v = $self->_upgrading_from)
1893 || $self->_rewriting) {
1894 local $self->naming->{monikers} = $upgrading_v
1897 my @result_namespace = @result_namespace;
1898 if ($self->_upgrading_from_load_classes) {
1899 @result_namespace = ($schema_class);
1901 elsif (my $ns = $self->_downgrading_to_load_classes) {
1902 @result_namespace = $self->_result_namespace(
1907 elsif ($ns = $self->_rewriting_result_namespace) {
1908 @result_namespace = $self->_result_namespace(
1914 my $old_class = join(q{::}, @result_namespace,
1915 $self->_table2moniker($table));
1917 $self->_upgrading_classes->{$table_class} = $old_class
1918 unless $table_class eq $old_class;
1921 $self->classes->{$table} = $table_class;
1922 $self->monikers->{$table} = $table_moniker;
1923 $self->tables->{$table_moniker} = $table;
1924 $self->class_to_table->{$table_class} = $table;
1926 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1928 $self->_use ($table_class, @{$self->additional_classes});
1930 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1932 $self->_inject($table_class, @{$self->left_base_classes});
1934 my @components = @{ $self->components || [] };
1936 push @components, @{ $self->result_components_map->{$table_moniker} }
1937 if exists $self->result_components_map->{$table_moniker};
1939 my @fq_components = @components;
1940 foreach my $component (@fq_components) {
1941 if ($component !~ s/^\+//) {
1942 $component = "DBIx::Class::$component";
1946 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1948 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1950 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1952 $self->_inject($table_class, @{$self->additional_base_classes});
1955 sub _is_result_class_method {
1956 my ($self, $name, $table_name) = @_;
1958 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1960 $self->_result_class_methods({})
1961 if not defined $self->_result_class_methods;
1963 if (not exists $self->_result_class_methods->{$table_moniker}) {
1964 my (@methods, %methods);
1965 my $base = $self->result_base_class || 'DBIx::Class::Core';
1967 my @components = @{ $self->components || [] };
1969 push @components, @{ $self->result_components_map->{$table_moniker} }
1970 if exists $self->result_components_map->{$table_moniker};
1972 for my $c (@components) {
1973 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1976 my @roles = @{ $self->result_roles || [] };
1978 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1979 if exists $self->result_roles_map->{$table_moniker};
1981 for my $class ($base, @components,
1982 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1983 $self->ensure_class_loaded($class);
1985 push @methods, @{ Class::Inspector->methods($class) || [] };
1988 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1990 @methods{@methods} = ();
1992 $self->_result_class_methods->{$table_moniker} = \%methods;
1994 my $result_methods = $self->_result_class_methods->{$table_moniker};
1996 return exists $result_methods->{$name};
1999 sub _resolve_col_accessor_collisions {
2000 my ($self, $table, $col_info) = @_;
2002 my $table_name = ref $table ? $$table : $table;
2004 while (my ($col, $info) = each %$col_info) {
2005 my $accessor = $info->{accessor} || $col;
2007 next if $accessor eq 'id'; # special case (very common column)
2009 if ($self->_is_result_class_method($accessor, $table_name)) {
2012 if (my $map = $self->col_collision_map) {
2013 for my $re (keys %$map) {
2014 if (my @matches = $col =~ /$re/) {
2015 $info->{accessor} = sprintf $map->{$re}, @matches;
2023 Column '$col' in table '$table_name' collides with an inherited method.
2024 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2026 $info->{accessor} = undef;
2032 # use the same logic to run moniker_map, col_accessor_map
2034 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2036 my $default_ident = $default_code->( $ident, @extra );
2038 if( $map && ref $map eq 'HASH' ) {
2039 $new_ident = $map->{ $ident };
2041 elsif( $map && ref $map eq 'CODE' ) {
2042 $new_ident = $map->( $ident, $default_ident, @extra );
2045 $new_ident ||= $default_ident;
2050 sub _default_column_accessor_name {
2051 my ( $self, $column_name ) = @_;
2053 my $accessor_name = $column_name;
2054 $accessor_name =~ s/\W+/_/g;
2056 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
2057 # older naming just lc'd the col accessor and that's all.
2058 return lc $accessor_name;
2060 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
2061 return $accessor_name;
2064 return join '_', map lc, split_name $column_name;
2067 sub _make_column_accessor_name {
2068 my ($self, $column_name, $column_context_info ) = @_;
2070 my $accessor = $self->_run_user_map(
2071 $self->col_accessor_map,
2072 sub { $self->_default_column_accessor_name( shift ) },
2074 $column_context_info,
2081 my ($self, $identifier) = @_;
2083 my $qt = $self->schema->storage->sql_maker->quote_char || '';
2086 return $qt->[0] . $identifier . $qt->[1];
2089 return "${qt}${identifier}${qt}";
2092 # Set up metadata (cols, pks, etc)
2093 sub _setup_src_meta {
2094 my ($self, $table) = @_;
2096 my $schema = $self->schema;
2097 my $schema_class = $self->schema_class;
2099 my $table_class = $self->classes->{$table};
2100 my $table_moniker = $self->monikers->{$table};
2102 my $table_name = $table;
2104 my $sql_maker = $self->schema->storage->sql_maker;
2105 my $name_sep = $sql_maker->name_sep;
2107 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
2108 $table_name = \ $self->_quote($table_name);
2111 my $full_table_name = ($self->qualify_objects ?
2112 ($self->_quote($self->db_schema) . '.') : '')
2113 . (ref $table_name ? $$table_name : $table_name);
2115 # be careful to not create refs Data::Dump can "optimize"
2116 $full_table_name = \do {"".$full_table_name} if ref $table_name;
2118 $self->_dbic_stmt($table_class, 'table', $full_table_name);
2120 my $cols = $self->_table_columns($table);
2121 my $col_info = $self->__columns_info_for($table);
2123 ### generate all the column accessor names
2124 while (my ($col, $info) = each %$col_info) {
2125 # hashref of other info that could be used by
2126 # user-defined accessor map functions
2128 table_class => $table_class,
2129 table_moniker => $table_moniker,
2130 table_name => $table_name,
2131 full_table_name => $full_table_name,
2132 schema_class => $schema_class,
2133 column_info => $info,
2136 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2139 $self->_resolve_col_accessor_collisions($table, $col_info);
2141 # prune any redundant accessor names
2142 while (my ($col, $info) = each %$col_info) {
2143 no warnings 'uninitialized';
2144 delete $info->{accessor} if $info->{accessor} eq $col;
2147 my $fks = $self->_table_fk_info($table);
2149 foreach my $fkdef (@$fks) {
2150 for my $col (@{ $fkdef->{local_columns} }) {
2151 $col_info->{$col}{is_foreign_key} = 1;
2155 my $pks = $self->_table_pk_info($table) || [];
2157 my %uniq_tag; # used to eliminate duplicate uniqs
2159 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2161 my $uniqs = $self->_table_uniq_info($table) || [];
2164 foreach my $uniq (@$uniqs) {
2165 my ($name, $cols) = @$uniq;
2166 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2167 push @uniqs, [$name, $cols];
2170 my @non_nullable_uniqs = grep {
2171 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2174 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2175 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2176 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2178 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2179 my @keys = map $_->[1], @by_colnum;
2183 # remove the uniq from list
2184 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2190 foreach my $pkcol (@$pks) {
2191 $col_info->{$pkcol}{is_nullable} = 0;
2197 map { $_, ($col_info->{$_}||{}) } @$cols
2200 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2203 foreach my $uniq (@uniqs) {
2204 my ($name, $cols) = @$uniq;
2205 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2209 sub __columns_info_for {
2210 my ($self, $table) = @_;
2212 my $result = $self->_columns_info_for($table);
2214 while (my ($col, $info) = each %$result) {
2215 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2216 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2218 $result->{$col} = $info;
2226 Returns a sorted list of loaded tables, using the original database table
2234 return keys %{$self->_tables};
2237 # Make a moniker from a table
2238 sub _default_table2moniker {
2239 no warnings 'uninitialized';
2240 my ($self, $table) = @_;
2242 if ($self->naming->{monikers} eq 'v4') {
2243 return join '', map ucfirst, split /[\W_]+/, lc $table;
2245 elsif ($self->naming->{monikers} eq 'v5') {
2246 return join '', map ucfirst, split /[\W_]+/,
2247 Lingua::EN::Inflect::Number::to_S(lc $table);
2249 elsif ($self->naming->{monikers} eq 'v6') {
2250 (my $as_phrase = lc $table) =~ s/_+/ /g;
2251 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2253 return join '', map ucfirst, split /\W+/, $inflected;
2256 my @words = map lc, split_name $table;
2257 my $as_phrase = join ' ', @words;
2259 my $inflected = $self->naming->{monikers} eq 'plural' ?
2260 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2262 $self->naming->{monikers} eq 'preserve' ?
2265 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2267 return join '', map ucfirst, split /\W+/, $inflected;
2270 sub _table2moniker {
2271 my ( $self, $table ) = @_;
2273 $self->_run_user_map(
2275 sub { $self->_default_table2moniker( shift ) },
2280 sub _load_relationships {
2281 my ($self, $tables) = @_;
2285 foreach my $table (@$tables) {
2286 my $tbl_fk_info = $self->_table_fk_info($table);
2287 foreach my $fkdef (@$tbl_fk_info) {
2288 $fkdef->{remote_source} =
2289 $self->monikers->{delete $fkdef->{remote_table}};
2291 my $tbl_uniq_info = $self->_table_uniq_info($table);
2293 my $local_moniker = $self->monikers->{$table};
2295 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2298 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2300 foreach my $src_class (sort keys %$rel_stmts) {
2302 my @src_stmts = map $_->[1],
2303 sort { $a->[0] cmp $b->[0] }
2304 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2306 foreach my $stmt (@src_stmts) {
2307 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2313 my ($self, $table) = @_;
2315 my $table_moniker = $self->monikers->{$table};
2316 my $table_class = $self->classes->{$table};
2318 my @roles = @{ $self->result_roles || [] };
2319 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2320 if exists $self->result_roles_map->{$table_moniker};
2323 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2325 $self->_with($table_class, @roles);
2329 # Overload these in driver class:
2331 # Returns an arrayref of column names
2332 sub _table_columns { croak "ABSTRACT METHOD" }
2334 # Returns arrayref of pk col names
2335 sub _table_pk_info { croak "ABSTRACT METHOD" }
2337 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2338 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2340 # Returns an arrayref of foreign key constraints, each
2341 # being a hashref with 3 keys:
2342 # local_columns (arrayref), remote_columns (arrayref), remote_table
2343 sub _table_fk_info { croak "ABSTRACT METHOD" }
2345 # Returns an array of lower case table names
2346 sub _tables_list { croak "ABSTRACT METHOD" }
2348 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2354 # generate the pod for this statement, storing it with $self->_pod
2355 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2357 my $args = dump(@_);
2358 $args = '(' . $args . ')' if @_ < 2;
2359 my $stmt = $method . $args . q{;};
2361 warn qq|$class\->$stmt\n| if $self->debug;
2362 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2366 sub _make_pod_heading {
2367 my ($self, $class) = @_;
2369 return '' if not $self->generate_pod;
2371 my $table = $self->class_to_table->{$class};
2374 my $pcm = $self->pod_comment_mode;
2375 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2376 $comment = $self->__table_comment($table);
2377 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2378 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2379 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2381 $pod .= "=head1 NAME\n\n";
2383 my $table_descr = $class;
2384 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2386 $pod .= "$table_descr\n\n";
2388 if ($comment and $comment_in_desc) {
2389 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2396 # generates the accompanying pod for a DBIC class method statement,
2397 # storing it with $self->_pod
2403 if ($method eq 'table') {
2405 $table = $$table if ref $table eq 'SCALAR';
2406 $self->_pod($class, "=head1 TABLE: C<$table>");
2407 $self->_pod_cut($class);
2409 elsif ( $method eq 'add_columns' ) {
2410 $self->_pod( $class, "=head1 ACCESSORS" );
2411 my $col_counter = 0;
2413 while( my ($name,$attrs) = splice @cols,0,2 ) {
2415 $self->_pod( $class, '=head2 ' . $name );
2416 $self->_pod( $class,
2418 my $s = $attrs->{$_};
2419 $s = !defined $s ? 'undef' :
2420 length($s) == 0 ? '(empty string)' :
2421 ref($s) eq 'SCALAR' ? $$s :
2422 ref($s) ? dumper_squashed $s :
2423 looks_like_number($s) ? $s : qq{'$s'};
2426 } sort keys %$attrs,
2428 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2429 $self->_pod( $class, $comment );
2432 $self->_pod_cut( $class );
2433 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2434 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2435 my ( $accessor, $rel_class ) = @_;
2436 $self->_pod( $class, "=head2 $accessor" );
2437 $self->_pod( $class, 'Type: ' . $method );
2438 $self->_pod( $class, "Related object: L<$rel_class>" );
2439 $self->_pod_cut( $class );
2440 $self->{_relations_started} { $class } = 1;
2442 elsif ($method eq 'add_unique_constraint') {
2443 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2444 unless $self->{_uniqs_started}{$class};
2446 my ($name, $cols) = @_;
2448 $self->_pod($class, "=head2 C<$name>");
2449 $self->_pod($class, '=over 4');
2451 foreach my $col (@$cols) {
2452 $self->_pod($class, "=item \* L</$col>");
2455 $self->_pod($class, '=back');
2456 $self->_pod_cut($class);
2458 $self->{_uniqs_started}{$class} = 1;
2460 elsif ($method eq 'set_primary_key') {
2461 $self->_pod($class, "=head1 PRIMARY KEY");
2462 $self->_pod($class, '=over 4');
2464 foreach my $col (@_) {
2465 $self->_pod($class, "=item \* L</$col>");
2468 $self->_pod($class, '=back');
2469 $self->_pod_cut($class);
2473 sub _pod_class_list {
2474 my ($self, $class, $title, @classes) = @_;
2476 return unless @classes && $self->generate_pod;
2478 $self->_pod($class, "=head1 $title");
2479 $self->_pod($class, '=over 4');
2481 foreach my $link (@classes) {
2482 $self->_pod($class, "=item * L<$link>");
2485 $self->_pod($class, '=back');
2486 $self->_pod_cut($class);
2489 sub _base_class_pod {
2490 my ($self, $base_class) = @_;
2492 return unless $self->generate_pod;
2495 =head1 BASE CLASS: L<$base_class>
2502 sub _filter_comment {
2503 my ($self, $txt) = @_;
2505 $txt = '' if not defined $txt;
2507 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2512 sub __table_comment {
2515 if (my $code = $self->can('_table_comment')) {
2516 return $self->_filter_comment($self->$code(@_));
2522 sub __column_comment {
2525 if (my $code = $self->can('_column_comment')) {
2526 return $self->_filter_comment($self->$code(@_));
2532 # Stores a POD documentation
2534 my ($self, $class, $stmt) = @_;
2535 $self->_raw_stmt( $class, "\n" . $stmt );
2539 my ($self, $class ) = @_;
2540 $self->_raw_stmt( $class, "\n=cut\n" );
2543 # Store a raw source line for a class (for dumping purposes)
2545 my ($self, $class, $stmt) = @_;
2546 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2549 # Like above, but separately for the externally loaded stuff
2551 my ($self, $class, $stmt) = @_;
2552 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2555 sub _custom_column_info {
2556 my ( $self, $table_name, $column_name, $column_info ) = @_;
2558 if (my $code = $self->custom_column_info) {
2559 return $code->($table_name, $column_name, $column_info) || {};
2564 sub _datetime_column_info {
2565 my ( $self, $table_name, $column_name, $column_info ) = @_;
2567 my $type = $column_info->{data_type} || '';
2568 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2569 or ($type =~ /date|timestamp/i)) {
2570 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2571 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2577 my ($self, $name) = @_;
2579 return $self->preserve_case ? $name : lc($name);
2583 my ($self, $name) = @_;
2585 return $self->preserve_case ? $name : uc($name);
2588 sub _unregister_source_for_table {
2589 my ($self, $table) = @_;
2593 my $schema = $self->schema;
2594 # in older DBIC it's a private method
2595 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2596 $schema->$unregister($self->_table2moniker($table));
2597 delete $self->monikers->{$table};
2598 delete $self->classes->{$table};
2599 delete $self->_upgrading_classes->{$table};
2600 delete $self->{_tables}{$table};
2604 # remove the dump dir from @INC on destruction
2608 @INC = grep $_ ne $self->dump_directory, @INC;
2613 Returns a hashref of loaded table to moniker mappings. There will
2614 be two entries for each table, the original name and the "normalized"
2615 name, in the case that the two are different (such as databases
2616 that like uppercase table names, or preserve your original mixed-case
2617 definitions, or what-have-you).
2621 Returns a hashref of table to class mappings. In some cases it will
2622 contain multiple entries per table for the original and normalized table
2623 names, as above in L</monikers>.
2625 =head1 COLUMN ACCESSOR COLLISIONS
2627 Occasionally you may have a column name that collides with a perl method, such
2628 as C<can>. In such cases, the default action is to set the C<accessor> of the
2629 column spec to C<undef>.
2631 You can then name the accessor yourself by placing code such as the following
2634 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2636 Another option is to use the L</col_collision_map> option.
2638 =head1 RELATIONSHIP NAME COLLISIONS
2640 In very rare cases, you may get a collision between a generated relationship
2641 name and a method in your Result class, for example if you have a foreign key
2642 called C<belongs_to>.
2644 This is a problem because relationship names are also relationship accessor
2645 methods in L<DBIx::Class>.
2647 The default behavior is to append C<_rel> to the relationship name and print
2648 out a warning that refers to this text.
2650 You can also control the renaming with the L</rel_collision_map> option.
2654 L<DBIx::Class::Schema::Loader>
2658 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2662 This library is free software; you can redistribute it and/or modify it under
2663 the same terms as Perl itself.
2668 # vim:et sts=4 sw=4 tw=0: