1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use DBIx::Class::Schema::Loader::RelBuilder;
9 use Data::Dump qw/ dump /;
14 use Lingua::EN::Inflect::Number qw//;
15 use Lingua::EN::Inflect::Phrase qw//;
18 use Class::Inspector ();
19 use Scalar::Util 'looks_like_number';
20 use File::Slurp 'slurp';
21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
25 use Encode qw/decode 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
76 __PACKAGE__->mk_group_accessors('simple', qw/
78 schema_version_to_dump
80 _upgrading_from_load_classes
81 _downgrading_to_load_classes
82 _rewriting_result_namespace
87 pod_comment_spillover_length
94 datetime_undef_if_invalid
102 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
106 See L<DBIx::Class::Schema::Loader>
110 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
111 classes, and implements the common functionality between them.
113 =head1 CONSTRUCTOR OPTIONS
115 These constructor options are the base options for
116 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
118 =head2 skip_relationships
120 Skip setting up relationships. The default is to attempt the loading
123 =head2 skip_load_external
125 Skip loading of other classes in @INC. The default is to merge all other classes
126 with the same name found in @INC into the schema file we are creating.
130 Static schemas (ones dumped to disk) will, by default, use the new-style
131 relationship names and singularized Results, unless you're overwriting an
132 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
133 which case the backward compatible RelBuilder will be activated, and the
134 appropriate monikerization used.
140 will disable the backward-compatible RelBuilder and use
141 the new-style relationship names along with singularized Results, even when
142 overwriting a dump made with an earlier version.
144 The option also takes a hashref:
146 naming => { relationships => 'v7', monikers => 'v7' }
154 How to name relationship accessors.
158 How to name Result classes.
160 =item column_accessors
162 How to name column accessors in Result classes.
172 Latest style, whatever that happens to be.
176 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
180 Monikers singularized as whole words, C<might_have> relationships for FKs on
181 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
183 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
188 All monikers and relationships are inflected using
189 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
190 from relationship names.
192 In general, there is very little difference between v5 and v6 schemas.
196 This mode is identical to C<v6> mode, except that monikerization of CamelCase
197 table names is also done correctly.
199 CamelCase column names in case-preserving mode will also be handled correctly
200 for relationship name inflection. See L</preserve_case>.
202 In this mode, CamelCase L</column_accessors> are normalized based on case
203 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
205 If you don't have any CamelCase table or column names, you can upgrade without
206 breaking any of your code.
210 For L</monikers>, this option does not inflect the table names but makes
211 monikers based on the actual name. For L</column_accessors> this option does
212 not normalize CamelCase column names to lowercase column accessors, but makes
213 accessors that are the same names as the columns (with any non-\w chars
214 replaced with underscores.)
218 For L</monikers>, singularizes the names using the most current inflector. This
219 is the same as setting the option to L</current>.
223 For L</monikers>, pluralizes the names, using the most current inflector.
227 Dynamic schemas will always default to the 0.04XXX relationship names and won't
228 singularize Results for backward compatibility, to activate the new RelBuilder
229 and singularization put this in your C<Schema.pm> file:
231 __PACKAGE__->naming('current');
233 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
234 next major version upgrade:
236 __PACKAGE__->naming('v7');
240 By default POD will be generated for columns and relationships, using database
241 metadata for the text if available and supported.
243 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
244 supported for Postgres right now.
246 Set this to C<0> to turn off all POD generation.
248 =head2 pod_comment_mode
250 Controls where table comments appear in the generated POD. Smaller table
251 comments are appended to the C<NAME> section of the documentation, and larger
252 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
253 section to be generated with the comment always, only use C<NAME>, or choose
254 the length threshold at which the comment is forced into the description.
260 Use C<NAME> section only.
264 Force C<DESCRIPTION> always.
268 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
273 =head2 pod_comment_spillover_length
275 When pod_comment_mode is set to C<auto>, this is the length of the comment at
276 which it will be forced into a separate description section.
280 =head2 relationship_attrs
282 Hashref of attributes to pass to each generated relationship, listed
283 by type. Also supports relationship type 'all', containing options to
284 pass to all generated relationships. Attributes set for more specific
285 relationship types override those set in 'all'.
289 relationship_attrs => {
290 belongs_to => { is_deferrable => 0 },
293 use this to turn off DEFERRABLE on your foreign key constraints.
297 If set to true, each constructive L<DBIx::Class> statement the loader
298 decides to execute will be C<warn>-ed before execution.
302 Set the name of the schema to load (schema in the sense that your database
303 vendor means it). Does not currently support loading more than one schema
308 Only load tables matching regex. Best specified as a qr// regex.
312 Exclude tables matching regex. Best specified as a qr// regex.
316 Overrides the default table name to moniker translation. Can be either
317 a hashref of table keys and moniker values, or a coderef for a translator
318 function taking a single scalar table name argument and returning
319 a scalar moniker. If the hash entry does not exist, or the function
320 returns a false value, the code falls back to default behavior
323 The default behavior is to split on case transition and non-alphanumeric
324 boundaries, singularize the resulting phrase, then join the titlecased words
327 Table Name | Moniker Name
328 ---------------------------------
330 luser_group | LuserGroup
331 luser-opts | LuserOpt
332 stations_visited | StationVisited
333 routeChange | RouteChange
335 =head2 col_accessor_map
337 Same as moniker_map, but for column accessor names. If a coderef is
338 passed, the code is called with arguments of
340 the name of the column in the underlying database,
341 default accessor name that DBICSL would ordinarily give this column,
343 table_class => name of the DBIC class we are building,
344 table_moniker => calculated moniker for this table (after moniker_map if present),
345 table_name => name of the database table,
346 full_table_name => schema-qualified name of the database table (RDBMS specific),
347 schema_class => name of the schema class we are building,
348 column_info => hashref of column info (data_type, is_nullable, etc),
351 =head2 inflect_plural
353 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
354 if hash key does not exist or coderef returns false), but acts as a map
355 for pluralizing relationship names. The default behavior is to utilize
356 L<Lingua::EN::Inflect::Phrase/to_PL>.
358 =head2 inflect_singular
360 As L</inflect_plural> above, but for singularizing relationship names.
361 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
363 =head2 schema_base_class
365 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
367 =head2 result_base_class
369 Base class for your table classes (aka result classes). Defaults to
372 =head2 additional_base_classes
374 List of additional base classes all of your table classes will use.
376 =head2 left_base_classes
378 List of additional base classes all of your table classes will use
379 that need to be leftmost.
381 =head2 additional_classes
383 List of additional classes which all of your table classes will use.
387 List of additional components to be loaded into all of your table
388 classes. A good example would be
389 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
391 =head2 result_components_map
393 A hashref of moniker keys and component values. Unlike L</components>, which
394 loads the given components into every Result class, this option allows you to
395 load certain components for specified Result classes. For example:
397 result_components_map => {
398 StationVisited => '+YourApp::Schema::Component::StationVisited',
400 '+YourApp::Schema::Component::RouteChange',
401 'InflateColumn::DateTime',
405 You may use this in conjunction with L</components>.
409 List of L<Moose> roles to be applied to all of your Result classes.
411 =head2 result_roles_map
413 A hashref of moniker keys and role values. Unlike L</result_roles>, which
414 applies the given roles to every Result class, this option allows you to apply
415 certain roles for specified Result classes. For example:
417 result_roles_map => {
419 'YourApp::Role::Building',
420 'YourApp::Role::Destination',
422 RouteChange => 'YourApp::Role::TripEvent',
425 You may use this in conjunction with L</result_roles>.
427 =head2 use_namespaces
429 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
432 Generate result class names suitable for
433 L<DBIx::Class::Schema/load_namespaces> and call that instead of
434 L<DBIx::Class::Schema/load_classes>. When using this option you can also
435 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
436 C<resultset_namespace>, C<default_resultset_class>), and they will be added
437 to the call (and the generated result class names adjusted appropriately).
439 =head2 dump_directory
441 The value of this option is a perl libdir pathname. Within
442 that directory this module will create a baseline manual
443 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
445 The created schema class will have the same classname as the one on
446 which you are setting this option (and the ResultSource classes will be
447 based on this name as well).
449 Normally you wouldn't hard-code this setting in your schema class, as it
450 is meant for one-time manual usage.
452 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
453 recommended way to access this functionality.
455 =head2 dump_overwrite
457 Deprecated. See L</really_erase_my_files> below, which does *not* mean
458 the same thing as the old C<dump_overwrite> setting from previous releases.
460 =head2 really_erase_my_files
462 Default false. If true, Loader will unconditionally delete any existing
463 files before creating the new ones from scratch when dumping a schema to disk.
465 The default behavior is instead to only replace the top portion of the
466 file, up to and including the final stanza which contains
467 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
468 leaving any customizations you placed after that as they were.
470 When C<really_erase_my_files> is not set, if the output file already exists,
471 but the aforementioned final stanza is not found, or the checksum
472 contained there does not match the generated contents, Loader will
473 croak and not touch the file.
475 You should really be using version control on your schema classes (and all
476 of the rest of your code for that matter). Don't blame me if a bug in this
477 code wipes something out when it shouldn't have, you've been warned.
479 =head2 overwrite_modifications
481 Default false. If false, when updating existing files, Loader will
482 refuse to modify any Loader-generated code that has been modified
483 since its last run (as determined by the checksum Loader put in its
486 If true, Loader will discard any manual modifications that have been
487 made to Loader-generated code.
489 Again, you should be using version control on your schema classes. Be
490 careful with this option.
492 =head2 custom_column_info
494 Hook for adding extra attributes to the
495 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
497 Must be a coderef that returns a hashref with the extra attributes.
499 Receives the table name, column name and column_info.
503 custom_column_info => sub {
504 my ($table_name, $column_name, $column_info) = @_;
506 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
507 return { is_snoopy => 1 };
511 This attribute can also be used to set C<inflate_datetime> on a non-datetime
512 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
514 =head2 datetime_timezone
516 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
517 columns with the DATE/DATETIME/TIMESTAMP data_types.
519 =head2 datetime_locale
521 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
522 columns with the DATE/DATETIME/TIMESTAMP data_types.
524 =head2 datetime_undef_if_invalid
526 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
527 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
530 The default is recommended to deal with data such as C<00/00/00> which
531 sometimes ends up in such columns in MySQL.
535 File in Perl format, which should return a HASH reference, from which to read
540 Usually column names are lowercased, to make them easier to work with in
541 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
544 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
545 case-sensitive collation will turn this option on unconditionally.
547 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
550 =head2 qualify_objects
552 Set to true to prepend the L</db_schema> to table names for C<<
553 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
557 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
558 L<namespace::autoclean>. The default content after the md5 sum also makes the
561 It is safe to upgrade your existing Schema to this option.
563 =head2 col_collision_map
565 This option controls how accessors for column names which collide with perl
566 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
568 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
569 strings which are compiled to regular expressions that map to
570 L<sprintf|perlfunc/sprintf> formats.
574 col_collision_map => 'column_%s'
576 col_collision_map => { '(.*)' => 'column_%s' }
578 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
580 =head2 rel_collision_map
582 Works just like L</col_collision_map>, but for relationship names/accessors
583 rather than column names/accessors.
585 The default is to just append C<_rel> to the relationship name, see
586 L</RELATIONSHIP NAME COLLISIONS>.
590 None of these methods are intended for direct invocation by regular
591 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
592 L<DBIx::Class::Schema::Loader>.
596 my $CURRENT_V = 'v7';
599 schema_base_class result_base_class additional_base_classes
600 left_base_classes additional_classes components result_roles
603 # ensure that a peice of object data is a valid arrayref, creating
604 # an empty one or encapsulating whatever's there.
605 sub _ensure_arrayref {
610 $self->{$_} = [ $self->{$_} ]
611 unless ref $self->{$_} eq 'ARRAY';
617 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
618 by L<DBIx::Class::Schema::Loader>.
623 my ( $class, %args ) = @_;
625 if (exists $args{column_accessor_map}) {
626 $args{col_accessor_map} = delete $args{column_accessor_map};
629 my $self = { %args };
631 # don't lose undef options
632 for (values %$self) {
633 $_ = 0 unless defined $_;
636 bless $self => $class;
638 if (my $config_file = $self->config_file) {
639 my $config_opts = do $config_file;
641 croak "Error reading config from $config_file: $@" if $@;
643 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
645 while (my ($k, $v) = each %$config_opts) {
646 $self->{$k} = $v unless exists $self->{$k};
650 $self->result_components_map($self->{result_component_map})
651 if defined $self->{result_component_map};
653 $self->result_roles_map($self->{result_role_map})
654 if defined $self->{result_role_map};
656 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
657 if ((not defined $self->use_moose) || (not $self->use_moose))
658 && ((defined $self->result_roles) || (defined $self->result_roles_map));
660 $self->_ensure_arrayref(qw/additional_classes
661 additional_base_classes
667 $self->_validate_class_args;
669 croak "result_components_map must be a hash"
670 if defined $self->result_components_map
671 && ref $self->result_components_map ne 'HASH';
673 if ($self->result_components_map) {
674 my %rc_map = %{ $self->result_components_map };
675 foreach my $moniker (keys %rc_map) {
676 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
678 $self->result_components_map(\%rc_map);
681 $self->result_components_map({});
683 $self->_validate_result_components_map;
685 croak "result_roles_map must be a hash"
686 if defined $self->result_roles_map
687 && ref $self->result_roles_map ne 'HASH';
689 if ($self->result_roles_map) {
690 my %rr_map = %{ $self->result_roles_map };
691 foreach my $moniker (keys %rr_map) {
692 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
694 $self->result_roles_map(\%rr_map);
696 $self->result_roles_map({});
698 $self->_validate_result_roles_map;
700 if ($self->use_moose) {
701 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
702 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
703 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
707 $self->{monikers} = {};
708 $self->{tables} = {};
709 $self->{classes} = {};
710 $self->{_upgrading_classes} = {};
712 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
713 $self->{schema} ||= $self->{schema_class};
715 croak "dump_overwrite is deprecated. Please read the"
716 . " DBIx::Class::Schema::Loader::Base documentation"
717 if $self->{dump_overwrite};
719 $self->{dynamic} = ! $self->{dump_directory};
720 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
725 $self->{dump_directory} ||= $self->{temp_directory};
727 $self->real_dump_directory($self->{dump_directory});
729 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
730 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
732 if (not defined $self->naming) {
733 $self->naming_set(0);
736 $self->naming_set(1);
739 if ((not ref $self->naming) && defined $self->naming) {
740 my $naming_ver = $self->naming;
742 relationships => $naming_ver,
743 monikers => $naming_ver,
744 column_accessors => $naming_ver,
749 for (values %{ $self->naming }) {
750 $_ = $CURRENT_V if $_ eq 'current';
753 $self->{naming} ||= {};
755 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
756 croak 'custom_column_info must be a CODE ref';
759 $self->_check_back_compat;
761 $self->use_namespaces(1) unless defined $self->use_namespaces;
762 $self->generate_pod(1) unless defined $self->generate_pod;
763 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
764 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
766 if (my $col_collision_map = $self->col_collision_map) {
767 if (my $reftype = ref $col_collision_map) {
768 if ($reftype ne 'HASH') {
769 croak "Invalid type $reftype for option 'col_collision_map'";
773 $self->col_collision_map({ '(.*)' => $col_collision_map });
780 sub _check_back_compat {
783 # dynamic schemas will always be in 0.04006 mode, unless overridden
784 if ($self->dynamic) {
785 # just in case, though no one is likely to dump a dynamic schema
786 $self->schema_version_to_dump('0.04006');
788 if (not $self->naming_set) {
789 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
791 Dynamic schema detected, will run in 0.04006 mode.
793 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
794 to disable this warning.
796 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
801 $self->_upgrading_from('v4');
804 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
805 $self->use_namespaces(1);
808 $self->naming->{relationships} ||= 'v4';
809 $self->naming->{monikers} ||= 'v4';
811 if ($self->use_namespaces) {
812 $self->_upgrading_from_load_classes(1);
815 $self->use_namespaces(0);
821 # otherwise check if we need backcompat mode for a static schema
822 my $filename = $self->_get_dump_filename($self->schema_class);
823 return unless -e $filename;
825 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
826 $self->_parse_generated_file($filename);
828 return unless $old_ver;
830 # determine if the existing schema was dumped with use_moose => 1
831 if (! defined $self->use_moose) {
832 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
835 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
836 my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
838 if ($load_classes && (not defined $self->use_namespaces)) {
839 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
841 'load_classes;' static schema detected, turning off 'use_namespaces'.
843 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
844 variable to disable this warning.
846 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
849 $self->use_namespaces(0);
851 elsif ($load_classes && $self->use_namespaces) {
852 $self->_upgrading_from_load_classes(1);
854 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
855 $self->_downgrading_to_load_classes(
856 $result_namespace || 'Result'
859 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
860 if (not $self->result_namespace) {
861 $self->result_namespace($result_namespace || 'Result');
863 elsif ($result_namespace ne $self->result_namespace) {
864 $self->_rewriting_result_namespace(
865 $result_namespace || 'Result'
870 # XXX when we go past .0 this will need fixing
871 my ($v) = $old_ver =~ /([1-9])/;
874 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
876 if (not %{ $self->naming }) {
877 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
879 Version $old_ver static schema detected, turning on backcompat mode.
881 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
882 to disable this warning.
884 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
886 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
887 from version 0.04006.
890 $self->naming->{relationships} ||= $v;
891 $self->naming->{monikers} ||= $v;
892 $self->naming->{column_accessors} ||= $v;
894 $self->schema_version_to_dump($old_ver);
897 $self->_upgrading_from($v);
901 sub _validate_class_args {
904 foreach my $k (@CLASS_ARGS) {
905 next unless $self->$k;
907 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
908 $self->_validate_classes($k, \@classes);
912 sub _validate_result_components_map {
915 foreach my $classes (values %{ $self->result_components_map }) {
916 $self->_validate_classes('result_components_map', $classes);
920 sub _validate_result_roles_map {
923 foreach my $classes (values %{ $self->result_roles_map }) {
924 $self->_validate_classes('result_roles_map', $classes);
928 sub _validate_classes {
933 # make a copy to not destroy original
934 my @classes = @$classes;
936 foreach my $c (@classes) {
937 # components default to being under the DBIx::Class namespace unless they
938 # are preceeded with a '+'
939 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
940 $c = 'DBIx::Class::' . $c;
943 # 1 == installed, 0 == not installed, undef == invalid classname
944 my $installed = Class::Inspector->installed($c);
945 if ( defined($installed) ) {
946 if ( $installed == 0 ) {
947 croak qq/$c, as specified in the loader option "$key", is not installed/;
950 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
956 sub _find_file_in_inc {
957 my ($self, $file) = @_;
959 foreach my $prefix (@INC) {
960 my $fullpath = File::Spec->catfile($prefix, $file);
961 return $fullpath if -f $fullpath
962 # abs_path throws on Windows for nonexistant files
963 and (try { Cwd::abs_path($fullpath) }) ne
964 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
970 sub _find_class_in_inc {
971 my ($self, $class) = @_;
973 return $self->_find_file_in_inc(class_path($class));
979 return $self->_upgrading_from
980 || $self->_upgrading_from_load_classes
981 || $self->_downgrading_to_load_classes
982 || $self->_rewriting_result_namespace
986 sub _rewrite_old_classnames {
987 my ($self, $code) = @_;
989 return $code unless $self->_rewriting;
991 my %old_classes = reverse %{ $self->_upgrading_classes };
993 my $re = join '|', keys %old_classes;
996 $code =~ s/$re/$old_classes{$1} || $1/eg;
1001 sub _load_external {
1002 my ($self, $class) = @_;
1004 return if $self->{skip_load_external};
1006 # so that we don't load our own classes, under any circumstances
1007 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1009 my $real_inc_path = $self->_find_class_in_inc($class);
1011 my $old_class = $self->_upgrading_classes->{$class}
1012 if $self->_rewriting;
1014 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1015 if $old_class && $old_class ne $class;
1017 return unless $real_inc_path || $old_real_inc_path;
1019 if ($real_inc_path) {
1020 # If we make it to here, we loaded an external definition
1021 warn qq/# Loaded external class definition for '$class'\n/
1024 my $code = $self->_rewrite_old_classnames(decode 'UTF-8', scalar slurp $real_inc_path);
1026 if ($self->dynamic) { # load the class too
1027 eval_package_without_redefine_warnings($class, $code);
1030 $self->_ext_stmt($class,
1031 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1032 .qq|# They are now part of the custom portion of this file\n|
1033 .qq|# for you to hand-edit. If you do not either delete\n|
1034 .qq|# this section or remove that file from \@INC, this section\n|
1035 .qq|# will be repeated redundantly when you re-create this\n|
1036 .qq|# file again via Loader! See skip_load_external to disable\n|
1037 .qq|# this feature.\n|
1040 $self->_ext_stmt($class, $code);
1041 $self->_ext_stmt($class,
1042 qq|# End of lines loaded from '$real_inc_path' |
1046 if ($old_real_inc_path) {
1047 my $code = decode 'UTF-8', scalar slurp $old_real_inc_path;
1049 $self->_ext_stmt($class, <<"EOF");
1051 # These lines were loaded from '$old_real_inc_path',
1052 # based on the Result class name that would have been created by an older
1053 # version of the Loader. For a static schema, this happens only once during
1054 # upgrade. See skip_load_external to disable this feature.
1057 $code = $self->_rewrite_old_classnames($code);
1059 if ($self->dynamic) {
1062 Detected external content in '$old_real_inc_path', a class name that would have
1063 been used by an older version of the Loader.
1065 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1066 new name of the Result.
1068 eval_package_without_redefine_warnings($class, $code);
1072 $self->_ext_stmt($class, $code);
1073 $self->_ext_stmt($class,
1074 qq|# End of lines loaded from '$old_real_inc_path' |
1081 Does the actual schema-construction work.
1088 $self->_load_tables(
1089 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1097 Rescan the database for changes. Returns a list of the newly added table
1100 The schema argument should be the schema class or object to be affected. It
1101 should probably be derived from the original schema_class used during L</load>.
1106 my ($self, $schema) = @_;
1108 $self->{schema} = $schema;
1109 $self->_relbuilder->{schema} = $schema;
1112 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1114 foreach my $table (@current) {
1115 if(!exists $self->{_tables}->{$table}) {
1116 push(@created, $table);
1121 @current{@current} = ();
1122 foreach my $table (keys %{ $self->{_tables} }) {
1123 if (not exists $current{$table}) {
1124 $self->_unregister_source_for_table($table);
1128 delete $self->{_dump_storage};
1129 delete $self->{_relations_started};
1131 my $loaded = $self->_load_tables(@current);
1133 return map { $self->monikers->{$_} } @created;
1139 return if $self->{skip_relationships};
1141 return $self->{relbuilder} ||= do {
1143 no warnings 'uninitialized';
1144 my $relbuilder_suff =
1150 ->{ $self->naming->{relationships}};
1152 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1153 $self->ensure_class_loaded($relbuilder_class);
1154 $relbuilder_class->new( $self );
1160 my ($self, @tables) = @_;
1162 # Save the new tables to the tables list
1164 $self->{_tables}->{$_} = 1;
1167 $self->_make_src_class($_) for @tables;
1169 # sanity-check for moniker clashes
1170 my $inverse_moniker_idx;
1171 for (keys %{$self->monikers}) {
1172 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1176 for (keys %$inverse_moniker_idx) {
1177 my $tables = $inverse_moniker_idx->{$_};
1179 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1180 join (', ', map { "'$_'" } @$tables),
1187 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1188 . 'Either change the naming style, or supply an explicit moniker_map: '
1189 . join ('; ', @clashes)
1195 $self->_setup_src_meta($_) for @tables;
1197 if(!$self->skip_relationships) {
1198 # The relationship loader needs a working schema
1200 local $self->{dump_directory} = $self->{temp_directory};
1201 $self->_reload_classes(\@tables);
1202 $self->_load_relationships(\@tables);
1205 # Remove that temp dir from INC so it doesn't get reloaded
1206 @INC = grep $_ ne $self->dump_directory, @INC;
1209 $self->_load_roles($_) for @tables;
1211 $self->_load_external($_)
1212 for map { $self->classes->{$_} } @tables;
1214 # Reload without unloading first to preserve any symbols from external
1216 $self->_reload_classes(\@tables, { unload => 0 });
1218 # Drop temporary cache
1219 delete $self->{_cache};
1224 sub _reload_classes {
1225 my ($self, $tables, $opts) = @_;
1227 my @tables = @$tables;
1229 my $unload = $opts->{unload};
1230 $unload = 1 unless defined $unload;
1232 # so that we don't repeat custom sections
1233 @INC = grep $_ ne $self->dump_directory, @INC;
1235 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1237 unshift @INC, $self->dump_directory;
1240 my %have_source = map { $_ => $self->schema->source($_) }
1241 $self->schema->sources;
1243 for my $table (@tables) {
1244 my $moniker = $self->monikers->{$table};
1245 my $class = $self->classes->{$table};
1248 no warnings 'redefine';
1249 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1252 if (my $mc = $self->_moose_metaclass($class)) {
1255 Class::Unload->unload($class) if $unload;
1256 my ($source, $resultset_class);
1258 ($source = $have_source{$moniker})
1259 && ($resultset_class = $source->resultset_class)
1260 && ($resultset_class ne 'DBIx::Class::ResultSet')
1262 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1263 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1266 Class::Unload->unload($resultset_class) if $unload;
1267 $self->_reload_class($resultset_class) if $has_file;
1269 $self->_reload_class($class);
1271 push @to_register, [$moniker, $class];
1274 Class::C3->reinitialize;
1275 for (@to_register) {
1276 $self->schema->register_class(@$_);
1280 sub _moose_metaclass {
1281 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1285 my $mc = try { Class::MOP::class_of($class) }
1288 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1291 # We use this instead of ensure_class_loaded when there are package symbols we
1294 my ($self, $class) = @_;
1296 delete $INC{ +class_path($class) };
1299 eval_package_without_redefine_warnings ($class, "require $class");
1302 my $source = decode 'UTF-8', scalar slurp $self->_get_dump_filename($class);
1303 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1307 sub _get_dump_filename {
1308 my ($self, $class) = (@_);
1310 $class =~ s{::}{/}g;
1311 return $self->dump_directory . q{/} . $class . q{.pm};
1314 =head2 get_dump_filename
1318 Returns the full path to the file for a class that the class has been or will
1319 be dumped to. This is a file in a temp dir for a dynamic schema.
1323 sub get_dump_filename {
1324 my ($self, $class) = (@_);
1326 local $self->{dump_directory} = $self->real_dump_directory;
1328 return $self->_get_dump_filename($class);
1331 sub _ensure_dump_subdirs {
1332 my ($self, $class) = (@_);
1334 my @name_parts = split(/::/, $class);
1335 pop @name_parts; # we don't care about the very last element,
1336 # which is a filename
1338 my $dir = $self->dump_directory;
1341 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1343 last if !@name_parts;
1344 $dir = File::Spec->catdir($dir, shift @name_parts);
1349 my ($self, @classes) = @_;
1351 my $schema_class = $self->schema_class;
1352 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1354 my $target_dir = $self->dump_directory;
1355 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1356 unless $self->{dynamic} or $self->{quiet};
1359 qq|package $schema_class;\n\n|
1360 . qq|# Created by DBIx::Class::Schema::Loader\n|
1361 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1363 if ($self->use_moose) {
1364 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1367 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1370 if ($self->use_namespaces) {
1371 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1372 my $namespace_options;
1374 my @attr = qw/resultset_namespace default_resultset_class/;
1376 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1378 for my $attr (@attr) {
1380 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1383 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1384 $schema_text .= qq|;\n|;
1387 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1391 local $self->{version_to_dump} = $self->schema_version_to_dump;
1392 $self->_write_classfile($schema_class, $schema_text, 1);
1395 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1397 foreach my $src_class (@classes) {
1399 qq|package $src_class;\n\n|
1400 . qq|# Created by DBIx::Class::Schema::Loader\n|
1401 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1402 . qq|use strict;\nuse warnings;\n\n|;
1403 if ($self->use_moose) {
1404 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1406 # these options 'use base' which is compile time
1407 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1408 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1411 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1415 $src_text .= qq|use base '$result_base_class';\n\n|;
1418 $self->_base_class_pod($src_class, $result_base_class)
1419 unless $result_base_class eq 'DBIx::Class::Core';
1421 $self->_write_classfile($src_class, $src_text);
1424 # remove Result dir if downgrading from use_namespaces, and there are no
1426 if (my $result_ns = $self->_downgrading_to_load_classes
1427 || $self->_rewriting_result_namespace) {
1428 my $result_namespace = $self->_result_namespace(
1433 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1434 $result_dir = $self->dump_directory . '/' . $result_dir;
1436 unless (my @files = glob "$result_dir/*") {
1441 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1446 my ($self, $version, $ts) = @_;
1447 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1450 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1453 sub _write_classfile {
1454 my ($self, $class, $text, $is_schema) = @_;
1456 my $filename = $self->_get_dump_filename($class);
1457 $self->_ensure_dump_subdirs($class);
1459 if (-f $filename && $self->really_erase_my_files) {
1460 warn "Deleting existing file '$filename' due to "
1461 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1465 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1466 = $self->_parse_generated_file($filename);
1468 if (! $old_gen && -f $filename) {
1469 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1470 . " it does not appear to have been generated by Loader"
1473 my $custom_content = $old_custom || '';
1475 # prepend extra custom content from a *renamed* class (singularization effect)
1476 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1477 my $old_filename = $self->_get_dump_filename($renamed_class);
1479 if (-f $old_filename) {
1480 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1482 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1484 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1487 unlink $old_filename;
1491 $custom_content ||= $self->_default_custom_content($is_schema);
1493 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1494 # If there is already custom content, which does not have the Moose content, add it.
1495 if ($self->use_moose) {
1497 my $non_moose_custom_content = do {
1498 local $self->{use_moose} = 0;
1499 $self->_default_custom_content;
1502 if ($custom_content eq $non_moose_custom_content) {
1503 $custom_content = $self->_default_custom_content($is_schema);
1505 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1506 $custom_content .= $self->_default_custom_content($is_schema);
1509 elsif (defined $self->use_moose && $old_gen) {
1510 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'
1511 if $old_gen =~ /use \s+ MooseX?\b/x;
1514 $custom_content = $self->_rewrite_old_classnames($custom_content);
1517 for @{$self->{_dump_storage}->{$class} || []};
1519 # Check and see if the dump is infact differnt
1523 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1524 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1525 return unless $self->_upgrading_from && $is_schema;
1529 $text .= $self->_sig_comment(
1530 $self->version_to_dump,
1531 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1534 open(my $fh, '>:encoding(UTF-8)', $filename)
1535 or croak "Cannot open '$filename' for writing: $!";
1537 # Write the top half and its MD5 sum
1538 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1540 # Write out anything loaded via external partial class file in @INC
1542 for @{$self->{_ext_storage}->{$class} || []};
1544 # Write out any custom content the user has added
1545 print $fh $custom_content;
1548 or croak "Error closing '$filename': $!";
1551 sub _default_moose_custom_content {
1552 my ($self, $is_schema) = @_;
1554 if (not $is_schema) {
1555 return qq|\n__PACKAGE__->meta->make_immutable;|;
1558 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1561 sub _default_custom_content {
1562 my ($self, $is_schema) = @_;
1563 my $default = qq|\n\n# You can replace this text with custom|
1564 . qq| code or comments, and it will be preserved on regeneration|;
1565 if ($self->use_moose) {
1566 $default .= $self->_default_moose_custom_content($is_schema);
1568 $default .= qq|\n1;\n|;
1572 sub _parse_generated_file {
1573 my ($self, $fn) = @_;
1575 return unless -f $fn;
1577 open(my $fh, '<:encoding(UTF-8)', $fn)
1578 or croak "Cannot open '$fn' for reading: $!";
1581 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1583 my ($md5, $ts, $ver, $gen);
1589 # Pull out the version and timestamp from the line above
1590 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1593 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"
1594 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1603 my $custom = do { local $/; <$fh> }
1608 return ($gen, $md5, $ver, $ts, $custom);
1616 warn "$target: use $_;" if $self->debug;
1617 $self->_raw_stmt($target, "use $_;");
1625 my $blist = join(q{ }, @_);
1627 return unless $blist;
1629 warn "$target: use base qw/$blist/;" if $self->debug;
1630 $self->_raw_stmt($target, "use base qw/$blist/;");
1637 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1639 return unless $rlist;
1641 warn "$target: with $rlist;" if $self->debug;
1642 $self->_raw_stmt($target, "\nwith $rlist;");
1645 sub _result_namespace {
1646 my ($self, $schema_class, $ns) = @_;
1647 my @result_namespace;
1649 if ($ns =~ /^\+(.*)/) {
1650 # Fully qualified namespace
1651 @result_namespace = ($1)
1654 # Relative namespace
1655 @result_namespace = ($schema_class, $ns);
1658 return wantarray ? @result_namespace : join '::', @result_namespace;
1661 # Create class with applicable bases, setup monikers, etc
1662 sub _make_src_class {
1663 my ($self, $table) = @_;
1665 my $schema = $self->schema;
1666 my $schema_class = $self->schema_class;
1668 my $table_moniker = $self->_table2moniker($table);
1669 my @result_namespace = ($schema_class);
1670 if ($self->use_namespaces) {
1671 my $result_namespace = $self->result_namespace || 'Result';
1672 @result_namespace = $self->_result_namespace(
1677 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1679 if ((my $upgrading_v = $self->_upgrading_from)
1680 || $self->_rewriting) {
1681 local $self->naming->{monikers} = $upgrading_v
1684 my @result_namespace = @result_namespace;
1685 if ($self->_upgrading_from_load_classes) {
1686 @result_namespace = ($schema_class);
1688 elsif (my $ns = $self->_downgrading_to_load_classes) {
1689 @result_namespace = $self->_result_namespace(
1694 elsif ($ns = $self->_rewriting_result_namespace) {
1695 @result_namespace = $self->_result_namespace(
1701 my $old_class = join(q{::}, @result_namespace,
1702 $self->_table2moniker($table));
1704 $self->_upgrading_classes->{$table_class} = $old_class
1705 unless $table_class eq $old_class;
1708 $self->classes->{$table} = $table_class;
1709 $self->monikers->{$table} = $table_moniker;
1710 $self->tables->{$table_moniker} = $table;
1712 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1714 $self->_use ($table_class, @{$self->additional_classes});
1716 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1718 $self->_inject($table_class, @{$self->left_base_classes});
1720 my @components = @{ $self->components || [] };
1722 push @components, @{ $self->result_components_map->{$table_moniker} }
1723 if exists $self->result_components_map->{$table_moniker};
1725 my @fq_components = @components;
1726 foreach my $component (@fq_components) {
1727 if ($component !~ s/^\+//) {
1728 $component = "DBIx::Class::$component";
1732 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1734 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1736 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1738 $self->_inject($table_class, @{$self->additional_base_classes});
1741 sub _is_result_class_method {
1742 my ($self, $name, $table_name) = @_;
1744 my $table_moniker = $table_name ? $self->monikers->{$table_name} : '';
1746 $self->_result_class_methods({})
1747 if not defined $self->_result_class_methods;
1749 if (not exists $self->_result_class_methods->{$table_moniker}) {
1750 my (@methods, %methods);
1751 my $base = $self->result_base_class || 'DBIx::Class::Core';
1753 my @components = @{ $self->components || [] };
1755 push @components, @{ $self->result_components_map->{$table_moniker} }
1756 if exists $self->result_components_map->{$table_moniker};
1758 for my $c (@components) {
1759 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1762 my @roles = @{ $self->result_roles || [] };
1764 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1765 if exists $self->result_roles_map->{$table_moniker};
1767 for my $class ($base, @components,
1768 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1769 $self->ensure_class_loaded($class);
1771 push @methods, @{ Class::Inspector->methods($class) || [] };
1774 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1776 @methods{@methods} = ();
1778 $self->_result_class_methods->{$table_moniker} = \%methods;
1780 my $result_methods = $self->_result_class_methods->{$table_moniker};
1782 return exists $result_methods->{$name};
1785 sub _resolve_col_accessor_collisions {
1786 my ($self, $table, $col_info) = @_;
1788 my $table_name = ref $table ? $$table : $table;
1790 while (my ($col, $info) = each %$col_info) {
1791 my $accessor = $info->{accessor} || $col;
1793 next if $accessor eq 'id'; # special case (very common column)
1795 if ($self->_is_result_class_method($accessor, $table_name)) {
1798 if (my $map = $self->col_collision_map) {
1799 for my $re (keys %$map) {
1800 if (my @matches = $col =~ /$re/) {
1801 $info->{accessor} = sprintf $map->{$re}, @matches;
1809 Column '$col' in table '$table_name' collides with an inherited method.
1810 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1812 $info->{accessor} = undef;
1818 # use the same logic to run moniker_map, col_accessor_map, and
1819 # relationship_name_map
1821 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1823 my $default_ident = $default_code->( $ident, @extra );
1825 if( $map && ref $map eq 'HASH' ) {
1826 $new_ident = $map->{ $ident };
1828 elsif( $map && ref $map eq 'CODE' ) {
1829 $new_ident = $map->( $ident, $default_ident, @extra );
1832 $new_ident ||= $default_ident;
1837 sub _default_column_accessor_name {
1838 my ( $self, $column_name ) = @_;
1840 my $accessor_name = $column_name;
1841 $accessor_name =~ s/\W+/_/g;
1843 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1844 # older naming just lc'd the col accessor and that's all.
1845 return lc $accessor_name;
1847 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
1848 return $accessor_name;
1851 return join '_', map lc, split_name $column_name;
1854 sub _make_column_accessor_name {
1855 my ($self, $column_name, $column_context_info ) = @_;
1857 my $accessor = $self->_run_user_map(
1858 $self->col_accessor_map,
1859 sub { $self->_default_column_accessor_name( shift ) },
1861 $column_context_info,
1868 my ($self, $identifier) = @_;
1870 my $qt = $self->schema->storage->sql_maker->quote_char || '';
1873 return $qt->[0] . $identifier . $qt->[1];
1876 return "${qt}${identifier}${qt}";
1879 # Set up metadata (cols, pks, etc)
1880 sub _setup_src_meta {
1881 my ($self, $table) = @_;
1883 my $schema = $self->schema;
1884 my $schema_class = $self->schema_class;
1886 my $table_class = $self->classes->{$table};
1887 my $table_moniker = $self->monikers->{$table};
1889 my $table_name = $table;
1891 my $sql_maker = $self->schema->storage->sql_maker;
1892 my $name_sep = $sql_maker->name_sep;
1894 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1895 $table_name = \ $self->_quote($table_name);
1898 my $full_table_name = ($self->qualify_objects ?
1899 ($self->_quote($self->db_schema) . '.') : '')
1900 . (ref $table_name ? $$table_name : $table_name);
1902 # be careful to not create refs Data::Dump can "optimize"
1903 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1905 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1907 my $cols = $self->_table_columns($table);
1908 my $col_info = $self->__columns_info_for($table);
1910 ### generate all the column accessor names
1911 while (my ($col, $info) = each %$col_info) {
1912 # hashref of other info that could be used by
1913 # user-defined accessor map functions
1915 table_class => $table_class,
1916 table_moniker => $table_moniker,
1917 table_name => $table_name,
1918 full_table_name => $full_table_name,
1919 schema_class => $schema_class,
1920 column_info => $info,
1923 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1926 $self->_resolve_col_accessor_collisions($table, $col_info);
1928 # prune any redundant accessor names
1929 while (my ($col, $info) = each %$col_info) {
1930 no warnings 'uninitialized';
1931 delete $info->{accessor} if $info->{accessor} eq $col;
1934 my $fks = $self->_table_fk_info($table);
1936 foreach my $fkdef (@$fks) {
1937 for my $col (@{ $fkdef->{local_columns} }) {
1938 $col_info->{$col}{is_foreign_key} = 1;
1942 my $pks = $self->_table_pk_info($table) || [];
1944 foreach my $pkcol (@$pks) {
1945 $col_info->{$pkcol}{is_nullable} = 0;
1951 map { $_, ($col_info->{$_}||{}) } @$cols
1954 my %uniq_tag; # used to eliminate duplicate uniqs
1956 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1957 : carp("$table has no primary key");
1958 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1960 my $uniqs = $self->_table_uniq_info($table) || [];
1962 my ($name, $cols) = @$_;
1963 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1964 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1969 sub __columns_info_for {
1970 my ($self, $table) = @_;
1972 my $result = $self->_columns_info_for($table);
1974 while (my ($col, $info) = each %$result) {
1975 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1976 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1978 $result->{$col} = $info;
1986 Returns a sorted list of loaded tables, using the original database table
1994 return keys %{$self->_tables};
1997 # Make a moniker from a table
1998 sub _default_table2moniker {
1999 no warnings 'uninitialized';
2000 my ($self, $table) = @_;
2002 if ($self->naming->{monikers} eq 'v4') {
2003 return join '', map ucfirst, split /[\W_]+/, lc $table;
2005 elsif ($self->naming->{monikers} eq 'v5') {
2006 return join '', map ucfirst, split /[\W_]+/,
2007 Lingua::EN::Inflect::Number::to_S(lc $table);
2009 elsif ($self->naming->{monikers} eq 'v6') {
2010 (my $as_phrase = lc $table) =~ s/_+/ /g;
2011 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2013 return join '', map ucfirst, split /\W+/, $inflected;
2016 my @words = map lc, split_name $table;
2017 my $as_phrase = join ' ', @words;
2019 my $inflected = $self->naming->{monikers} eq 'plural' ?
2020 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2022 $self->naming->{monikers} eq 'preserve' ?
2025 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2027 return join '', map ucfirst, split /\W+/, $inflected;
2030 sub _table2moniker {
2031 my ( $self, $table ) = @_;
2033 $self->_run_user_map(
2035 sub { $self->_default_table2moniker( shift ) },
2040 sub _load_relationships {
2041 my ($self, $tables) = @_;
2045 foreach my $table (@$tables) {
2046 my $tbl_fk_info = $self->_table_fk_info($table);
2047 foreach my $fkdef (@$tbl_fk_info) {
2048 $fkdef->{remote_source} =
2049 $self->monikers->{delete $fkdef->{remote_table}};
2051 my $tbl_uniq_info = $self->_table_uniq_info($table);
2053 my $local_moniker = $self->monikers->{$table};
2055 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2058 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2060 foreach my $src_class (sort keys %$rel_stmts) {
2061 my $src_stmts = $rel_stmts->{$src_class};
2062 foreach my $stmt (@$src_stmts) {
2063 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2069 my ($self, $table) = @_;
2071 my $table_moniker = $self->monikers->{$table};
2072 my $table_class = $self->classes->{$table};
2074 my @roles = @{ $self->result_roles || [] };
2075 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2076 if exists $self->result_roles_map->{$table_moniker};
2079 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2081 $self->_with($table_class, @roles);
2085 # Overload these in driver class:
2087 # Returns an arrayref of column names
2088 sub _table_columns { croak "ABSTRACT METHOD" }
2090 # Returns arrayref of pk col names
2091 sub _table_pk_info { croak "ABSTRACT METHOD" }
2093 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2094 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2096 # Returns an arrayref of foreign key constraints, each
2097 # being a hashref with 3 keys:
2098 # local_columns (arrayref), remote_columns (arrayref), remote_table
2099 sub _table_fk_info { croak "ABSTRACT METHOD" }
2101 # Returns an array of lower case table names
2102 sub _tables_list { croak "ABSTRACT METHOD" }
2104 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2110 # generate the pod for this statement, storing it with $self->_pod
2111 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2113 my $args = dump(@_);
2114 $args = '(' . $args . ')' if @_ < 2;
2115 my $stmt = $method . $args . q{;};
2117 warn qq|$class\->$stmt\n| if $self->debug;
2118 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2122 # generates the accompanying pod for a DBIC class method statement,
2123 # storing it with $self->_pod
2129 if ( $method eq 'table' ) {
2131 my $pcm = $self->pod_comment_mode;
2132 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2133 $comment = $self->__table_comment($table);
2134 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2135 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2136 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2137 $self->_pod( $class, "=head1 NAME" );
2138 my $table_descr = $class;
2139 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2140 $self->{_class2table}{ $class } = $table;
2141 $self->_pod( $class, $table_descr );
2142 if ($comment and $comment_in_desc) {
2143 $self->_pod( $class, "=head1 DESCRIPTION" );
2144 $self->_pod( $class, $comment );
2146 $self->_pod_cut( $class );
2147 } elsif ( $method eq 'add_columns' ) {
2148 $self->_pod( $class, "=head1 ACCESSORS" );
2149 my $col_counter = 0;
2151 while( my ($name,$attrs) = splice @cols,0,2 ) {
2153 $self->_pod( $class, '=head2 ' . $name );
2154 $self->_pod( $class,
2156 my $s = $attrs->{$_};
2157 $s = !defined $s ? 'undef' :
2158 length($s) == 0 ? '(empty string)' :
2159 ref($s) eq 'SCALAR' ? $$s :
2160 ref($s) ? dumper_squashed $s :
2161 looks_like_number($s) ? $s : qq{'$s'};
2164 } sort keys %$attrs,
2166 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
2167 $self->_pod( $class, $comment );
2170 $self->_pod_cut( $class );
2171 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2172 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2173 my ( $accessor, $rel_class ) = @_;
2174 $self->_pod( $class, "=head2 $accessor" );
2175 $self->_pod( $class, 'Type: ' . $method );
2176 $self->_pod( $class, "Related object: L<$rel_class>" );
2177 $self->_pod_cut( $class );
2178 $self->{_relations_started} { $class } = 1;
2182 sub _pod_class_list {
2183 my ($self, $class, $title, @classes) = @_;
2185 return unless @classes && $self->generate_pod;
2187 $self->_pod($class, "=head1 $title");
2188 $self->_pod($class, '=over 4');
2190 foreach my $link (@classes) {
2191 $self->_pod($class, "=item * L<$link>");
2194 $self->_pod($class, '=back');
2195 $self->_pod_cut($class);
2198 sub _base_class_pod {
2199 my ($self, $class, $base_class) = @_;
2201 return unless $self->generate_pod;
2203 $self->_pod($class, "=head1 BASE CLASS: L<$base_class>");
2204 $self->_pod_cut($class);
2207 sub _filter_comment {
2208 my ($self, $txt) = @_;
2210 $txt = '' if not defined $txt;
2212 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2217 sub __table_comment {
2220 if (my $code = $self->can('_table_comment')) {
2221 return $self->_filter_comment($self->$code(@_));
2227 sub __column_comment {
2230 if (my $code = $self->can('_column_comment')) {
2231 return $self->_filter_comment($self->$code(@_));
2237 # Stores a POD documentation
2239 my ($self, $class, $stmt) = @_;
2240 $self->_raw_stmt( $class, "\n" . $stmt );
2244 my ($self, $class ) = @_;
2245 $self->_raw_stmt( $class, "\n=cut\n" );
2248 # Store a raw source line for a class (for dumping purposes)
2250 my ($self, $class, $stmt) = @_;
2251 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2254 # Like above, but separately for the externally loaded stuff
2256 my ($self, $class, $stmt) = @_;
2257 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2260 sub _custom_column_info {
2261 my ( $self, $table_name, $column_name, $column_info ) = @_;
2263 if (my $code = $self->custom_column_info) {
2264 return $code->($table_name, $column_name, $column_info) || {};
2269 sub _datetime_column_info {
2270 my ( $self, $table_name, $column_name, $column_info ) = @_;
2272 my $type = $column_info->{data_type} || '';
2273 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2274 or ($type =~ /date|timestamp/i)) {
2275 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2276 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2282 my ($self, $name) = @_;
2284 return $self->preserve_case ? $name : lc($name);
2288 my ($self, $name) = @_;
2290 return $self->preserve_case ? $name : uc($name);
2293 sub _unregister_source_for_table {
2294 my ($self, $table) = @_;
2298 my $schema = $self->schema;
2299 # in older DBIC it's a private method
2300 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2301 $schema->$unregister($self->_table2moniker($table));
2302 delete $self->monikers->{$table};
2303 delete $self->classes->{$table};
2304 delete $self->_upgrading_classes->{$table};
2305 delete $self->{_tables}{$table};
2309 # remove the dump dir from @INC on destruction
2313 @INC = grep $_ ne $self->dump_directory, @INC;
2318 Returns a hashref of loaded table to moniker mappings. There will
2319 be two entries for each table, the original name and the "normalized"
2320 name, in the case that the two are different (such as databases
2321 that like uppercase table names, or preserve your original mixed-case
2322 definitions, or what-have-you).
2326 Returns a hashref of table to class mappings. In some cases it will
2327 contain multiple entries per table for the original and normalized table
2328 names, as above in L</monikers>.
2330 =head1 COLUMN ACCESSOR COLLISIONS
2332 Occasionally you may have a column name that collides with a perl method, such
2333 as C<can>. In such cases, the default action is to set the C<accessor> of the
2334 column spec to C<undef>.
2336 You can then name the accessor yourself by placing code such as the following
2339 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2341 Another option is to use the L</col_collision_map> option.
2343 =head1 RELATIONSHIP NAME COLLISIONS
2345 In very rare cases, you may get a collision between a generated relationship
2346 name and a method in your Result class, for example if you have a foreign key
2347 called C<belongs_to>.
2349 This is a problem because relationship names are also relationship accessor
2350 methods in L<DBIx::Class>.
2352 The default behavior is to append C<_rel> to the relationship name and print
2353 out a warning that refers to this text.
2355 You can also control the renaming with the L</rel_collision_map> option.
2359 L<DBIx::Class::Schema::Loader>
2363 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2367 This library is free software; you can redistribute it and/or modify it under
2368 the same terms as Perl itself.
2373 # vim:et sts=4 sw=4 tw=0: