1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
6 use namespace::autoclean;
8 use Carp::Clan qw/^DBIx::Class/;
9 use DBIx::Class::Schema::Loader::RelBuilder;
10 use Data::Dump qw/ dump /;
15 use Lingua::EN::Inflect::Number qw//;
18 use Class::Inspector ();
19 use Data::Dumper::Concise;
20 use Scalar::Util 'looks_like_number';
23 our $VERSION = '0.05003';
25 __PACKAGE__->mk_group_ro_accessors('simple', qw/
32 additional_base_classes
47 default_resultset_class
50 overwrite_modifications
66 __PACKAGE__->mk_group_accessors('simple', qw/
68 schema_version_to_dump
70 _upgrading_from_load_classes
71 _downgrading_to_load_classes
72 _rewriting_result_namespace
77 pod_comment_spillover_length
82 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
86 See L<DBIx::Class::Schema::Loader>
90 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
91 classes, and implements the common functionality between them.
93 =head1 CONSTRUCTOR OPTIONS
95 These constructor options are the base options for
96 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
98 =head2 skip_relationships
100 Skip setting up relationships. The default is to attempt the loading
103 =head2 skip_load_external
105 Skip loading of other classes in @INC. The default is to merge all other classes
106 with the same name found in @INC into the schema file we are creating.
110 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
111 relationship names and singularized Results, unless you're overwriting an
112 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
113 which case the backward compatible RelBuilder will be activated, and
114 singularization will be turned off.
120 will disable the backward-compatible RelBuilder and use
121 the new-style relationship names along with singularized Results, even when
122 overwriting a dump made with an earlier version.
124 The option also takes a hashref:
126 naming => { relationships => 'v5', monikers => 'v4' }
134 How to name relationship accessors.
138 How to name Result classes.
148 Latest default style, whatever that happens to be.
152 Version 0.05XXX style.
156 Version 0.04XXX style.
160 Dynamic schemas will always default to the 0.04XXX relationship names and won't
161 singularize Results for backward compatibility, to activate the new RelBuilder
162 and singularization put this in your C<Schema.pm> file:
164 __PACKAGE__->naming('current');
166 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
167 next major version upgrade:
169 __PACKAGE__->naming('v5');
173 By default POD will be generated for columns and relationships, using database
174 metadata for the text if available and supported.
176 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
177 supported for Postgres right now.
179 Set this to C<0> to turn off all POD generation.
181 =head2 pod_comment_mode
183 Controls where table comments appear in the generated POD. Smaller table
184 comments are appended to the C<NAME> section of the documentation, and larger
185 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
186 section to be generated with the comment always, only use C<NAME>, or choose
187 the length threshold at which the comment is forced into the description.
193 Use C<NAME> section only.
197 Force C<DESCRIPTION> always.
201 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
206 =head2 pod_comment_spillover_length
208 When pod_comment_mode is set to C<auto>, this is the length of the comment at
209 which it will be forced into a separate description section.
213 =head2 relationship_attrs
215 Hashref of attributes to pass to each generated relationship, listed
216 by type. Also supports relationship type 'all', containing options to
217 pass to all generated relationships. Attributes set for more specific
218 relationship types override those set in 'all'.
222 relationship_attrs => {
223 all => { cascade_delete => 0 },
224 has_many => { cascade_delete => 1 },
227 will set the C<cascade_delete> option to 0 for all generated relationships,
228 except for C<has_many>, which will have cascade_delete as 1.
230 NOTE: this option is not supported if v4 backward-compatible naming is
231 set either globally (naming => 'v4') or just for relationships.
235 If set to true, each constructive L<DBIx::Class> statement the loader
236 decides to execute will be C<warn>-ed before execution.
240 Set the name of the schema to load (schema in the sense that your database
241 vendor means it). Does not currently support loading more than one schema
246 Only load tables matching regex. Best specified as a qr// regex.
250 Exclude tables matching regex. Best specified as a qr// regex.
254 Overrides the default table name to moniker translation. Can be either
255 a hashref of table keys and moniker values, or a coderef for a translator
256 function taking a single scalar table name argument and returning
257 a scalar moniker. If the hash entry does not exist, or the function
258 returns a false value, the code falls back to default behavior
261 The default behavior is to singularize the table name, and: C<join '', map
262 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
263 split up the table name into chunks anywhere a non-alpha-numeric character
264 occurs, change the case of first letter of each chunk to upper case, and put
265 the chunks back together. Examples:
267 Table Name | Moniker Name
268 ---------------------------
270 luser_group | LuserGroup
271 luser-opts | LuserOpt
273 =head2 inflect_plural
275 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
276 if hash key does not exist or coderef returns false), but acts as a map
277 for pluralizing relationship names. The default behavior is to utilize
278 L<Lingua::EN::Inflect::Number/to_PL>.
280 =head2 inflect_singular
282 As L</inflect_plural> above, but for singularizing relationship names.
283 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
285 =head2 schema_base_class
287 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
289 =head2 result_base_class
291 Base class for your table classes (aka result classes). Defaults to
294 =head2 additional_base_classes
296 List of additional base classes all of your table classes will use.
298 =head2 left_base_classes
300 List of additional base classes all of your table classes will use
301 that need to be leftmost.
303 =head2 additional_classes
305 List of additional classes which all of your table classes will use.
309 List of additional components to be loaded into all of your table
310 classes. A good example would be C<ResultSetManager>.
312 =head2 resultset_components
314 List of additional ResultSet components to be loaded into your table
315 classes. A good example would be C<AlwaysRS>. Component
316 C<ResultSetManager> will be automatically added to the above
317 C<components> list if this option is set.
319 =head2 use_namespaces
321 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
324 Generate result class names suitable for
325 L<DBIx::Class::Schema/load_namespaces> and call that instead of
326 L<DBIx::Class::Schema/load_classes>. When using this option you can also
327 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
328 C<resultset_namespace>, C<default_resultset_class>), and they will be added
329 to the call (and the generated result class names adjusted appropriately).
331 =head2 dump_directory
333 This option is designed to be a tool to help you transition from this
334 loader to a manually-defined schema when you decide it's time to do so.
336 The value of this option is a perl libdir pathname. Within
337 that directory this module will create a baseline manual
338 L<DBIx::Class::Schema> module set, based on what it creates at runtime
341 The created schema class will have the same classname as the one on
342 which you are setting this option (and the ResultSource classes will be
343 based on this name as well).
345 Normally you wouldn't hard-code this setting in your schema class, as it
346 is meant for one-time manual usage.
348 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
349 recommended way to access this functionality.
351 =head2 dump_overwrite
353 Deprecated. See L</really_erase_my_files> below, which does *not* mean
354 the same thing as the old C<dump_overwrite> setting from previous releases.
356 =head2 really_erase_my_files
358 Default false. If true, Loader will unconditionally delete any existing
359 files before creating the new ones from scratch when dumping a schema to disk.
361 The default behavior is instead to only replace the top portion of the
362 file, up to and including the final stanza which contains
363 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
364 leaving any customizations you placed after that as they were.
366 When C<really_erase_my_files> is not set, if the output file already exists,
367 but the aforementioned final stanza is not found, or the checksum
368 contained there does not match the generated contents, Loader will
369 croak and not touch the file.
371 You should really be using version control on your schema classes (and all
372 of the rest of your code for that matter). Don't blame me if a bug in this
373 code wipes something out when it shouldn't have, you've been warned.
375 =head2 overwrite_modifications
377 Default false. If false, when updating existing files, Loader will
378 refuse to modify any Loader-generated code that has been modified
379 since its last run (as determined by the checksum Loader put in its
382 If true, Loader will discard any manual modifications that have been
383 made to Loader-generated code.
385 Again, you should be using version control on your schema classes. Be
386 careful with this option.
388 =head2 custom_column_info
390 Hook for adding extra attributes to the
391 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
393 Must be a coderef that returns a hashref with the extra attributes.
395 Receives the table name, column name and column_info.
399 custom_column_info => sub {
400 my ($table_name, $column_name, $column_info) = @_;
402 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
403 return { is_snoopy => 1 };
407 This attribute can also be used to set C<inflate_datetime> on a non-datetime
408 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
410 =head2 datetime_timezone
412 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
413 columns with the DATE/DATETIME/TIMESTAMP data_types.
415 =head2 datetime_locale
417 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
418 columns with the DATE/DATETIME/TIMESTAMP data_types.
422 None of these methods are intended for direct invocation by regular
423 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
424 L<DBIx::Class::Schema::Loader>.
428 my $CURRENT_V = 'v5';
431 schema_base_class result_base_class additional_base_classes
432 left_base_classes additional_classes components resultset_components
435 # ensure that a peice of object data is a valid arrayref, creating
436 # an empty one or encapsulating whatever's there.
437 sub _ensure_arrayref {
442 $self->{$_} = [ $self->{$_} ]
443 unless ref $self->{$_} eq 'ARRAY';
449 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
450 by L<DBIx::Class::Schema::Loader>.
455 my ( $class, %args ) = @_;
457 my $self = { %args };
459 bless $self => $class;
461 $self->_ensure_arrayref(qw/additional_classes
462 additional_base_classes
468 $self->_validate_class_args;
470 push(@{$self->{components}}, 'ResultSetManager')
471 if @{$self->{resultset_components}};
473 $self->{monikers} = {};
474 $self->{classes} = {};
475 $self->{_upgrading_classes} = {};
477 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
478 $self->{schema} ||= $self->{schema_class};
480 croak "dump_overwrite is deprecated. Please read the"
481 . " DBIx::Class::Schema::Loader::Base documentation"
482 if $self->{dump_overwrite};
484 $self->{dynamic} = ! $self->{dump_directory};
485 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
490 $self->{dump_directory} ||= $self->{temp_directory};
492 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
493 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
495 if ((not ref $self->naming) && defined $self->naming) {
496 my $naming_ver = $self->naming;
498 relationships => $naming_ver,
499 monikers => $naming_ver,
504 for (values %{ $self->naming }) {
505 $_ = $CURRENT_V if $_ eq 'current';
508 $self->{naming} ||= {};
510 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
511 croak 'custom_column_info must be a CODE ref';
514 $self->_check_back_compat;
516 $self->use_namespaces(1) unless defined $self->use_namespaces;
517 $self->generate_pod(1) unless defined $self->generate_pod;
518 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
519 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
524 sub _check_back_compat {
527 # dynamic schemas will always be in 0.04006 mode, unless overridden
528 if ($self->dynamic) {
529 # just in case, though no one is likely to dump a dynamic schema
530 $self->schema_version_to_dump('0.04006');
532 if (not %{ $self->naming }) {
533 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
535 Dynamic schema detected, will run in 0.04006 mode.
537 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
538 to disable this warning.
540 Also consider setting 'use_namespaces => 1' if/when upgrading.
542 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
547 $self->_upgrading_from('v4');
550 $self->naming->{relationships} ||= 'v4';
551 $self->naming->{monikers} ||= 'v4';
553 if ($self->use_namespaces) {
554 $self->_upgrading_from_load_classes(1);
557 $self->use_namespaces(0);
563 # otherwise check if we need backcompat mode for a static schema
564 my $filename = $self->_get_dump_filename($self->schema_class);
565 return unless -e $filename;
567 open(my $fh, '<', $filename)
568 or croak "Cannot open '$filename' for reading: $!";
570 my $load_classes = 0;
571 my $result_namespace = '';
574 if (/^__PACKAGE__->load_classes;/) {
576 } elsif (/result_namespace => '([^']+)'/) {
577 $result_namespace = $1;
578 } elsif (my ($real_ver) =
579 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
581 if ($load_classes && (not defined $self->use_namespaces)) {
582 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
584 'load_classes;' static schema detected, turning off 'use_namespaces'.
586 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
587 variable to disable this warning.
589 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
592 $self->use_namespaces(0);
594 elsif ($load_classes && $self->use_namespaces) {
595 $self->_upgrading_from_load_classes(1);
597 elsif ((not $load_classes) && defined $self->use_namespaces
598 && (not $self->use_namespaces)) {
599 $self->_downgrading_to_load_classes(
600 $result_namespace || 'Result'
603 elsif ((not defined $self->use_namespaces)
604 || $self->use_namespaces) {
605 if (not $self->result_namespace) {
606 $self->result_namespace($result_namespace || 'Result');
608 elsif ($result_namespace ne $self->result_namespace) {
609 $self->_rewriting_result_namespace(
610 $result_namespace || 'Result'
615 # XXX when we go past .0 this will need fixing
616 my ($v) = $real_ver =~ /([1-9])/;
619 last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
621 if (not %{ $self->naming }) {
622 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
624 Version $real_ver static schema detected, turning on backcompat mode.
626 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
627 to disable this warning.
629 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
634 $self->_upgrading_from($v);
638 $self->naming->{relationships} ||= $v;
639 $self->naming->{monikers} ||= $v;
641 $self->schema_version_to_dump($real_ver);
649 sub _validate_class_args {
653 foreach my $k (@CLASS_ARGS) {
654 next unless $self->$k;
656 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
657 foreach my $c (@classes) {
658 # components default to being under the DBIx::Class namespace unless they
659 # are preceeded with a '+'
660 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
661 $c = 'DBIx::Class::' . $c;
664 # 1 == installed, 0 == not installed, undef == invalid classname
665 my $installed = Class::Inspector->installed($c);
666 if ( defined($installed) ) {
667 if ( $installed == 0 ) {
668 croak qq/$c, as specified in the loader option "$k", is not installed/;
671 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
677 sub _find_file_in_inc {
678 my ($self, $file) = @_;
680 foreach my $prefix (@INC) {
681 my $fullpath = File::Spec->catfile($prefix, $file);
682 return $fullpath if -f $fullpath
683 # abs_path throws on Windows for nonexistant files
684 and eval { Cwd::abs_path($fullpath) } ne
685 (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
692 my ($self, $class) = @_;
694 my $class_path = $class;
695 $class_path =~ s{::}{/}g;
696 $class_path .= '.pm';
701 sub _find_class_in_inc {
702 my ($self, $class) = @_;
704 return $self->_find_file_in_inc($self->_class_path($class));
710 return $self->_upgrading_from
711 || $self->_upgrading_from_load_classes
712 || $self->_downgrading_to_load_classes
713 || $self->_rewriting_result_namespace
717 sub _rewrite_old_classnames {
718 my ($self, $code) = @_;
720 return $code unless $self->_rewriting;
722 my %old_classes = reverse %{ $self->_upgrading_classes };
724 my $re = join '|', keys %old_classes;
727 $code =~ s/$re/$old_classes{$1} || $1/eg;
733 my ($self, $class) = @_;
735 return if $self->{skip_load_external};
737 # so that we don't load our own classes, under any circumstances
738 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
740 my $real_inc_path = $self->_find_class_in_inc($class);
742 my $old_class = $self->_upgrading_classes->{$class}
743 if $self->_rewriting;
745 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
746 if $old_class && $old_class ne $class;
748 return unless $real_inc_path || $old_real_inc_path;
750 if ($real_inc_path) {
751 # If we make it to here, we loaded an external definition
752 warn qq/# Loaded external class definition for '$class'\n/
755 open(my $fh, '<', $real_inc_path)
756 or croak "Failed to open '$real_inc_path' for reading: $!";
757 my $code = do { local $/; <$fh> };
759 or croak "Failed to close $real_inc_path: $!";
760 $code = $self->_rewrite_old_classnames($code);
762 if ($self->dynamic) { # load the class too
763 # kill redefined warnings
764 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
765 local $SIG{__WARN__} = sub {
767 unless $_[0] =~ /^Subroutine \S+ redefined/;
773 $self->_ext_stmt($class,
774 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
775 .qq|# They are now part of the custom portion of this file\n|
776 .qq|# for you to hand-edit. If you do not either delete\n|
777 .qq|# this section or remove that file from \@INC, this section\n|
778 .qq|# will be repeated redundantly when you re-create this\n|
779 .qq|# file again via Loader! See skip_load_external to disable\n|
780 .qq|# this feature.\n|
783 $self->_ext_stmt($class, $code);
784 $self->_ext_stmt($class,
785 qq|# End of lines loaded from '$real_inc_path' |
789 if ($old_real_inc_path) {
790 open(my $fh, '<', $old_real_inc_path)
791 or croak "Failed to open '$old_real_inc_path' for reading: $!";
792 $self->_ext_stmt($class, <<"EOF");
794 # These lines were loaded from '$old_real_inc_path',
795 # based on the Result class name that would have been created by an 0.04006
796 # version of the Loader. For a static schema, this happens only once during
797 # upgrade. See skip_load_external to disable this feature.
801 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
803 $code = $self->_rewrite_old_classnames($code);
805 if ($self->dynamic) {
808 Detected external content in '$old_real_inc_path', a class name that would have
809 been used by an 0.04006 version of the Loader.
811 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
812 new name of the Result.
814 # kill redefined warnings
815 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
816 local $SIG{__WARN__} = sub {
818 unless $_[0] =~ /^Subroutine \S+ redefined/;
825 $self->_ext_stmt($class, $code);
826 $self->_ext_stmt($class,
827 qq|# End of lines loaded from '$old_real_inc_path' |
834 Does the actual schema-construction work.
841 $self->_load_tables($self->_tables_list);
848 Rescan the database for newly added tables. Does
849 not process drops or changes. Returns a list of
850 the newly added table monikers.
852 The schema argument should be the schema class
853 or object to be affected. It should probably
854 be derived from the original schema_class used
860 my ($self, $schema) = @_;
862 $self->{schema} = $schema;
863 $self->_relbuilder->{schema} = $schema;
866 my @current = $self->_tables_list;
867 foreach my $table ($self->_tables_list) {
868 if(!exists $self->{_tables}->{$table}) {
869 push(@created, $table);
873 my $loaded = $self->_load_tables(@created);
875 return map { $self->monikers->{$_} } @$loaded;
879 no warnings 'uninitialized';
882 return if $self->{skip_relationships};
884 if ($self->naming->{relationships} eq 'v4') {
885 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
886 return $self->{relbuilder} ||=
887 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
888 $self->schema, $self->inflect_plural, $self->inflect_singular
892 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
894 $self->inflect_plural,
895 $self->inflect_singular,
896 $self->relationship_attrs,
901 my ($self, @tables) = @_;
903 # First, use _tables_list with constraint and exclude
904 # to get a list of tables to operate on
906 my $constraint = $self->constraint;
907 my $exclude = $self->exclude;
909 @tables = grep { /$constraint/ } @tables if $constraint;
910 @tables = grep { ! /$exclude/ } @tables if $exclude;
912 # Save the new tables to the tables list
914 $self->{_tables}->{$_} = 1;
917 $self->_make_src_class($_) for @tables;
918 $self->_setup_src_meta($_) for @tables;
920 if(!$self->skip_relationships) {
921 # The relationship loader needs a working schema
923 local $self->{dump_directory} = $self->{temp_directory};
924 $self->_reload_classes(\@tables);
925 $self->_load_relationships($_) for @tables;
928 # Remove that temp dir from INC so it doesn't get reloaded
929 @INC = grep $_ ne $self->dump_directory, @INC;
932 $self->_load_external($_)
933 for map { $self->classes->{$_} } @tables;
935 # Reload without unloading first to preserve any symbols from external
937 $self->_reload_classes(\@tables, 0);
939 # Drop temporary cache
940 delete $self->{_cache};
945 sub _reload_classes {
946 my ($self, $tables, $unload) = @_;
948 my @tables = @$tables;
949 $unload = 1 unless defined $unload;
951 # so that we don't repeat custom sections
952 @INC = grep $_ ne $self->dump_directory, @INC;
954 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
956 unshift @INC, $self->dump_directory;
959 my %have_source = map { $_ => $self->schema->source($_) }
960 $self->schema->sources;
962 for my $table (@tables) {
963 my $moniker = $self->monikers->{$table};
964 my $class = $self->classes->{$table};
967 no warnings 'redefine';
968 local *Class::C3::reinitialize = sub {};
971 Class::Unload->unload($class) if $unload;
972 my ($source, $resultset_class);
974 ($source = $have_source{$moniker})
975 && ($resultset_class = $source->resultset_class)
976 && ($resultset_class ne 'DBIx::Class::ResultSet')
978 my $has_file = Class::Inspector->loaded_filename($resultset_class);
979 Class::Unload->unload($resultset_class) if $unload;
980 $self->_reload_class($resultset_class) if $has_file;
982 $self->_reload_class($class);
984 push @to_register, [$moniker, $class];
987 Class::C3->reinitialize;
989 $self->schema->register_class(@$_);
993 # We use this instead of ensure_class_loaded when there are package symbols we
996 my ($self, $class) = @_;
998 my $class_path = $self->_class_path($class);
999 delete $INC{ $class_path };
1001 # kill redefined warnings
1002 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1003 local $SIG{__WARN__} = sub {
1005 unless $_[0] =~ /^Subroutine \S+ redefined/;
1007 eval "require $class;";
1010 sub _get_dump_filename {
1011 my ($self, $class) = (@_);
1013 $class =~ s{::}{/}g;
1014 return $self->dump_directory . q{/} . $class . q{.pm};
1017 sub _ensure_dump_subdirs {
1018 my ($self, $class) = (@_);
1020 my @name_parts = split(/::/, $class);
1021 pop @name_parts; # we don't care about the very last element,
1022 # which is a filename
1024 my $dir = $self->dump_directory;
1027 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1029 last if !@name_parts;
1030 $dir = File::Spec->catdir($dir, shift @name_parts);
1035 my ($self, @classes) = @_;
1037 my $schema_class = $self->schema_class;
1038 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1040 my $target_dir = $self->dump_directory;
1041 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1042 unless $self->{dynamic} or $self->{quiet};
1045 qq|package $schema_class;\n\n|
1046 . qq|# Created by DBIx::Class::Schema::Loader\n|
1047 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1048 . qq|use strict;\nuse warnings;\n\n|
1049 . qq|use base '$schema_base_class';\n\n|;
1051 if ($self->use_namespaces) {
1052 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1053 my $namespace_options;
1054 for my $attr (qw(result_namespace
1056 default_resultset_class)) {
1058 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1061 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1062 $schema_text .= qq|;\n|;
1065 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1069 local $self->{version_to_dump} = $self->schema_version_to_dump;
1070 $self->_write_classfile($schema_class, $schema_text, 1);
1073 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1075 foreach my $src_class (@classes) {
1077 qq|package $src_class;\n\n|
1078 . qq|# Created by DBIx::Class::Schema::Loader\n|
1079 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1080 . qq|use strict;\nuse warnings;\n\n|
1081 . qq|use base '$result_base_class';\n\n|;
1083 $self->_write_classfile($src_class, $src_text);
1086 # remove Result dir if downgrading from use_namespaces, and there are no
1088 if (my $result_ns = $self->_downgrading_to_load_classes
1089 || $self->_rewriting_result_namespace) {
1090 my $result_namespace = $self->_result_namespace(
1095 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1096 $result_dir = $self->dump_directory . '/' . $result_dir;
1098 unless (my @files = glob "$result_dir/*") {
1103 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1108 my ($self, $version, $ts) = @_;
1109 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1112 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1115 sub _write_classfile {
1116 my ($self, $class, $text, $is_schema) = @_;
1118 my $filename = $self->_get_dump_filename($class);
1119 $self->_ensure_dump_subdirs($class);
1121 if (-f $filename && $self->really_erase_my_files) {
1122 warn "Deleting existing file '$filename' due to "
1123 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1127 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1129 if (my $old_class = $self->_upgrading_classes->{$class}) {
1130 my $old_filename = $self->_get_dump_filename($old_class);
1132 my ($old_custom_content) = $self->_get_custom_content(
1133 $old_class, $old_filename, 0 # do not add default comment
1136 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1138 if ($old_custom_content) {
1140 "\n" . $old_custom_content . "\n" . $custom_content;
1143 unlink $old_filename;
1146 $custom_content = $self->_rewrite_old_classnames($custom_content);
1149 for @{$self->{_dump_storage}->{$class} || []};
1151 # Check and see if the dump is infact differnt
1155 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1158 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1159 return unless $self->_upgrading_from && $is_schema;
1163 $text .= $self->_sig_comment(
1164 $self->version_to_dump,
1165 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1168 open(my $fh, '>', $filename)
1169 or croak "Cannot open '$filename' for writing: $!";
1171 # Write the top half and its MD5 sum
1172 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1174 # Write out anything loaded via external partial class file in @INC
1176 for @{$self->{_ext_storage}->{$class} || []};
1178 # Write out any custom content the user has added
1179 print $fh $custom_content;
1182 or croak "Error closing '$filename': $!";
1185 sub _default_custom_content {
1186 return qq|\n\n# You can replace this text with custom|
1187 . qq| content, and it will be preserved on regeneration|
1191 sub _get_custom_content {
1192 my ($self, $class, $filename, $add_default) = @_;
1194 $add_default = 1 unless defined $add_default;
1196 return ($self->_default_custom_content) if ! -f $filename;
1198 open(my $fh, '<', $filename)
1199 or croak "Cannot open '$filename' for reading: $!";
1202 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1205 my ($md5, $ts, $ver);
1207 if(!$md5 && /$mark_re/) {
1211 # Pull out the previous version and timestamp
1212 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1215 croak "Checksum mismatch in '$filename', 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"
1216 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1225 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1226 . " it does not appear to have been generated by Loader"
1229 # Default custom content:
1230 $buffer ||= $self->_default_custom_content if $add_default;
1232 return ($buffer, $md5, $ver, $ts);
1240 warn "$target: use $_;" if $self->debug;
1241 $self->_raw_stmt($target, "use $_;");
1248 my $schema_class = $self->schema_class;
1250 my $blist = join(q{ }, @_);
1251 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1252 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1255 sub _result_namespace {
1256 my ($self, $schema_class, $ns) = @_;
1257 my @result_namespace;
1259 if ($ns =~ /^\+(.*)/) {
1260 # Fully qualified namespace
1261 @result_namespace = ($1)
1264 # Relative namespace
1265 @result_namespace = ($schema_class, $ns);
1268 return wantarray ? @result_namespace : join '::', @result_namespace;
1271 # Create class with applicable bases, setup monikers, etc
1272 sub _make_src_class {
1273 my ($self, $table) = @_;
1275 my $schema = $self->schema;
1276 my $schema_class = $self->schema_class;
1278 my $table_moniker = $self->_table2moniker($table);
1279 my @result_namespace = ($schema_class);
1280 if ($self->use_namespaces) {
1281 my $result_namespace = $self->result_namespace || 'Result';
1282 @result_namespace = $self->_result_namespace(
1287 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1289 if ((my $upgrading_v = $self->_upgrading_from)
1290 || $self->_rewriting) {
1291 local $self->naming->{monikers} = $upgrading_v
1294 my @result_namespace = @result_namespace;
1295 if ($self->_upgrading_from_load_classes) {
1296 @result_namespace = ($schema_class);
1298 elsif (my $ns = $self->_downgrading_to_load_classes) {
1299 @result_namespace = $self->_result_namespace(
1304 elsif ($ns = $self->_rewriting_result_namespace) {
1305 @result_namespace = $self->_result_namespace(
1311 my $old_class = join(q{::}, @result_namespace,
1312 $self->_table2moniker($table));
1314 $self->_upgrading_classes->{$table_class} = $old_class
1315 unless $table_class eq $old_class;
1318 my $table_normalized = lc $table;
1319 $self->classes->{$table} = $table_class;
1320 $self->classes->{$table_normalized} = $table_class;
1321 $self->monikers->{$table} = $table_moniker;
1322 $self->monikers->{$table_normalized} = $table_moniker;
1324 $self->_use ($table_class, @{$self->additional_classes});
1325 $self->_inject($table_class, @{$self->left_base_classes});
1327 if (my @components = @{ $self->components }) {
1328 $self->_dbic_stmt($table_class, 'load_components', @components);
1331 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1332 if @{$self->resultset_components};
1333 $self->_inject($table_class, @{$self->additional_base_classes});
1336 # Set up metadata (cols, pks, etc)
1337 sub _setup_src_meta {
1338 my ($self, $table) = @_;
1340 my $schema = $self->schema;
1341 my $schema_class = $self->schema_class;
1343 my $table_class = $self->classes->{$table};
1344 my $table_moniker = $self->monikers->{$table};
1346 my $table_name = $table;
1347 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1349 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1350 $table_name = \ $self->_quote_table_name($table_name);
1353 $self->_dbic_stmt($table_class,'table',$table_name);
1355 my $cols = $self->_table_columns($table);
1357 eval { $col_info = $self->__columns_info_for($table) };
1359 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1362 if ($self->_is_case_sensitive) {
1363 for my $col (keys %$col_info) {
1364 $col_info->{$col}{accessor} = lc $col
1365 if $col ne lc($col);
1368 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1371 my $fks = $self->_table_fk_info($table);
1373 for my $fkdef (@$fks) {
1374 for my $col (@{ $fkdef->{local_columns} }) {
1375 $col_info->{$col}{is_foreign_key} = 1;
1381 map { $_, ($col_info->{$_}||{}) } @$cols
1385 my %uniq_tag; # used to eliminate duplicate uniqs
1387 my $pks = $self->_table_pk_info($table) || [];
1388 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1389 : carp("$table has no primary key");
1390 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1392 my $uniqs = $self->_table_uniq_info($table) || [];
1394 my ($name, $cols) = @$_;
1395 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1396 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1401 sub __columns_info_for {
1402 my ($self, $table) = @_;
1404 my $result = $self->_columns_info_for($table);
1406 while (my ($col, $info) = each %$result) {
1407 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1408 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1410 $result->{$col} = $info;
1418 Returns a sorted list of loaded tables, using the original database table
1426 return keys %{$self->_tables};
1429 # Make a moniker from a table
1430 sub _default_table2moniker {
1431 no warnings 'uninitialized';
1432 my ($self, $table) = @_;
1434 if ($self->naming->{monikers} eq 'v4') {
1435 return join '', map ucfirst, split /[\W_]+/, lc $table;
1438 return join '', map ucfirst, split /[\W_]+/,
1439 Lingua::EN::Inflect::Number::to_S(lc $table);
1442 sub _table2moniker {
1443 my ( $self, $table ) = @_;
1447 if( ref $self->moniker_map eq 'HASH' ) {
1448 $moniker = $self->moniker_map->{$table};
1450 elsif( ref $self->moniker_map eq 'CODE' ) {
1451 $moniker = $self->moniker_map->($table);
1454 $moniker ||= $self->_default_table2moniker($table);
1459 sub _load_relationships {
1460 my ($self, $table) = @_;
1462 my $tbl_fk_info = $self->_table_fk_info($table);
1463 foreach my $fkdef (@$tbl_fk_info) {
1464 $fkdef->{remote_source} =
1465 $self->monikers->{delete $fkdef->{remote_table}};
1467 my $tbl_uniq_info = $self->_table_uniq_info($table);
1469 my $local_moniker = $self->monikers->{$table};
1470 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1472 foreach my $src_class (sort keys %$rel_stmts) {
1473 my $src_stmts = $rel_stmts->{$src_class};
1474 foreach my $stmt (@$src_stmts) {
1475 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1480 # Overload these in driver class:
1482 # Returns an arrayref of column names
1483 sub _table_columns { croak "ABSTRACT METHOD" }
1485 # Returns arrayref of pk col names
1486 sub _table_pk_info { croak "ABSTRACT METHOD" }
1488 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1489 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1491 # Returns an arrayref of foreign key constraints, each
1492 # being a hashref with 3 keys:
1493 # local_columns (arrayref), remote_columns (arrayref), remote_table
1494 sub _table_fk_info { croak "ABSTRACT METHOD" }
1496 # Returns an array of lower case table names
1497 sub _tables_list { croak "ABSTRACT METHOD" }
1499 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1505 # generate the pod for this statement, storing it with $self->_pod
1506 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1508 my $args = dump(@_);
1509 $args = '(' . $args . ')' if @_ < 2;
1510 my $stmt = $method . $args . q{;};
1512 warn qq|$class\->$stmt\n| if $self->debug;
1513 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1517 # generates the accompanying pod for a DBIC class method statement,
1518 # storing it with $self->_pod
1524 if ( $method eq 'table' ) {
1526 my $pcm = $self->pod_comment_mode;
1527 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1528 if ( $self->can('_table_comment') ) {
1529 $comment = $self->_table_comment($table);
1530 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1531 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1532 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1534 $self->_pod( $class, "=head1 NAME" );
1535 my $table_descr = $class;
1536 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1537 $self->{_class2table}{ $class } = $table;
1538 $self->_pod( $class, $table_descr );
1539 if ($comment and $comment_in_desc) {
1540 $self->_pod( $class, "=head1 DESCRIPTION" );
1541 $self->_pod( $class, $comment );
1543 $self->_pod_cut( $class );
1544 } elsif ( $method eq 'add_columns' ) {
1545 $self->_pod( $class, "=head1 ACCESSORS" );
1546 my $col_counter = 0;
1548 while( my ($name,$attrs) = splice @cols,0,2 ) {
1550 $self->_pod( $class, '=head2 ' . $name );
1551 $self->_pod( $class,
1553 my $s = $attrs->{$_};
1554 $s = !defined $s ? 'undef' :
1555 length($s) == 0 ? '(empty string)' :
1556 ref($s) eq 'SCALAR' ? $$s :
1563 looks_like_number($s) ? $s :
1568 } sort keys %$attrs,
1571 if( $self->can('_column_comment')
1572 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1574 $self->_pod( $class, $comment );
1577 $self->_pod_cut( $class );
1578 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1579 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1580 my ( $accessor, $rel_class ) = @_;
1581 $self->_pod( $class, "=head2 $accessor" );
1582 $self->_pod( $class, 'Type: ' . $method );
1583 $self->_pod( $class, "Related object: L<$rel_class>" );
1584 $self->_pod_cut( $class );
1585 $self->{_relations_started} { $class } = 1;
1589 # Stores a POD documentation
1591 my ($self, $class, $stmt) = @_;
1592 $self->_raw_stmt( $class, "\n" . $stmt );
1596 my ($self, $class ) = @_;
1597 $self->_raw_stmt( $class, "\n=cut\n" );
1600 # Store a raw source line for a class (for dumping purposes)
1602 my ($self, $class, $stmt) = @_;
1603 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1606 # Like above, but separately for the externally loaded stuff
1608 my ($self, $class, $stmt) = @_;
1609 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1612 sub _quote_table_name {
1613 my ($self, $table) = @_;
1615 my $qt = $self->schema->storage->sql_maker->quote_char;
1617 return $table unless $qt;
1620 return $qt->[0] . $table . $qt->[1];
1623 return $qt . $table . $qt;
1626 sub _is_case_sensitive { 0 }
1628 sub _custom_column_info {
1629 my ( $self, $table_name, $column_name, $column_info ) = @_;
1631 if (my $code = $self->custom_column_info) {
1632 return $code->($table_name, $column_name, $column_info) || {};
1637 sub _datetime_column_info {
1638 my ( $self, $table_name, $column_name, $column_info ) = @_;
1640 my $type = $column_info->{data_type} || '';
1641 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1642 or ($type =~ /date|timestamp/i)) {
1643 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1644 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
1649 # remove the dump dir from @INC on destruction
1653 @INC = grep $_ ne $self->dump_directory, @INC;
1658 Returns a hashref of loaded table to moniker mappings. There will
1659 be two entries for each table, the original name and the "normalized"
1660 name, in the case that the two are different (such as databases
1661 that like uppercase table names, or preserve your original mixed-case
1662 definitions, or what-have-you).
1666 Returns a hashref of table to class mappings. In some cases it will
1667 contain multiple entries per table for the original and normalized table
1668 names, as above in L</monikers>.
1672 L<DBIx::Class::Schema::Loader>
1676 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1680 This library is free software; you can redistribute it and/or modify it under
1681 the same terms as Perl itself.