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|;
1398 $self->_write_classfile($src_class, $src_text);
1401 # remove Result dir if downgrading from use_namespaces, and there are no
1403 if (my $result_ns = $self->_downgrading_to_load_classes
1404 || $self->_rewriting_result_namespace) {
1405 my $result_namespace = $self->_result_namespace(
1410 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1411 $result_dir = $self->dump_directory . '/' . $result_dir;
1413 unless (my @files = glob "$result_dir/*") {
1418 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1423 my ($self, $version, $ts) = @_;
1424 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1427 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1430 sub _write_classfile {
1431 my ($self, $class, $text, $is_schema) = @_;
1433 my $filename = $self->_get_dump_filename($class);
1434 $self->_ensure_dump_subdirs($class);
1436 if (-f $filename && $self->really_erase_my_files) {
1437 warn "Deleting existing file '$filename' due to "
1438 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1442 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1443 = $self->_parse_generated_file($filename);
1445 if (! $old_gen && -f $filename) {
1446 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1447 . " it does not appear to have been generated by Loader"
1450 my $custom_content = $old_custom || '';
1452 # prepend extra custom content from a *renamed* class (singularization effect)
1453 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1454 my $old_filename = $self->_get_dump_filename($renamed_class);
1456 if (-f $old_filename) {
1457 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1459 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1461 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1464 unlink $old_filename;
1468 $custom_content ||= $self->_default_custom_content($is_schema);
1470 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1471 # If there is already custom content, which does not have the Moose content, add it.
1472 if ($self->use_moose) {
1474 my $non_moose_custom_content = do {
1475 local $self->{use_moose} = 0;
1476 $self->_default_custom_content;
1479 if ($custom_content eq $non_moose_custom_content) {
1480 $custom_content = $self->_default_custom_content($is_schema);
1482 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1483 $custom_content .= $self->_default_custom_content($is_schema);
1486 elsif (defined $self->use_moose && $old_gen) {
1487 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'
1488 if $old_gen =~ /use \s+ MooseX?\b/x;
1491 $custom_content = $self->_rewrite_old_classnames($custom_content);
1494 for @{$self->{_dump_storage}->{$class} || []};
1496 # Check and see if the dump is infact differnt
1500 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1501 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1502 return unless $self->_upgrading_from && $is_schema;
1506 $text .= $self->_sig_comment(
1507 $self->version_to_dump,
1508 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1511 open(my $fh, '>', $filename)
1512 or croak "Cannot open '$filename' for writing: $!";
1514 # Write the top half and its MD5 sum
1515 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1517 # Write out anything loaded via external partial class file in @INC
1519 for @{$self->{_ext_storage}->{$class} || []};
1521 # Write out any custom content the user has added
1522 print $fh $custom_content;
1525 or croak "Error closing '$filename': $!";
1528 sub _default_moose_custom_content {
1529 my ($self, $is_schema) = @_;
1531 if (not $is_schema) {
1532 return qq|\n__PACKAGE__->meta->make_immutable;|;
1535 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1538 sub _default_custom_content {
1539 my ($self, $is_schema) = @_;
1540 my $default = qq|\n\n# You can replace this text with custom|
1541 . qq| code or comments, and it will be preserved on regeneration|;
1542 if ($self->use_moose) {
1543 $default .= $self->_default_moose_custom_content($is_schema);
1545 $default .= qq|\n1;\n|;
1549 sub _parse_generated_file {
1550 my ($self, $fn) = @_;
1552 return unless -f $fn;
1554 open(my $fh, '<', $fn)
1555 or croak "Cannot open '$fn' for reading: $!";
1558 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1560 my ($md5, $ts, $ver, $gen);
1566 # Pull out the version and timestamp from the line above
1567 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1570 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"
1571 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1580 my $custom = do { local $/; <$fh> }
1585 return ($gen, $md5, $ver, $ts, $custom);
1593 warn "$target: use $_;" if $self->debug;
1594 $self->_raw_stmt($target, "use $_;");
1602 my $blist = join(q{ }, @_);
1604 return unless $blist;
1606 warn "$target: use base qw/$blist/;" if $self->debug;
1607 $self->_raw_stmt($target, "use base qw/$blist/;");
1614 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1616 return unless $rlist;
1618 warn "$target: with $rlist;" if $self->debug;
1619 $self->_raw_stmt($target, "\nwith $rlist;");
1622 sub _result_namespace {
1623 my ($self, $schema_class, $ns) = @_;
1624 my @result_namespace;
1626 if ($ns =~ /^\+(.*)/) {
1627 # Fully qualified namespace
1628 @result_namespace = ($1)
1631 # Relative namespace
1632 @result_namespace = ($schema_class, $ns);
1635 return wantarray ? @result_namespace : join '::', @result_namespace;
1638 # Create class with applicable bases, setup monikers, etc
1639 sub _make_src_class {
1640 my ($self, $table) = @_;
1642 my $schema = $self->schema;
1643 my $schema_class = $self->schema_class;
1645 my $table_moniker = $self->_table2moniker($table);
1646 my @result_namespace = ($schema_class);
1647 if ($self->use_namespaces) {
1648 my $result_namespace = $self->result_namespace || 'Result';
1649 @result_namespace = $self->_result_namespace(
1654 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1656 if ((my $upgrading_v = $self->_upgrading_from)
1657 || $self->_rewriting) {
1658 local $self->naming->{monikers} = $upgrading_v
1661 my @result_namespace = @result_namespace;
1662 if ($self->_upgrading_from_load_classes) {
1663 @result_namespace = ($schema_class);
1665 elsif (my $ns = $self->_downgrading_to_load_classes) {
1666 @result_namespace = $self->_result_namespace(
1671 elsif ($ns = $self->_rewriting_result_namespace) {
1672 @result_namespace = $self->_result_namespace(
1678 my $old_class = join(q{::}, @result_namespace,
1679 $self->_table2moniker($table));
1681 $self->_upgrading_classes->{$table_class} = $old_class
1682 unless $table_class eq $old_class;
1685 $self->classes->{$table} = $table_class;
1686 $self->monikers->{$table} = $table_moniker;
1688 $self->_use ($table_class, @{$self->additional_classes});
1689 $self->_inject($table_class, @{$self->left_base_classes});
1691 my @components = @{ $self->components || [] };
1693 push @components, @{ $self->result_components_map->{$table_moniker} }
1694 if exists $self->result_components_map->{$table_moniker};
1696 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
1698 $self->_inject($table_class, @{$self->additional_base_classes});
1701 sub _is_result_class_method {
1702 my ($self, $name, $table_name) = @_;
1704 my $table_moniker = $table_name ? $self->_table2moniker($table_name) : '';
1706 $self->_result_class_methods({})
1707 if not defined $self->_result_class_methods;
1709 if (not exists $self->_result_class_methods->{$table_moniker}) {
1710 my (@methods, %methods);
1711 my $base = $self->result_base_class || 'DBIx::Class::Core';
1713 my @components = @{ $self->components || [] };
1715 push @components, @{ $self->result_components_map->{$table_moniker} }
1716 if exists $self->result_components_map->{$table_moniker};
1718 for my $c (@components) {
1719 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
1722 my @roles = @{ $self->result_roles || [] };
1724 push @roles, @{ $self->result_roles_map->{$table_moniker} }
1725 if exists $self->result_roles_map->{$table_moniker};
1727 for my $class ($base, @components,
1728 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
1729 $self->ensure_class_loaded($class);
1731 push @methods, @{ Class::Inspector->methods($class) || [] };
1734 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1736 @methods{@methods} = ();
1738 $self->_result_class_methods->{$table_moniker} = \%methods;
1740 my $result_methods = $self->_result_class_methods->{$table_moniker};
1742 return exists $result_methods->{$name};
1745 sub _resolve_col_accessor_collisions {
1746 my ($self, $table, $col_info) = @_;
1748 my $table_name = ref $table ? $$table : $table;
1750 while (my ($col, $info) = each %$col_info) {
1751 my $accessor = $info->{accessor} || $col;
1753 next if $accessor eq 'id'; # special case (very common column)
1755 if ($self->_is_result_class_method($accessor, $table_name)) {
1758 if (my $map = $self->col_collision_map) {
1759 for my $re (keys %$map) {
1760 if (my @matches = $col =~ /$re/) {
1761 $info->{accessor} = sprintf $map->{$re}, @matches;
1769 Column '$col' in table '$table_name' collides with an inherited method.
1770 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1772 $info->{accessor} = undef;
1778 # use the same logic to run moniker_map, col_accessor_map, and
1779 # relationship_name_map
1781 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1783 my $default_ident = $default_code->( $ident, @extra );
1785 if( $map && ref $map eq 'HASH' ) {
1786 $new_ident = $map->{ $ident };
1788 elsif( $map && ref $map eq 'CODE' ) {
1789 $new_ident = $map->( $ident, $default_ident, @extra );
1792 $new_ident ||= $default_ident;
1797 sub _default_column_accessor_name {
1798 my ( $self, $column_name ) = @_;
1800 my $accessor_name = $column_name;
1801 $accessor_name =~ s/\W+/_/g;
1803 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1804 # older naming just lc'd the col accessor and that's all.
1805 return lc $accessor_name;
1808 return join '_', map lc, split_name $column_name;
1812 sub _make_column_accessor_name {
1813 my ($self, $column_name, $column_context_info ) = @_;
1815 my $accessor = $self->_run_user_map(
1816 $self->col_accessor_map,
1817 sub { $self->_default_column_accessor_name( shift ) },
1819 $column_context_info,
1825 # Set up metadata (cols, pks, etc)
1826 sub _setup_src_meta {
1827 my ($self, $table) = @_;
1829 my $schema = $self->schema;
1830 my $schema_class = $self->schema_class;
1832 my $table_class = $self->classes->{$table};
1833 my $table_moniker = $self->monikers->{$table};
1835 my $table_name = $table;
1836 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1838 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1839 $table_name = \ $self->_quote_table_name($table_name);
1842 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1844 # be careful to not create refs Data::Dump can "optimize"
1845 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1847 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1849 my $cols = $self->_table_columns($table);
1850 my $col_info = $self->__columns_info_for($table);
1852 ### generate all the column accessor names
1853 while (my ($col, $info) = each %$col_info) {
1854 # hashref of other info that could be used by
1855 # user-defined accessor map functions
1857 table_class => $table_class,
1858 table_moniker => $table_moniker,
1859 table_name => $table_name,
1860 full_table_name => $full_table_name,
1861 schema_class => $schema_class,
1862 column_info => $info,
1865 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1868 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1870 # prune any redundant accessor names
1871 while (my ($col, $info) = each %$col_info) {
1872 no warnings 'uninitialized';
1873 delete $info->{accessor} if $info->{accessor} eq $col;
1876 my $fks = $self->_table_fk_info($table);
1878 foreach my $fkdef (@$fks) {
1879 for my $col (@{ $fkdef->{local_columns} }) {
1880 $col_info->{$col}{is_foreign_key} = 1;
1884 my $pks = $self->_table_pk_info($table) || [];
1886 foreach my $pkcol (@$pks) {
1887 $col_info->{$pkcol}{is_nullable} = 0;
1893 map { $_, ($col_info->{$_}||{}) } @$cols
1896 my %uniq_tag; # used to eliminate duplicate uniqs
1898 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1899 : carp("$table has no primary key");
1900 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1902 my $uniqs = $self->_table_uniq_info($table) || [];
1904 my ($name, $cols) = @$_;
1905 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1906 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1911 sub __columns_info_for {
1912 my ($self, $table) = @_;
1914 my $result = $self->_columns_info_for($table);
1916 while (my ($col, $info) = each %$result) {
1917 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1918 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1920 $result->{$col} = $info;
1928 Returns a sorted list of loaded tables, using the original database table
1936 return keys %{$self->_tables};
1939 # Make a moniker from a table
1940 sub _default_table2moniker {
1941 no warnings 'uninitialized';
1942 my ($self, $table) = @_;
1944 if ($self->naming->{monikers} eq 'v4') {
1945 return join '', map ucfirst, split /[\W_]+/, lc $table;
1947 elsif ($self->naming->{monikers} eq 'v5') {
1948 return join '', map ucfirst, split /[\W_]+/,
1949 Lingua::EN::Inflect::Number::to_S(lc $table);
1951 elsif ($self->naming->{monikers} eq 'v6') {
1952 (my $as_phrase = lc $table) =~ s/_+/ /g;
1953 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1955 return join '', map ucfirst, split /\W+/, $inflected;
1958 my @words = map lc, split_name $table;
1959 my $as_phrase = join ' ', @words;
1961 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1963 return join '', map ucfirst, split /\W+/, $inflected;
1966 sub _table2moniker {
1967 my ( $self, $table ) = @_;
1969 $self->_run_user_map(
1971 sub { $self->_default_table2moniker( shift ) },
1976 sub _load_relationships {
1977 my ($self, $table) = @_;
1979 my $tbl_fk_info = $self->_table_fk_info($table);
1980 foreach my $fkdef (@$tbl_fk_info) {
1981 $fkdef->{remote_source} =
1982 $self->monikers->{delete $fkdef->{remote_table}};
1984 my $tbl_uniq_info = $self->_table_uniq_info($table);
1986 my $local_moniker = $self->monikers->{$table};
1987 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1989 foreach my $src_class (sort keys %$rel_stmts) {
1990 my $src_stmts = $rel_stmts->{$src_class};
1991 foreach my $stmt (@$src_stmts) {
1992 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1998 my ($self, $table) = @_;
2000 my $table_moniker = $self->monikers->{$table};
2001 my $table_class = $self->classes->{$table};
2003 my @roles = @{ $self->result_roles || [] };
2004 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2005 if exists $self->result_roles_map->{$table_moniker};
2007 $self->_with($table_class, @roles) if @roles;
2010 # Overload these in driver class:
2012 # Returns an arrayref of column names
2013 sub _table_columns { croak "ABSTRACT METHOD" }
2015 # Returns arrayref of pk col names
2016 sub _table_pk_info { croak "ABSTRACT METHOD" }
2018 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2019 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2021 # Returns an arrayref of foreign key constraints, each
2022 # being a hashref with 3 keys:
2023 # local_columns (arrayref), remote_columns (arrayref), remote_table
2024 sub _table_fk_info { croak "ABSTRACT METHOD" }
2026 # Returns an array of lower case table names
2027 sub _tables_list { croak "ABSTRACT METHOD" }
2029 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2035 # generate the pod for this statement, storing it with $self->_pod
2036 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2038 my $args = dump(@_);
2039 $args = '(' . $args . ')' if @_ < 2;
2040 my $stmt = $method . $args . q{;};
2042 warn qq|$class\->$stmt\n| if $self->debug;
2043 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2047 # generates the accompanying pod for a DBIC class method statement,
2048 # storing it with $self->_pod
2054 if ( $method eq 'table' ) {
2056 my $pcm = $self->pod_comment_mode;
2057 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2058 $comment = $self->__table_comment($table);
2059 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2060 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2061 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2062 $self->_pod( $class, "=head1 NAME" );
2063 my $table_descr = $class;
2064 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2065 $self->{_class2table}{ $class } = $table;
2066 $self->_pod( $class, $table_descr );
2067 if ($comment and $comment_in_desc) {
2068 $self->_pod( $class, "=head1 DESCRIPTION" );
2069 $self->_pod( $class, $comment );
2071 $self->_pod_cut( $class );
2072 } elsif ( $method eq 'add_columns' ) {
2073 $self->_pod( $class, "=head1 ACCESSORS" );
2074 my $col_counter = 0;
2076 while( my ($name,$attrs) = splice @cols,0,2 ) {
2078 $self->_pod( $class, '=head2 ' . $name );
2079 $self->_pod( $class,
2081 my $s = $attrs->{$_};
2082 $s = !defined $s ? 'undef' :
2083 length($s) == 0 ? '(empty string)' :
2084 ref($s) eq 'SCALAR' ? $$s :
2085 ref($s) ? dumper_squashed $s :
2086 looks_like_number($s) ? $s : qq{'$s'};
2089 } sort keys %$attrs,
2091 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
2092 $self->_pod( $class, $comment );
2095 $self->_pod_cut( $class );
2096 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2097 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2098 my ( $accessor, $rel_class ) = @_;
2099 $self->_pod( $class, "=head2 $accessor" );
2100 $self->_pod( $class, 'Type: ' . $method );
2101 $self->_pod( $class, "Related object: L<$rel_class>" );
2102 $self->_pod_cut( $class );
2103 $self->{_relations_started} { $class } = 1;
2107 sub _filter_comment {
2108 my ($self, $txt) = @_;
2110 $txt = '' if not defined $txt;
2112 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2117 sub __table_comment {
2120 if (my $code = $self->can('_table_comment')) {
2121 return $self->_filter_comment($self->$code(@_));
2127 sub __column_comment {
2130 if (my $code = $self->can('_column_comment')) {
2131 return $self->_filter_comment($self->$code(@_));
2137 # Stores a POD documentation
2139 my ($self, $class, $stmt) = @_;
2140 $self->_raw_stmt( $class, "\n" . $stmt );
2144 my ($self, $class ) = @_;
2145 $self->_raw_stmt( $class, "\n=cut\n" );
2148 # Store a raw source line for a class (for dumping purposes)
2150 my ($self, $class, $stmt) = @_;
2151 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2154 # Like above, but separately for the externally loaded stuff
2156 my ($self, $class, $stmt) = @_;
2157 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2160 sub _quote_table_name {
2161 my ($self, $table) = @_;
2163 my $qt = $self->schema->storage->sql_maker->quote_char;
2165 return $table unless $qt;
2168 return $qt->[0] . $table . $qt->[1];
2171 return $qt . $table . $qt;
2174 sub _custom_column_info {
2175 my ( $self, $table_name, $column_name, $column_info ) = @_;
2177 if (my $code = $self->custom_column_info) {
2178 return $code->($table_name, $column_name, $column_info) || {};
2183 sub _datetime_column_info {
2184 my ( $self, $table_name, $column_name, $column_info ) = @_;
2186 my $type = $column_info->{data_type} || '';
2187 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2188 or ($type =~ /date|timestamp/i)) {
2189 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2190 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2196 my ($self, $name) = @_;
2198 return $self->preserve_case ? $name : lc($name);
2202 my ($self, $name) = @_;
2204 return $self->preserve_case ? $name : uc($name);
2207 sub _unregister_source_for_table {
2208 my ($self, $table) = @_;
2212 my $schema = $self->schema;
2213 # in older DBIC it's a private method
2214 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2215 $schema->$unregister($self->_table2moniker($table));
2216 delete $self->monikers->{$table};
2217 delete $self->classes->{$table};
2218 delete $self->_upgrading_classes->{$table};
2219 delete $self->{_tables}{$table};
2223 # remove the dump dir from @INC on destruction
2227 @INC = grep $_ ne $self->dump_directory, @INC;
2232 Returns a hashref of loaded table to moniker mappings. There will
2233 be two entries for each table, the original name and the "normalized"
2234 name, in the case that the two are different (such as databases
2235 that like uppercase table names, or preserve your original mixed-case
2236 definitions, or what-have-you).
2240 Returns a hashref of table to class mappings. In some cases it will
2241 contain multiple entries per table for the original and normalized table
2242 names, as above in L</monikers>.
2244 =head1 COLUMN ACCESSOR COLLISIONS
2246 Occasionally you may have a column name that collides with a perl method, such
2247 as C<can>. In such cases, the default action is to set the C<accessor> of the
2248 column spec to C<undef>.
2250 You can then name the accessor yourself by placing code such as the following
2253 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2255 Another option is to use the L</col_collision_map> option.
2257 =head1 RELATIONSHIP NAME COLLISIONS
2259 In very rare cases, you may get a collision between a generated relationship
2260 name and a method in your Result class, for example if you have a foreign key
2261 called C<belongs_to>.
2263 This is a problem because relationship names are also relationship accessor
2264 methods in L<DBIx::Class>.
2266 The default behavior is to append C<_rel> to the relationship name and print
2267 out a warning that refers to this text.
2269 You can also control the renaming with the L</rel_collision_map> option.
2273 L<DBIx::Class::Schema::Loader>
2277 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2281 This library is free software; you can redistribute it and/or modify it under
2282 the same terms as Perl itself.
2287 # vim:et sts=4 sw=4 tw=0: