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 ();
27 our $VERSION = '0.07010';
29 __PACKAGE__->mk_group_ro_accessors('simple', qw/
36 additional_base_classes
51 default_resultset_class
56 overwrite_modifications
75 __PACKAGE__->mk_group_accessors('simple', qw/
77 schema_version_to_dump
79 _upgrading_from_load_classes
80 _downgrading_to_load_classes
81 _rewriting_result_namespace
86 pod_comment_spillover_length
93 datetime_undef_if_invalid
100 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
104 See L<DBIx::Class::Schema::Loader>
108 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
109 classes, and implements the common functionality between them.
111 =head1 CONSTRUCTOR OPTIONS
113 These constructor options are the base options for
114 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
116 =head2 skip_relationships
118 Skip setting up relationships. The default is to attempt the loading
121 =head2 skip_load_external
123 Skip loading of other classes in @INC. The default is to merge all other classes
124 with the same name found in @INC into the schema file we are creating.
128 Static schemas (ones dumped to disk) will, by default, use the new-style
129 relationship names and singularized Results, unless you're overwriting an
130 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
131 which case the backward compatible RelBuilder will be activated, and the
132 appropriate monikerization used.
138 will disable the backward-compatible RelBuilder and use
139 the new-style relationship names along with singularized Results, even when
140 overwriting a dump made with an earlier version.
142 The option also takes a hashref:
144 naming => { relationships => 'v7', monikers => 'v7' }
152 How to name relationship accessors.
156 How to name Result classes.
158 =item column_accessors
160 How to name column accessors in Result classes.
170 Latest style, whatever that happens to be.
174 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
178 Monikers singularized as whole words, C<might_have> relationships for FKs on
179 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
181 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
186 All monikers and relationships are inflected using
187 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
188 from relationship names.
190 In general, there is very little difference between v5 and v6 schemas.
194 This mode is identical to C<v6> mode, except that monikerization of CamelCase
195 table names is also done correctly.
197 CamelCase column names in case-preserving mode will also be handled correctly
198 for relationship name inflection. See L</preserve_case>.
200 In this mode, CamelCase L</column_accessors> are normalized based on case
201 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
203 If you don't have any CamelCase table or column names, you can upgrade without
204 breaking any of your code.
208 Dynamic schemas will always default to the 0.04XXX relationship names and won't
209 singularize Results for backward compatibility, to activate the new RelBuilder
210 and singularization put this in your C<Schema.pm> file:
212 __PACKAGE__->naming('current');
214 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
215 next major version upgrade:
217 __PACKAGE__->naming('v7');
221 By default POD will be generated for columns and relationships, using database
222 metadata for the text if available and supported.
224 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
225 supported for Postgres right now.
227 Set this to C<0> to turn off all POD generation.
229 =head2 pod_comment_mode
231 Controls where table comments appear in the generated POD. Smaller table
232 comments are appended to the C<NAME> section of the documentation, and larger
233 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
234 section to be generated with the comment always, only use C<NAME>, or choose
235 the length threshold at which the comment is forced into the description.
241 Use C<NAME> section only.
245 Force C<DESCRIPTION> always.
249 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
254 =head2 pod_comment_spillover_length
256 When pod_comment_mode is set to C<auto>, this is the length of the comment at
257 which it will be forced into a separate description section.
261 =head2 relationship_attrs
263 Hashref of attributes to pass to each generated relationship, listed
264 by type. Also supports relationship type 'all', containing options to
265 pass to all generated relationships. Attributes set for more specific
266 relationship types override those set in 'all'.
270 relationship_attrs => {
271 belongs_to => { is_deferrable => 0 },
274 use this to turn off DEFERRABLE on your foreign key constraints.
278 If set to true, each constructive L<DBIx::Class> statement the loader
279 decides to execute will be C<warn>-ed before execution.
283 Set the name of the schema to load (schema in the sense that your database
284 vendor means it). Does not currently support loading more than one schema
289 Only load tables matching regex. Best specified as a qr// regex.
293 Exclude tables matching regex. Best specified as a qr// regex.
297 Overrides the default table name to moniker translation. Can be either
298 a hashref of table keys and moniker values, or a coderef for a translator
299 function taking a single scalar table name argument and returning
300 a scalar moniker. If the hash entry does not exist, or the function
301 returns a false value, the code falls back to default behavior
304 The default behavior is to split on case transition and non-alphanumeric
305 boundaries, singularize the resulting phrase, then join the titlecased words
308 Table Name | Moniker Name
309 ---------------------------------
311 luser_group | LuserGroup
312 luser-opts | LuserOpt
313 stations_visited | StationVisited
314 routeChange | RouteChange
316 =head2 col_accessor_map
318 Same as moniker_map, but for column accessor names. If a coderef is
319 passed, the code is called with arguments of
321 the name of the column in the underlying database,
322 default accessor name that DBICSL would ordinarily give this column,
324 table_class => name of the DBIC class we are building,
325 table_moniker => calculated moniker for this table (after moniker_map if present),
326 table_name => name of the database table,
327 full_table_name => schema-qualified name of the database table (RDBMS specific),
328 schema_class => name of the schema class we are building,
329 column_info => hashref of column info (data_type, is_nullable, etc),
332 =head2 inflect_plural
334 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
335 if hash key does not exist or coderef returns false), but acts as a map
336 for pluralizing relationship names. The default behavior is to utilize
337 L<Lingua::EN::Inflect::Phrase/to_PL>.
339 =head2 inflect_singular
341 As L</inflect_plural> above, but for singularizing relationship names.
342 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
344 =head2 schema_base_class
346 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
348 =head2 result_base_class
350 Base class for your table classes (aka result classes). Defaults to
353 =head2 additional_base_classes
355 List of additional base classes all of your table classes will use.
357 =head2 left_base_classes
359 List of additional base classes all of your table classes will use
360 that need to be leftmost.
362 =head2 additional_classes
364 List of additional classes which all of your table classes will use.
368 List of additional components to be loaded into all of your table
369 classes. A good example would be
370 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
372 =head2 result_components_map
374 A hashref of moniker keys and component values. Unlike C<components>, which
375 loads the given components into every Result class, this option allows you to
376 load certain components for specified Result classes. For example:
378 result_components_map => {
379 StationVisited => '+YourApp::Schema::Component::StationVisited',
381 '+YourApp::Schema::Component::RouteChange',
382 'InflateColumn::DateTime',
386 You may use this in conjunction with C<components>.
390 List of L<Moose> roles to be applied to all of your Result classes.
392 =head2 result_roles_map
394 A hashref of moniker keys and role values. Unlike C<result_roles>, which
395 applies the given roles to every Result class, this option allows you to apply
396 certain roles for specified Result classes. For example:
398 result_roles_map => {
400 'YourApp::Role::Building',
401 'YourApp::Role::Destination',
403 RouteChange => 'YourApp::Role::TripEvent',
406 You may use this in conjunction with C<components>.
408 =head2 use_namespaces
410 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
413 Generate result class names suitable for
414 L<DBIx::Class::Schema/load_namespaces> and call that instead of
415 L<DBIx::Class::Schema/load_classes>. When using this option you can also
416 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
417 C<resultset_namespace>, C<default_resultset_class>), and they will be added
418 to the call (and the generated result class names adjusted appropriately).
420 =head2 dump_directory
422 The value of this option is a perl libdir pathname. Within
423 that directory this module will create a baseline manual
424 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
426 The created schema class will have the same classname as the one on
427 which you are setting this option (and the ResultSource classes will be
428 based on this name as well).
430 Normally you wouldn't hard-code this setting in your schema class, as it
431 is meant for one-time manual usage.
433 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
434 recommended way to access this functionality.
436 =head2 dump_overwrite
438 Deprecated. See L</really_erase_my_files> below, which does *not* mean
439 the same thing as the old C<dump_overwrite> setting from previous releases.
441 =head2 really_erase_my_files
443 Default false. If true, Loader will unconditionally delete any existing
444 files before creating the new ones from scratch when dumping a schema to disk.
446 The default behavior is instead to only replace the top portion of the
447 file, up to and including the final stanza which contains
448 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
449 leaving any customizations you placed after that as they were.
451 When C<really_erase_my_files> is not set, if the output file already exists,
452 but the aforementioned final stanza is not found, or the checksum
453 contained there does not match the generated contents, Loader will
454 croak and not touch the file.
456 You should really be using version control on your schema classes (and all
457 of the rest of your code for that matter). Don't blame me if a bug in this
458 code wipes something out when it shouldn't have, you've been warned.
460 =head2 overwrite_modifications
462 Default false. If false, when updating existing files, Loader will
463 refuse to modify any Loader-generated code that has been modified
464 since its last run (as determined by the checksum Loader put in its
467 If true, Loader will discard any manual modifications that have been
468 made to Loader-generated code.
470 Again, you should be using version control on your schema classes. Be
471 careful with this option.
473 =head2 custom_column_info
475 Hook for adding extra attributes to the
476 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
478 Must be a coderef that returns a hashref with the extra attributes.
480 Receives the table name, column name and column_info.
484 custom_column_info => sub {
485 my ($table_name, $column_name, $column_info) = @_;
487 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
488 return { is_snoopy => 1 };
492 This attribute can also be used to set C<inflate_datetime> on a non-datetime
493 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
495 =head2 datetime_timezone
497 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
498 columns with the DATE/DATETIME/TIMESTAMP data_types.
500 =head2 datetime_locale
502 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
503 columns with the DATE/DATETIME/TIMESTAMP data_types.
505 =head2 datetime_undef_if_invalid
507 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
508 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
511 The default is recommended to deal with data such as C<00/00/00> which
512 sometimes ends up in such columns in MySQL.
516 File in Perl format, which should return a HASH reference, from which to read
521 Usually column names are lowercased, to make them easier to work with in
522 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
525 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
526 case-sensitive collation will turn this option on unconditionally.
528 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
531 =head2 qualify_objects
533 Set to true to prepend the L</db_schema> to table names for C<<
534 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
538 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
539 L<namespace::autoclean>. The default content after the md5 sum also makes the
542 It is safe to upgrade your existing Schema to this option.
544 =head2 col_collision_map
546 This option controls how accessors for column names which collide with perl
547 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
549 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
550 strings which are compiled to regular expressions that map to
551 L<sprintf|perlfunc/sprintf> formats.
555 col_collision_map => 'column_%s'
557 col_collision_map => { '(.*)' => 'column_%s' }
559 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
561 =head2 rel_collision_map
563 Works just like L</col_collision_map>, but for relationship names/accessors
564 rather than column names/accessors.
566 The default is to just append C<_rel> to the relationship name, see
567 L</RELATIONSHIP NAME COLLISIONS>.
571 None of these methods are intended for direct invocation by regular
572 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
573 L<DBIx::Class::Schema::Loader>.
577 my $CURRENT_V = 'v7';
580 schema_base_class result_base_class additional_base_classes
581 left_base_classes additional_classes components result_roles
584 # ensure that a peice of object data is a valid arrayref, creating
585 # an empty one or encapsulating whatever's there.
586 sub _ensure_arrayref {
591 $self->{$_} = [ $self->{$_} ]
592 unless ref $self->{$_} eq 'ARRAY';
598 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
599 by L<DBIx::Class::Schema::Loader>.
604 my ( $class, %args ) = @_;
606 if (exists $args{column_accessor_map}) {
607 $args{col_accessor_map} = delete $args{column_accessor_map};
610 my $self = { %args };
612 # don't lose undef options
613 for (values %$self) {
614 $_ = 0 unless defined $_;
617 bless $self => $class;
619 if (my $config_file = $self->config_file) {
620 my $config_opts = do $config_file;
622 croak "Error reading config from $config_file: $@" if $@;
624 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
626 while (my ($k, $v) = each %$config_opts) {
627 $self->{$k} = $v unless exists $self->{$k};
631 $self->result_components_map($self->{result_component_map})
632 if defined $self->{result_component_map};
634 $self->result_roles_map($self->{result_role_map})
635 if defined $self->{result_role_map};
637 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
638 if ((not defined $self->use_moose) || (not $self->use_moose))
639 && ((defined $self->result_roles) || (defined $self->result_roles_map));
641 $self->_ensure_arrayref(qw/additional_classes
642 additional_base_classes
648 $self->_validate_class_args;
650 croak "result_components_map must be a hash"
651 if defined $self->result_components_map
652 && ref $self->result_components_map ne 'HASH';
654 if ($self->result_components_map) {
655 my %rc_map = %{ $self->result_components_map };
656 foreach my $moniker (keys %rc_map) {
657 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
659 $self->result_components_map(\%rc_map);
662 $self->result_components_map({});
664 $self->_validate_result_components_map;
666 croak "result_roles_map must be a hash"
667 if defined $self->result_roles_map
668 && ref $self->result_roles_map ne 'HASH';
670 if ($self->result_roles_map) {
671 my %rr_map = %{ $self->result_roles_map };
672 foreach my $moniker (keys %rr_map) {
673 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
675 $self->result_roles_map(\%rr_map);
677 $self->result_roles_map({});
679 $self->_validate_result_roles_map;
681 if ($self->use_moose) {
682 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
683 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
684 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
688 $self->{monikers} = {};
689 $self->{classes} = {};
690 $self->{_upgrading_classes} = {};
692 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
693 $self->{schema} ||= $self->{schema_class};
695 croak "dump_overwrite is deprecated. Please read the"
696 . " DBIx::Class::Schema::Loader::Base documentation"
697 if $self->{dump_overwrite};
699 $self->{dynamic} = ! $self->{dump_directory};
700 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
705 $self->{dump_directory} ||= $self->{temp_directory};
707 $self->real_dump_directory($self->{dump_directory});
709 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
710 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
712 if (not defined $self->naming) {
713 $self->naming_set(0);
716 $self->naming_set(1);
719 if ((not ref $self->naming) && defined $self->naming) {
720 my $naming_ver = $self->naming;
722 relationships => $naming_ver,
723 monikers => $naming_ver,
724 column_accessors => $naming_ver,
729 for (values %{ $self->naming }) {
730 $_ = $CURRENT_V if $_ eq 'current';
733 $self->{naming} ||= {};
735 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
736 croak 'custom_column_info must be a CODE ref';
739 $self->_check_back_compat;
741 $self->use_namespaces(1) unless defined $self->use_namespaces;
742 $self->generate_pod(1) unless defined $self->generate_pod;
743 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
744 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
746 if (my $col_collision_map = $self->col_collision_map) {
747 if (my $reftype = ref $col_collision_map) {
748 if ($reftype ne 'HASH') {
749 croak "Invalid type $reftype for option 'col_collision_map'";
753 $self->col_collision_map({ '(.*)' => $col_collision_map });
760 sub _check_back_compat {
763 # dynamic schemas will always be in 0.04006 mode, unless overridden
764 if ($self->dynamic) {
765 # just in case, though no one is likely to dump a dynamic schema
766 $self->schema_version_to_dump('0.04006');
768 if (not $self->naming_set) {
769 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
771 Dynamic schema detected, will run in 0.04006 mode.
773 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
774 to disable this warning.
776 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
781 $self->_upgrading_from('v4');
784 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
785 $self->use_namespaces(1);
788 $self->naming->{relationships} ||= 'v4';
789 $self->naming->{monikers} ||= 'v4';
791 if ($self->use_namespaces) {
792 $self->_upgrading_from_load_classes(1);
795 $self->use_namespaces(0);
801 # otherwise check if we need backcompat mode for a static schema
802 my $filename = $self->_get_dump_filename($self->schema_class);
803 return unless -e $filename;
805 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
806 $self->_parse_generated_file($filename);
808 return unless $old_ver;
810 # determine if the existing schema was dumped with use_moose => 1
811 if (! defined $self->use_moose) {
812 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
815 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
816 my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
818 if ($load_classes && (not defined $self->use_namespaces)) {
819 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
821 'load_classes;' static schema detected, turning off 'use_namespaces'.
823 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
824 variable to disable this warning.
826 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
829 $self->use_namespaces(0);
831 elsif ($load_classes && $self->use_namespaces) {
832 $self->_upgrading_from_load_classes(1);
834 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
835 $self->_downgrading_to_load_classes(
836 $result_namespace || 'Result'
839 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
840 if (not $self->result_namespace) {
841 $self->result_namespace($result_namespace || 'Result');
843 elsif ($result_namespace ne $self->result_namespace) {
844 $self->_rewriting_result_namespace(
845 $result_namespace || 'Result'
850 # XXX when we go past .0 this will need fixing
851 my ($v) = $old_ver =~ /([1-9])/;
854 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
856 if (not %{ $self->naming }) {
857 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
859 Version $old_ver static schema detected, turning on backcompat mode.
861 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
862 to disable this warning.
864 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
866 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
867 from version 0.04006.
870 $self->naming->{relationships} ||= $v;
871 $self->naming->{monikers} ||= $v;
872 $self->naming->{column_accessors} ||= $v;
874 $self->schema_version_to_dump($old_ver);
877 $self->_upgrading_from($v);
881 sub _validate_class_args {
884 foreach my $k (@CLASS_ARGS) {
885 next unless $self->$k;
887 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
888 $self->_validate_classes($k, \@classes);
892 sub _validate_result_components_map {
895 foreach my $classes (values %{ $self->result_components_map }) {
896 $self->_validate_classes('result_components_map', $classes);
900 sub _validate_result_roles_map {
903 foreach my $classes (values %{ $self->result_roles_map }) {
904 $self->_validate_classes('result_roles_map', $classes);
908 sub _validate_classes {
913 # make a copy to not destroy original
914 my @classes = @$classes;
916 foreach my $c (@classes) {
917 # components default to being under the DBIx::Class namespace unless they
918 # are preceeded with a '+'
919 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
920 $c = 'DBIx::Class::' . $c;
923 # 1 == installed, 0 == not installed, undef == invalid classname
924 my $installed = Class::Inspector->installed($c);
925 if ( defined($installed) ) {
926 if ( $installed == 0 ) {
927 croak qq/$c, as specified in the loader option "$key", is not installed/;
930 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
936 sub _find_file_in_inc {
937 my ($self, $file) = @_;
939 foreach my $prefix (@INC) {
940 my $fullpath = File::Spec->catfile($prefix, $file);
941 return $fullpath if -f $fullpath
942 # abs_path throws on Windows for nonexistant files
943 and (try { Cwd::abs_path($fullpath) }) ne
944 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
950 sub _find_class_in_inc {
951 my ($self, $class) = @_;
953 return $self->_find_file_in_inc(class_path($class));
959 return $self->_upgrading_from
960 || $self->_upgrading_from_load_classes
961 || $self->_downgrading_to_load_classes
962 || $self->_rewriting_result_namespace
966 sub _rewrite_old_classnames {
967 my ($self, $code) = @_;
969 return $code unless $self->_rewriting;
971 my %old_classes = reverse %{ $self->_upgrading_classes };
973 my $re = join '|', keys %old_classes;
976 $code =~ s/$re/$old_classes{$1} || $1/eg;
982 my ($self, $class) = @_;
984 return if $self->{skip_load_external};
986 # so that we don't load our own classes, under any circumstances
987 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
989 my $real_inc_path = $self->_find_class_in_inc($class);
991 my $old_class = $self->_upgrading_classes->{$class}
992 if $self->_rewriting;
994 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
995 if $old_class && $old_class ne $class;
997 return unless $real_inc_path || $old_real_inc_path;
999 if ($real_inc_path) {
1000 # If we make it to here, we loaded an external definition
1001 warn qq/# Loaded external class definition for '$class'\n/
1004 my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
1006 if ($self->dynamic) { # load the class too
1007 eval_package_without_redefine_warnings($class, $code);
1010 $self->_ext_stmt($class,
1011 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1012 .qq|# They are now part of the custom portion of this file\n|
1013 .qq|# for you to hand-edit. If you do not either delete\n|
1014 .qq|# this section or remove that file from \@INC, this section\n|
1015 .qq|# will be repeated redundantly when you re-create this\n|
1016 .qq|# file again via Loader! See skip_load_external to disable\n|
1017 .qq|# this feature.\n|
1020 $self->_ext_stmt($class, $code);
1021 $self->_ext_stmt($class,
1022 qq|# End of lines loaded from '$real_inc_path' |
1026 if ($old_real_inc_path) {
1027 my $code = slurp $old_real_inc_path;
1029 $self->_ext_stmt($class, <<"EOF");
1031 # These lines were loaded from '$old_real_inc_path',
1032 # based on the Result class name that would have been created by an older
1033 # version of the Loader. For a static schema, this happens only once during
1034 # upgrade. See skip_load_external to disable this feature.
1037 $code = $self->_rewrite_old_classnames($code);
1039 if ($self->dynamic) {
1042 Detected external content in '$old_real_inc_path', a class name that would have
1043 been used by an older version of the Loader.
1045 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1046 new name of the Result.
1048 eval_package_without_redefine_warnings($class, $code);
1052 $self->_ext_stmt($class, $code);
1053 $self->_ext_stmt($class,
1054 qq|# End of lines loaded from '$old_real_inc_path' |
1061 Does the actual schema-construction work.
1068 $self->_load_tables(
1069 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1077 Rescan the database for changes. Returns a list of the newly added table
1080 The schema argument should be the schema class or object to be affected. It
1081 should probably be derived from the original schema_class used during L</load>.
1086 my ($self, $schema) = @_;
1088 $self->{schema} = $schema;
1089 $self->_relbuilder->{schema} = $schema;
1092 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1094 foreach my $table (@current) {
1095 if(!exists $self->{_tables}->{$table}) {
1096 push(@created, $table);
1101 @current{@current} = ();
1102 foreach my $table (keys %{ $self->{_tables} }) {
1103 if (not exists $current{$table}) {
1104 $self->_unregister_source_for_table($table);
1108 delete $self->{_dump_storage};
1109 delete $self->{_relations_started};
1111 my $loaded = $self->_load_tables(@current);
1113 return map { $self->monikers->{$_} } @created;
1119 return if $self->{skip_relationships};
1121 return $self->{relbuilder} ||= do {
1123 no warnings 'uninitialized';
1124 my $relbuilder_suff =
1130 ->{ $self->naming->{relationships}};
1132 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1133 $self->ensure_class_loaded($relbuilder_class);
1134 $relbuilder_class->new( $self );
1140 my ($self, @tables) = @_;
1142 # Save the new tables to the tables list
1144 $self->{_tables}->{$_} = 1;
1147 $self->_make_src_class($_) for @tables;
1149 # sanity-check for moniker clashes
1150 my $inverse_moniker_idx;
1151 for (keys %{$self->monikers}) {
1152 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1156 for (keys %$inverse_moniker_idx) {
1157 my $tables = $inverse_moniker_idx->{$_};
1159 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1160 join (', ', map { "'$_'" } @$tables),
1167 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1168 . 'Either change the naming style, or supply an explicit moniker_map: '
1169 . join ('; ', @clashes)
1175 $self->_setup_src_meta($_) for @tables;
1177 if(!$self->skip_relationships) {
1178 # The relationship loader needs a working schema
1180 local $self->{dump_directory} = $self->{temp_directory};
1181 $self->_reload_classes(\@tables);
1182 $self->_load_relationships($_) for @tables;
1183 $self->_relbuilder->cleanup;
1186 # Remove that temp dir from INC so it doesn't get reloaded
1187 @INC = grep $_ ne $self->dump_directory, @INC;
1190 $self->_load_roles($_) for @tables;
1192 $self->_load_external($_)
1193 for map { $self->classes->{$_} } @tables;
1195 # Reload without unloading first to preserve any symbols from external
1197 $self->_reload_classes(\@tables, { unload => 0 });
1199 # Drop temporary cache
1200 delete $self->{_cache};
1205 sub _reload_classes {
1206 my ($self, $tables, $opts) = @_;
1208 my @tables = @$tables;
1210 my $unload = $opts->{unload};
1211 $unload = 1 unless defined $unload;
1213 # so that we don't repeat custom sections
1214 @INC = grep $_ ne $self->dump_directory, @INC;
1216 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1218 unshift @INC, $self->dump_directory;
1221 my %have_source = map { $_ => $self->schema->source($_) }
1222 $self->schema->sources;
1224 for my $table (@tables) {
1225 my $moniker = $self->monikers->{$table};
1226 my $class = $self->classes->{$table};
1229 no warnings 'redefine';
1230 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1233 if (my $mc = $self->_moose_metaclass($class)) {
1236 Class::Unload->unload($class) if $unload;
1237 my ($source, $resultset_class);
1239 ($source = $have_source{$moniker})
1240 && ($resultset_class = $source->resultset_class)
1241 && ($resultset_class ne 'DBIx::Class::ResultSet')
1243 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1244 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1247 Class::Unload->unload($resultset_class) if $unload;
1248 $self->_reload_class($resultset_class) if $has_file;
1250 $self->_reload_class($class);
1252 push @to_register, [$moniker, $class];
1255 Class::C3->reinitialize;
1256 for (@to_register) {
1257 $self->schema->register_class(@$_);
1261 sub _moose_metaclass {
1262 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1266 my $mc = try { Class::MOP::class_of($class) }
1269 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1272 # We use this instead of ensure_class_loaded when there are package symbols we
1275 my ($self, $class) = @_;
1277 delete $INC{ +class_path($class) };
1280 eval_package_without_redefine_warnings ($class, "require $class");
1283 my $source = slurp $self->_get_dump_filename($class);
1284 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1288 sub _get_dump_filename {
1289 my ($self, $class) = (@_);
1291 $class =~ s{::}{/}g;
1292 return $self->dump_directory . q{/} . $class . q{.pm};
1295 =head2 get_dump_filename
1299 Returns the full path to the file for a class that the class has been or will
1300 be dumped to. This is a file in a temp dir for a dynamic schema.
1304 sub get_dump_filename {
1305 my ($self, $class) = (@_);
1307 local $self->{dump_directory} = $self->real_dump_directory;
1309 return $self->_get_dump_filename($class);
1312 sub _ensure_dump_subdirs {
1313 my ($self, $class) = (@_);
1315 my @name_parts = split(/::/, $class);
1316 pop @name_parts; # we don't care about the very last element,
1317 # which is a filename
1319 my $dir = $self->dump_directory;
1322 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1324 last if !@name_parts;
1325 $dir = File::Spec->catdir($dir, shift @name_parts);
1330 my ($self, @classes) = @_;
1332 my $schema_class = $self->schema_class;
1333 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1335 my $target_dir = $self->dump_directory;
1336 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1337 unless $self->{dynamic} or $self->{quiet};
1340 qq|package $schema_class;\n\n|
1341 . qq|# Created by DBIx::Class::Schema::Loader\n|
1342 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1344 if ($self->use_moose) {
1345 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1348 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1351 if ($self->use_namespaces) {
1352 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1353 my $namespace_options;
1355 my @attr = qw/resultset_namespace default_resultset_class/;
1357 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1359 for my $attr (@attr) {
1361 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1364 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1365 $schema_text .= qq|;\n|;
1368 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1372 local $self->{version_to_dump} = $self->schema_version_to_dump;
1373 $self->_write_classfile($schema_class, $schema_text, 1);
1376 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1378 foreach my $src_class (@classes) {
1380 qq|package $src_class;\n\n|
1381 . qq|# Created by DBIx::Class::Schema::Loader\n|
1382 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1383 . qq|use strict;\nuse warnings;\n\n|;
1384 if ($self->use_moose) {
1385 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1387 # these options 'use base' which is compile time
1388 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1389 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1392 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1396 $src_text .= qq|use base '$result_base_class';\n\n|;
1399 $self->_base_class_pod($src_class, $result_base_class)
1400 unless $result_base_class eq 'DBIx::Class::Core';
1402 $self->_write_classfile($src_class, $src_text);
1405 # remove Result dir if downgrading from use_namespaces, and there are no
1407 if (my $result_ns = $self->_downgrading_to_load_classes
1408 || $self->_rewriting_result_namespace) {
1409 my $result_namespace = $self->_result_namespace(
1414 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1415 $result_dir = $self->dump_directory . '/' . $result_dir;
1417 unless (my @files = glob "$result_dir/*") {
1422 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1427 my ($self, $version, $ts) = @_;
1428 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1431 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1434 sub _write_classfile {
1435 my ($self, $class, $text, $is_schema) = @_;
1437 my $filename = $self->_get_dump_filename($class);
1438 $self->_ensure_dump_subdirs($class);
1440 if (-f $filename && $self->really_erase_my_files) {
1441 warn "Deleting existing file '$filename' due to "
1442 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1446 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1447 = $self->_parse_generated_file($filename);
1449 if (! $old_gen && -f $filename) {
1450 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1451 . " it does not appear to have been generated by Loader"
1454 my $custom_content = $old_custom || '';
1456 # prepend extra custom content from a *renamed* class (singularization effect)
1457 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1458 my $old_filename = $self->_get_dump_filename($renamed_class);
1460 if (-f $old_filename) {
1461 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1463 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1465 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1468 unlink $old_filename;
1472 $custom_content ||= $self->_default_custom_content($is_schema);
1474 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1475 # If there is already custom content, which does not have the Moose content, add it.
1476 if ($self->use_moose) {
1478 my $non_moose_custom_content = do {
1479 local $self->{use_moose} = 0;
1480 $self->_default_custom_content;
1483 if ($custom_content eq $non_moose_custom_content) {
1484 $custom_content = $self->_default_custom_content($is_schema);
1486 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1487 $custom_content .= $self->_default_custom_content($is_schema);
1490 elsif (defined $self->use_moose && $old_gen) {
1491 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'
1492 if $old_gen =~ /use \s+ MooseX?\b/x;
1495 $custom_content = $self->_rewrite_old_classnames($custom_content);
1498 for @{$self->{_dump_storage}->{$class} || []};
1500 # Check and see if the dump is infact differnt
1504 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1505 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1506 return unless $self->_upgrading_from && $is_schema;
1510 $text .= $self->_sig_comment(
1511 $self->version_to_dump,
1512 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1515 open(my $fh, '>', $filename)
1516 or croak "Cannot open '$filename' for writing: $!";
1518 # Write the top half and its MD5 sum
1519 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1521 # Write out anything loaded via external partial class file in @INC
1523 for @{$self->{_ext_storage}->{$class} || []};
1525 # Write out any custom content the user has added
1526 print $fh $custom_content;
1529 or croak "Error closing '$filename': $!";
1532 sub _default_moose_custom_content {
1533 my ($self, $is_schema) = @_;
1535 if (not $is_schema) {
1536 return qq|\n__PACKAGE__->meta->make_immutable;|;
1539 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1542 sub _default_custom_content {
1543 my ($self, $is_schema) = @_;
1544 my $default = qq|\n\n# You can replace this text with custom|
1545 . qq| code or comments, and it will be preserved on regeneration|;
1546 if ($self->use_moose) {
1547 $default .= $self->_default_moose_custom_content($is_schema);
1549 $default .= qq|\n1;\n|;
1553 sub _parse_generated_file {
1554 my ($self, $fn) = @_;
1556 return unless -f $fn;
1558 open(my $fh, '<', $fn)
1559 or croak "Cannot open '$fn' for reading: $!";
1562 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1564 my ($md5, $ts, $ver, $gen);
1570 # Pull out the version and timestamp from the line above
1571 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1574 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"
1575 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1584 my $custom = do { local $/; <$fh> }
1589 return ($gen, $md5, $ver, $ts, $custom);
1597 warn "$target: use $_;" if $self->debug;
1598 $self->_raw_stmt($target, "use $_;");
1606 my $blist = join(q{ }, @_);
1608 return unless $blist;
1610 warn "$target: use base qw/$blist/;" if $self->debug;
1611 $self->_raw_stmt($target, "use base qw/$blist/;");
1618 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1620 return unless $rlist;
1622 warn "$target: with $rlist;" if $self->debug;
1623 $self->_raw_stmt($target, "\nwith $rlist;");
1626 sub _result_namespace {
1627 my ($self, $schema_class, $ns) = @_;
1628 my @result_namespace;
1630 if ($ns =~ /^\+(.*)/) {
1631 # Fully qualified namespace
1632 @result_namespace = ($1)
1635 # Relative namespace
1636 @result_namespace = ($schema_class, $ns);
1639 return wantarray ? @result_namespace : join '::', @result_namespace;
1642 # Create class with applicable bases, setup monikers, etc
1643 sub _make_src_class {
1644 my ($self, $table) = @_;
1646 my $schema = $self->schema;
1647 my $schema_class = $self->schema_class;
1649 my $table_moniker = $self->_table2moniker($table);
1650 my @result_namespace = ($schema_class);
1651 if ($self->use_namespaces) {
1652 my $result_namespace = $self->result_namespace || 'Result';
1653 @result_namespace = $self->_result_namespace(
1658 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1660 if ((my $upgrading_v = $self->_upgrading_from)
1661 || $self->_rewriting) {
1662 local $self->naming->{monikers} = $upgrading_v
1665 my @result_namespace = @result_namespace;
1666 if ($self->_upgrading_from_load_classes) {
1667 @result_namespace = ($schema_class);
1669 elsif (my $ns = $self->_downgrading_to_load_classes) {
1670 @result_namespace = $self->_result_namespace(
1675 elsif ($ns = $self->_rewriting_result_namespace) {
1676 @result_namespace = $self->_result_namespace(
1682 my $old_class = join(q{::}, @result_namespace,
1683 $self->_table2moniker($table));
1685 $self->_upgrading_classes->{$table_class} = $old_class
1686 unless $table_class eq $old_class;
1689 $self->classes->{$table} = $table_class;
1690 $self->monikers->{$table} = $table_moniker;
1692 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
1694 $self->_use ($table_class, @{$self->additional_classes});
1696 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
1698 $self->_inject($table_class, @{$self->left_base_classes});
1700 my @components = @{ $self->components || [] };
1702 push @components, @{ $self->result_components_map->{$table_moniker} }
1703 if exists $self->result_components_map->{$table_moniker};
1705 my @fq_components = @components;
1706 foreach my $component (@fq_components) {
1707 if ($component !~ s/^\+//) {
1708 $component = "DBIx::Class::$component";
1712 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
1714 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1716 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
1718 $self->_inject($table_class, @{$self->additional_base_classes});
1721 sub _is_result_class_method {
1722 my ($self, $name, $table_name) = @_;
1724 my $table_moniker = $table_name ? $self->_table2moniker($table_name) : '';
1726 $self->_result_class_methods({})
1727 if not defined $self->_result_class_methods;
1729 if (not exists $self->_result_class_methods->{$table_moniker}) {
1730 my (@methods, %methods);
1731 my $base = $self->result_base_class || 'DBIx::Class::Core';
1733 my @components = @{ $self->components || [] };
1735 push @components, @{ $self->result_components_map->{$table_moniker} }
1736 if exists $self->result_components_map->{$table_moniker};
1738 for my $c (@components) {
1739 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1742 my @roles = @{ $self->result_roles || [] };
1744 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1745 if exists $self->result_roles_map->{$table_moniker};
1747 for my $class ($base, @components,
1748 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1749 $self->ensure_class_loaded($class);
1751 push @methods, @{ Class::Inspector->methods($class) || [] };
1754 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1756 @methods{@methods} = ();
1758 $self->_result_class_methods->{$table_moniker} = \%methods;
1760 my $result_methods = $self->_result_class_methods->{$table_moniker};
1762 return exists $result_methods->{$name};
1765 sub _resolve_col_accessor_collisions {
1766 my ($self, $table, $col_info) = @_;
1768 my $table_name = ref $table ? $$table : $table;
1770 while (my ($col, $info) = each %$col_info) {
1771 my $accessor = $info->{accessor} || $col;
1773 next if $accessor eq 'id'; # special case (very common column)
1775 if ($self->_is_result_class_method($accessor, $table_name)) {
1778 if (my $map = $self->col_collision_map) {
1779 for my $re (keys %$map) {
1780 if (my @matches = $col =~ /$re/) {
1781 $info->{accessor} = sprintf $map->{$re}, @matches;
1789 Column '$col' in table '$table_name' collides with an inherited method.
1790 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1792 $info->{accessor} = undef;
1798 # use the same logic to run moniker_map, col_accessor_map, and
1799 # relationship_name_map
1801 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1803 my $default_ident = $default_code->( $ident, @extra );
1805 if( $map && ref $map eq 'HASH' ) {
1806 $new_ident = $map->{ $ident };
1808 elsif( $map && ref $map eq 'CODE' ) {
1809 $new_ident = $map->( $ident, $default_ident, @extra );
1812 $new_ident ||= $default_ident;
1817 sub _default_column_accessor_name {
1818 my ( $self, $column_name ) = @_;
1820 my $accessor_name = $column_name;
1821 $accessor_name =~ s/\W+/_/g;
1823 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1824 # older naming just lc'd the col accessor and that's all.
1825 return lc $accessor_name;
1828 return join '_', map lc, split_name $column_name;
1832 sub _make_column_accessor_name {
1833 my ($self, $column_name, $column_context_info ) = @_;
1835 my $accessor = $self->_run_user_map(
1836 $self->col_accessor_map,
1837 sub { $self->_default_column_accessor_name( shift ) },
1839 $column_context_info,
1845 # Set up metadata (cols, pks, etc)
1846 sub _setup_src_meta {
1847 my ($self, $table) = @_;
1849 my $schema = $self->schema;
1850 my $schema_class = $self->schema_class;
1852 my $table_class = $self->classes->{$table};
1853 my $table_moniker = $self->monikers->{$table};
1855 my $table_name = $table;
1856 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1858 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1859 $table_name = \ $self->_quote_table_name($table_name);
1862 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1864 # be careful to not create refs Data::Dump can "optimize"
1865 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1867 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1869 my $cols = $self->_table_columns($table);
1870 my $col_info = $self->__columns_info_for($table);
1872 ### generate all the column accessor names
1873 while (my ($col, $info) = each %$col_info) {
1874 # hashref of other info that could be used by
1875 # user-defined accessor map functions
1877 table_class => $table_class,
1878 table_moniker => $table_moniker,
1879 table_name => $table_name,
1880 full_table_name => $full_table_name,
1881 schema_class => $schema_class,
1882 column_info => $info,
1885 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1888 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1890 # prune any redundant accessor names
1891 while (my ($col, $info) = each %$col_info) {
1892 no warnings 'uninitialized';
1893 delete $info->{accessor} if $info->{accessor} eq $col;
1896 my $fks = $self->_table_fk_info($table);
1898 foreach my $fkdef (@$fks) {
1899 for my $col (@{ $fkdef->{local_columns} }) {
1900 $col_info->{$col}{is_foreign_key} = 1;
1904 my $pks = $self->_table_pk_info($table) || [];
1906 foreach my $pkcol (@$pks) {
1907 $col_info->{$pkcol}{is_nullable} = 0;
1913 map { $_, ($col_info->{$_}||{}) } @$cols
1916 my %uniq_tag; # used to eliminate duplicate uniqs
1918 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1919 : carp("$table has no primary key");
1920 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1922 my $uniqs = $self->_table_uniq_info($table) || [];
1924 my ($name, $cols) = @$_;
1925 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1926 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1931 sub __columns_info_for {
1932 my ($self, $table) = @_;
1934 my $result = $self->_columns_info_for($table);
1936 while (my ($col, $info) = each %$result) {
1937 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1938 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1940 $result->{$col} = $info;
1948 Returns a sorted list of loaded tables, using the original database table
1956 return keys %{$self->_tables};
1959 # Make a moniker from a table
1960 sub _default_table2moniker {
1961 no warnings 'uninitialized';
1962 my ($self, $table) = @_;
1964 if ($self->naming->{monikers} eq 'v4') {
1965 return join '', map ucfirst, split /[\W_]+/, lc $table;
1967 elsif ($self->naming->{monikers} eq 'v5') {
1968 return join '', map ucfirst, split /[\W_]+/,
1969 Lingua::EN::Inflect::Number::to_S(lc $table);
1971 elsif ($self->naming->{monikers} eq 'v6') {
1972 (my $as_phrase = lc $table) =~ s/_+/ /g;
1973 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1975 return join '', map ucfirst, split /\W+/, $inflected;
1978 my @words = map lc, split_name $table;
1979 my $as_phrase = join ' ', @words;
1981 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1983 return join '', map ucfirst, split /\W+/, $inflected;
1986 sub _table2moniker {
1987 my ( $self, $table ) = @_;
1989 $self->_run_user_map(
1991 sub { $self->_default_table2moniker( shift ) },
1996 sub _load_relationships {
1997 my ($self, $table) = @_;
1999 my $tbl_fk_info = $self->_table_fk_info($table);
2000 foreach my $fkdef (@$tbl_fk_info) {
2001 $fkdef->{remote_source} =
2002 $self->monikers->{delete $fkdef->{remote_table}};
2004 my $tbl_uniq_info = $self->_table_uniq_info($table);
2006 my $local_moniker = $self->monikers->{$table};
2007 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
2009 foreach my $src_class (sort keys %$rel_stmts) {
2010 my $src_stmts = $rel_stmts->{$src_class};
2011 foreach my $stmt (@$src_stmts) {
2012 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2018 my ($self, $table) = @_;
2020 my $table_moniker = $self->monikers->{$table};
2021 my $table_class = $self->classes->{$table};
2023 my @roles = @{ $self->result_roles || [] };
2024 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2025 if exists $self->result_roles_map->{$table_moniker};
2028 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2030 $self->_with($table_class, @roles);
2034 # Overload these in driver class:
2036 # Returns an arrayref of column names
2037 sub _table_columns { croak "ABSTRACT METHOD" }
2039 # Returns arrayref of pk col names
2040 sub _table_pk_info { croak "ABSTRACT METHOD" }
2042 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2043 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2045 # Returns an arrayref of foreign key constraints, each
2046 # being a hashref with 3 keys:
2047 # local_columns (arrayref), remote_columns (arrayref), remote_table
2048 sub _table_fk_info { croak "ABSTRACT METHOD" }
2050 # Returns an array of lower case table names
2051 sub _tables_list { croak "ABSTRACT METHOD" }
2053 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2059 # generate the pod for this statement, storing it with $self->_pod
2060 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2062 my $args = dump(@_);
2063 $args = '(' . $args . ')' if @_ < 2;
2064 my $stmt = $method . $args . q{;};
2066 warn qq|$class\->$stmt\n| if $self->debug;
2067 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2071 # generates the accompanying pod for a DBIC class method statement,
2072 # storing it with $self->_pod
2078 if ( $method eq 'table' ) {
2080 my $pcm = $self->pod_comment_mode;
2081 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2082 $comment = $self->__table_comment($table);
2083 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2084 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2085 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2086 $self->_pod( $class, "=head1 NAME" );
2087 my $table_descr = $class;
2088 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2089 $self->{_class2table}{ $class } = $table;
2090 $self->_pod( $class, $table_descr );
2091 if ($comment and $comment_in_desc) {
2092 $self->_pod( $class, "=head1 DESCRIPTION" );
2093 $self->_pod( $class, $comment );
2095 $self->_pod_cut( $class );
2096 } elsif ( $method eq 'add_columns' ) {
2097 $self->_pod( $class, "=head1 ACCESSORS" );
2098 my $col_counter = 0;
2100 while( my ($name,$attrs) = splice @cols,0,2 ) {
2102 $self->_pod( $class, '=head2 ' . $name );
2103 $self->_pod( $class,
2105 my $s = $attrs->{$_};
2106 $s = !defined $s ? 'undef' :
2107 length($s) == 0 ? '(empty string)' :
2108 ref($s) eq 'SCALAR' ? $$s :
2109 ref($s) ? dumper_squashed $s :
2110 looks_like_number($s) ? $s : qq{'$s'};
2113 } sort keys %$attrs,
2115 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
2116 $self->_pod( $class, $comment );
2119 $self->_pod_cut( $class );
2120 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2121 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2122 my ( $accessor, $rel_class ) = @_;
2123 $self->_pod( $class, "=head2 $accessor" );
2124 $self->_pod( $class, 'Type: ' . $method );
2125 $self->_pod( $class, "Related object: L<$rel_class>" );
2126 $self->_pod_cut( $class );
2127 $self->{_relations_started} { $class } = 1;
2131 sub _pod_class_list {
2132 my ($self, $class, $title, @classes) = @_;
2134 return unless @classes && $self->generate_pod;
2136 $self->_pod($class, "=head1 $title");
2137 $self->_pod($class, '=over 4');
2139 foreach my $link (@classes) {
2140 $self->_pod($class, "=item L<$link>");
2143 $self->_pod($class, '=back');
2144 $self->_pod_cut($class);
2147 sub _base_class_pod {
2148 my ($self, $class, $base_class) = @_;
2150 return unless $self->generate_pod;
2152 $self->_pod($class, "=head1 BASE CLASS: L<$base_class>");
2153 $self->_pod_cut($class);
2156 sub _filter_comment {
2157 my ($self, $txt) = @_;
2159 $txt = '' if not defined $txt;
2161 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2166 sub __table_comment {
2169 if (my $code = $self->can('_table_comment')) {
2170 return $self->_filter_comment($self->$code(@_));
2176 sub __column_comment {
2179 if (my $code = $self->can('_column_comment')) {
2180 return $self->_filter_comment($self->$code(@_));
2186 # Stores a POD documentation
2188 my ($self, $class, $stmt) = @_;
2189 $self->_raw_stmt( $class, "\n" . $stmt );
2193 my ($self, $class ) = @_;
2194 $self->_raw_stmt( $class, "\n=cut\n" );
2197 # Store a raw source line for a class (for dumping purposes)
2199 my ($self, $class, $stmt) = @_;
2200 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2203 # Like above, but separately for the externally loaded stuff
2205 my ($self, $class, $stmt) = @_;
2206 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2209 sub _quote_table_name {
2210 my ($self, $table) = @_;
2212 my $qt = $self->schema->storage->sql_maker->quote_char;
2214 return $table unless $qt;
2217 return $qt->[0] . $table . $qt->[1];
2220 return $qt . $table . $qt;
2223 sub _custom_column_info {
2224 my ( $self, $table_name, $column_name, $column_info ) = @_;
2226 if (my $code = $self->custom_column_info) {
2227 return $code->($table_name, $column_name, $column_info) || {};
2232 sub _datetime_column_info {
2233 my ( $self, $table_name, $column_name, $column_info ) = @_;
2235 my $type = $column_info->{data_type} || '';
2236 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2237 or ($type =~ /date|timestamp/i)) {
2238 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2239 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2245 my ($self, $name) = @_;
2247 return $self->preserve_case ? $name : lc($name);
2251 my ($self, $name) = @_;
2253 return $self->preserve_case ? $name : uc($name);
2256 sub _unregister_source_for_table {
2257 my ($self, $table) = @_;
2261 my $schema = $self->schema;
2262 # in older DBIC it's a private method
2263 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2264 $schema->$unregister($self->_table2moniker($table));
2265 delete $self->monikers->{$table};
2266 delete $self->classes->{$table};
2267 delete $self->_upgrading_classes->{$table};
2268 delete $self->{_tables}{$table};
2272 # remove the dump dir from @INC on destruction
2276 @INC = grep $_ ne $self->dump_directory, @INC;
2281 Returns a hashref of loaded table to moniker mappings. There will
2282 be two entries for each table, the original name and the "normalized"
2283 name, in the case that the two are different (such as databases
2284 that like uppercase table names, or preserve your original mixed-case
2285 definitions, or what-have-you).
2289 Returns a hashref of table to class mappings. In some cases it will
2290 contain multiple entries per table for the original and normalized table
2291 names, as above in L</monikers>.
2293 =head1 COLUMN ACCESSOR COLLISIONS
2295 Occasionally you may have a column name that collides with a perl method, such
2296 as C<can>. In such cases, the default action is to set the C<accessor> of the
2297 column spec to C<undef>.
2299 You can then name the accessor yourself by placing code such as the following
2302 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2304 Another option is to use the L</col_collision_map> option.
2306 =head1 RELATIONSHIP NAME COLLISIONS
2308 In very rare cases, you may get a collision between a generated relationship
2309 name and a method in your Result class, for example if you have a foreign key
2310 called C<belongs_to>.
2312 This is a problem because relationship names are also relationship accessor
2313 methods in L<DBIx::Class>.
2315 The default behavior is to append C<_rel> to the relationship name and print
2316 out a warning that refers to this text.
2318 You can also control the renaming with the L</rel_collision_map> option.
2322 L<DBIx::Class::Schema::Loader>
2326 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2330 This library is free software; you can redistribute it and/or modify it under
2331 the same terms as Perl itself.
2336 # vim:et sts=4 sw=4 tw=0: