1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use DBIx::Class::Schema::Loader::RelBuilder;
9 use Data::Dump qw/ dump /;
14 use Lingua::EN::Inflect::Number qw//;
15 use Lingua::EN::Inflect::Phrase qw//;
18 use Class::Inspector ();
19 use Scalar::Util 'looks_like_number';
20 use File::Slurp 'read_file';
21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
25 use Encode qw/encode/;
28 our $VERSION = '0.07010';
30 __PACKAGE__->mk_group_ro_accessors('simple', qw/
37 additional_base_classes
52 default_resultset_class
57 overwrite_modifications
78 __PACKAGE__->mk_group_accessors('simple', qw/
80 schema_version_to_dump
82 _upgrading_from_load_classes
83 _downgrading_to_load_classes
84 _rewriting_result_namespace
89 pod_comment_spillover_length
96 datetime_undef_if_invalid
103 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
107 See L<DBIx::Class::Schema::Loader>
111 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
112 classes, and implements the common functionality between them.
114 =head1 CONSTRUCTOR OPTIONS
116 These constructor options are the base options for
117 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
119 =head2 skip_relationships
121 Skip setting up relationships. The default is to attempt the loading
124 =head2 skip_load_external
126 Skip loading of other classes in @INC. The default is to merge all other classes
127 with the same name found in @INC into the schema file we are creating.
131 Static schemas (ones dumped to disk) will, by default, use the new-style
132 relationship names and singularized Results, unless you're overwriting an
133 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
134 which case the backward compatible RelBuilder will be activated, and the
135 appropriate monikerization used.
141 will disable the backward-compatible RelBuilder and use
142 the new-style relationship names along with singularized Results, even when
143 overwriting a dump made with an earlier version.
145 The option also takes a hashref:
147 naming => { relationships => 'v7', monikers => 'v7' }
155 How to name relationship accessors.
159 How to name Result classes.
161 =item column_accessors
163 How to name column accessors in Result classes.
173 Latest style, whatever that happens to be.
177 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
181 Monikers singularized as whole words, C<might_have> relationships for FKs on
182 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
184 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
189 All monikers and relationships are inflected using
190 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
191 from relationship names.
193 In general, there is very little difference between v5 and v6 schemas.
197 This mode is identical to C<v6> mode, except that monikerization of CamelCase
198 table names is also done correctly.
200 CamelCase column names in case-preserving mode will also be handled correctly
201 for relationship name inflection. See L</preserve_case>.
203 In this mode, CamelCase L</column_accessors> are normalized based on case
204 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
206 If you don't have any CamelCase table or column names, you can upgrade without
207 breaking any of your code.
211 For L</monikers>, this option does not inflect the table names but makes
212 monikers based on the actual name. For L</column_accessors> this option does
213 not normalize CamelCase column names to lowercase column accessors, but makes
214 accessors that are the same names as the columns (with any non-\w chars
215 replaced with underscores.)
219 For L</monikers>, singularizes the names using the most current inflector. This
220 is the same as setting the option to L</current>.
224 For L</monikers>, pluralizes the names, using the most current inflector.
228 Dynamic schemas will always default to the 0.04XXX relationship names and won't
229 singularize Results for backward compatibility, to activate the new RelBuilder
230 and singularization put this in your C<Schema.pm> file:
232 __PACKAGE__->naming('current');
234 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
235 next major version upgrade:
237 __PACKAGE__->naming('v7');
241 By default POD will be generated for columns and relationships, using database
242 metadata for the text if available and supported.
244 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
245 supported for Postgres right now.
247 Set this to C<0> to turn off all POD generation.
249 =head2 pod_comment_mode
251 Controls where table comments appear in the generated POD. Smaller table
252 comments are appended to the C<NAME> section of the documentation, and larger
253 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
254 section to be generated with the comment always, only use C<NAME>, or choose
255 the length threshold at which the comment is forced into the description.
261 Use C<NAME> section only.
265 Force C<DESCRIPTION> always.
269 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
274 =head2 pod_comment_spillover_length
276 When pod_comment_mode is set to C<auto>, this is the length of the comment at
277 which it will be forced into a separate description section.
281 =head2 relationship_attrs
283 Hashref of attributes to pass to each generated relationship, listed
284 by type. Also supports relationship type 'all', containing options to
285 pass to all generated relationships. Attributes set for more specific
286 relationship types override those set in 'all'.
290 relationship_attrs => {
291 belongs_to => { is_deferrable => 0 },
294 use this to turn off DEFERRABLE on your foreign key constraints.
298 If set to true, each constructive L<DBIx::Class> statement the loader
299 decides to execute will be C<warn>-ed before execution.
303 Set the name of the schema to load (schema in the sense that your database
304 vendor means it). Does not currently support loading more than one schema
309 Only load tables matching regex. Best specified as a qr// regex.
313 Exclude tables matching regex. Best specified as a qr// regex.
317 Overrides the default table name to moniker translation. Can be either
318 a hashref of table keys and moniker values, or a coderef for a translator
319 function taking a single scalar table name argument and returning
320 a scalar moniker. If the hash entry does not exist, or the function
321 returns a false value, the code falls back to default behavior
324 The default behavior is to split on case transition and non-alphanumeric
325 boundaries, singularize the resulting phrase, then join the titlecased words
328 Table Name | Moniker Name
329 ---------------------------------
331 luser_group | LuserGroup
332 luser-opts | LuserOpt
333 stations_visited | StationVisited
334 routeChange | RouteChange
336 =head2 col_accessor_map
338 Same as moniker_map, but for column accessor names. If a coderef is
339 passed, the code is called with arguments of
341 the name of the column in the underlying database,
342 default accessor name that DBICSL would ordinarily give this column,
344 table_class => name of the DBIC class we are building,
345 table_moniker => calculated moniker for this table (after moniker_map if present),
346 table_name => name of the database table,
347 full_table_name => schema-qualified name of the database table (RDBMS specific),
348 schema_class => name of the schema class we are building,
349 column_info => hashref of column info (data_type, is_nullable, etc),
352 =head2 inflect_plural
354 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
355 if hash key does not exist or coderef returns false), but acts as a map
356 for pluralizing relationship names. The default behavior is to utilize
357 L<Lingua::EN::Inflect::Phrase/to_PL>.
359 =head2 inflect_singular
361 As L</inflect_plural> above, but for singularizing relationship names.
362 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
364 =head2 schema_base_class
366 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
368 =head2 result_base_class
370 Base class for your table classes (aka result classes). Defaults to
373 =head2 additional_base_classes
375 List of additional base classes all of your table classes will use.
377 =head2 left_base_classes
379 List of additional base classes all of your table classes will use
380 that need to be leftmost.
382 =head2 additional_classes
384 List of additional classes which all of your table classes will use.
388 List of additional components to be loaded into all of your table
389 classes. A good example would be
390 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
392 =head2 result_components_map
394 A hashref of moniker keys and component values. Unlike L</components>, which
395 loads the given components into every Result class, this option allows you to
396 load certain components for specified Result classes. For example:
398 result_components_map => {
399 StationVisited => '+YourApp::Schema::Component::StationVisited',
401 '+YourApp::Schema::Component::RouteChange',
402 'InflateColumn::DateTime',
406 You may use this in conjunction with L</components>.
410 List of L<Moose> roles to be applied to all of your Result classes.
412 =head2 result_roles_map
414 A hashref of moniker keys and role values. Unlike L</result_roles>, which
415 applies the given roles to every Result class, this option allows you to apply
416 certain roles for specified Result classes. For example:
418 result_roles_map => {
420 'YourApp::Role::Building',
421 'YourApp::Role::Destination',
423 RouteChange => 'YourApp::Role::TripEvent',
426 You may use this in conjunction with L</result_roles>.
428 =head2 use_namespaces
430 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
433 Generate result class names suitable for
434 L<DBIx::Class::Schema/load_namespaces> and call that instead of
435 L<DBIx::Class::Schema/load_classes>. When using this option you can also
436 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
437 C<resultset_namespace>, C<default_resultset_class>), and they will be added
438 to the call (and the generated result class names adjusted appropriately).
440 =head2 dump_directory
442 The value of this option is a perl libdir pathname. Within
443 that directory this module will create a baseline manual
444 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
446 The created schema class will have the same classname as the one on
447 which you are setting this option (and the ResultSource classes will be
448 based on this name as well).
450 Normally you wouldn't hard-code this setting in your schema class, as it
451 is meant for one-time manual usage.
453 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
454 recommended way to access this functionality.
456 =head2 dump_overwrite
458 Deprecated. See L</really_erase_my_files> below, which does *not* mean
459 the same thing as the old C<dump_overwrite> setting from previous releases.
461 =head2 really_erase_my_files
463 Default false. If true, Loader will unconditionally delete any existing
464 files before creating the new ones from scratch when dumping a schema to disk.
466 The default behavior is instead to only replace the top portion of the
467 file, up to and including the final stanza which contains
468 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
469 leaving any customizations you placed after that as they were.
471 When C<really_erase_my_files> is not set, if the output file already exists,
472 but the aforementioned final stanza is not found, or the checksum
473 contained there does not match the generated contents, Loader will
474 croak and not touch the file.
476 You should really be using version control on your schema classes (and all
477 of the rest of your code for that matter). Don't blame me if a bug in this
478 code wipes something out when it shouldn't have, you've been warned.
480 =head2 overwrite_modifications
482 Default false. If false, when updating existing files, Loader will
483 refuse to modify any Loader-generated code that has been modified
484 since its last run (as determined by the checksum Loader put in its
487 If true, Loader will discard any manual modifications that have been
488 made to Loader-generated code.
490 Again, you should be using version control on your schema classes. Be
491 careful with this option.
493 =head2 custom_column_info
495 Hook for adding extra attributes to the
496 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
498 Must be a coderef that returns a hashref with the extra attributes.
500 Receives the table name, column name and column_info.
504 custom_column_info => sub {
505 my ($table_name, $column_name, $column_info) = @_;
507 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
508 return { is_snoopy => 1 };
512 This attribute can also be used to set C<inflate_datetime> on a non-datetime
513 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
515 =head2 datetime_timezone
517 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
518 columns with the DATE/DATETIME/TIMESTAMP data_types.
520 =head2 datetime_locale
522 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
523 columns with the DATE/DATETIME/TIMESTAMP data_types.
525 =head2 datetime_undef_if_invalid
527 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
528 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
531 The default is recommended to deal with data such as C<00/00/00> which
532 sometimes ends up in such columns in MySQL.
536 File in Perl format, which should return a HASH reference, from which to read
541 Usually column names are lowercased, to make them easier to work with in
542 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
545 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
546 case-sensitive collation will turn this option on unconditionally.
548 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
551 =head2 qualify_objects
553 Set to true to prepend the L</db_schema> to table names for C<<
554 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
558 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
559 L<namespace::autoclean>. The default content after the md5 sum also makes the
562 It is safe to upgrade your existing Schema to this option.
564 =head2 col_collision_map
566 This option controls how accessors for column names which collide with perl
567 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
569 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
570 strings which are compiled to regular expressions that map to
571 L<sprintf|perlfunc/sprintf> formats.
575 col_collision_map => 'column_%s'
577 col_collision_map => { '(.*)' => 'column_%s' }
579 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
581 =head2 rel_collision_map
583 Works just like L</col_collision_map>, but for relationship names/accessors
584 rather than column names/accessors.
586 The default is to just append C<_rel> to the relationship name, see
587 L</RELATIONSHIP NAME COLLISIONS>.
591 None of these methods are intended for direct invocation by regular
592 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
593 L<DBIx::Class::Schema::Loader>.
597 my $CURRENT_V = 'v7';
600 schema_base_class result_base_class additional_base_classes
601 left_base_classes additional_classes components result_roles
604 # ensure that a peice of object data is a valid arrayref, creating
605 # an empty one or encapsulating whatever's there.
606 sub _ensure_arrayref {
611 $self->{$_} = [ $self->{$_} ]
612 unless ref $self->{$_} eq 'ARRAY';
618 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
619 by L<DBIx::Class::Schema::Loader>.
624 my ( $class, %args ) = @_;
626 if (exists $args{column_accessor_map}) {
627 $args{col_accessor_map} = delete $args{column_accessor_map};
630 my $self = { %args };
632 # don't lose undef options
633 for (values %$self) {
634 $_ = 0 unless defined $_;
637 bless $self => $class;
639 if (my $config_file = $self->config_file) {
640 my $config_opts = do $config_file;
642 croak "Error reading config from $config_file: $@" if $@;
644 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
646 while (my ($k, $v) = each %$config_opts) {
647 $self->{$k} = $v unless exists $self->{$k};
651 $self->result_components_map($self->{result_component_map})
652 if defined $self->{result_component_map};
654 $self->result_roles_map($self->{result_role_map})
655 if defined $self->{result_role_map};
657 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
658 if ((not defined $self->use_moose) || (not $self->use_moose))
659 && ((defined $self->result_roles) || (defined $self->result_roles_map));
661 $self->_ensure_arrayref(qw/additional_classes
662 additional_base_classes
668 $self->_validate_class_args;
670 croak "result_components_map must be a hash"
671 if defined $self->result_components_map
672 && ref $self->result_components_map ne 'HASH';
674 if ($self->result_components_map) {
675 my %rc_map = %{ $self->result_components_map };
676 foreach my $moniker (keys %rc_map) {
677 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
679 $self->result_components_map(\%rc_map);
682 $self->result_components_map({});
684 $self->_validate_result_components_map;
686 croak "result_roles_map must be a hash"
687 if defined $self->result_roles_map
688 && ref $self->result_roles_map ne 'HASH';
690 if ($self->result_roles_map) {
691 my %rr_map = %{ $self->result_roles_map };
692 foreach my $moniker (keys %rr_map) {
693 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
695 $self->result_roles_map(\%rr_map);
697 $self->result_roles_map({});
699 $self->_validate_result_roles_map;
701 if ($self->use_moose) {
702 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
703 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
704 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
708 $self->{monikers} = {};
709 $self->{tables} = {};
710 $self->{class_to_table} = {};
711 $self->{classes} = {};
712 $self->{_upgrading_classes} = {};
714 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
715 $self->{schema} ||= $self->{schema_class};
717 croak "dump_overwrite is deprecated. Please read the"
718 . " DBIx::Class::Schema::Loader::Base documentation"
719 if $self->{dump_overwrite};
721 $self->{dynamic} = ! $self->{dump_directory};
722 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
727 $self->{dump_directory} ||= $self->{temp_directory};
729 $self->real_dump_directory($self->{dump_directory});
731 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
732 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
734 if (not defined $self->naming) {
735 $self->naming_set(0);
738 $self->naming_set(1);
741 if ((not ref $self->naming) && defined $self->naming) {
742 my $naming_ver = $self->naming;
744 relationships => $naming_ver,
745 monikers => $naming_ver,
746 column_accessors => $naming_ver,
751 for (values %{ $self->naming }) {
752 $_ = $CURRENT_V if $_ eq 'current';
755 $self->{naming} ||= {};
757 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
758 croak 'custom_column_info must be a CODE ref';
761 $self->_check_back_compat;
763 $self->use_namespaces(1) unless defined $self->use_namespaces;
764 $self->generate_pod(1) unless defined $self->generate_pod;
765 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
766 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
768 if (my $col_collision_map = $self->col_collision_map) {
769 if (my $reftype = ref $col_collision_map) {
770 if ($reftype ne 'HASH') {
771 croak "Invalid type $reftype for option 'col_collision_map'";
775 $self->col_collision_map({ '(.*)' => $col_collision_map });
782 sub _check_back_compat {
785 # dynamic schemas will always be in 0.04006 mode, unless overridden
786 if ($self->dynamic) {
787 # just in case, though no one is likely to dump a dynamic schema
788 $self->schema_version_to_dump('0.04006');
790 if (not $self->naming_set) {
791 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
793 Dynamic schema detected, will run in 0.04006 mode.
795 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
796 to disable this warning.
798 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
803 $self->_upgrading_from('v4');
806 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
807 $self->use_namespaces(1);
810 $self->naming->{relationships} ||= 'v4';
811 $self->naming->{monikers} ||= 'v4';
813 if ($self->use_namespaces) {
814 $self->_upgrading_from_load_classes(1);
817 $self->use_namespaces(0);
823 # otherwise check if we need backcompat mode for a static schema
824 my $filename = $self->get_dump_filename($self->schema_class);
825 return unless -e $filename;
827 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
828 $self->_parse_generated_file($filename);
830 return unless $old_ver;
832 # determine if the existing schema was dumped with use_moose => 1
833 if (! defined $self->use_moose) {
834 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
837 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
839 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
840 my $ds = eval $result_namespace;
842 Could not eval expression '$result_namespace' for result_namespace from
845 $result_namespace = $ds || '';
847 if ($load_classes && (not defined $self->use_namespaces)) {
848 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
850 'load_classes;' static schema detected, turning off 'use_namespaces'.
852 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
853 variable to disable this warning.
855 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
858 $self->use_namespaces(0);
860 elsif ($load_classes && $self->use_namespaces) {
861 $self->_upgrading_from_load_classes(1);
863 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
864 $self->_downgrading_to_load_classes(
865 $result_namespace || 'Result'
868 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
869 if (not $self->result_namespace) {
870 $self->result_namespace($result_namespace || 'Result');
872 elsif ($result_namespace ne $self->result_namespace) {
873 $self->_rewriting_result_namespace(
874 $result_namespace || 'Result'
879 # XXX when we go past .0 this will need fixing
880 my ($v) = $old_ver =~ /([1-9])/;
883 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
885 if (not %{ $self->naming }) {
886 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
888 Version $old_ver static schema detected, turning on backcompat mode.
890 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
891 to disable this warning.
893 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
895 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
896 from version 0.04006.
899 $self->naming->{relationships} ||= $v;
900 $self->naming->{monikers} ||= $v;
901 $self->naming->{column_accessors} ||= $v;
903 $self->schema_version_to_dump($old_ver);
906 $self->_upgrading_from($v);
910 sub _validate_class_args {
913 foreach my $k (@CLASS_ARGS) {
914 next unless $self->$k;
916 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
917 $self->_validate_classes($k, \@classes);
921 sub _validate_result_components_map {
924 foreach my $classes (values %{ $self->result_components_map }) {
925 $self->_validate_classes('result_components_map', $classes);
929 sub _validate_result_roles_map {
932 foreach my $classes (values %{ $self->result_roles_map }) {
933 $self->_validate_classes('result_roles_map', $classes);
937 sub _validate_classes {
942 # make a copy to not destroy original
943 my @classes = @$classes;
945 foreach my $c (@classes) {
946 # components default to being under the DBIx::Class namespace unless they
947 # are preceeded with a '+'
948 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
949 $c = 'DBIx::Class::' . $c;
952 # 1 == installed, 0 == not installed, undef == invalid classname
953 my $installed = Class::Inspector->installed($c);
954 if ( defined($installed) ) {
955 if ( $installed == 0 ) {
956 croak qq/$c, as specified in the loader option "$key", is not installed/;
959 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
965 sub _find_file_in_inc {
966 my ($self, $file) = @_;
968 foreach my $prefix (@INC) {
969 my $fullpath = File::Spec->catfile($prefix, $file);
970 return $fullpath if -f $fullpath
971 # abs_path throws on Windows for nonexistant files
972 and (try { Cwd::abs_path($fullpath) }) ne
973 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
979 sub _find_class_in_inc {
980 my ($self, $class) = @_;
982 return $self->_find_file_in_inc(class_path($class));
988 return $self->_upgrading_from
989 || $self->_upgrading_from_load_classes
990 || $self->_downgrading_to_load_classes
991 || $self->_rewriting_result_namespace
995 sub _rewrite_old_classnames {
996 my ($self, $code) = @_;
998 return $code unless $self->_rewriting;
1000 my %old_classes = reverse %{ $self->_upgrading_classes };
1002 my $re = join '|', keys %old_classes;
1003 $re = qr/\b($re)\b/;
1005 $code =~ s/$re/$old_classes{$1} || $1/eg;
1010 sub _load_external {
1011 my ($self, $class) = @_;
1013 return if $self->{skip_load_external};
1015 # so that we don't load our own classes, under any circumstances
1016 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1018 my $real_inc_path = $self->_find_class_in_inc($class);
1020 my $old_class = $self->_upgrading_classes->{$class}
1021 if $self->_rewriting;
1023 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1024 if $old_class && $old_class ne $class;
1026 return unless $real_inc_path || $old_real_inc_path;
1028 if ($real_inc_path) {
1029 # If we make it to here, we loaded an external definition
1030 warn qq/# Loaded external class definition for '$class'\n/
1033 my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)'));
1035 if ($self->dynamic) { # load the class too
1036 eval_package_without_redefine_warnings($class, $code);
1039 $self->_ext_stmt($class,
1040 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1041 .qq|# They are now part of the custom portion of this file\n|
1042 .qq|# for you to hand-edit. If you do not either delete\n|
1043 .qq|# this section or remove that file from \@INC, this section\n|
1044 .qq|# will be repeated redundantly when you re-create this\n|
1045 .qq|# file again via Loader! See skip_load_external to disable\n|
1046 .qq|# this feature.\n|
1049 $self->_ext_stmt($class, $code);
1050 $self->_ext_stmt($class,
1051 qq|# End of lines loaded from '$real_inc_path' |
1055 if ($old_real_inc_path) {
1056 my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)');
1058 $self->_ext_stmt($class, <<"EOF");
1060 # These lines were loaded from '$old_real_inc_path',
1061 # based on the Result class name that would have been created by an older
1062 # version of the Loader. For a static schema, this happens only once during
1063 # upgrade. See skip_load_external to disable this feature.
1066 $code = $self->_rewrite_old_classnames($code);
1068 if ($self->dynamic) {
1071 Detected external content in '$old_real_inc_path', a class name that would have
1072 been used by an older version of the Loader.
1074 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1075 new name of the Result.
1077 eval_package_without_redefine_warnings($class, $code);
1081 $self->_ext_stmt($class, $code);
1082 $self->_ext_stmt($class,
1083 qq|# End of lines loaded from '$old_real_inc_path' |
1090 Does the actual schema-construction work.
1097 $self->_load_tables(
1098 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1106 Rescan the database for changes. Returns a list of the newly added table
1109 The schema argument should be the schema class or object to be affected. It
1110 should probably be derived from the original schema_class used during L</load>.
1115 my ($self, $schema) = @_;
1117 $self->{schema} = $schema;
1118 $self->_relbuilder->{schema} = $schema;
1121 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1123 foreach my $table (@current) {
1124 if(!exists $self->{_tables}->{$table}) {
1125 push(@created, $table);
1130 @current{@current} = ();
1131 foreach my $table (keys %{ $self->{_tables} }) {
1132 if (not exists $current{$table}) {
1133 $self->_unregister_source_for_table($table);
1137 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1139 my $loaded = $self->_load_tables(@current);
1141 return map { $self->monikers->{$_} } @created;
1147 return if $self->{skip_relationships};
1149 return $self->{relbuilder} ||= do {
1151 no warnings 'uninitialized';
1152 my $relbuilder_suff =
1158 ->{ $self->naming->{relationships}};
1160 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1161 $self->ensure_class_loaded($relbuilder_class);
1162 $relbuilder_class->new( $self );
1168 my ($self, @tables) = @_;
1170 # Save the new tables to the tables list
1172 $self->{_tables}->{$_} = 1;
1175 $self->_make_src_class($_) for @tables;
1177 # sanity-check for moniker clashes
1178 my $inverse_moniker_idx;
1179 for (keys %{$self->monikers}) {
1180 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1184 for (keys %$inverse_moniker_idx) {
1185 my $tables = $inverse_moniker_idx->{$_};
1187 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1188 join (', ', map { "'$_'" } @$tables),
1195 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1196 . 'Either change the naming style, or supply an explicit moniker_map: '
1197 . join ('; ', @clashes)
1203 $self->_setup_src_meta($_) for @tables;
1205 if(!$self->skip_relationships) {
1206 # The relationship loader needs a working schema
1208 local $self->{dump_directory} = $self->{temp_directory};
1209 $self->_reload_classes(\@tables);
1210 $self->_load_relationships(\@tables);
1213 # Remove that temp dir from INC so it doesn't get reloaded
1214 @INC = grep $_ ne $self->dump_directory, @INC;
1217 $self->_load_roles($_) for @tables;
1219 $self->_load_external($_)
1220 for map { $self->classes->{$_} } @tables;
1222 # Reload without unloading first to preserve any symbols from external
1224 $self->_reload_classes(\@tables, { unload => 0 });
1226 # Drop temporary cache
1227 delete $self->{_cache};
1232 sub _reload_classes {
1233 my ($self, $tables, $opts) = @_;
1235 my @tables = @$tables;
1237 my $unload = $opts->{unload};
1238 $unload = 1 unless defined $unload;
1240 # so that we don't repeat custom sections
1241 @INC = grep $_ ne $self->dump_directory, @INC;
1243 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1245 unshift @INC, $self->dump_directory;
1248 my %have_source = map { $_ => $self->schema->source($_) }
1249 $self->schema->sources;
1251 for my $table (@tables) {
1252 my $moniker = $self->monikers->{$table};
1253 my $class = $self->classes->{$table};
1256 no warnings 'redefine';
1257 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1260 if (my $mc = $self->_moose_metaclass($class)) {
1263 Class::Unload->unload($class) if $unload;
1264 my ($source, $resultset_class);
1266 ($source = $have_source{$moniker})
1267 && ($resultset_class = $source->resultset_class)
1268 && ($resultset_class ne 'DBIx::Class::ResultSet')
1270 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1271 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1274 Class::Unload->unload($resultset_class) if $unload;
1275 $self->_reload_class($resultset_class) if $has_file;
1277 $self->_reload_class($class);
1279 push @to_register, [$moniker, $class];
1282 Class::C3->reinitialize;
1283 for (@to_register) {
1284 $self->schema->register_class(@$_);
1288 sub _moose_metaclass {
1289 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1293 my $mc = try { Class::MOP::class_of($class) }
1296 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1299 # We use this instead of ensure_class_loaded when there are package symbols we
1302 my ($self, $class) = @_;
1304 delete $INC{ +class_path($class) };
1307 eval_package_without_redefine_warnings ($class, "require $class");
1310 my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)');
1311 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1315 sub _get_dump_filename {
1316 my ($self, $class) = (@_);
1318 $class =~ s{::}{/}g;
1319 return $self->dump_directory . q{/} . $class . q{.pm};
1322 =head2 get_dump_filename
1326 Returns the full path to the file for a class that the class has been or will
1327 be dumped to. This is a file in a temp dir for a dynamic schema.
1331 sub get_dump_filename {
1332 my ($self, $class) = (@_);
1334 local $self->{dump_directory} = $self->real_dump_directory;
1336 return $self->_get_dump_filename($class);
1339 sub _ensure_dump_subdirs {
1340 my ($self, $class) = (@_);
1342 my @name_parts = split(/::/, $class);
1343 pop @name_parts; # we don't care about the very last element,
1344 # which is a filename
1346 my $dir = $self->dump_directory;
1349 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1351 last if !@name_parts;
1352 $dir = File::Spec->catdir($dir, shift @name_parts);
1357 my ($self, @classes) = @_;
1359 my $schema_class = $self->schema_class;
1360 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1362 my $target_dir = $self->dump_directory;
1363 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1364 unless $self->{dynamic} or $self->{quiet};
1367 qq|package $schema_class;\n\n|
1368 . qq|# Created by DBIx::Class::Schema::Loader\n|
1369 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1371 if ($self->use_moose) {
1372 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1375 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1378 if ($self->use_namespaces) {
1379 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1380 my $namespace_options;
1382 my @attr = qw/resultset_namespace default_resultset_class/;
1384 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1386 for my $attr (@attr) {
1388 my $code = dumper_squashed $self->$attr;
1389 $namespace_options .= qq| $attr => $code,\n|
1392 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1393 $schema_text .= qq|;\n|;
1396 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1400 local $self->{version_to_dump} = $self->schema_version_to_dump;
1401 $self->_write_classfile($schema_class, $schema_text, 1);
1404 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1406 foreach my $src_class (@classes) {
1408 qq|package $src_class;\n\n|
1409 . qq|# Created by DBIx::Class::Schema::Loader\n|
1410 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1412 $src_text .= $self->_make_pod_heading($src_class);
1414 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1416 $src_text .= $self->_base_class_pod($result_base_class)
1417 unless $result_base_class eq 'DBIx::Class::Core';
1419 if ($self->use_moose) {
1420 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1422 # these options 'use base' which is compile time
1423 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1424 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1427 $src_text .= qq|\nextends '$result_base_class';\n|;
1431 $src_text .= qq|use base '$result_base_class';\n|;
1434 $self->_write_classfile($src_class, $src_text);
1437 # remove Result dir if downgrading from use_namespaces, and there are no
1439 if (my $result_ns = $self->_downgrading_to_load_classes
1440 || $self->_rewriting_result_namespace) {
1441 my $result_namespace = $self->_result_namespace(
1446 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1447 $result_dir = $self->dump_directory . '/' . $result_dir;
1449 unless (my @files = glob "$result_dir/*") {
1454 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1459 my ($self, $version, $ts) = @_;
1460 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1463 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1466 sub _write_classfile {
1467 my ($self, $class, $text, $is_schema) = @_;
1469 my $filename = $self->_get_dump_filename($class);
1470 $self->_ensure_dump_subdirs($class);
1472 if (-f $filename && $self->really_erase_my_files) {
1473 warn "Deleting existing file '$filename' due to "
1474 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1478 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1479 = $self->_parse_generated_file($filename);
1481 if (! $old_gen && -f $filename) {
1482 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1483 . " it does not appear to have been generated by Loader"
1486 my $custom_content = $old_custom || '';
1488 # prepend extra custom content from a *renamed* class (singularization effect)
1489 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1490 my $old_filename = $self->_get_dump_filename($renamed_class);
1492 if (-f $old_filename) {
1493 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1495 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1497 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1500 unlink $old_filename;
1504 $custom_content ||= $self->_default_custom_content($is_schema);
1506 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1507 # If there is already custom content, which does not have the Moose content, add it.
1508 if ($self->use_moose) {
1510 my $non_moose_custom_content = do {
1511 local $self->{use_moose} = 0;
1512 $self->_default_custom_content;
1515 if ($custom_content eq $non_moose_custom_content) {
1516 $custom_content = $self->_default_custom_content($is_schema);
1518 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1519 $custom_content .= $self->_default_custom_content($is_schema);
1522 elsif (defined $self->use_moose && $old_gen) {
1523 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'
1524 if $old_gen =~ /use \s+ MooseX?\b/x;
1527 $custom_content = $self->_rewrite_old_classnames($custom_content);
1530 for @{$self->{_dump_storage}->{$class} || []};
1532 # Check and see if the dump is infact differnt
1536 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1537 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1538 return unless $self->_upgrading_from && $is_schema;
1542 $text .= $self->_sig_comment(
1543 $self->version_to_dump,
1544 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1547 open(my $fh, '>:encoding(UTF-8)', $filename)
1548 or croak "Cannot open '$filename' for writing: $!";
1550 # Write the top half and its MD5 sum
1551 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1553 # Write out anything loaded via external partial class file in @INC
1555 for @{$self->{_ext_storage}->{$class} || []};
1557 # Write out any custom content the user has added
1558 print $fh $custom_content;
1561 or croak "Error closing '$filename': $!";
1564 sub _default_moose_custom_content {
1565 my ($self, $is_schema) = @_;
1567 if (not $is_schema) {
1568 return qq|\n__PACKAGE__->meta->make_immutable;|;
1571 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1574 sub _default_custom_content {
1575 my ($self, $is_schema) = @_;
1576 my $default = qq|\n\n# You can replace this text with custom|
1577 . qq| code or comments, and it will be preserved on regeneration|;
1578 if ($self->use_moose) {
1579 $default .= $self->_default_moose_custom_content($is_schema);
1581 $default .= qq|\n1;\n|;
1585 sub _parse_generated_file {
1586 my ($self, $fn) = @_;
1588 return unless -f $fn;
1590 open(my $fh, '<:encoding(UTF-8)', $fn)
1591 or croak "Cannot open '$fn' for reading: $!";
1594 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1596 my ($md5, $ts, $ver, $gen);
1602 # Pull out the version and timestamp from the line above
1603 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1606 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"
1607 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1616 my $custom = do { local $/; <$fh> }
1621 return ($gen, $md5, $ver, $ts, $custom);
1629 warn "$target: use $_;" if $self->debug;
1630 $self->_raw_stmt($target, "use $_;");
1638 my $blist = join(q{ }, @_);
1640 return unless $blist;
1642 warn "$target: use base qw/$blist/;" if $self->debug;
1643 $self->_raw_stmt($target, "use base qw/$blist/;");
1650 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1652 return unless $rlist;
1654 warn "$target: with $rlist;" if $self->debug;
1655 $self->_raw_stmt($target, "\nwith $rlist;");
1658 sub _result_namespace {
1659 my ($self, $schema_class, $ns) = @_;
1660 my @result_namespace;
1662 $ns = $ns->[0] if ref $ns;
1664 if ($ns =~ /^\+(.*)/) {
1665 # Fully qualified namespace
1666 @result_namespace = ($1)
1669 # Relative namespace
1670 @result_namespace = ($schema_class, $ns);
1673 return wantarray ? @result_namespace : join '::', @result_namespace;
1676 # Create class with applicable bases, setup monikers, etc
1677 sub _make_src_class {
1678 my ($self, $table) = @_;
1680 my $schema = $self->schema;
1681 my $schema_class = $self->schema_class;
1683 my $table_moniker = $self->_table2moniker($table);
1684 my @result_namespace = ($schema_class);
1685 if ($self->use_namespaces) {
1686 my $result_namespace = $self->result_namespace || 'Result';
1687 @result_namespace = $self->_result_namespace(
1692 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1694 if ((my $upgrading_v = $self->_upgrading_from)
1695 || $self->_rewriting) {
1696 local $self->naming->{monikers} = $upgrading_v
1699 my @result_namespace = @result_namespace;
1700 if ($self->_upgrading_from_load_classes) {
1701 @result_namespace = ($schema_class);
1703 elsif (my $ns = $self->_downgrading_to_load_classes) {
1704 @result_namespace = $self->_result_namespace(
1709 elsif ($ns = $self->_rewriting_result_namespace) {
1710 @result_namespace = $self->_result_namespace(
1716 my $old_class = join(q{::}, @result_namespace,
1717 $self->_table2moniker($table));
1719 $self->_upgrading_classes->{$table_class} = $old_class
1720 unless $table_class eq $old_class;
1723 $self->classes->{$table} = $table_class;
1724 $self->monikers->{$table} = $table_moniker;
1725 $self->tables->{$table_moniker} = $table;
1726 $self->class_to_table->{$table_class} = $table;
1728 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1730 $self->_use ($table_class, @{$self->additional_classes});
1732 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1734 $self->_inject($table_class, @{$self->left_base_classes});
1736 my @components = @{ $self->components || [] };
1738 push @components, @{ $self->result_components_map->{$table_moniker} }
1739 if exists $self->result_components_map->{$table_moniker};
1741 my @fq_components = @components;
1742 foreach my $component (@fq_components) {
1743 if ($component !~ s/^\+//) {
1744 $component = "DBIx::Class::$component";
1748 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1750 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1752 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1754 $self->_inject($table_class, @{$self->additional_base_classes});
1757 sub _is_result_class_method {
1758 my ($self, $name, $table_name) = @_;
1760 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1762 $self->_result_class_methods({})
1763 if not defined $self->_result_class_methods;
1765 if (not exists $self->_result_class_methods->{$table_moniker}) {
1766 my (@methods, %methods);
1767 my $base = $self->result_base_class || 'DBIx::Class::Core';
1769 my @components = @{ $self->components || [] };
1771 push @components, @{ $self->result_components_map->{$table_moniker} }
1772 if exists $self->result_components_map->{$table_moniker};
1774 for my $c (@components) {
1775 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1778 my @roles = @{ $self->result_roles || [] };
1780 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1781 if exists $self->result_roles_map->{$table_moniker};
1783 for my $class ($base, @components,
1784 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1785 $self->ensure_class_loaded($class);
1787 push @methods, @{ Class::Inspector->methods($class) || [] };
1790 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1792 @methods{@methods} = ();
1794 $self->_result_class_methods->{$table_moniker} = \%methods;
1796 my $result_methods = $self->_result_class_methods->{$table_moniker};
1798 return exists $result_methods->{$name};
1801 sub _resolve_col_accessor_collisions {
1802 my ($self, $table, $col_info) = @_;
1804 my $table_name = ref $table ? $$table : $table;
1806 while (my ($col, $info) = each %$col_info) {
1807 my $accessor = $info->{accessor} || $col;
1809 next if $accessor eq 'id'; # special case (very common column)
1811 if ($self->_is_result_class_method($accessor, $table_name)) {
1814 if (my $map = $self->col_collision_map) {
1815 for my $re (keys %$map) {
1816 if (my @matches = $col =~ /$re/) {
1817 $info->{accessor} = sprintf $map->{$re}, @matches;
1825 Column '$col' in table '$table_name' collides with an inherited method.
1826 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1828 $info->{accessor} = undef;
1834 # use the same logic to run moniker_map, col_accessor_map, and
1835 # relationship_name_map
1837 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1839 my $default_ident = $default_code->( $ident, @extra );
1841 if( $map && ref $map eq 'HASH' ) {
1842 $new_ident = $map->{ $ident };
1844 elsif( $map && ref $map eq 'CODE' ) {
1845 $new_ident = $map->( $ident, $default_ident, @extra );
1848 $new_ident ||= $default_ident;
1853 sub _default_column_accessor_name {
1854 my ( $self, $column_name ) = @_;
1856 my $accessor_name = $column_name;
1857 $accessor_name =~ s/\W+/_/g;
1859 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1860 # older naming just lc'd the col accessor and that's all.
1861 return lc $accessor_name;
1863 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1864 return $accessor_name;
1867 return join '_', map lc, split_name $column_name;
1870 sub _make_column_accessor_name {
1871 my ($self, $column_name, $column_context_info ) = @_;
1873 my $accessor = $self->_run_user_map(
1874 $self->col_accessor_map,
1875 sub { $self->_default_column_accessor_name( shift ) },
1877 $column_context_info,
1884 my ($self, $identifier) = @_;
1886 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1889 return $qt->[0] . $identifier . $qt->[1];
1892 return "${qt}${identifier}${qt}";
1895 # Set up metadata (cols, pks, etc)
1896 sub _setup_src_meta {
1897 my ($self, $table) = @_;
1899 my $schema = $self->schema;
1900 my $schema_class = $self->schema_class;
1902 my $table_class = $self->classes->{$table};
1903 my $table_moniker = $self->monikers->{$table};
1905 my $table_name = $table;
1907 my $sql_maker = $self->schema->storage->sql_maker;
1908 my $name_sep = $sql_maker->name_sep;
1910 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1911 $table_name = \ $self->_quote($table_name);
1914 my $full_table_name = ($self->qualify_objects ?
1915 ($self->_quote($self->db_schema) . '.') : '')
1916 . (ref $table_name ? $$table_name : $table_name);
1918 # be careful to not create refs Data::Dump can "optimize"
1919 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1921 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1923 my $cols = $self->_table_columns($table);
1924 my $col_info = $self->__columns_info_for($table);
1926 ### generate all the column accessor names
1927 while (my ($col, $info) = each %$col_info) {
1928 # hashref of other info that could be used by
1929 # user-defined accessor map functions
1931 table_class => $table_class,
1932 table_moniker => $table_moniker,
1933 table_name => $table_name,
1934 full_table_name => $full_table_name,
1935 schema_class => $schema_class,
1936 column_info => $info,
1939 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1942 $self->_resolve_col_accessor_collisions($table, $col_info);
1944 # prune any redundant accessor names
1945 while (my ($col, $info) = each %$col_info) {
1946 no warnings 'uninitialized';
1947 delete $info->{accessor} if $info->{accessor} eq $col;
1950 my $fks = $self->_table_fk_info($table);
1952 foreach my $fkdef (@$fks) {
1953 for my $col (@{ $fkdef->{local_columns} }) {
1954 $col_info->{$col}{is_foreign_key} = 1;
1958 my $pks = $self->_table_pk_info($table) || [];
1960 foreach my $pkcol (@$pks) {
1961 $col_info->{$pkcol}{is_nullable} = 0;
1967 map { $_, ($col_info->{$_}||{}) } @$cols
1970 my %uniq_tag; # used to eliminate duplicate uniqs
1972 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1973 : carp("$table has no primary key");
1974 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1976 my $uniqs = $self->_table_uniq_info($table) || [];
1978 my ($name, $cols) = @$_;
1979 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1980 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1985 sub __columns_info_for {
1986 my ($self, $table) = @_;
1988 my $result = $self->_columns_info_for($table);
1990 while (my ($col, $info) = each %$result) {
1991 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1992 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1994 $result->{$col} = $info;
2002 Returns a sorted list of loaded tables, using the original database table
2010 return keys %{$self->_tables};
2013 # Make a moniker from a table
2014 sub _default_table2moniker {
2015 no warnings 'uninitialized';
2016 my ($self, $table) = @_;
2018 if ($self->naming->{monikers} eq 'v4') {
2019 return join '', map ucfirst, split /[\W_]+/, lc $table;
2021 elsif ($self->naming->{monikers} eq 'v5') {
2022 return join '', map ucfirst, split /[\W_]+/,
2023 Lingua::EN::Inflect::Number::to_S(lc $table);
2025 elsif ($self->naming->{monikers} eq 'v6') {
2026 (my $as_phrase = lc $table) =~ s/_+/ /g;
2027 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2029 return join '', map ucfirst, split /\W+/, $inflected;
2032 my @words = map lc, split_name $table;
2033 my $as_phrase = join ' ', @words;
2035 my $inflected = $self->naming->{monikers} eq 'plural' ?
2036 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2038 $self->naming->{monikers} eq 'preserve' ?
2041 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2043 return join '', map ucfirst, split /\W+/, $inflected;
2046 sub _table2moniker {
2047 my ( $self, $table ) = @_;
2049 $self->_run_user_map(
2051 sub { $self->_default_table2moniker( shift ) },
2056 sub _load_relationships {
2057 my ($self, $tables) = @_;
2061 foreach my $table (@$tables) {
2062 my $tbl_fk_info = $self->_table_fk_info($table);
2063 foreach my $fkdef (@$tbl_fk_info) {
2064 $fkdef->{remote_source} =
2065 $self->monikers->{delete $fkdef->{remote_table}};
2067 my $tbl_uniq_info = $self->_table_uniq_info($table);
2069 my $local_moniker = $self->monikers->{$table};
2071 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2074 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2076 foreach my $src_class (sort keys %$rel_stmts) {
2077 my $src_stmts = $rel_stmts->{$src_class};
2078 foreach my $stmt (@$src_stmts) {
2079 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2085 my ($self, $table) = @_;
2087 my $table_moniker = $self->monikers->{$table};
2088 my $table_class = $self->classes->{$table};
2090 my @roles = @{ $self->result_roles || [] };
2091 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2092 if exists $self->result_roles_map->{$table_moniker};
2095 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2097 $self->_with($table_class, @roles);
2101 # Overload these in driver class:
2103 # Returns an arrayref of column names
2104 sub _table_columns { croak "ABSTRACT METHOD" }
2106 # Returns arrayref of pk col names
2107 sub _table_pk_info { croak "ABSTRACT METHOD" }
2109 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2110 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2112 # Returns an arrayref of foreign key constraints, each
2113 # being a hashref with 3 keys:
2114 # local_columns (arrayref), remote_columns (arrayref), remote_table
2115 sub _table_fk_info { croak "ABSTRACT METHOD" }
2117 # Returns an array of lower case table names
2118 sub _tables_list { croak "ABSTRACT METHOD" }
2120 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2126 # generate the pod for this statement, storing it with $self->_pod
2127 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2129 my $args = dump(@_);
2130 $args = '(' . $args . ')' if @_ < 2;
2131 my $stmt = $method . $args . q{;};
2133 warn qq|$class\->$stmt\n| if $self->debug;
2134 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2138 sub _make_pod_heading {
2139 my ($self, $class) = @_;
2141 return '' if not $self->generate_pod;
2143 my $table = $self->class_to_table->{$class};
2146 my $pcm = $self->pod_comment_mode;
2147 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2148 $comment = $self->__table_comment($table);
2149 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2150 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2151 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2153 $pod .= "=head1 NAME\n\n";
2155 my $table_descr = $class;
2156 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2158 $pod .= "$table_descr\n\n";
2160 if ($comment and $comment_in_desc) {
2161 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2168 # generates the accompanying pod for a DBIC class method statement,
2169 # storing it with $self->_pod
2175 if ($method eq 'table') {
2177 $self->_pod($class, "=head1 TABLE: C<$table>");
2178 $self->_pod_cut($class);
2180 elsif ( $method eq 'add_columns' ) {
2181 $self->_pod( $class, "=head1 ACCESSORS" );
2182 my $col_counter = 0;
2184 while( my ($name,$attrs) = splice @cols,0,2 ) {
2186 $self->_pod( $class, '=head2 ' . $name );
2187 $self->_pod( $class,
2189 my $s = $attrs->{$_};
2190 $s = !defined $s ? 'undef' :
2191 length($s) == 0 ? '(empty string)' :
2192 ref($s) eq 'SCALAR' ? $$s :
2193 ref($s) ? dumper_squashed $s :
2194 looks_like_number($s) ? $s : qq{'$s'};
2197 } sort keys %$attrs,
2199 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2200 $self->_pod( $class, $comment );
2203 $self->_pod_cut( $class );
2204 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2205 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2206 my ( $accessor, $rel_class ) = @_;
2207 $self->_pod( $class, "=head2 $accessor" );
2208 $self->_pod( $class, 'Type: ' . $method );
2209 $self->_pod( $class, "Related object: L<$rel_class>" );
2210 $self->_pod_cut( $class );
2211 $self->{_relations_started} { $class } = 1;
2213 elsif ($method eq 'add_unique_constraint') {
2214 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2215 unless $self->{_uniqs_started}{$class};
2217 my ($name, $cols) = @_;
2219 $self->_pod($class, "=head2 C<$name>");
2220 $self->_pod($class, '=over 4');
2222 foreach my $col (@$cols) {
2223 $self->_pod($class, "=item \* L</$col>");
2226 $self->_pod($class, '=back');
2227 $self->_pod_cut($class);
2229 $self->{_uniqs_started}{$class} = 1;
2231 elsif ($method eq 'set_primary_key') {
2232 $self->_pod($class, "=head1 PRIMARY KEY");
2233 $self->_pod($class, '=over 4');
2235 foreach my $col (@_) {
2236 $self->_pod($class, "=item \* L</$col>");
2239 $self->_pod($class, '=back');
2240 $self->_pod_cut($class);
2244 sub _pod_class_list {
2245 my ($self, $class, $title, @classes) = @_;
2247 return unless @classes && $self->generate_pod;
2249 $self->_pod($class, "=head1 $title");
2250 $self->_pod($class, '=over 4');
2252 foreach my $link (@classes) {
2253 $self->_pod($class, "=item * L<$link>");
2256 $self->_pod($class, '=back');
2257 $self->_pod_cut($class);
2260 sub _base_class_pod {
2261 my ($self, $base_class) = @_;
2263 return unless $self->generate_pod;
2266 =head1 BASE CLASS: L<$base_class>
2273 sub _filter_comment {
2274 my ($self, $txt) = @_;
2276 $txt = '' if not defined $txt;
2278 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2283 sub __table_comment {
2286 if (my $code = $self->can('_table_comment')) {
2287 return $self->_filter_comment($self->$code(@_));
2293 sub __column_comment {
2296 if (my $code = $self->can('_column_comment')) {
2297 return $self->_filter_comment($self->$code(@_));
2303 # Stores a POD documentation
2305 my ($self, $class, $stmt) = @_;
2306 $self->_raw_stmt( $class, "\n" . $stmt );
2310 my ($self, $class ) = @_;
2311 $self->_raw_stmt( $class, "\n=cut\n" );
2314 # Store a raw source line for a class (for dumping purposes)
2316 my ($self, $class, $stmt) = @_;
2317 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2320 # Like above, but separately for the externally loaded stuff
2322 my ($self, $class, $stmt) = @_;
2323 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2326 sub _custom_column_info {
2327 my ( $self, $table_name, $column_name, $column_info ) = @_;
2329 if (my $code = $self->custom_column_info) {
2330 return $code->($table_name, $column_name, $column_info) || {};
2335 sub _datetime_column_info {
2336 my ( $self, $table_name, $column_name, $column_info ) = @_;
2338 my $type = $column_info->{data_type} || '';
2339 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2340 or ($type =~ /date|timestamp/i)) {
2341 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2342 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2348 my ($self, $name) = @_;
2350 return $self->preserve_case ? $name : lc($name);
2354 my ($self, $name) = @_;
2356 return $self->preserve_case ? $name : uc($name);
2359 sub _unregister_source_for_table {
2360 my ($self, $table) = @_;
2364 my $schema = $self->schema;
2365 # in older DBIC it's a private method
2366 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2367 $schema->$unregister($self->_table2moniker($table));
2368 delete $self->monikers->{$table};
2369 delete $self->classes->{$table};
2370 delete $self->_upgrading_classes->{$table};
2371 delete $self->{_tables}{$table};
2375 # remove the dump dir from @INC on destruction
2379 @INC = grep $_ ne $self->dump_directory, @INC;
2384 Returns a hashref of loaded table to moniker mappings. There will
2385 be two entries for each table, the original name and the "normalized"
2386 name, in the case that the two are different (such as databases
2387 that like uppercase table names, or preserve your original mixed-case
2388 definitions, or what-have-you).
2392 Returns a hashref of table to class mappings. In some cases it will
2393 contain multiple entries per table for the original and normalized table
2394 names, as above in L</monikers>.
2396 =head1 COLUMN ACCESSOR COLLISIONS
2398 Occasionally you may have a column name that collides with a perl method, such
2399 as C<can>. In such cases, the default action is to set the C<accessor> of the
2400 column spec to C<undef>.
2402 You can then name the accessor yourself by placing code such as the following
2405 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2407 Another option is to use the L</col_collision_map> option.
2409 =head1 RELATIONSHIP NAME COLLISIONS
2411 In very rare cases, you may get a collision between a generated relationship
2412 name and a method in your Result class, for example if you have a foreign key
2413 called C<belongs_to>.
2415 This is a problem because relationship names are also relationship accessor
2416 methods in L<DBIx::Class>.
2418 The default behavior is to append C<_rel> to the relationship name and print
2419 out a warning that refers to this text.
2421 You can also control the renaming with the L</rel_collision_map> option.
2425 L<DBIx::Class::Schema::Loader>
2429 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2433 This library is free software; you can redistribute it and/or modify it under
2434 the same terms as Perl itself.
2439 # vim:et sts=4 sw=4 tw=0: