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
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
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 }) {
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) && (not $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_external($_)
1191 for map { $self->classes->{$_} } @tables;
1193 # Reload without unloading first to preserve any symbols from external
1195 $self->_reload_classes(\@tables, { unload => 0 });
1197 # Drop temporary cache
1198 delete $self->{_cache};
1203 sub _reload_classes {
1204 my ($self, $tables, $opts) = @_;
1206 my @tables = @$tables;
1208 my $unload = $opts->{unload};
1209 $unload = 1 unless defined $unload;
1211 # so that we don't repeat custom sections
1212 @INC = grep $_ ne $self->dump_directory, @INC;
1214 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1216 unshift @INC, $self->dump_directory;
1219 my %have_source = map { $_ => $self->schema->source($_) }
1220 $self->schema->sources;
1222 for my $table (@tables) {
1223 my $moniker = $self->monikers->{$table};
1224 my $class = $self->classes->{$table};
1227 no warnings 'redefine';
1228 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1231 if (my $mc = $self->_moose_metaclass($class)) {
1234 Class::Unload->unload($class) if $unload;
1235 my ($source, $resultset_class);
1237 ($source = $have_source{$moniker})
1238 && ($resultset_class = $source->resultset_class)
1239 && ($resultset_class ne 'DBIx::Class::ResultSet')
1241 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1242 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1245 Class::Unload->unload($resultset_class) if $unload;
1246 $self->_reload_class($resultset_class) if $has_file;
1248 $self->_reload_class($class);
1250 push @to_register, [$moniker, $class];
1253 Class::C3->reinitialize;
1254 for (@to_register) {
1255 $self->schema->register_class(@$_);
1259 sub _moose_metaclass {
1260 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1264 my $mc = try { Class::MOP::class_of($class) }
1267 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1270 # We use this instead of ensure_class_loaded when there are package symbols we
1273 my ($self, $class) = @_;
1275 delete $INC{ +class_path($class) };
1278 eval_package_without_redefine_warnings ($class, "require $class");
1281 my $source = slurp $self->_get_dump_filename($class);
1282 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1286 sub _get_dump_filename {
1287 my ($self, $class) = (@_);
1289 $class =~ s{::}{/}g;
1290 return $self->dump_directory . q{/} . $class . q{.pm};
1293 =head2 get_dump_filename
1297 Returns the full path to the file for a class that the class has been or will
1298 be dumped to. This is a file in a temp dir for a dynamic schema.
1302 sub get_dump_filename {
1303 my ($self, $class) = (@_);
1305 local $self->{dump_directory} = $self->real_dump_directory;
1307 return $self->_get_dump_filename($class);
1310 sub _ensure_dump_subdirs {
1311 my ($self, $class) = (@_);
1313 my @name_parts = split(/::/, $class);
1314 pop @name_parts; # we don't care about the very last element,
1315 # which is a filename
1317 my $dir = $self->dump_directory;
1320 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1322 last if !@name_parts;
1323 $dir = File::Spec->catdir($dir, shift @name_parts);
1328 my ($self, @classes) = @_;
1330 my $schema_class = $self->schema_class;
1331 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1333 my $target_dir = $self->dump_directory;
1334 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1335 unless $self->{dynamic} or $self->{quiet};
1338 qq|package $schema_class;\n\n|
1339 . qq|# Created by DBIx::Class::Schema::Loader\n|
1340 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1342 if ($self->use_moose) {
1343 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1346 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1349 if ($self->use_namespaces) {
1350 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1351 my $namespace_options;
1353 my @attr = qw/resultset_namespace default_resultset_class/;
1355 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1357 for my $attr (@attr) {
1359 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1362 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1363 $schema_text .= qq|;\n|;
1366 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1370 local $self->{version_to_dump} = $self->schema_version_to_dump;
1371 $self->_write_classfile($schema_class, $schema_text, 1);
1374 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1376 foreach my $src_class (@classes) {
1378 qq|package $src_class;\n\n|
1379 . qq|# Created by DBIx::Class::Schema::Loader\n|
1380 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1381 . qq|use strict;\nuse warnings;\n\n|;
1382 if ($self->use_moose) {
1383 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1385 # these options 'use base' which is compile time
1386 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1387 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1390 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1394 $src_text .= qq|use base '$result_base_class';\n\n|;
1396 $self->_write_classfile($src_class, $src_text);
1399 # remove Result dir if downgrading from use_namespaces, and there are no
1401 if (my $result_ns = $self->_downgrading_to_load_classes
1402 || $self->_rewriting_result_namespace) {
1403 my $result_namespace = $self->_result_namespace(
1408 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1409 $result_dir = $self->dump_directory . '/' . $result_dir;
1411 unless (my @files = glob "$result_dir/*") {
1416 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1421 my ($self, $version, $ts) = @_;
1422 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1425 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1428 sub _write_classfile {
1429 my ($self, $class, $text, $is_schema) = @_;
1431 my $filename = $self->_get_dump_filename($class);
1432 $self->_ensure_dump_subdirs($class);
1434 if (-f $filename && $self->really_erase_my_files) {
1435 warn "Deleting existing file '$filename' due to "
1436 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1440 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1441 = $self->_parse_generated_file($filename);
1443 if (! $old_gen && -f $filename) {
1444 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1445 . " it does not appear to have been generated by Loader"
1448 my $custom_content = $old_custom || '';
1450 # prepend extra custom content from a *renamed* class (singularization effect)
1451 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1452 my $old_filename = $self->_get_dump_filename($renamed_class);
1454 if (-f $old_filename) {
1455 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1457 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1459 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1462 unlink $old_filename;
1466 $custom_content ||= $self->_default_custom_content($is_schema);
1468 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1469 # If there is already custom content, which does not have the Moose content, add it.
1470 if ($self->use_moose) {
1472 my $non_moose_custom_content = do {
1473 local $self->{use_moose} = 0;
1474 $self->_default_custom_content;
1477 if ($custom_content eq $non_moose_custom_content) {
1478 $custom_content = $self->_default_custom_content($is_schema);
1480 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1481 $custom_content .= $self->_default_custom_content($is_schema);
1484 elsif (defined $self->use_moose && $old_gen) {
1485 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'
1486 if $old_gen =~ /use \s+ MooseX?\b/x;
1489 $custom_content = $self->_rewrite_old_classnames($custom_content);
1492 for @{$self->{_dump_storage}->{$class} || []};
1494 # Check and see if the dump is infact differnt
1498 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1499 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1500 return unless $self->_upgrading_from && $is_schema;
1504 $text .= $self->_sig_comment(
1505 $self->version_to_dump,
1506 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1509 open(my $fh, '>', $filename)
1510 or croak "Cannot open '$filename' for writing: $!";
1512 # Write the top half and its MD5 sum
1513 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1515 # Write out anything loaded via external partial class file in @INC
1517 for @{$self->{_ext_storage}->{$class} || []};
1519 # Write out any custom content the user has added
1520 print $fh $custom_content;
1523 or croak "Error closing '$filename': $!";
1526 sub _default_moose_custom_content {
1527 my ($self, $is_schema) = @_;
1529 if (not $is_schema) {
1530 return qq|\n__PACKAGE__->meta->make_immutable;|;
1533 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1536 sub _default_custom_content {
1537 my ($self, $is_schema) = @_;
1538 my $default = qq|\n\n# You can replace this text with custom|
1539 . qq| code or comments, and it will be preserved on regeneration|;
1540 if ($self->use_moose) {
1541 $default .= $self->_default_moose_custom_content($is_schema);
1543 $default .= qq|\n1;\n|;
1547 sub _parse_generated_file {
1548 my ($self, $fn) = @_;
1550 return unless -f $fn;
1552 open(my $fh, '<', $fn)
1553 or croak "Cannot open '$fn' for reading: $!";
1556 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1558 my ($md5, $ts, $ver, $gen);
1564 # Pull out the version and timestamp from the line above
1565 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1568 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"
1569 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1578 my $custom = do { local $/; <$fh> }
1583 return ($gen, $md5, $ver, $ts, $custom);
1591 warn "$target: use $_;" if $self->debug;
1592 $self->_raw_stmt($target, "use $_;");
1600 my $blist = join(q{ }, @_);
1602 return unless $blist;
1604 warn "$target: use base qw/$blist/;" if $self->debug;
1605 $self->_raw_stmt($target, "use base qw/$blist/;");
1612 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1614 return unless $rlist;
1616 warn "$target: with $rlist;" if $self->debug;
1617 $self->_raw_stmt($target, "\nwith $rlist;");
1620 sub _result_namespace {
1621 my ($self, $schema_class, $ns) = @_;
1622 my @result_namespace;
1624 if ($ns =~ /^\+(.*)/) {
1625 # Fully qualified namespace
1626 @result_namespace = ($1)
1629 # Relative namespace
1630 @result_namespace = ($schema_class, $ns);
1633 return wantarray ? @result_namespace : join '::', @result_namespace;
1636 # Create class with applicable bases, setup monikers, etc
1637 sub _make_src_class {
1638 my ($self, $table) = @_;
1640 my $schema = $self->schema;
1641 my $schema_class = $self->schema_class;
1643 my $table_moniker = $self->_table2moniker($table);
1644 my @result_namespace = ($schema_class);
1645 if ($self->use_namespaces) {
1646 my $result_namespace = $self->result_namespace || 'Result';
1647 @result_namespace = $self->_result_namespace(
1652 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1654 if ((my $upgrading_v = $self->_upgrading_from)
1655 || $self->_rewriting) {
1656 local $self->naming->{monikers} = $upgrading_v
1659 my @result_namespace = @result_namespace;
1660 if ($self->_upgrading_from_load_classes) {
1661 @result_namespace = ($schema_class);
1663 elsif (my $ns = $self->_downgrading_to_load_classes) {
1664 @result_namespace = $self->_result_namespace(
1669 elsif ($ns = $self->_rewriting_result_namespace) {
1670 @result_namespace = $self->_result_namespace(
1676 my $old_class = join(q{::}, @result_namespace,
1677 $self->_table2moniker($table));
1679 $self->_upgrading_classes->{$table_class} = $old_class
1680 unless $table_class eq $old_class;
1683 $self->classes->{$table} = $table_class;
1684 $self->monikers->{$table} = $table_moniker;
1686 $self->_use ($table_class, @{$self->additional_classes});
1687 $self->_inject($table_class, @{$self->left_base_classes});
1689 my @components = @{ $self->components || [] };
1691 push @components, @{ $self->result_components_map->{$table_moniker} }
1692 if exists $self->result_components_map->{$table_moniker};
1694 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1696 $self->_inject($table_class, @{$self->additional_base_classes});
1698 my @roles = @{ $self->result_roles || [] };
1699 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1700 if exists $self->result_roles_map->{$table_moniker};
1702 $self->_with($table_class, @roles) if @roles;
1705 sub _is_result_class_method {
1706 my ($self, $name, $table_name) = @_;
1708 my $table_moniker = $table_name ? $self->_table2moniker($table_name) : '';
1710 $self->_result_class_methods({})
1711 if not defined $self->_result_class_methods;
1713 if (not exists $self->_result_class_methods->{$table_moniker}) {
1714 my (@methods, %methods);
1715 my $base = $self->result_base_class || 'DBIx::Class::Core';
1717 my @components = @{ $self->components || [] };
1719 push @components, @{ $self->result_components_map->{$table_moniker} }
1720 if exists $self->result_components_map->{$table_moniker};
1722 for my $c (@components) {
1723 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1726 my @roles = @{ $self->result_roles || [] };
1728 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1729 if exists $self->result_roles_map->{$table_moniker};
1731 for my $class ($base, @components,
1732 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1733 $self->ensure_class_loaded($class);
1735 push @methods, @{ Class::Inspector->methods($class) || [] };
1738 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1740 @methods{@methods} = ();
1742 $self->_result_class_methods->{$table_moniker} = \%methods;
1744 my $result_methods = $self->_result_class_methods->{$table_moniker};
1746 return exists $result_methods->{$name};
1749 sub _resolve_col_accessor_collisions {
1750 my ($self, $table, $col_info) = @_;
1752 my $table_name = ref $table ? $$table : $table;
1754 while (my ($col, $info) = each %$col_info) {
1755 my $accessor = $info->{accessor} || $col;
1757 next if $accessor eq 'id'; # special case (very common column)
1759 if ($self->_is_result_class_method($accessor, $table_name)) {
1762 if (my $map = $self->col_collision_map) {
1763 for my $re (keys %$map) {
1764 if (my @matches = $col =~ /$re/) {
1765 $info->{accessor} = sprintf $map->{$re}, @matches;
1773 Column '$col' in table '$table_name' collides with an inherited method.
1774 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1776 $info->{accessor} = undef;
1782 # use the same logic to run moniker_map, col_accessor_map, and
1783 # relationship_name_map
1785 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1787 my $default_ident = $default_code->( $ident, @extra );
1789 if( $map && ref $map eq 'HASH' ) {
1790 $new_ident = $map->{ $ident };
1792 elsif( $map && ref $map eq 'CODE' ) {
1793 $new_ident = $map->( $ident, $default_ident, @extra );
1796 $new_ident ||= $default_ident;
1801 sub _default_column_accessor_name {
1802 my ( $self, $column_name ) = @_;
1804 my $accessor_name = $column_name;
1805 $accessor_name =~ s/\W+/_/g;
1807 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1808 # older naming just lc'd the col accessor and that's all.
1809 return lc $accessor_name;
1812 return join '_', map lc, split_name $column_name;
1816 sub _make_column_accessor_name {
1817 my ($self, $column_name, $column_context_info ) = @_;
1819 my $accessor = $self->_run_user_map(
1820 $self->col_accessor_map,
1821 sub { $self->_default_column_accessor_name( shift ) },
1823 $column_context_info,
1829 # Set up metadata (cols, pks, etc)
1830 sub _setup_src_meta {
1831 my ($self, $table) = @_;
1833 my $schema = $self->schema;
1834 my $schema_class = $self->schema_class;
1836 my $table_class = $self->classes->{$table};
1837 my $table_moniker = $self->monikers->{$table};
1839 my $table_name = $table;
1840 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1842 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1843 $table_name = \ $self->_quote_table_name($table_name);
1846 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1848 # be careful to not create refs Data::Dump can "optimize"
1849 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1851 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1853 my $cols = $self->_table_columns($table);
1854 my $col_info = $self->__columns_info_for($table);
1856 ### generate all the column accessor names
1857 while (my ($col, $info) = each %$col_info) {
1858 # hashref of other info that could be used by
1859 # user-defined accessor map functions
1861 table_class => $table_class,
1862 table_moniker => $table_moniker,
1863 table_name => $table_name,
1864 full_table_name => $full_table_name,
1865 schema_class => $schema_class,
1866 column_info => $info,
1869 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1872 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1874 # prune any redundant accessor names
1875 while (my ($col, $info) = each %$col_info) {
1876 no warnings 'uninitialized';
1877 delete $info->{accessor} if $info->{accessor} eq $col;
1880 my $fks = $self->_table_fk_info($table);
1882 foreach my $fkdef (@$fks) {
1883 for my $col (@{ $fkdef->{local_columns} }) {
1884 $col_info->{$col}{is_foreign_key} = 1;
1888 my $pks = $self->_table_pk_info($table) || [];
1890 foreach my $pkcol (@$pks) {
1891 $col_info->{$pkcol}{is_nullable} = 0;
1897 map { $_, ($col_info->{$_}||{}) } @$cols
1900 my %uniq_tag; # used to eliminate duplicate uniqs
1902 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1903 : carp("$table has no primary key");
1904 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1906 my $uniqs = $self->_table_uniq_info($table) || [];
1908 my ($name, $cols) = @$_;
1909 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1910 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1915 sub __columns_info_for {
1916 my ($self, $table) = @_;
1918 my $result = $self->_columns_info_for($table);
1920 while (my ($col, $info) = each %$result) {
1921 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1922 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1924 $result->{$col} = $info;
1932 Returns a sorted list of loaded tables, using the original database table
1940 return keys %{$self->_tables};
1943 # Make a moniker from a table
1944 sub _default_table2moniker {
1945 no warnings 'uninitialized';
1946 my ($self, $table) = @_;
1948 if ($self->naming->{monikers} eq 'v4') {
1949 return join '', map ucfirst, split /[\W_]+/, lc $table;
1951 elsif ($self->naming->{monikers} eq 'v5') {
1952 return join '', map ucfirst, split /[\W_]+/,
1953 Lingua::EN::Inflect::Number::to_S(lc $table);
1955 elsif ($self->naming->{monikers} eq 'v6') {
1956 (my $as_phrase = lc $table) =~ s/_+/ /g;
1957 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1959 return join '', map ucfirst, split /\W+/, $inflected;
1962 my @words = map lc, split_name $table;
1963 my $as_phrase = join ' ', @words;
1965 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1967 return join '', map ucfirst, split /\W+/, $inflected;
1970 sub _table2moniker {
1971 my ( $self, $table ) = @_;
1973 $self->_run_user_map(
1975 sub { $self->_default_table2moniker( shift ) },
1980 sub _load_relationships {
1981 my ($self, $table) = @_;
1983 my $tbl_fk_info = $self->_table_fk_info($table);
1984 foreach my $fkdef (@$tbl_fk_info) {
1985 $fkdef->{remote_source} =
1986 $self->monikers->{delete $fkdef->{remote_table}};
1988 my $tbl_uniq_info = $self->_table_uniq_info($table);
1990 my $local_moniker = $self->monikers->{$table};
1991 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1993 foreach my $src_class (sort keys %$rel_stmts) {
1994 my $src_stmts = $rel_stmts->{$src_class};
1995 foreach my $stmt (@$src_stmts) {
1996 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
2001 # Overload these in driver class:
2003 # Returns an arrayref of column names
2004 sub _table_columns { croak "ABSTRACT METHOD" }
2006 # Returns arrayref of pk col names
2007 sub _table_pk_info { croak "ABSTRACT METHOD" }
2009 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2010 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2012 # Returns an arrayref of foreign key constraints, each
2013 # being a hashref with 3 keys:
2014 # local_columns (arrayref), remote_columns (arrayref), remote_table
2015 sub _table_fk_info { croak "ABSTRACT METHOD" }
2017 # Returns an array of lower case table names
2018 sub _tables_list { croak "ABSTRACT METHOD" }
2020 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2026 # generate the pod for this statement, storing it with $self->_pod
2027 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2029 my $args = dump(@_);
2030 $args = '(' . $args . ')' if @_ < 2;
2031 my $stmt = $method . $args . q{;};
2033 warn qq|$class\->$stmt\n| if $self->debug;
2034 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2038 # generates the accompanying pod for a DBIC class method statement,
2039 # storing it with $self->_pod
2045 if ( $method eq 'table' ) {
2047 my $pcm = $self->pod_comment_mode;
2048 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2049 $comment = $self->__table_comment($table);
2050 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2051 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2052 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2053 $self->_pod( $class, "=head1 NAME" );
2054 my $table_descr = $class;
2055 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2056 $self->{_class2table}{ $class } = $table;
2057 $self->_pod( $class, $table_descr );
2058 if ($comment and $comment_in_desc) {
2059 $self->_pod( $class, "=head1 DESCRIPTION" );
2060 $self->_pod( $class, $comment );
2062 $self->_pod_cut( $class );
2063 } elsif ( $method eq 'add_columns' ) {
2064 $self->_pod( $class, "=head1 ACCESSORS" );
2065 my $col_counter = 0;
2067 while( my ($name,$attrs) = splice @cols,0,2 ) {
2069 $self->_pod( $class, '=head2 ' . $name );
2070 $self->_pod( $class,
2072 my $s = $attrs->{$_};
2073 $s = !defined $s ? 'undef' :
2074 length($s) == 0 ? '(empty string)' :
2075 ref($s) eq 'SCALAR' ? $$s :
2076 ref($s) ? dumper_squashed $s :
2077 looks_like_number($s) ? $s : qq{'$s'};
2080 } sort keys %$attrs,
2082 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
2083 $self->_pod( $class, $comment );
2086 $self->_pod_cut( $class );
2087 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2088 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2089 my ( $accessor, $rel_class ) = @_;
2090 $self->_pod( $class, "=head2 $accessor" );
2091 $self->_pod( $class, 'Type: ' . $method );
2092 $self->_pod( $class, "Related object: L<$rel_class>" );
2093 $self->_pod_cut( $class );
2094 $self->{_relations_started} { $class } = 1;
2098 sub _filter_comment {
2099 my ($self, $txt) = @_;
2101 $txt = '' if not defined $txt;
2103 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2108 sub __table_comment {
2111 if (my $code = $self->can('_table_comment')) {
2112 return $self->_filter_comment($self->$code(@_));
2118 sub __column_comment {
2121 if (my $code = $self->can('_column_comment')) {
2122 return $self->_filter_comment($self->$code(@_));
2128 # Stores a POD documentation
2130 my ($self, $class, $stmt) = @_;
2131 $self->_raw_stmt( $class, "\n" . $stmt );
2135 my ($self, $class ) = @_;
2136 $self->_raw_stmt( $class, "\n=cut\n" );
2139 # Store a raw source line for a class (for dumping purposes)
2141 my ($self, $class, $stmt) = @_;
2142 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2145 # Like above, but separately for the externally loaded stuff
2147 my ($self, $class, $stmt) = @_;
2148 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2151 sub _quote_table_name {
2152 my ($self, $table) = @_;
2154 my $qt = $self->schema->storage->sql_maker->quote_char;
2156 return $table unless $qt;
2159 return $qt->[0] . $table . $qt->[1];
2162 return $qt . $table . $qt;
2165 sub _custom_column_info {
2166 my ( $self, $table_name, $column_name, $column_info ) = @_;
2168 if (my $code = $self->custom_column_info) {
2169 return $code->($table_name, $column_name, $column_info) || {};
2174 sub _datetime_column_info {
2175 my ( $self, $table_name, $column_name, $column_info ) = @_;
2177 my $type = $column_info->{data_type} || '';
2178 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2179 or ($type =~ /date|timestamp/i)) {
2180 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2181 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2187 my ($self, $name) = @_;
2189 return $self->preserve_case ? $name : lc($name);
2193 my ($self, $name) = @_;
2195 return $self->preserve_case ? $name : uc($name);
2198 sub _unregister_source_for_table {
2199 my ($self, $table) = @_;
2203 my $schema = $self->schema;
2204 # in older DBIC it's a private method
2205 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2206 $schema->$unregister($self->_table2moniker($table));
2207 delete $self->monikers->{$table};
2208 delete $self->classes->{$table};
2209 delete $self->_upgrading_classes->{$table};
2210 delete $self->{_tables}{$table};
2214 # remove the dump dir from @INC on destruction
2218 @INC = grep $_ ne $self->dump_directory, @INC;
2223 Returns a hashref of loaded table to moniker mappings. There will
2224 be two entries for each table, the original name and the "normalized"
2225 name, in the case that the two are different (such as databases
2226 that like uppercase table names, or preserve your original mixed-case
2227 definitions, or what-have-you).
2231 Returns a hashref of table to class mappings. In some cases it will
2232 contain multiple entries per table for the original and normalized table
2233 names, as above in L</monikers>.
2235 =head1 COLUMN ACCESSOR COLLISIONS
2237 Occasionally you may have a column name that collides with a perl method, such
2238 as C<can>. In such cases, the default action is to set the C<accessor> of the
2239 column spec to C<undef>.
2241 You can then name the accessor yourself by placing code such as the following
2244 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2246 Another option is to use the L</col_collision_map> option.
2248 =head1 RELATIONSHIP NAME COLLISIONS
2250 In very rare cases, you may get a collision between a generated relationship
2251 name and a method in your Result class, for example if you have a foreign key
2252 called C<belongs_to>.
2254 This is a problem because relationship names are also relationship accessor
2255 methods in L<DBIx::Class>.
2257 The default behavior is to append C<_rel> to the relationship name and print
2258 out a warning that refers to this text.
2260 You can also control the renaming with the L</rel_collision_map> option.
2264 L<DBIx::Class::Schema::Loader>
2268 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2272 This library is free software; you can redistribute it and/or modify it under
2273 the same terms as Perl itself.
2278 # vim:et sts=4 sw=4 tw=0: