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//;
19 our $VERSION = '0.04999_13';
21 __PACKAGE__->mk_group_ro_accessors('simple', qw/
28 additional_base_classes
42 default_resultset_class
45 overwrite_modifications
59 __PACKAGE__->mk_group_accessors('simple', qw/
61 schema_version_to_dump
63 _upgrading_from_load_classes
64 _downgrading_to_load_classes
65 _rewriting_result_namespace
72 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
76 See L<DBIx::Class::Schema::Loader>
80 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
81 classes, and implements the common functionality between them.
83 =head1 CONSTRUCTOR OPTIONS
85 These constructor options are the base options for
86 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
88 =head2 skip_relationships
90 Skip setting up relationships. The default is to attempt the loading
93 =head2 skip_load_external
95 Skip loading of other classes in @INC. The default is to merge all other classes
96 with the same name found in @INC into the schema file we are creating.
100 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
101 relationship names and singularized Results, unless you're overwriting an
102 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
103 which case the backward compatible RelBuilder will be activated, and
104 singularization will be turned off.
110 will disable the backward-compatible RelBuilder and use
111 the new-style relationship names along with singularized Results, even when
112 overwriting a dump made with an earlier version.
114 The option also takes a hashref:
116 naming => { relationships => 'v5', monikers => 'v4' }
124 How to name relationship accessors.
128 How to name Result classes.
138 Latest default style, whatever that happens to be.
142 Version 0.05XXX style.
146 Version 0.04XXX style.
150 Dynamic schemas will always default to the 0.04XXX relationship names and won't
151 singularize Results for backward compatibility, to activate the new RelBuilder
152 and singularization put this in your C<Schema.pm> file:
154 __PACKAGE__->naming('current');
156 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
157 next major version upgrade:
159 __PACKAGE__->naming('v5');
161 =head2 relationship_attrs
163 Hashref of attributes to pass to each generated relationship, listed
164 by type. Also supports relationship type 'all', containing options to
165 pass to all generated relationships. Attributes set for more specific
166 relationship types override those set in 'all'.
170 relationship_attrs => {
171 all => { cascade_delete => 0 },
172 has_many => { cascade_delete => 1 },
175 will set the C<cascade_delete> option to 0 for all generated relationships,
176 except for C<has_many>, which will have cascade_delete as 1.
178 NOTE: this option is not supported if v4 backward-compatible naming is
179 set either globally (naming => 'v4') or just for relationships.
183 If set to true, each constructive L<DBIx::Class> statement the loader
184 decides to execute will be C<warn>-ed before execution.
188 Set the name of the schema to load (schema in the sense that your database
189 vendor means it). Does not currently support loading more than one schema
194 Only load tables matching regex. Best specified as a qr// regex.
198 Exclude tables matching regex. Best specified as a qr// regex.
202 Overrides the default table name to moniker translation. Can be either
203 a hashref of table keys and moniker values, or a coderef for a translator
204 function taking a single scalar table name argument and returning
205 a scalar moniker. If the hash entry does not exist, or the function
206 returns a false value, the code falls back to default behavior
209 The default behavior is to singularize the table name, and: C<join '', map
210 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
211 split up the table name into chunks anywhere a non-alpha-numeric character
212 occurs, change the case of first letter of each chunk to upper case, and put
213 the chunks back together. Examples:
215 Table Name | Moniker Name
216 ---------------------------
218 luser_group | LuserGroup
219 luser-opts | LuserOpt
221 =head2 inflect_plural
223 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
224 if hash key does not exist or coderef returns false), but acts as a map
225 for pluralizing relationship names. The default behavior is to utilize
226 L<Lingua::EN::Inflect::Number/to_PL>.
228 =head2 inflect_singular
230 As L</inflect_plural> above, but for singularizing relationship names.
231 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
233 =head2 schema_base_class
235 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
237 =head2 result_base_class
239 Base class for your table classes (aka result classes). Defaults to
242 =head2 additional_base_classes
244 List of additional base classes all of your table classes will use.
246 =head2 left_base_classes
248 List of additional base classes all of your table classes will use
249 that need to be leftmost.
251 =head2 additional_classes
253 List of additional classes which all of your table classes will use.
257 List of additional components to be loaded into all of your table
258 classes. A good example would be C<ResultSetManager>.
260 =head2 resultset_components
262 List of additional ResultSet components to be loaded into your table
263 classes. A good example would be C<AlwaysRS>. Component
264 C<ResultSetManager> will be automatically added to the above
265 C<components> list if this option is set.
267 =head2 use_namespaces
269 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
272 Generate result class names suitable for
273 L<DBIx::Class::Schema/load_namespaces> and call that instead of
274 L<DBIx::Class::Schema/load_classes>. When using this option you can also
275 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
276 C<resultset_namespace>, C<default_resultset_class>), and they will be added
277 to the call (and the generated result class names adjusted appropriately).
279 =head2 dump_directory
281 This option is designed to be a tool to help you transition from this
282 loader to a manually-defined schema when you decide it's time to do so.
284 The value of this option is a perl libdir pathname. Within
285 that directory this module will create a baseline manual
286 L<DBIx::Class::Schema> module set, based on what it creates at runtime
289 The created schema class will have the same classname as the one on
290 which you are setting this option (and the ResultSource classes will be
291 based on this name as well).
293 Normally you wouldn't hard-code this setting in your schema class, as it
294 is meant for one-time manual usage.
296 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
297 recommended way to access this functionality.
299 =head2 dump_overwrite
301 Deprecated. See L</really_erase_my_files> below, which does *not* mean
302 the same thing as the old C<dump_overwrite> setting from previous releases.
304 =head2 really_erase_my_files
306 Default false. If true, Loader will unconditionally delete any existing
307 files before creating the new ones from scratch when dumping a schema to disk.
309 The default behavior is instead to only replace the top portion of the
310 file, up to and including the final stanza which contains
311 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
312 leaving any customizations you placed after that as they were.
314 When C<really_erase_my_files> is not set, if the output file already exists,
315 but the aforementioned final stanza is not found, or the checksum
316 contained there does not match the generated contents, Loader will
317 croak and not touch the file.
319 You should really be using version control on your schema classes (and all
320 of the rest of your code for that matter). Don't blame me if a bug in this
321 code wipes something out when it shouldn't have, you've been warned.
323 =head2 overwrite_modifications
325 Default false. If false, when updating existing files, Loader will
326 refuse to modify any Loader-generated code that has been modified
327 since its last run (as determined by the checksum Loader put in its
330 If true, Loader will discard any manual modifications that have been
331 made to Loader-generated code.
333 Again, you should be using version control on your schema classes. Be
334 careful with this option.
338 None of these methods are intended for direct invocation by regular
339 users of L<DBIx::Class::Schema::Loader>. Anything you can find here
340 can also be found via standard L<DBIx::Class::Schema> methods somehow.
344 use constant CURRENT_V => 'v5';
346 # ensure that a peice of object data is a valid arrayref, creating
347 # an empty one or encapsulating whatever's there.
348 sub _ensure_arrayref {
353 $self->{$_} = [ $self->{$_} ]
354 unless ref $self->{$_} eq 'ARRAY';
360 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
361 by L<DBIx::Class::Schema::Loader>.
366 my ( $class, %args ) = @_;
368 my $self = { %args };
370 bless $self => $class;
372 $self->_ensure_arrayref(qw/additional_classes
373 additional_base_classes
379 push(@{$self->{components}}, 'ResultSetManager')
380 if @{$self->{resultset_components}};
382 $self->{monikers} = {};
383 $self->{classes} = {};
384 $self->{_upgrading_classes} = {};
386 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
387 $self->{schema} ||= $self->{schema_class};
389 croak "dump_overwrite is deprecated. Please read the"
390 . " DBIx::Class::Schema::Loader::Base documentation"
391 if $self->{dump_overwrite};
393 $self->{dynamic} = ! $self->{dump_directory};
394 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
399 $self->{dump_directory} ||= $self->{temp_directory};
401 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
402 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
404 if ((not ref $self->naming) && defined $self->naming) {
405 my $naming_ver = $self->naming;
407 relationships => $naming_ver,
408 monikers => $naming_ver,
413 for (values %{ $self->naming }) {
414 $_ = CURRENT_V if $_ eq 'current';
417 $self->{naming} ||= {};
419 $self->_check_back_compat;
421 $self->use_namespaces(1) unless defined $self->use_namespaces;
426 sub _check_back_compat {
429 # dynamic schemas will always be in 0.04006 mode, unless overridden
430 if ($self->dynamic) {
431 # just in case, though no one is likely to dump a dynamic schema
432 $self->schema_version_to_dump('0.04006');
434 if (not %{ $self->naming }) {
435 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
437 Dynamic schema detected, will run in 0.04006 mode.
439 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
440 to disable this warning.
442 Also consider setting 'use_namespaces => 1' if/when upgrading.
444 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
449 $self->_upgrading_from('v4');
452 $self->naming->{relationships} ||= 'v4';
453 $self->naming->{monikers} ||= 'v4';
455 if ($self->use_namespaces) {
456 $self->_upgrading_from_load_classes(1);
459 $self->use_namespaces(0);
465 # otherwise check if we need backcompat mode for a static schema
466 my $filename = $self->_get_dump_filename($self->schema_class);
467 return unless -e $filename;
469 open(my $fh, '<', $filename)
470 or croak "Cannot open '$filename' for reading: $!";
472 my $load_classes = 0;
473 my $result_namespace = '';
476 if (/^__PACKAGE__->load_classes;/) {
478 } elsif (/result_namespace => '([^']+)'/) {
479 $result_namespace = $1;
480 } elsif (my ($real_ver) =
481 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
483 if ($load_classes && (not defined $self->use_namespaces)) {
484 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
486 'load_classes;' static schema detected, turning off 'use_namespaces'.
488 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
489 variable to disable this warning.
491 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
494 $self->use_namespaces(0);
496 elsif ($load_classes && $self->use_namespaces) {
497 $self->_upgrading_from_load_classes(1);
499 elsif ((not $load_classes) && defined $self->use_namespaces
500 && (not $self->use_namespaces)) {
501 $self->_downgrading_to_load_classes(
502 $result_namespace || 'Result'
505 elsif ((not defined $self->use_namespaces)
506 || $self->use_namespaces) {
507 if (not $self->result_namespace) {
508 $self->result_namespace($result_namespace || 'Result');
510 elsif ($result_namespace ne $self->result_namespace) {
511 $self->_rewriting_result_namespace(
512 $result_namespace || 'Result'
517 # XXX when we go past .0 this will need fixing
518 my ($v) = $real_ver =~ /([1-9])/;
521 last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
523 if (not %{ $self->naming }) {
524 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
526 Version $real_ver static schema detected, turning on backcompat mode.
528 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
529 to disable this warning.
531 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
536 $self->_upgrading_from($v);
540 $self->naming->{relationships} ||= $v;
541 $self->naming->{monikers} ||= $v;
543 $self->schema_version_to_dump($real_ver);
551 sub _find_file_in_inc {
552 my ($self, $file) = @_;
554 foreach my $prefix (@INC) {
555 my $fullpath = File::Spec->catfile($prefix, $file);
556 return $fullpath if -f $fullpath
557 and Cwd::abs_path($fullpath) ne
558 (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
565 my ($self, $class) = @_;
567 my $class_path = $class;
568 $class_path =~ s{::}{/}g;
569 $class_path .= '.pm';
574 sub _find_class_in_inc {
575 my ($self, $class) = @_;
577 return $self->_find_file_in_inc($self->_class_path($class));
583 return $self->_upgrading_from
584 || $self->_upgrading_from_load_classes
585 || $self->_downgrading_to_load_classes
586 || $self->_rewriting_result_namespace
590 sub _rewrite_old_classnames {
591 my ($self, $code) = @_;
593 return $code unless $self->_rewriting;
595 my %old_classes = reverse %{ $self->_upgrading_classes };
597 my $re = join '|', keys %old_classes;
600 $code =~ s/$re/$old_classes{$1} || $1/eg;
606 my ($self, $class) = @_;
608 return if $self->{skip_load_external};
610 # so that we don't load our own classes, under any circumstances
611 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
613 my $real_inc_path = $self->_find_class_in_inc($class);
615 my $old_class = $self->_upgrading_classes->{$class}
616 if $self->_rewriting;
618 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
619 if $old_class && $old_class ne $class;
621 return unless $real_inc_path || $old_real_inc_path;
623 if ($real_inc_path) {
624 # If we make it to here, we loaded an external definition
625 warn qq/# Loaded external class definition for '$class'\n/
628 open(my $fh, '<', $real_inc_path)
629 or croak "Failed to open '$real_inc_path' for reading: $!";
630 my $code = do { local $/; <$fh> };
632 or croak "Failed to close $real_inc_path: $!";
633 $code = $self->_rewrite_old_classnames($code);
635 if ($self->dynamic) { # load the class too
636 # kill redefined warnings
637 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
638 local $SIG{__WARN__} = sub {
640 unless $_[0] =~ /^Subroutine \S+ redefined/;
646 $self->_ext_stmt($class,
647 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
648 .qq|# They are now part of the custom portion of this file\n|
649 .qq|# for you to hand-edit. If you do not either delete\n|
650 .qq|# this section or remove that file from \@INC, this section\n|
651 .qq|# will be repeated redundantly when you re-create this\n|
652 .qq|# file again via Loader! See skip_load_external to disable\n|
653 .qq|# this feature.\n|
656 $self->_ext_stmt($class, $code);
657 $self->_ext_stmt($class,
658 qq|# End of lines loaded from '$real_inc_path' |
662 if ($old_real_inc_path) {
663 open(my $fh, '<', $old_real_inc_path)
664 or croak "Failed to open '$old_real_inc_path' for reading: $!";
665 $self->_ext_stmt($class, <<"EOF");
667 # These lines were loaded from '$old_real_inc_path',
668 # based on the Result class name that would have been created by an 0.04006
669 # version of the Loader. For a static schema, this happens only once during
670 # upgrade. See skip_load_external to disable this feature.
674 local ($/, @ARGV) = (undef, $old_real_inc_path); <>
676 $code = $self->_rewrite_old_classnames($code);
678 if ($self->dynamic) {
681 Detected external content in '$old_real_inc_path', a class name that would have
682 been used by an 0.04006 version of the Loader.
684 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
685 new name of the Result.
687 # kill redefined warnings
688 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
689 local $SIG{__WARN__} = sub {
691 unless $_[0] =~ /^Subroutine \S+ redefined/;
698 $self->_ext_stmt($class, $code);
699 $self->_ext_stmt($class,
700 qq|# End of lines loaded from '$old_real_inc_path' |
707 Does the actual schema-construction work.
714 $self->_load_tables($self->_tables_list);
721 Rescan the database for newly added tables. Does
722 not process drops or changes. Returns a list of
723 the newly added table monikers.
725 The schema argument should be the schema class
726 or object to be affected. It should probably
727 be derived from the original schema_class used
733 my ($self, $schema) = @_;
735 $self->{schema} = $schema;
736 $self->_relbuilder->{schema} = $schema;
739 my @current = $self->_tables_list;
740 foreach my $table ($self->_tables_list) {
741 if(!exists $self->{_tables}->{$table}) {
742 push(@created, $table);
746 my $loaded = $self->_load_tables(@created);
748 return map { $self->monikers->{$_} } @$loaded;
752 no warnings 'uninitialized';
755 return if $self->{skip_relationships};
757 if ($self->naming->{relationships} eq 'v4') {
758 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
759 return $self->{relbuilder} ||=
760 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
761 $self->schema, $self->inflect_plural, $self->inflect_singular
765 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
767 $self->inflect_plural,
768 $self->inflect_singular,
769 $self->relationship_attrs,
774 my ($self, @tables) = @_;
776 # First, use _tables_list with constraint and exclude
777 # to get a list of tables to operate on
779 my $constraint = $self->constraint;
780 my $exclude = $self->exclude;
782 @tables = grep { /$constraint/ } @tables if $constraint;
783 @tables = grep { ! /$exclude/ } @tables if $exclude;
785 # Save the new tables to the tables list
787 $self->{_tables}->{$_} = 1;
790 $self->_make_src_class($_) for @tables;
791 $self->_setup_src_meta($_) for @tables;
793 if(!$self->skip_relationships) {
794 # The relationship loader needs a working schema
796 local $self->{dump_directory} = $self->{temp_directory};
797 $self->_reload_classes(\@tables);
798 $self->_load_relationships($_) for @tables;
801 # Remove that temp dir from INC so it doesn't get reloaded
802 @INC = grep $_ ne $self->dump_directory, @INC;
805 $self->_load_external($_)
806 for map { $self->classes->{$_} } @tables;
808 # Reload without unloading first to preserve any symbols from external
810 $self->_reload_classes(\@tables, 0);
812 # Drop temporary cache
813 delete $self->{_cache};
818 sub _reload_classes {
819 my ($self, $tables, $unload) = @_;
821 my @tables = @$tables;
822 $unload = 1 unless defined $unload;
824 # so that we don't repeat custom sections
825 @INC = grep $_ ne $self->dump_directory, @INC;
827 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
829 unshift @INC, $self->dump_directory;
832 my %have_source = map { $_ => $self->schema->source($_) }
833 $self->schema->sources;
835 for my $table (@tables) {
836 my $moniker = $self->monikers->{$table};
837 my $class = $self->classes->{$table};
840 no warnings 'redefine';
841 local *Class::C3::reinitialize = sub {};
844 Class::Unload->unload($class) if $unload;
845 my ($source, $resultset_class);
847 ($source = $have_source{$moniker})
848 && ($resultset_class = $source->resultset_class)
849 && ($resultset_class ne 'DBIx::Class::ResultSet')
851 my $has_file = Class::Inspector->loaded_filename($resultset_class);
852 Class::Unload->unload($resultset_class) if $unload;
853 $self->_reload_class($resultset_class) if $has_file;
855 $self->_reload_class($class);
857 push @to_register, [$moniker, $class];
860 Class::C3->reinitialize;
862 $self->schema->register_class(@$_);
866 # We use this instead of ensure_class_loaded when there are package symbols we
869 my ($self, $class) = @_;
871 my $class_path = $self->_class_path($class);
872 delete $INC{ $class_path };
874 # kill redefined warnings
875 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
876 local $SIG{__WARN__} = sub {
878 unless $_[0] =~ /^Subroutine \S+ redefined/;
880 eval "require $class;";
883 sub _get_dump_filename {
884 my ($self, $class) = (@_);
887 return $self->dump_directory . q{/} . $class . q{.pm};
890 sub _ensure_dump_subdirs {
891 my ($self, $class) = (@_);
893 my @name_parts = split(/::/, $class);
894 pop @name_parts; # we don't care about the very last element,
895 # which is a filename
897 my $dir = $self->dump_directory;
900 mkdir($dir) or croak "mkdir('$dir') failed: $!";
902 last if !@name_parts;
903 $dir = File::Spec->catdir($dir, shift @name_parts);
908 my ($self, @classes) = @_;
910 my $schema_class = $self->schema_class;
911 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
913 my $target_dir = $self->dump_directory;
914 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
915 unless $self->{dynamic} or $self->{quiet};
918 qq|package $schema_class;\n\n|
919 . qq|# Created by DBIx::Class::Schema::Loader\n|
920 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
921 . qq|use strict;\nuse warnings;\n\n|
922 . qq|use base '$schema_base_class';\n\n|;
924 if ($self->use_namespaces) {
925 $schema_text .= qq|__PACKAGE__->load_namespaces|;
926 my $namespace_options;
927 for my $attr (qw(result_namespace
929 default_resultset_class)) {
931 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
934 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
935 $schema_text .= qq|;\n|;
938 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
942 local $self->{version_to_dump} = $self->schema_version_to_dump;
943 $self->_write_classfile($schema_class, $schema_text, 1);
946 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
948 foreach my $src_class (@classes) {
950 qq|package $src_class;\n\n|
951 . qq|# Created by DBIx::Class::Schema::Loader\n|
952 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
953 . qq|use strict;\nuse warnings;\n\n|
954 . qq|use base '$result_base_class';\n\n|;
956 $self->_write_classfile($src_class, $src_text);
959 # remove Result dir if downgrading from use_namespaces, and there are no
961 if (my $result_ns = $self->_downgrading_to_load_classes
962 || $self->_rewriting_result_namespace) {
963 my $result_namespace = $self->_result_namespace(
968 (my $result_dir = $result_namespace) =~ s{::}{/}g;
969 $result_dir = $self->dump_directory . '/' . $result_dir;
971 unless (my @files = glob "$result_dir/*") {
976 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
981 my ($self, $version, $ts) = @_;
982 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
985 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
988 sub _write_classfile {
989 my ($self, $class, $text, $is_schema) = @_;
991 my $filename = $self->_get_dump_filename($class);
992 $self->_ensure_dump_subdirs($class);
994 if (-f $filename && $self->really_erase_my_files) {
995 warn "Deleting existing file '$filename' due to "
996 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1000 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1002 if (my $old_class = $self->_upgrading_classes->{$class}) {
1003 my $old_filename = $self->_get_dump_filename($old_class);
1005 my ($old_custom_content) = $self->_get_custom_content(
1006 $old_class, $old_filename, 0 # do not add default comment
1009 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1011 if ($old_custom_content) {
1013 "\n" . $old_custom_content . "\n" . $custom_content;
1016 unlink $old_filename;
1019 $custom_content = $self->_rewrite_old_classnames($custom_content);
1022 for @{$self->{_dump_storage}->{$class} || []};
1024 # Check and see if the dump is infact differnt
1028 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1031 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1032 return unless $self->_upgrading_from && $is_schema;
1036 $text .= $self->_sig_comment(
1037 $self->version_to_dump,
1038 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1041 open(my $fh, '>', $filename)
1042 or croak "Cannot open '$filename' for writing: $!";
1044 # Write the top half and its MD5 sum
1045 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1047 # Write out anything loaded via external partial class file in @INC
1049 for @{$self->{_ext_storage}->{$class} || []};
1051 # Write out any custom content the user has added
1052 print $fh $custom_content;
1055 or croak "Error closing '$filename': $!";
1058 sub _default_custom_content {
1059 return qq|\n\n# You can replace this text with custom|
1060 . qq| content, and it will be preserved on regeneration|
1064 sub _get_custom_content {
1065 my ($self, $class, $filename, $add_default) = @_;
1067 $add_default = 1 unless defined $add_default;
1069 return ($self->_default_custom_content) if ! -f $filename;
1071 open(my $fh, '<', $filename)
1072 or croak "Cannot open '$filename' for reading: $!";
1075 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1078 my ($md5, $ts, $ver);
1080 if(!$md5 && /$mark_re/) {
1084 # Pull out the previous version and timestamp
1085 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1088 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"
1089 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1098 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1099 . " it does not appear to have been generated by Loader"
1102 # Default custom content:
1103 $buffer ||= $self->_default_custom_content if $add_default;
1105 return ($buffer, $md5, $ver, $ts);
1113 warn "$target: use $_;" if $self->debug;
1114 $self->_raw_stmt($target, "use $_;");
1121 my $schema_class = $self->schema_class;
1123 my $blist = join(q{ }, @_);
1124 warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1125 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1128 sub _result_namespace {
1129 my ($self, $schema_class, $ns) = @_;
1130 my @result_namespace;
1132 if ($ns =~ /^\+(.*)/) {
1133 # Fully qualified namespace
1134 @result_namespace = ($1)
1137 # Relative namespace
1138 @result_namespace = ($schema_class, $ns);
1141 return wantarray ? @result_namespace : join '::', @result_namespace;
1144 # Create class with applicable bases, setup monikers, etc
1145 sub _make_src_class {
1146 my ($self, $table) = @_;
1148 my $schema = $self->schema;
1149 my $schema_class = $self->schema_class;
1151 my $table_moniker = $self->_table2moniker($table);
1152 my @result_namespace = ($schema_class);
1153 if ($self->use_namespaces) {
1154 my $result_namespace = $self->result_namespace || 'Result';
1155 @result_namespace = $self->_result_namespace(
1160 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1162 if ((my $upgrading_v = $self->_upgrading_from)
1163 || $self->_rewriting) {
1164 local $self->naming->{monikers} = $upgrading_v
1167 my @result_namespace = @result_namespace;
1168 if ($self->_upgrading_from_load_classes) {
1169 @result_namespace = ($schema_class);
1171 elsif (my $ns = $self->_downgrading_to_load_classes) {
1172 @result_namespace = $self->_result_namespace(
1177 elsif ($ns = $self->_rewriting_result_namespace) {
1178 @result_namespace = $self->_result_namespace(
1184 my $old_class = join(q{::}, @result_namespace,
1185 $self->_table2moniker($table));
1187 $self->_upgrading_classes->{$table_class} = $old_class
1188 unless $table_class eq $old_class;
1191 my $table_normalized = lc $table;
1192 $self->classes->{$table} = $table_class;
1193 $self->classes->{$table_normalized} = $table_class;
1194 $self->monikers->{$table} = $table_moniker;
1195 $self->monikers->{$table_normalized} = $table_moniker;
1197 $self->_use ($table_class, @{$self->additional_classes});
1198 $self->_inject($table_class, @{$self->left_base_classes});
1200 if (my @components = @{ $self->components }) {
1201 $self->_dbic_stmt($table_class, 'load_components', @components);
1204 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1205 if @{$self->resultset_components};
1206 $self->_inject($table_class, @{$self->additional_base_classes});
1209 # Set up metadata (cols, pks, etc)
1210 sub _setup_src_meta {
1211 my ($self, $table) = @_;
1213 my $schema = $self->schema;
1214 my $schema_class = $self->schema_class;
1216 my $table_class = $self->classes->{$table};
1217 my $table_moniker = $self->monikers->{$table};
1219 my $table_name = $table;
1220 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1222 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1223 $table_name = \ $self->_quote_table_name($table_name);
1226 $self->_dbic_stmt($table_class,'table',$table_name);
1228 my $cols = $self->_table_columns($table);
1230 eval { $col_info = $self->_columns_info_for($table) };
1232 $self->_dbic_stmt($table_class,'add_columns',@$cols);
1235 if ($self->_is_case_sensitive) {
1236 for my $col (keys %$col_info) {
1237 $col_info->{$col}{accessor} = lc $col
1238 if $col ne lc($col);
1241 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1244 my $fks = $self->_table_fk_info($table);
1246 for my $fkdef (@$fks) {
1247 for my $col (@{ $fkdef->{local_columns} }) {
1248 $col_info->{$col}{is_foreign_key} = 1;
1254 map { $_, ($col_info->{$_}||{}) } @$cols
1258 my %uniq_tag; # used to eliminate duplicate uniqs
1260 my $pks = $self->_table_pk_info($table) || [];
1261 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1262 : carp("$table has no primary key");
1263 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1265 my $uniqs = $self->_table_uniq_info($table) || [];
1267 my ($name, $cols) = @$_;
1268 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1269 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1276 Returns a sorted list of loaded tables, using the original database table
1284 return keys %{$self->_tables};
1287 # Make a moniker from a table
1288 sub _default_table2moniker {
1289 no warnings 'uninitialized';
1290 my ($self, $table) = @_;
1292 if ($self->naming->{monikers} eq 'v4') {
1293 return join '', map ucfirst, split /[\W_]+/, lc $table;
1296 return join '', map ucfirst, split /[\W_]+/,
1297 Lingua::EN::Inflect::Number::to_S(lc $table);
1300 sub _table2moniker {
1301 my ( $self, $table ) = @_;
1305 if( ref $self->moniker_map eq 'HASH' ) {
1306 $moniker = $self->moniker_map->{$table};
1308 elsif( ref $self->moniker_map eq 'CODE' ) {
1309 $moniker = $self->moniker_map->($table);
1312 $moniker ||= $self->_default_table2moniker($table);
1317 sub _load_relationships {
1318 my ($self, $table) = @_;
1320 my $tbl_fk_info = $self->_table_fk_info($table);
1321 foreach my $fkdef (@$tbl_fk_info) {
1322 $fkdef->{remote_source} =
1323 $self->monikers->{delete $fkdef->{remote_table}};
1325 my $tbl_uniq_info = $self->_table_uniq_info($table);
1327 my $local_moniker = $self->monikers->{$table};
1328 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1330 foreach my $src_class (sort keys %$rel_stmts) {
1331 my $src_stmts = $rel_stmts->{$src_class};
1332 foreach my $stmt (@$src_stmts) {
1333 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1338 # Overload these in driver class:
1340 # Returns an arrayref of column names
1341 sub _table_columns { croak "ABSTRACT METHOD" }
1343 # Returns arrayref of pk col names
1344 sub _table_pk_info { croak "ABSTRACT METHOD" }
1346 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1347 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1349 # Returns an arrayref of foreign key constraints, each
1350 # being a hashref with 3 keys:
1351 # local_columns (arrayref), remote_columns (arrayref), remote_table
1352 sub _table_fk_info { croak "ABSTRACT METHOD" }
1354 # Returns an array of lower case table names
1355 sub _tables_list { croak "ABSTRACT METHOD" }
1357 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1363 # generate the pod for this statement, storing it with $self->_pod
1364 $self->_make_pod( $class, $method, @_ );
1366 my $args = dump(@_);
1367 $args = '(' . $args . ')' if @_ < 2;
1368 my $stmt = $method . $args . q{;};
1370 warn qq|$class\->$stmt\n| if $self->debug;
1371 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1375 # generates the accompanying pod for a DBIC class method statement,
1376 # storing it with $self->_pod
1382 if ( $method eq 'table' ) {
1384 $self->_pod( $class, "=head1 NAME" );
1385 my $table_descr = $class;
1386 if ( $self->can('_table_comment') ) {
1387 my $comment = $self->_table_comment($table);
1388 $table_descr .= " - " . $comment if $comment;
1390 $self->{_class2table}{ $class } = $table;
1391 $self->_pod( $class, $table_descr );
1392 $self->_pod_cut( $class );
1393 } elsif ( $method eq 'add_columns' ) {
1394 $self->_pod( $class, "=head1 ACCESSORS" );
1395 my $col_counter = 0;
1397 while( my ($name,$attrs) = splice @cols,0,2 ) {
1399 $self->_pod( $class, '=head2 ' . $name );
1400 $self->_pod( $class,
1402 my $s = $attrs->{$_};
1403 $s = !defined $s ? 'undef' :
1404 length($s) == 0 ? '(empty string)' :
1408 } sort keys %$attrs,
1411 if( $self->can('_column_comment')
1412 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1414 $self->_pod( $class, $comment );
1417 $self->_pod_cut( $class );
1418 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1419 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1420 my ( $accessor, $rel_class ) = @_;
1421 $self->_pod( $class, "=head2 $accessor" );
1422 $self->_pod( $class, 'Type: ' . $method );
1423 $self->_pod( $class, "Related object: L<$rel_class>" );
1424 $self->_pod_cut( $class );
1425 $self->{_relations_started} { $class } = 1;
1429 # Stores a POD documentation
1431 my ($self, $class, $stmt) = @_;
1432 $self->_raw_stmt( $class, "\n" . $stmt );
1436 my ($self, $class ) = @_;
1437 $self->_raw_stmt( $class, "\n=cut\n" );
1441 # Store a raw source line for a class (for dumping purposes)
1443 my ($self, $class, $stmt) = @_;
1444 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1447 # Like above, but separately for the externally loaded stuff
1449 my ($self, $class, $stmt) = @_;
1450 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1453 sub _quote_table_name {
1454 my ($self, $table) = @_;
1456 my $qt = $self->schema->storage->sql_maker->quote_char;
1458 return $table unless $qt;
1461 return $qt->[0] . $table . $qt->[1];
1464 return $qt . $table . $qt;
1467 sub _is_case_sensitive { 0 }
1469 # remove the dump dir from @INC on destruction
1473 @INC = grep $_ ne $self->dump_directory, @INC;
1478 Returns a hashref of loaded table to moniker mappings. There will
1479 be two entries for each table, the original name and the "normalized"
1480 name, in the case that the two are different (such as databases
1481 that like uppercase table names, or preserve your original mixed-case
1482 definitions, or what-have-you).
1486 Returns a hashref of table to class mappings. In some cases it will
1487 contain multiple entries per table for the original and normalized table
1488 names, as above in L</monikers>.
1492 L<DBIx::Class::Schema::Loader>
1496 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1500 This library is free software; you can redistribute it and/or modify it under
1501 the same terms as Perl itself.