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 Data::Dumper::Concise;
20 use Scalar::Util 'looks_like_number';
21 use File::Slurp 'slurp';
22 use DBIx::Class::Schema::Loader::Utils 'split_name';
26 our $VERSION = '0.07001';
28 __PACKAGE__->mk_group_ro_accessors('simple', qw/
35 additional_base_classes
50 default_resultset_class
54 overwrite_modifications
73 __PACKAGE__->mk_group_accessors('simple', qw/
75 schema_version_to_dump
77 _upgrading_from_load_classes
78 _downgrading_to_load_classes
79 _rewriting_result_namespace
84 pod_comment_spillover_length
90 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
94 See L<DBIx::Class::Schema::Loader>
98 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
99 classes, and implements the common functionality between them.
101 =head1 CONSTRUCTOR OPTIONS
103 These constructor options are the base options for
104 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
106 =head2 skip_relationships
108 Skip setting up relationships. The default is to attempt the loading
111 =head2 skip_load_external
113 Skip loading of other classes in @INC. The default is to merge all other classes
114 with the same name found in @INC into the schema file we are creating.
118 Static schemas (ones dumped to disk) will, by default, use the new-style
119 relationship names and singularized Results, unless you're overwriting an
120 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
121 which case the backward compatible RelBuilder will be activated, and the
122 appropriate monikerization used.
128 will disable the backward-compatible RelBuilder and use
129 the new-style relationship names along with singularized Results, even when
130 overwriting a dump made with an earlier version.
132 The option also takes a hashref:
134 naming => { relationships => 'v7', monikers => 'v7' }
142 How to name relationship accessors.
146 How to name Result classes.
148 =item column_accessors
150 How to name column accessors in Result classes.
160 Latest style, whatever that happens to be.
164 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
168 Monikers singularized as whole words, C<might_have> relationships for FKs on
169 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
171 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
176 All monikers and relationships are inflected using
177 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
178 from relationship names.
180 In general, there is very little difference between v5 and v6 schemas.
184 This mode is identical to C<v6> mode, except that monikerization of CamelCase
185 table names is also done correctly.
187 CamelCase column names in case-preserving mode will also be handled correctly
188 for relationship name inflection. See L</preserve_case>.
190 In this mode, CamelCase L</column_accessors> are normalized based on case
191 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
193 If you don't have any CamelCase table or column names, you can upgrade without
194 breaking any of your code.
198 Dynamic schemas will always default to the 0.04XXX relationship names and won't
199 singularize Results for backward compatibility, to activate the new RelBuilder
200 and singularization put this in your C<Schema.pm> file:
202 __PACKAGE__->naming('current');
204 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
205 next major version upgrade:
207 __PACKAGE__->naming('v7');
211 By default POD will be generated for columns and relationships, using database
212 metadata for the text if available and supported.
214 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
215 supported for Postgres right now.
217 Set this to C<0> to turn off all POD generation.
219 =head2 pod_comment_mode
221 Controls where table comments appear in the generated POD. Smaller table
222 comments are appended to the C<NAME> section of the documentation, and larger
223 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
224 section to be generated with the comment always, only use C<NAME>, or choose
225 the length threshold at which the comment is forced into the description.
231 Use C<NAME> section only.
235 Force C<DESCRIPTION> always.
239 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
244 =head2 pod_comment_spillover_length
246 When pod_comment_mode is set to C<auto>, this is the length of the comment at
247 which it will be forced into a separate description section.
251 =head2 relationship_attrs
253 Hashref of attributes to pass to each generated relationship, listed
254 by type. Also supports relationship type 'all', containing options to
255 pass to all generated relationships. Attributes set for more specific
256 relationship types override those set in 'all'.
260 relationship_attrs => {
261 belongs_to => { is_deferrable => 1 },
264 use this to make your foreign key constraints DEFERRABLE.
268 If set to true, each constructive L<DBIx::Class> statement the loader
269 decides to execute will be C<warn>-ed before execution.
273 Set the name of the schema to load (schema in the sense that your database
274 vendor means it). Does not currently support loading more than one schema
279 Only load tables matching regex. Best specified as a qr// regex.
283 Exclude tables matching regex. Best specified as a qr// regex.
287 Overrides the default table name to moniker translation. Can be either
288 a hashref of table keys and moniker values, or a coderef for a translator
289 function taking a single scalar table name argument and returning
290 a scalar moniker. If the hash entry does not exist, or the function
291 returns a false value, the code falls back to default behavior
294 The default behavior is to split on case transition and non-alphanumeric
295 boundaries, singularize the resulting phrase, then join the titlecased words
298 Table Name | Moniker Name
299 ---------------------------------
301 luser_group | LuserGroup
302 luser-opts | LuserOpt
303 stations_visited | StationVisited
304 routeChange | RouteChange
306 =head2 inflect_plural
308 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
309 if hash key does not exist or coderef returns false), but acts as a map
310 for pluralizing relationship names. The default behavior is to utilize
311 L<Lingua::EN::Inflect::Number/to_PL>.
313 =head2 inflect_singular
315 As L</inflect_plural> above, but for singularizing relationship names.
316 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
318 =head2 schema_base_class
320 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
322 =head2 result_base_class
324 Base class for your table classes (aka result classes). Defaults to
327 =head2 additional_base_classes
329 List of additional base classes all of your table classes will use.
331 =head2 left_base_classes
333 List of additional base classes all of your table classes will use
334 that need to be leftmost.
336 =head2 additional_classes
338 List of additional classes which all of your table classes will use.
342 List of additional components to be loaded into all of your table
343 classes. A good example would be
344 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
346 =head2 resultset_components
348 List of additional ResultSet components to be loaded into your table
349 classes. A good example would be C<AlwaysRS>. Component
350 C<ResultSetManager> will be automatically added to the above
351 C<components> list if this option is set.
353 =head2 use_namespaces
355 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
358 Generate result class names suitable for
359 L<DBIx::Class::Schema/load_namespaces> and call that instead of
360 L<DBIx::Class::Schema/load_classes>. When using this option you can also
361 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
362 C<resultset_namespace>, C<default_resultset_class>), and they will be added
363 to the call (and the generated result class names adjusted appropriately).
365 =head2 dump_directory
367 This option is designed to be a tool to help you transition from this
368 loader to a manually-defined schema when you decide it's time to do so.
370 The value of this option is a perl libdir pathname. Within
371 that directory this module will create a baseline manual
372 L<DBIx::Class::Schema> module set, based on what it creates at runtime
375 The created schema class will have the same classname as the one on
376 which you are setting this option (and the ResultSource classes will be
377 based on this name as well).
379 Normally you wouldn't hard-code this setting in your schema class, as it
380 is meant for one-time manual usage.
382 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
383 recommended way to access this functionality.
385 =head2 dump_overwrite
387 Deprecated. See L</really_erase_my_files> below, which does *not* mean
388 the same thing as the old C<dump_overwrite> setting from previous releases.
390 =head2 really_erase_my_files
392 Default false. If true, Loader will unconditionally delete any existing
393 files before creating the new ones from scratch when dumping a schema to disk.
395 The default behavior is instead to only replace the top portion of the
396 file, up to and including the final stanza which contains
397 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
398 leaving any customizations you placed after that as they were.
400 When C<really_erase_my_files> is not set, if the output file already exists,
401 but the aforementioned final stanza is not found, or the checksum
402 contained there does not match the generated contents, Loader will
403 croak and not touch the file.
405 You should really be using version control on your schema classes (and all
406 of the rest of your code for that matter). Don't blame me if a bug in this
407 code wipes something out when it shouldn't have, you've been warned.
409 =head2 overwrite_modifications
411 Default false. If false, when updating existing files, Loader will
412 refuse to modify any Loader-generated code that has been modified
413 since its last run (as determined by the checksum Loader put in its
416 If true, Loader will discard any manual modifications that have been
417 made to Loader-generated code.
419 Again, you should be using version control on your schema classes. Be
420 careful with this option.
422 =head2 custom_column_info
424 Hook for adding extra attributes to the
425 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
427 Must be a coderef that returns a hashref with the extra attributes.
429 Receives the table name, column name and column_info.
433 custom_column_info => sub {
434 my ($table_name, $column_name, $column_info) = @_;
436 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
437 return { is_snoopy => 1 };
441 This attribute can also be used to set C<inflate_datetime> on a non-datetime
442 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
444 =head2 datetime_timezone
446 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
447 columns with the DATE/DATETIME/TIMESTAMP data_types.
449 =head2 datetime_locale
451 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
452 columns with the DATE/DATETIME/TIMESTAMP data_types.
456 File in Perl format, which should return a HASH reference, from which to read
461 Usually column names are lowercased, to make them easier to work with in
462 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
465 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
466 case-sensitive collation will turn this option on unconditionally.
468 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
471 =head2 qualify_objects
473 Set to true to prepend the L</db_schema> to table names for C<<
474 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
478 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
479 L<namespace::autoclean>. The default content after the md5 sum also makes the
482 It is safe to upgrade your existing Schema to this option.
486 None of these methods are intended for direct invocation by regular
487 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
488 L<DBIx::Class::Schema::Loader>.
492 my $CURRENT_V = 'v7';
495 schema_base_class result_base_class additional_base_classes
496 left_base_classes additional_classes components resultset_components
499 # ensure that a peice of object data is a valid arrayref, creating
500 # an empty one or encapsulating whatever's there.
501 sub _ensure_arrayref {
506 $self->{$_} = [ $self->{$_} ]
507 unless ref $self->{$_} eq 'ARRAY';
513 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
514 by L<DBIx::Class::Schema::Loader>.
519 my ( $class, %args ) = @_;
521 my $self = { %args };
523 bless $self => $class;
525 if (my $config_file = $self->config_file) {
526 my $config_opts = do $config_file;
528 croak "Error reading config from $config_file: $@" if $@;
530 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
532 while (my ($k, $v) = each %$config_opts) {
533 $self->{$k} = $v unless exists $self->{$k};
537 $self->_ensure_arrayref(qw/additional_classes
538 additional_base_classes
544 $self->_validate_class_args;
546 if ($self->use_moose) {
549 require MooseX::NonMoose;
550 require namespace::autoclean;
553 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
554 "Moose, MooseX::NonMoose and namespace::autoclean";
558 push(@{$self->{components}}, 'ResultSetManager')
559 if @{$self->{resultset_components}};
561 $self->{monikers} = {};
562 $self->{classes} = {};
563 $self->{_upgrading_classes} = {};
565 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
566 $self->{schema} ||= $self->{schema_class};
568 croak "dump_overwrite is deprecated. Please read the"
569 . " DBIx::Class::Schema::Loader::Base documentation"
570 if $self->{dump_overwrite};
572 $self->{dynamic} = ! $self->{dump_directory};
573 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
578 $self->{dump_directory} ||= $self->{temp_directory};
580 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
581 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
583 if ((not ref $self->naming) && defined $self->naming) {
584 my $naming_ver = $self->naming;
586 relationships => $naming_ver,
587 monikers => $naming_ver,
588 column_accessors => $naming_ver,
593 for (values %{ $self->naming }) {
594 $_ = $CURRENT_V if $_ eq 'current';
597 $self->{naming} ||= {};
599 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
600 croak 'custom_column_info must be a CODE ref';
603 $self->_check_back_compat;
605 $self->use_namespaces(1) unless defined $self->use_namespaces;
606 $self->generate_pod(1) unless defined $self->generate_pod;
607 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
608 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
613 sub _check_back_compat {
616 # dynamic schemas will always be in 0.04006 mode, unless overridden
617 if ($self->dynamic) {
618 # just in case, though no one is likely to dump a dynamic schema
619 $self->schema_version_to_dump('0.04006');
621 if (not %{ $self->naming }) {
622 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
624 Dynamic schema detected, will run in 0.04006 mode.
626 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
627 to disable this warning.
629 Also consider setting 'use_namespaces => 1' if/when upgrading.
631 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
636 $self->_upgrading_from('v4');
639 $self->naming->{relationships} ||= 'v4';
640 $self->naming->{monikers} ||= 'v4';
642 if ($self->use_namespaces) {
643 $self->_upgrading_from_load_classes(1);
646 $self->use_namespaces(0);
652 # otherwise check if we need backcompat mode for a static schema
653 my $filename = $self->_get_dump_filename($self->schema_class);
654 return unless -e $filename;
656 open(my $fh, '<', $filename)
657 or croak "Cannot open '$filename' for reading: $!";
659 my $load_classes = 0;
660 my $result_namespace = '';
663 if (/^__PACKAGE__->load_classes;/) {
665 } elsif (/result_namespace => '([^']+)'/) {
666 $result_namespace = $1;
667 } elsif (my ($real_ver) =
668 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
670 if ($load_classes && (not defined $self->use_namespaces)) {
671 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
673 'load_classes;' static schema detected, turning off 'use_namespaces'.
675 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
676 variable to disable this warning.
678 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
681 $self->use_namespaces(0);
683 elsif ($load_classes && $self->use_namespaces) {
684 $self->_upgrading_from_load_classes(1);
686 elsif ((not $load_classes) && defined $self->use_namespaces
687 && (not $self->use_namespaces)) {
688 $self->_downgrading_to_load_classes(
689 $result_namespace || 'Result'
692 elsif ((not defined $self->use_namespaces)
693 || $self->use_namespaces) {
694 if (not $self->result_namespace) {
695 $self->result_namespace($result_namespace || 'Result');
697 elsif ($result_namespace ne $self->result_namespace) {
698 $self->_rewriting_result_namespace(
699 $result_namespace || 'Result'
704 # XXX when we go past .0 this will need fixing
705 my ($v) = $real_ver =~ /([1-9])/;
708 last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
710 if (not %{ $self->naming }) {
711 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
713 Version $real_ver static schema detected, turning on backcompat mode.
715 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
716 to disable this warning.
718 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
720 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
721 from version 0.04006.
725 $self->_upgrading_from($v);
729 $self->naming->{relationships} ||= $v;
730 $self->naming->{monikers} ||= $v;
731 $self->naming->{column_accessors} ||= $v;
733 $self->schema_version_to_dump($real_ver);
741 sub _validate_class_args {
745 foreach my $k (@CLASS_ARGS) {
746 next unless $self->$k;
748 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
749 foreach my $c (@classes) {
750 # components default to being under the DBIx::Class namespace unless they
751 # are preceeded with a '+'
752 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
753 $c = 'DBIx::Class::' . $c;
756 # 1 == installed, 0 == not installed, undef == invalid classname
757 my $installed = Class::Inspector->installed($c);
758 if ( defined($installed) ) {
759 if ( $installed == 0 ) {
760 croak qq/$c, as specified in the loader option "$k", is not installed/;
763 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
769 sub _find_file_in_inc {
770 my ($self, $file) = @_;
772 foreach my $prefix (@INC) {
773 my $fullpath = File::Spec->catfile($prefix, $file);
774 return $fullpath if -f $fullpath
775 # abs_path throws on Windows for nonexistant files
776 and eval { Cwd::abs_path($fullpath) } ne
777 (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
784 my ($self, $class) = @_;
786 my $class_path = $class;
787 $class_path =~ s{::}{/}g;
788 $class_path .= '.pm';
793 sub _find_class_in_inc {
794 my ($self, $class) = @_;
796 return $self->_find_file_in_inc($self->_class_path($class));
802 return $self->_upgrading_from
803 || $self->_upgrading_from_load_classes
804 || $self->_downgrading_to_load_classes
805 || $self->_rewriting_result_namespace
809 sub _rewrite_old_classnames {
810 my ($self, $code) = @_;
812 return $code unless $self->_rewriting;
814 my %old_classes = reverse %{ $self->_upgrading_classes };
816 my $re = join '|', keys %old_classes;
819 $code =~ s/$re/$old_classes{$1} || $1/eg;
825 my ($self, $class) = @_;
827 return if $self->{skip_load_external};
829 # so that we don't load our own classes, under any circumstances
830 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
832 my $real_inc_path = $self->_find_class_in_inc($class);
834 my $old_class = $self->_upgrading_classes->{$class}
835 if $self->_rewriting;
837 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
838 if $old_class && $old_class ne $class;
840 return unless $real_inc_path || $old_real_inc_path;
842 if ($real_inc_path) {
843 # If we make it to here, we loaded an external definition
844 warn qq/# Loaded external class definition for '$class'\n/
847 open(my $fh, '<', $real_inc_path)
848 or croak "Failed to open '$real_inc_path' for reading: $!";
849 my $code = do { local $/; <$fh> };
851 or croak "Failed to close $real_inc_path: $!";
852 $code = $self->_rewrite_old_classnames($code);
854 if ($self->dynamic) { # load the class too
855 # kill redefined warnings
856 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
857 local $SIG{__WARN__} = sub {
859 unless $_[0] =~ /^Subroutine \S+ redefined/;
865 $self->_ext_stmt($class,
866 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
867 .qq|# They are now part of the custom portion of this file\n|
868 .qq|# for you to hand-edit. If you do not either delete\n|
869 .qq|# this section or remove that file from \@INC, this section\n|
870 .qq|# will be repeated redundantly when you re-create this\n|
871 .qq|# file again via Loader! See skip_load_external to disable\n|
872 .qq|# this feature.\n|
875 $self->_ext_stmt($class, $code);
876 $self->_ext_stmt($class,
877 qq|# End of lines loaded from '$real_inc_path' |
881 if ($old_real_inc_path) {
882 my $code = slurp $old_real_inc_path;
884 $self->_ext_stmt($class, <<"EOF");
886 # These lines were loaded from '$old_real_inc_path',
887 # based on the Result class name that would have been created by an older
888 # version of the Loader. For a static schema, this happens only once during
889 # upgrade. See skip_load_external to disable this feature.
892 $code = $self->_rewrite_old_classnames($code);
894 if ($self->dynamic) {
897 Detected external content in '$old_real_inc_path', a class name that would have
898 been used by an older version of the Loader.
900 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
901 new name of the Result.
903 # kill redefined warnings
904 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
905 local $SIG{__WARN__} = sub {
907 unless $_[0] =~ /^Subroutine \S+ redefined/;
914 $self->_ext_stmt($class, $code);
915 $self->_ext_stmt($class,
916 qq|# End of lines loaded from '$old_real_inc_path' |
923 Does the actual schema-construction work.
931 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
939 Rescan the database for changes. Returns a list of the newly added table
942 The schema argument should be the schema class or object to be affected. It
943 should probably be derived from the original schema_class used during L</load>.
948 my ($self, $schema) = @_;
950 $self->{schema} = $schema;
951 $self->_relbuilder->{schema} = $schema;
954 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
956 foreach my $table (@current) {
957 if(!exists $self->{_tables}->{$table}) {
958 push(@created, $table);
963 @current{@current} = ();
964 foreach my $table (keys %{ $self->{_tables} }) {
965 if (not exists $current{$table}) {
966 $self->_unregister_source_for_table($table);
970 delete $self->{_dump_storage};
971 delete $self->{_relations_started};
973 my $loaded = $self->_load_tables(@current);
975 return map { $self->monikers->{$_} } @created;
979 no warnings 'uninitialized';
982 return if $self->{skip_relationships};
984 if ($self->naming->{relationships} eq 'v4') {
985 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
986 return $self->{relbuilder} ||=
987 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
989 $self->inflect_plural,
990 $self->inflect_singular,
991 $self->relationship_attrs,
994 elsif ($self->naming->{relationships} eq 'v5') {
995 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
996 return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
998 $self->inflect_plural,
999 $self->inflect_singular,
1000 $self->relationship_attrs,
1003 elsif ($self->naming->{relationships} eq 'v6') {
1004 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
1005 return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
1007 $self->inflect_plural,
1008 $self->inflect_singular,
1009 $self->relationship_attrs,
1013 return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
1015 $self->inflect_plural,
1016 $self->inflect_singular,
1017 $self->relationship_attrs,
1022 my ($self, @tables) = @_;
1024 # Save the new tables to the tables list
1026 $self->{_tables}->{$_} = 1;
1029 $self->_make_src_class($_) for @tables;
1031 # sanity-check for moniker clashes
1032 my $inverse_moniker_idx;
1033 for (keys %{$self->monikers}) {
1034 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1038 for (keys %$inverse_moniker_idx) {
1039 my $tables = $inverse_moniker_idx->{$_};
1041 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1042 join (', ', map { "'$_'" } @$tables),
1049 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1050 . 'Either change the naming style, or supply an explicit moniker_map: '
1051 . join ('; ', @clashes)
1057 $self->_setup_src_meta($_) for @tables;
1059 if(!$self->skip_relationships) {
1060 # The relationship loader needs a working schema
1062 local $self->{dump_directory} = $self->{temp_directory};
1063 $self->_reload_classes(\@tables);
1064 $self->_load_relationships($_) for @tables;
1067 # Remove that temp dir from INC so it doesn't get reloaded
1068 @INC = grep $_ ne $self->dump_directory, @INC;
1071 $self->_load_external($_)
1072 for map { $self->classes->{$_} } @tables;
1074 # Reload without unloading first to preserve any symbols from external
1076 $self->_reload_classes(\@tables, 0);
1078 # Drop temporary cache
1079 delete $self->{_cache};
1084 sub _reload_classes {
1085 my ($self, $tables, $unload) = @_;
1087 my @tables = @$tables;
1088 $unload = 1 unless defined $unload;
1090 # so that we don't repeat custom sections
1091 @INC = grep $_ ne $self->dump_directory, @INC;
1093 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1095 unshift @INC, $self->dump_directory;
1098 my %have_source = map { $_ => $self->schema->source($_) }
1099 $self->schema->sources;
1101 for my $table (@tables) {
1102 my $moniker = $self->monikers->{$table};
1103 my $class = $self->classes->{$table};
1106 no warnings 'redefine';
1107 local *Class::C3::reinitialize = sub {};
1110 if ($class->can('meta') && (ref $class->meta)->isa('Moose::Meta::Class')) {
1111 $class->meta->make_mutable;
1113 Class::Unload->unload($class) if $unload;
1114 my ($source, $resultset_class);
1116 ($source = $have_source{$moniker})
1117 && ($resultset_class = $source->resultset_class)
1118 && ($resultset_class ne 'DBIx::Class::ResultSet')
1120 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1121 if ($resultset_class->can('meta') && (ref $resultset_class->meta)->isa('Moose::Meta::Class')) {
1122 $resultset_class->meta->make_mutable;
1124 Class::Unload->unload($resultset_class) if $unload;
1125 $self->_reload_class($resultset_class) if $has_file;
1127 $self->_reload_class($class);
1129 push @to_register, [$moniker, $class];
1132 Class::C3->reinitialize;
1133 for (@to_register) {
1134 $self->schema->register_class(@$_);
1138 # We use this instead of ensure_class_loaded when there are package symbols we
1141 my ($self, $class) = @_;
1143 my $class_path = $self->_class_path($class);
1144 delete $INC{ $class_path };
1146 # kill redefined warnings
1147 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1148 local $SIG{__WARN__} = sub {
1150 unless $_[0] =~ /^Subroutine \S+ redefined/;
1152 eval "require $class;";
1153 die "Failed to reload class $class: $@" if $@;
1156 sub _get_dump_filename {
1157 my ($self, $class) = (@_);
1159 $class =~ s{::}{/}g;
1160 return $self->dump_directory . q{/} . $class . q{.pm};
1163 sub _ensure_dump_subdirs {
1164 my ($self, $class) = (@_);
1166 my @name_parts = split(/::/, $class);
1167 pop @name_parts; # we don't care about the very last element,
1168 # which is a filename
1170 my $dir = $self->dump_directory;
1173 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1175 last if !@name_parts;
1176 $dir = File::Spec->catdir($dir, shift @name_parts);
1181 my ($self, @classes) = @_;
1183 my $schema_class = $self->schema_class;
1184 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1186 my $target_dir = $self->dump_directory;
1187 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1188 unless $self->{dynamic} or $self->{quiet};
1191 qq|package $schema_class;\n\n|
1192 . qq|# Created by DBIx::Class::Schema::Loader\n|
1193 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1194 . qq|use strict;\nuse warnings;\n\n|;
1195 if ($self->use_moose) {
1196 $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1199 $schema_text .= qq|use base '$schema_base_class';\n\n|;
1202 if ($self->use_namespaces) {
1203 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1204 my $namespace_options;
1206 my @attr = qw/resultset_namespace default_resultset_class/;
1208 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1210 for my $attr (@attr) {
1212 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1215 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1216 $schema_text .= qq|;\n|;
1219 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1223 local $self->{version_to_dump} = $self->schema_version_to_dump;
1224 $self->_write_classfile($schema_class, $schema_text, 1);
1227 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1229 foreach my $src_class (@classes) {
1231 qq|package $src_class;\n\n|
1232 . qq|# Created by DBIx::Class::Schema::Loader\n|
1233 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1234 . qq|use strict;\nuse warnings;\n\n|;
1235 if ($self->use_moose) {
1236 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1238 # these options 'use base' which is compile time
1239 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1240 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1243 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1247 $src_text .= qq|use base '$result_base_class';\n\n|;
1249 $self->_write_classfile($src_class, $src_text);
1252 # remove Result dir if downgrading from use_namespaces, and there are no
1254 if (my $result_ns = $self->_downgrading_to_load_classes
1255 || $self->_rewriting_result_namespace) {
1256 my $result_namespace = $self->_result_namespace(
1261 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1262 $result_dir = $self->dump_directory . '/' . $result_dir;
1264 unless (my @files = glob "$result_dir/*") {
1269 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1274 my ($self, $version, $ts) = @_;
1275 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1278 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1281 sub _write_classfile {
1282 my ($self, $class, $text, $is_schema) = @_;
1284 my $filename = $self->_get_dump_filename($class);
1285 $self->_ensure_dump_subdirs($class);
1287 if (-f $filename && $self->really_erase_my_files) {
1288 warn "Deleting existing file '$filename' due to "
1289 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1293 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1295 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1296 # If there is already custom content, which does not have the Moose content, add it.
1297 if ($self->use_moose) {
1298 local $self->{use_moose} = 0;
1300 if ($custom_content eq $self->_default_custom_content) {
1301 local $self->{use_moose} = 1;
1303 $custom_content = $self->_default_custom_content;
1306 local $self->{use_moose} = 1;
1308 if ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1309 $custom_content .= $self->_default_custom_content;
1314 if (my $old_class = $self->_upgrading_classes->{$class}) {
1315 my $old_filename = $self->_get_dump_filename($old_class);
1317 my ($old_custom_content) = $self->_get_custom_content(
1318 $old_class, $old_filename, 0 # do not add default comment
1321 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1323 if ($old_custom_content) {
1325 "\n" . $old_custom_content . "\n" . $custom_content;
1328 unlink $old_filename;
1331 $custom_content = $self->_rewrite_old_classnames($custom_content);
1334 for @{$self->{_dump_storage}->{$class} || []};
1336 # Check and see if the dump is infact differnt
1340 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1343 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1344 return unless $self->_upgrading_from && $is_schema;
1348 $text .= $self->_sig_comment(
1349 $self->version_to_dump,
1350 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1353 open(my $fh, '>', $filename)
1354 or croak "Cannot open '$filename' for writing: $!";
1356 # Write the top half and its MD5 sum
1357 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1359 # Write out anything loaded via external partial class file in @INC
1361 for @{$self->{_ext_storage}->{$class} || []};
1363 # Write out any custom content the user has added
1364 print $fh $custom_content;
1367 or croak "Error closing '$filename': $!";
1370 sub _default_moose_custom_content {
1371 return qq|\n__PACKAGE__->meta->make_immutable;|;
1374 sub _default_custom_content {
1376 my $default = qq|\n\n# You can replace this text with custom|
1377 . qq| content, and it will be preserved on regeneration|;
1378 if ($self->use_moose) {
1379 $default .= $self->_default_moose_custom_content;
1381 $default .= qq|\n1;\n|;
1385 sub _get_custom_content {
1386 my ($self, $class, $filename, $add_default) = @_;
1388 $add_default = 1 unless defined $add_default;
1390 return ($self->_default_custom_content) if ! -f $filename;
1392 open(my $fh, '<', $filename)
1393 or croak "Cannot open '$filename' for reading: $!";
1396 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1399 my ($md5, $ts, $ver);
1401 if(!$md5 && /$mark_re/) {
1405 # Pull out the previous version and timestamp
1406 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1409 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"
1410 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1419 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1420 . " it does not appear to have been generated by Loader"
1423 # Default custom content:
1424 $buffer ||= $self->_default_custom_content if $add_default;
1426 return ($buffer, $md5, $ver, $ts);
1434 warn "$target: use $_;" if $self->debug;
1435 $self->_raw_stmt($target, "use $_;");
1443 my $blist = join(q{ }, @_);
1445 return unless $blist;
1447 warn "$target: use base qw/$blist/;" if $self->debug;
1448 $self->_raw_stmt($target, "use base qw/$blist/;");
1451 sub _result_namespace {
1452 my ($self, $schema_class, $ns) = @_;
1453 my @result_namespace;
1455 if ($ns =~ /^\+(.*)/) {
1456 # Fully qualified namespace
1457 @result_namespace = ($1)
1460 # Relative namespace
1461 @result_namespace = ($schema_class, $ns);
1464 return wantarray ? @result_namespace : join '::', @result_namespace;
1467 # Create class with applicable bases, setup monikers, etc
1468 sub _make_src_class {
1469 my ($self, $table) = @_;
1471 my $schema = $self->schema;
1472 my $schema_class = $self->schema_class;
1474 my $table_moniker = $self->_table2moniker($table);
1475 my @result_namespace = ($schema_class);
1476 if ($self->use_namespaces) {
1477 my $result_namespace = $self->result_namespace || 'Result';
1478 @result_namespace = $self->_result_namespace(
1483 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1485 if ((my $upgrading_v = $self->_upgrading_from)
1486 || $self->_rewriting) {
1487 local $self->naming->{monikers} = $upgrading_v
1490 my @result_namespace = @result_namespace;
1491 if ($self->_upgrading_from_load_classes) {
1492 @result_namespace = ($schema_class);
1494 elsif (my $ns = $self->_downgrading_to_load_classes) {
1495 @result_namespace = $self->_result_namespace(
1500 elsif ($ns = $self->_rewriting_result_namespace) {
1501 @result_namespace = $self->_result_namespace(
1507 my $old_class = join(q{::}, @result_namespace,
1508 $self->_table2moniker($table));
1510 $self->_upgrading_classes->{$table_class} = $old_class
1511 unless $table_class eq $old_class;
1514 # this was a bad idea, should be ok now without it
1515 # my $table_normalized = lc $table;
1516 # $self->classes->{$table_normalized} = $table_class;
1517 # $self->monikers->{$table_normalized} = $table_moniker;
1519 $self->classes->{$table} = $table_class;
1520 $self->monikers->{$table} = $table_moniker;
1522 $self->_use ($table_class, @{$self->additional_classes});
1523 $self->_inject($table_class, @{$self->left_base_classes});
1525 if (my @components = @{ $self->components }) {
1526 $self->_dbic_stmt($table_class, 'load_components', @components);
1529 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1530 if @{$self->resultset_components};
1531 $self->_inject($table_class, @{$self->additional_base_classes});
1534 sub _resolve_col_accessor_collisions {
1535 my ($self, $col_info) = @_;
1537 my $base = $self->result_base_class || 'DBIx::Class::Core';
1538 my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1542 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1543 eval "require ${class};";
1546 push @methods, @{ Class::Inspector->methods($class) || [] };
1550 @methods{@methods} = ();
1553 $methods{meta} = undef;
1555 while (my ($col, $info) = each %$col_info) {
1556 my $accessor = $info->{accessor} || $col;
1558 next if $accessor eq 'id'; # special case (very common column)
1560 if (exists $methods{$accessor}) {
1561 $info->{accessor} = undef;
1566 sub _make_column_accessor_name {
1567 my ($self, $column_name) = @_;
1569 return join '_', map lc, split_name $column_name;
1572 # Set up metadata (cols, pks, etc)
1573 sub _setup_src_meta {
1574 my ($self, $table) = @_;
1576 my $schema = $self->schema;
1577 my $schema_class = $self->schema_class;
1579 my $table_class = $self->classes->{$table};
1580 my $table_moniker = $self->monikers->{$table};
1582 my $table_name = $table;
1583 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1585 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1586 $table_name = \ $self->_quote_table_name($table_name);
1589 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1591 # be careful to not create refs Data::Dump can "optimize"
1592 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1594 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1596 my $cols = $self->_table_columns($table);
1597 my $col_info = $self->__columns_info_for($table);
1599 while (my ($col, $info) = each %$col_info) {
1601 ($info->{accessor} = $col) =~ s/\W+/_/g;
1605 if ($self->preserve_case) {
1606 while (my ($col, $info) = each %$col_info) {
1607 if ($col ne lc($col)) {
1608 if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
1609 $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
1612 $info->{accessor} = lc($info->{accessor} || $col);
1618 # XXX this needs to go away
1619 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1622 $self->_resolve_col_accessor_collisions($col_info);
1624 my $fks = $self->_table_fk_info($table);
1626 foreach my $fkdef (@$fks) {
1627 for my $col (@{ $fkdef->{local_columns} }) {
1628 $col_info->{$col}{is_foreign_key} = 1;
1632 my $pks = $self->_table_pk_info($table) || [];
1634 foreach my $pkcol (@$pks) {
1635 $col_info->{$pkcol}{is_nullable} = 0;
1641 map { $_, ($col_info->{$_}||{}) } @$cols
1644 my %uniq_tag; # used to eliminate duplicate uniqs
1646 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1647 : carp("$table has no primary key");
1648 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1650 my $uniqs = $self->_table_uniq_info($table) || [];
1652 my ($name, $cols) = @$_;
1653 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1654 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1659 sub __columns_info_for {
1660 my ($self, $table) = @_;
1662 my $result = $self->_columns_info_for($table);
1664 while (my ($col, $info) = each %$result) {
1665 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1666 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1668 $result->{$col} = $info;
1676 Returns a sorted list of loaded tables, using the original database table
1684 return keys %{$self->_tables};
1687 # Make a moniker from a table
1688 sub _default_table2moniker {
1689 no warnings 'uninitialized';
1690 my ($self, $table) = @_;
1692 if ($self->naming->{monikers} eq 'v4') {
1693 return join '', map ucfirst, split /[\W_]+/, lc $table;
1695 elsif ($self->naming->{monikers} eq 'v5') {
1696 return join '', map ucfirst, split /[\W_]+/,
1697 Lingua::EN::Inflect::Number::to_S(lc $table);
1699 elsif ($self->naming->{monikers} eq 'v6') {
1700 (my $as_phrase = lc $table) =~ s/_+/ /g;
1701 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1703 return join '', map ucfirst, split /\W+/, $inflected;
1706 my @words = map lc, split_name $table;
1707 my $as_phrase = join ' ', @words;
1709 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1711 return join '', map ucfirst, split /\W+/, $inflected;
1714 sub _table2moniker {
1715 my ( $self, $table ) = @_;
1719 if( ref $self->moniker_map eq 'HASH' ) {
1720 $moniker = $self->moniker_map->{$table};
1722 elsif( ref $self->moniker_map eq 'CODE' ) {
1723 $moniker = $self->moniker_map->($table);
1726 $moniker ||= $self->_default_table2moniker($table);
1731 sub _load_relationships {
1732 my ($self, $table) = @_;
1734 my $tbl_fk_info = $self->_table_fk_info($table);
1735 foreach my $fkdef (@$tbl_fk_info) {
1736 $fkdef->{remote_source} =
1737 $self->monikers->{delete $fkdef->{remote_table}};
1739 my $tbl_uniq_info = $self->_table_uniq_info($table);
1741 my $local_moniker = $self->monikers->{$table};
1742 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1744 foreach my $src_class (sort keys %$rel_stmts) {
1745 my $src_stmts = $rel_stmts->{$src_class};
1746 foreach my $stmt (@$src_stmts) {
1747 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1752 # Overload these in driver class:
1754 # Returns an arrayref of column names
1755 sub _table_columns { croak "ABSTRACT METHOD" }
1757 # Returns arrayref of pk col names
1758 sub _table_pk_info { croak "ABSTRACT METHOD" }
1760 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1761 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1763 # Returns an arrayref of foreign key constraints, each
1764 # being a hashref with 3 keys:
1765 # local_columns (arrayref), remote_columns (arrayref), remote_table
1766 sub _table_fk_info { croak "ABSTRACT METHOD" }
1768 # Returns an array of lower case table names
1769 sub _tables_list { croak "ABSTRACT METHOD" }
1771 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1777 # generate the pod for this statement, storing it with $self->_pod
1778 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1780 my $args = dump(@_);
1781 $args = '(' . $args . ')' if @_ < 2;
1782 my $stmt = $method . $args . q{;};
1784 warn qq|$class\->$stmt\n| if $self->debug;
1785 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1789 # generates the accompanying pod for a DBIC class method statement,
1790 # storing it with $self->_pod
1796 if ( $method eq 'table' ) {
1798 my $pcm = $self->pod_comment_mode;
1799 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1800 $comment = $self->__table_comment($table);
1801 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1802 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1803 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1804 $self->_pod( $class, "=head1 NAME" );
1805 my $table_descr = $class;
1806 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1807 $self->{_class2table}{ $class } = $table;
1808 $self->_pod( $class, $table_descr );
1809 if ($comment and $comment_in_desc) {
1810 $self->_pod( $class, "=head1 DESCRIPTION" );
1811 $self->_pod( $class, $comment );
1813 $self->_pod_cut( $class );
1814 } elsif ( $method eq 'add_columns' ) {
1815 $self->_pod( $class, "=head1 ACCESSORS" );
1816 my $col_counter = 0;
1818 while( my ($name,$attrs) = splice @cols,0,2 ) {
1820 $self->_pod( $class, '=head2 ' . $name );
1821 $self->_pod( $class,
1823 my $s = $attrs->{$_};
1824 $s = !defined $s ? 'undef' :
1825 length($s) == 0 ? '(empty string)' :
1826 ref($s) eq 'SCALAR' ? $$s :
1833 looks_like_number($s) ? $s :
1838 } sort keys %$attrs,
1841 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter)) {
1842 $self->_pod( $class, $comment );
1845 $self->_pod_cut( $class );
1846 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1847 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1848 my ( $accessor, $rel_class ) = @_;
1849 $self->_pod( $class, "=head2 $accessor" );
1850 $self->_pod( $class, 'Type: ' . $method );
1851 $self->_pod( $class, "Related object: L<$rel_class>" );
1852 $self->_pod_cut( $class );
1853 $self->{_relations_started} { $class } = 1;
1857 sub _filter_comment {
1858 my ($self, $txt) = @_;
1860 $txt = '' if not defined $txt;
1862 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1867 sub __table_comment {
1870 if (my $code = $self->can('_table_comment')) {
1871 return $self->_filter_comment($self->$code(@_));
1877 sub __column_comment {
1880 if (my $code = $self->can('_column_comment')) {
1881 return $self->_filter_comment($self->$code(@_));
1887 # Stores a POD documentation
1889 my ($self, $class, $stmt) = @_;
1890 $self->_raw_stmt( $class, "\n" . $stmt );
1894 my ($self, $class ) = @_;
1895 $self->_raw_stmt( $class, "\n=cut\n" );
1898 # Store a raw source line for a class (for dumping purposes)
1900 my ($self, $class, $stmt) = @_;
1901 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1904 # Like above, but separately for the externally loaded stuff
1906 my ($self, $class, $stmt) = @_;
1907 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1910 sub _quote_table_name {
1911 my ($self, $table) = @_;
1913 my $qt = $self->schema->storage->sql_maker->quote_char;
1915 return $table unless $qt;
1918 return $qt->[0] . $table . $qt->[1];
1921 return $qt . $table . $qt;
1924 sub _custom_column_info {
1925 my ( $self, $table_name, $column_name, $column_info ) = @_;
1927 if (my $code = $self->custom_column_info) {
1928 return $code->($table_name, $column_name, $column_info) || {};
1933 sub _datetime_column_info {
1934 my ( $self, $table_name, $column_name, $column_info ) = @_;
1936 my $type = $column_info->{data_type} || '';
1937 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1938 or ($type =~ /date|timestamp/i)) {
1939 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1940 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
1946 my ($self, $name) = @_;
1948 return $self->preserve_case ? $name : lc($name);
1952 my ($self, $name) = @_;
1954 return $self->preserve_case ? $name : uc($name);
1957 sub _unregister_source_for_table {
1958 my ($self, $table) = @_;
1962 my $schema = $self->schema;
1963 # in older DBIC it's a private method
1964 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
1965 $schema->$unregister($self->_table2moniker($table));
1966 delete $self->monikers->{$table};
1967 delete $self->classes->{$table};
1968 delete $self->_upgrading_classes->{$table};
1969 delete $self->{_tables}{$table};
1973 # remove the dump dir from @INC on destruction
1977 @INC = grep $_ ne $self->dump_directory, @INC;
1982 Returns a hashref of loaded table to moniker mappings. There will
1983 be two entries for each table, the original name and the "normalized"
1984 name, in the case that the two are different (such as databases
1985 that like uppercase table names, or preserve your original mixed-case
1986 definitions, or what-have-you).
1990 Returns a hashref of table to class mappings. In some cases it will
1991 contain multiple entries per table for the original and normalized table
1992 names, as above in L</monikers>.
1996 L<DBIx::Class::Schema::Loader>
2000 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2004 This library is free software; you can redistribute it and/or modify it under
2005 the same terms as Perl itself.
2010 # vim:et sts=4 sw=4 tw=0: