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
56 overwrite_modifications
75 __PACKAGE__->mk_group_accessors('simple', qw/
77 schema_version_to_dump
79 _upgrading_from_load_classes
80 _downgrading_to_load_classes
81 _rewriting_result_namespace
86 pod_comment_spillover_length
92 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
96 See L<DBIx::Class::Schema::Loader>
100 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
101 classes, and implements the common functionality between them.
103 =head1 CONSTRUCTOR OPTIONS
105 These constructor options are the base options for
106 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
108 =head2 skip_relationships
110 Skip setting up relationships. The default is to attempt the loading
113 =head2 skip_load_external
115 Skip loading of other classes in @INC. The default is to merge all other classes
116 with the same name found in @INC into the schema file we are creating.
120 Static schemas (ones dumped to disk) will, by default, use the new-style
121 relationship names and singularized Results, unless you're overwriting an
122 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
123 which case the backward compatible RelBuilder will be activated, and the
124 appropriate monikerization used.
130 will disable the backward-compatible RelBuilder and use
131 the new-style relationship names along with singularized Results, even when
132 overwriting a dump made with an earlier version.
134 The option also takes a hashref:
136 naming => { relationships => 'v7', monikers => 'v7' }
144 How to name relationship accessors.
148 How to name Result classes.
150 =item column_accessors
152 How to name column accessors in Result classes.
162 Latest style, whatever that happens to be.
166 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
170 Monikers singularized as whole words, C<might_have> relationships for FKs on
171 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
173 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
178 All monikers and relationships are inflected using
179 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
180 from relationship names.
182 In general, there is very little difference between v5 and v6 schemas.
186 This mode is identical to C<v6> mode, except that monikerization of CamelCase
187 table names is also done correctly.
189 CamelCase column names in case-preserving mode will also be handled correctly
190 for relationship name inflection. See L</preserve_case>.
192 In this mode, CamelCase L</column_accessors> are normalized based on case
193 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
195 If you don't have any CamelCase table or column names, you can upgrade without
196 breaking any of your code.
200 Dynamic schemas will always default to the 0.04XXX relationship names and won't
201 singularize Results for backward compatibility, to activate the new RelBuilder
202 and singularization put this in your C<Schema.pm> file:
204 __PACKAGE__->naming('current');
206 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
207 next major version upgrade:
209 __PACKAGE__->naming('v7');
213 By default POD will be generated for columns and relationships, using database
214 metadata for the text if available and supported.
216 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
217 supported for Postgres right now.
219 Set this to C<0> to turn off all POD generation.
221 =head2 pod_comment_mode
223 Controls where table comments appear in the generated POD. Smaller table
224 comments are appended to the C<NAME> section of the documentation, and larger
225 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
226 section to be generated with the comment always, only use C<NAME>, or choose
227 the length threshold at which the comment is forced into the description.
233 Use C<NAME> section only.
237 Force C<DESCRIPTION> always.
241 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
246 =head2 pod_comment_spillover_length
248 When pod_comment_mode is set to C<auto>, this is the length of the comment at
249 which it will be forced into a separate description section.
253 =head2 relationship_attrs
255 Hashref of attributes to pass to each generated relationship, listed
256 by type. Also supports relationship type 'all', containing options to
257 pass to all generated relationships. Attributes set for more specific
258 relationship types override those set in 'all'.
262 relationship_attrs => {
263 belongs_to => { is_deferrable => 1 },
266 use this to make your foreign key constraints DEFERRABLE.
270 If set to true, each constructive L<DBIx::Class> statement the loader
271 decides to execute will be C<warn>-ed before execution.
275 Set the name of the schema to load (schema in the sense that your database
276 vendor means it). Does not currently support loading more than one schema
281 Only load tables matching regex. Best specified as a qr// regex.
285 Exclude tables matching regex. Best specified as a qr// regex.
289 Overrides the default table name to moniker translation. Can be either
290 a hashref of table keys and moniker values, or a coderef for a translator
291 function taking a single scalar table name argument and returning
292 a scalar moniker. If the hash entry does not exist, or the function
293 returns a false value, the code falls back to default behavior
296 The default behavior is to split on case transition and non-alphanumeric
297 boundaries, singularize the resulting phrase, then join the titlecased words
300 Table Name | Moniker Name
301 ---------------------------------
303 luser_group | LuserGroup
304 luser-opts | LuserOpt
305 stations_visited | StationVisited
306 routeChange | RouteChange
308 =head2 inflect_plural
310 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
311 if hash key does not exist or coderef returns false), but acts as a map
312 for pluralizing relationship names. The default behavior is to utilize
313 L<Lingua::EN::Inflect::Number/to_PL>.
315 =head2 inflect_singular
317 As L</inflect_plural> above, but for singularizing relationship names.
318 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
320 =head2 schema_base_class
322 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
326 Roles your schema class will consume, implies L</use_moose>.
328 =head2 result_base_class
330 Base class for your table classes (aka result classes). Defaults to
335 Roles your Result classes will consume, implies L</use_moose>.
337 =head2 additional_base_classes
339 List of additional base classes all of your table classes will use.
341 =head2 left_base_classes
343 List of additional base classes all of your table classes will use
344 that need to be leftmost.
346 =head2 additional_classes
348 List of additional classes which all of your table classes will use.
352 List of additional components to be loaded into all of your table
353 classes. A good example would be
354 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
356 =head2 resultset_components
358 List of additional ResultSet components to be loaded into your table
359 classes. A good example would be C<AlwaysRS>. Component
360 C<ResultSetManager> will be automatically added to the above
361 C<components> list if this option is set.
363 =head2 use_namespaces
365 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
368 Generate result class names suitable for
369 L<DBIx::Class::Schema/load_namespaces> and call that instead of
370 L<DBIx::Class::Schema/load_classes>. When using this option you can also
371 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
372 C<resultset_namespace>, C<default_resultset_class>), and they will be added
373 to the call (and the generated result class names adjusted appropriately).
375 =head2 dump_directory
377 This option is designed to be a tool to help you transition from this
378 loader to a manually-defined schema when you decide it's time to do so.
380 The value of this option is a perl libdir pathname. Within
381 that directory this module will create a baseline manual
382 L<DBIx::Class::Schema> module set, based on what it creates at runtime
385 The created schema class will have the same classname as the one on
386 which you are setting this option (and the ResultSource classes will be
387 based on this name as well).
389 Normally you wouldn't hard-code this setting in your schema class, as it
390 is meant for one-time manual usage.
392 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
393 recommended way to access this functionality.
395 =head2 dump_overwrite
397 Deprecated. See L</really_erase_my_files> below, which does *not* mean
398 the same thing as the old C<dump_overwrite> setting from previous releases.
400 =head2 really_erase_my_files
402 Default false. If true, Loader will unconditionally delete any existing
403 files before creating the new ones from scratch when dumping a schema to disk.
405 The default behavior is instead to only replace the top portion of the
406 file, up to and including the final stanza which contains
407 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
408 leaving any customizations you placed after that as they were.
410 When C<really_erase_my_files> is not set, if the output file already exists,
411 but the aforementioned final stanza is not found, or the checksum
412 contained there does not match the generated contents, Loader will
413 croak and not touch the file.
415 You should really be using version control on your schema classes (and all
416 of the rest of your code for that matter). Don't blame me if a bug in this
417 code wipes something out when it shouldn't have, you've been warned.
419 =head2 overwrite_modifications
421 Default false. If false, when updating existing files, Loader will
422 refuse to modify any Loader-generated code that has been modified
423 since its last run (as determined by the checksum Loader put in its
426 If true, Loader will discard any manual modifications that have been
427 made to Loader-generated code.
429 Again, you should be using version control on your schema classes. Be
430 careful with this option.
432 =head2 custom_column_info
434 Hook for adding extra attributes to the
435 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
437 Must be a coderef that returns a hashref with the extra attributes.
439 Receives the table name, column name and column_info.
443 custom_column_info => sub {
444 my ($table_name, $column_name, $column_info) = @_;
446 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
447 return { is_snoopy => 1 };
451 This attribute can also be used to set C<inflate_datetime> on a non-datetime
452 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
454 =head2 datetime_timezone
456 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
457 columns with the DATE/DATETIME/TIMESTAMP data_types.
459 =head2 datetime_locale
461 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
462 columns with the DATE/DATETIME/TIMESTAMP data_types.
466 File in Perl format, which should return a HASH reference, from which to read
471 Usually column names are lowercased, to make them easier to work with in
472 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
475 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
476 case-sensitive collation will turn this option on unconditionally.
478 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
481 =head2 qualify_objects
483 Set to true to prepend the L</db_schema> to table names for C<<
484 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
488 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
489 L<namespace::autoclean>. The default content after the md5 sum also makes the
492 It is safe to upgrade your existing Schema to this option.
496 None of these methods are intended for direct invocation by regular
497 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
498 L<DBIx::Class::Schema::Loader>.
502 my $CURRENT_V = 'v7';
505 schema_base_class result_base_class additional_base_classes
506 left_base_classes additional_classes components resultset_components
507 schema_roles result_roles
510 # ensure that a peice of object data is a valid arrayref, creating
511 # an empty one or encapsulating whatever's there.
512 sub _ensure_arrayref {
517 $self->{$_} = [ $self->{$_} ]
518 unless ref $self->{$_} eq 'ARRAY';
524 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
525 by L<DBIx::Class::Schema::Loader>.
530 my ( $class, %args ) = @_;
532 my $self = { %args };
534 bless $self => $class;
536 if (my $config_file = $self->config_file) {
537 my $config_opts = do $config_file;
539 croak "Error reading config from $config_file: $@" if $@;
541 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
543 while (my ($k, $v) = each %$config_opts) {
544 $self->{$k} = $v unless exists $self->{$k};
548 $self->_ensure_arrayref(qw/additional_classes
549 additional_base_classes
557 $self->_validate_class_args;
559 if ($self->use_moose) {
562 require MooseX::NonMoose;
563 require namespace::autoclean;
566 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
567 "Moose, MooseX::NonMoose and namespace::autoclean";
571 push(@{$self->{components}}, 'ResultSetManager')
572 if @{$self->{resultset_components}};
574 $self->{monikers} = {};
575 $self->{classes} = {};
576 $self->{_upgrading_classes} = {};
578 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
579 $self->{schema} ||= $self->{schema_class};
581 croak "dump_overwrite is deprecated. Please read the"
582 . " DBIx::Class::Schema::Loader::Base documentation"
583 if $self->{dump_overwrite};
585 $self->{dynamic} = ! $self->{dump_directory};
586 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
591 $self->{dump_directory} ||= $self->{temp_directory};
593 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
594 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
596 if ((not ref $self->naming) && defined $self->naming) {
597 my $naming_ver = $self->naming;
599 relationships => $naming_ver,
600 monikers => $naming_ver,
601 column_accessors => $naming_ver,
606 for (values %{ $self->naming }) {
607 $_ = $CURRENT_V if $_ eq 'current';
610 $self->{naming} ||= {};
612 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
613 croak 'custom_column_info must be a CODE ref';
616 $self->_check_back_compat;
618 $self->use_namespaces(1) unless defined $self->use_namespaces;
619 $self->generate_pod(1) unless defined $self->generate_pod;
620 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
621 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
626 sub _check_back_compat {
629 # dynamic schemas will always be in 0.04006 mode, unless overridden
630 if ($self->dynamic) {
631 # just in case, though no one is likely to dump a dynamic schema
632 $self->schema_version_to_dump('0.04006');
634 if (not %{ $self->naming }) {
635 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
637 Dynamic schema detected, will run in 0.04006 mode.
639 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
640 to disable this warning.
642 Also consider setting 'use_namespaces => 1' if/when upgrading.
644 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
649 $self->_upgrading_from('v4');
652 $self->naming->{relationships} ||= 'v4';
653 $self->naming->{monikers} ||= 'v4';
655 if ($self->use_namespaces) {
656 $self->_upgrading_from_load_classes(1);
659 $self->use_namespaces(0);
665 # otherwise check if we need backcompat mode for a static schema
666 my $filename = $self->_get_dump_filename($self->schema_class);
667 return unless -e $filename;
669 open(my $fh, '<', $filename)
670 or croak "Cannot open '$filename' for reading: $!";
672 my $load_classes = 0;
673 my $result_namespace = '';
676 if (/^__PACKAGE__->load_classes;/) {
678 } elsif (/result_namespace => '([^']+)'/) {
679 $result_namespace = $1;
680 } elsif (my ($real_ver) =
681 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
683 if ($load_classes && (not defined $self->use_namespaces)) {
684 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
686 'load_classes;' static schema detected, turning off 'use_namespaces'.
688 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
689 variable to disable this warning.
691 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
694 $self->use_namespaces(0);
696 elsif ($load_classes && $self->use_namespaces) {
697 $self->_upgrading_from_load_classes(1);
699 elsif ((not $load_classes) && defined $self->use_namespaces
700 && (not $self->use_namespaces)) {
701 $self->_downgrading_to_load_classes(
702 $result_namespace || 'Result'
705 elsif ((not defined $self->use_namespaces)
706 || $self->use_namespaces) {
707 if (not $self->result_namespace) {
708 $self->result_namespace($result_namespace || 'Result');
710 elsif ($result_namespace ne $self->result_namespace) {
711 $self->_rewriting_result_namespace(
712 $result_namespace || 'Result'
717 # XXX when we go past .0 this will need fixing
718 my ($v) = $real_ver =~ /([1-9])/;
721 last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
723 if (not %{ $self->naming }) {
724 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
726 Version $real_ver static schema detected, turning on backcompat mode.
728 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
729 to disable this warning.
731 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
733 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
734 from version 0.04006.
738 $self->_upgrading_from($v);
742 $self->naming->{relationships} ||= $v;
743 $self->naming->{monikers} ||= $v;
744 $self->naming->{column_accessors} ||= $v;
746 $self->schema_version_to_dump($real_ver);
754 sub _validate_class_args {
758 foreach my $k (@CLASS_ARGS) {
759 next unless $self->$k;
761 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
762 foreach my $c (@classes) {
763 # components default to being under the DBIx::Class namespace unless they
764 # are preceeded with a '+'
765 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
766 $c = 'DBIx::Class::' . $c;
769 # 1 == installed, 0 == not installed, undef == invalid classname
770 my $installed = Class::Inspector->installed($c);
771 if ( defined($installed) ) {
772 if ( $installed == 0 ) {
773 croak qq/$c, as specified in the loader option "$k", is not installed/;
776 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
782 sub _find_file_in_inc {
783 my ($self, $file) = @_;
785 foreach my $prefix (@INC) {
786 my $fullpath = File::Spec->catfile($prefix, $file);
787 return $fullpath if -f $fullpath
788 # abs_path throws on Windows for nonexistant files
789 and eval { Cwd::abs_path($fullpath) } ne
790 (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
797 my ($self, $class) = @_;
799 my $class_path = $class;
800 $class_path =~ s{::}{/}g;
801 $class_path .= '.pm';
806 sub _find_class_in_inc {
807 my ($self, $class) = @_;
809 return $self->_find_file_in_inc($self->_class_path($class));
815 return $self->_upgrading_from
816 || $self->_upgrading_from_load_classes
817 || $self->_downgrading_to_load_classes
818 || $self->_rewriting_result_namespace
822 sub _rewrite_old_classnames {
823 my ($self, $code) = @_;
825 return $code unless $self->_rewriting;
827 my %old_classes = reverse %{ $self->_upgrading_classes };
829 my $re = join '|', keys %old_classes;
832 $code =~ s/$re/$old_classes{$1} || $1/eg;
838 my ($self, $class) = @_;
840 return if $self->{skip_load_external};
842 # so that we don't load our own classes, under any circumstances
843 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
845 my $real_inc_path = $self->_find_class_in_inc($class);
847 my $old_class = $self->_upgrading_classes->{$class}
848 if $self->_rewriting;
850 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
851 if $old_class && $old_class ne $class;
853 return unless $real_inc_path || $old_real_inc_path;
855 if ($real_inc_path) {
856 # If we make it to here, we loaded an external definition
857 warn qq/# Loaded external class definition for '$class'\n/
860 open(my $fh, '<', $real_inc_path)
861 or croak "Failed to open '$real_inc_path' for reading: $!";
862 my $code = do { local $/; <$fh> };
864 or croak "Failed to close $real_inc_path: $!";
865 $code = $self->_rewrite_old_classnames($code);
867 if ($self->dynamic) { # load the class too
868 # kill redefined warnings
869 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
870 local $SIG{__WARN__} = sub {
872 unless $_[0] =~ /^Subroutine \S+ redefined/;
878 $self->_ext_stmt($class,
879 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
880 .qq|# They are now part of the custom portion of this file\n|
881 .qq|# for you to hand-edit. If you do not either delete\n|
882 .qq|# this section or remove that file from \@INC, this section\n|
883 .qq|# will be repeated redundantly when you re-create this\n|
884 .qq|# file again via Loader! See skip_load_external to disable\n|
885 .qq|# this feature.\n|
888 $self->_ext_stmt($class, $code);
889 $self->_ext_stmt($class,
890 qq|# End of lines loaded from '$real_inc_path' |
894 if ($old_real_inc_path) {
895 my $code = slurp $old_real_inc_path;
897 $self->_ext_stmt($class, <<"EOF");
899 # These lines were loaded from '$old_real_inc_path',
900 # based on the Result class name that would have been created by an older
901 # version of the Loader. For a static schema, this happens only once during
902 # upgrade. See skip_load_external to disable this feature.
905 $code = $self->_rewrite_old_classnames($code);
907 if ($self->dynamic) {
910 Detected external content in '$old_real_inc_path', a class name that would have
911 been used by an older version of the Loader.
913 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
914 new name of the Result.
916 # kill redefined warnings
917 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
918 local $SIG{__WARN__} = sub {
920 unless $_[0] =~ /^Subroutine \S+ redefined/;
927 $self->_ext_stmt($class, $code);
928 $self->_ext_stmt($class,
929 qq|# End of lines loaded from '$old_real_inc_path' |
936 Does the actual schema-construction work.
944 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
952 Rescan the database for changes. Returns a list of the newly added table
955 The schema argument should be the schema class or object to be affected. It
956 should probably be derived from the original schema_class used during L</load>.
961 my ($self, $schema) = @_;
963 $self->{schema} = $schema;
964 $self->_relbuilder->{schema} = $schema;
967 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
969 foreach my $table (@current) {
970 if(!exists $self->{_tables}->{$table}) {
971 push(@created, $table);
976 @current{@current} = ();
977 foreach my $table (keys %{ $self->{_tables} }) {
978 if (not exists $current{$table}) {
979 $self->_unregister_source_for_table($table);
983 delete $self->{_dump_storage};
984 delete $self->{_relations_started};
986 my $loaded = $self->_load_tables(@current);
988 return map { $self->monikers->{$_} } @created;
992 no warnings 'uninitialized';
995 return if $self->{skip_relationships};
997 if ($self->naming->{relationships} eq 'v4') {
998 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
999 return $self->{relbuilder} ||=
1000 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
1002 $self->inflect_plural,
1003 $self->inflect_singular,
1004 $self->relationship_attrs,
1007 elsif ($self->naming->{relationships} eq 'v5') {
1008 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05;
1009 return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_05->new (
1011 $self->inflect_plural,
1012 $self->inflect_singular,
1013 $self->relationship_attrs,
1016 elsif ($self->naming->{relationships} eq 'v6') {
1017 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
1018 return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
1020 $self->inflect_plural,
1021 $self->inflect_singular,
1022 $self->relationship_attrs,
1026 return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
1028 $self->inflect_plural,
1029 $self->inflect_singular,
1030 $self->relationship_attrs,
1035 my ($self, @tables) = @_;
1037 # Save the new tables to the tables list
1039 $self->{_tables}->{$_} = 1;
1042 $self->_make_src_class($_) for @tables;
1044 # sanity-check for moniker clashes
1045 my $inverse_moniker_idx;
1046 for (keys %{$self->monikers}) {
1047 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1051 for (keys %$inverse_moniker_idx) {
1052 my $tables = $inverse_moniker_idx->{$_};
1054 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1055 join (', ', map { "'$_'" } @$tables),
1062 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1063 . 'Either change the naming style, or supply an explicit moniker_map: '
1064 . join ('; ', @clashes)
1070 $self->_setup_src_meta($_) for @tables;
1072 if(!$self->skip_relationships) {
1073 # The relationship loader needs a working schema
1075 local $self->{dump_directory} = $self->{temp_directory};
1076 $self->_reload_classes(\@tables);
1077 $self->_load_relationships($_) for @tables;
1080 # Remove that temp dir from INC so it doesn't get reloaded
1081 @INC = grep $_ ne $self->dump_directory, @INC;
1084 $self->_load_external($_)
1085 for map { $self->classes->{$_} } @tables;
1087 # Reload without unloading first to preserve any symbols from external
1089 $self->_reload_classes(\@tables, 0);
1091 # Drop temporary cache
1092 delete $self->{_cache};
1097 sub _reload_classes {
1098 my ($self, $tables, $unload) = @_;
1100 my @tables = @$tables;
1101 $unload = 1 unless defined $unload;
1103 # so that we don't repeat custom sections
1104 @INC = grep $_ ne $self->dump_directory, @INC;
1106 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1108 unshift @INC, $self->dump_directory;
1111 my %have_source = map { $_ => $self->schema->source($_) }
1112 $self->schema->sources;
1114 for my $table (@tables) {
1115 my $moniker = $self->monikers->{$table};
1116 my $class = $self->classes->{$table};
1119 no warnings 'redefine';
1120 local *Class::C3::reinitialize = sub {};
1123 if ($class->can('meta') && (ref $class->meta)->isa('Moose::Meta::Class')) {
1124 $class->meta->make_mutable;
1126 Class::Unload->unload($class) if $unload;
1127 my ($source, $resultset_class);
1129 ($source = $have_source{$moniker})
1130 && ($resultset_class = $source->resultset_class)
1131 && ($resultset_class ne 'DBIx::Class::ResultSet')
1133 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1134 if ($resultset_class->can('meta') && (ref $resultset_class->meta)->isa('Moose::Meta::Class')) {
1135 $resultset_class->meta->make_mutable;
1137 Class::Unload->unload($resultset_class) if $unload;
1138 $self->_reload_class($resultset_class) if $has_file;
1140 $self->_reload_class($class);
1142 push @to_register, [$moniker, $class];
1145 Class::C3->reinitialize;
1146 for (@to_register) {
1147 $self->schema->register_class(@$_);
1151 # We use this instead of ensure_class_loaded when there are package symbols we
1154 my ($self, $class) = @_;
1156 my $class_path = $self->_class_path($class);
1157 delete $INC{ $class_path };
1159 # kill redefined warnings
1160 my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
1161 local $SIG{__WARN__} = sub {
1163 unless $_[0] =~ /^Subroutine \S+ redefined/;
1165 eval "require $class;";
1166 die "Failed to reload class $class: $@" if $@;
1169 sub _get_dump_filename {
1170 my ($self, $class) = (@_);
1172 $class =~ s{::}{/}g;
1173 return $self->dump_directory . q{/} . $class . q{.pm};
1176 sub _ensure_dump_subdirs {
1177 my ($self, $class) = (@_);
1179 my @name_parts = split(/::/, $class);
1180 pop @name_parts; # we don't care about the very last element,
1181 # which is a filename
1183 my $dir = $self->dump_directory;
1186 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1188 last if !@name_parts;
1189 $dir = File::Spec->catdir($dir, shift @name_parts);
1194 my ($self, @classes) = @_;
1196 my $schema_class = $self->schema_class;
1197 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1199 my $target_dir = $self->dump_directory;
1200 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1201 unless $self->{dynamic} or $self->{quiet};
1204 qq|package $schema_class;\n\n|
1205 . qq|# Created by DBIx::Class::Schema::Loader\n|
1206 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1207 . qq|use strict;\nuse warnings;\n\n|;
1208 if ($self->use_moose) {
1209 $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1212 $schema_text .= qq|use base '$schema_base_class';\n\n|;
1215 if ($self->use_namespaces) {
1216 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1217 my $namespace_options;
1219 my @attr = qw/resultset_namespace default_resultset_class/;
1221 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1223 for my $attr (@attr) {
1225 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1228 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1229 $schema_text .= qq|;\n|;
1232 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1236 local $self->{version_to_dump} = $self->schema_version_to_dump;
1237 $self->_write_classfile($schema_class, $schema_text, 1);
1240 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1242 foreach my $src_class (@classes) {
1244 qq|package $src_class;\n\n|
1245 . qq|# Created by DBIx::Class::Schema::Loader\n|
1246 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1247 . qq|use strict;\nuse warnings;\n\n|;
1248 if ($self->use_moose) {
1249 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1251 # these options 'use base' which is compile time
1252 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1253 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1256 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1260 $src_text .= qq|use base '$result_base_class';\n\n|;
1262 $self->_write_classfile($src_class, $src_text);
1265 # remove Result dir if downgrading from use_namespaces, and there are no
1267 if (my $result_ns = $self->_downgrading_to_load_classes
1268 || $self->_rewriting_result_namespace) {
1269 my $result_namespace = $self->_result_namespace(
1274 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1275 $result_dir = $self->dump_directory . '/' . $result_dir;
1277 unless (my @files = glob "$result_dir/*") {
1282 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1287 my ($self, $version, $ts) = @_;
1288 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1291 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1294 sub _write_classfile {
1295 my ($self, $class, $text, $is_schema) = @_;
1297 my $filename = $self->_get_dump_filename($class);
1298 $self->_ensure_dump_subdirs($class);
1300 if (-f $filename && $self->really_erase_my_files) {
1301 warn "Deleting existing file '$filename' due to "
1302 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1306 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
1308 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1309 # If there is already custom content, which does not have the Moose content, add it.
1310 if ($self->use_moose) {
1311 local $self->{use_moose} = 0;
1313 if ($custom_content eq $self->_default_custom_content) {
1314 local $self->{use_moose} = 1;
1316 $custom_content = $self->_default_custom_content;
1319 local $self->{use_moose} = 1;
1321 if ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1322 $custom_content .= $self->_default_custom_content;
1327 if (my $old_class = $self->_upgrading_classes->{$class}) {
1328 my $old_filename = $self->_get_dump_filename($old_class);
1330 my ($old_custom_content) = $self->_get_custom_content(
1331 $old_class, $old_filename, 0 # do not add default comment
1334 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
1336 if ($old_custom_content) {
1338 "\n" . $old_custom_content . "\n" . $custom_content;
1341 unlink $old_filename;
1344 $custom_content = $self->_rewrite_old_classnames($custom_content);
1347 for @{$self->{_dump_storage}->{$class} || []};
1349 # Check and see if the dump is infact differnt
1353 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1356 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1357 return unless $self->_upgrading_from && $is_schema;
1361 $text .= $self->_sig_comment(
1362 $self->version_to_dump,
1363 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1366 open(my $fh, '>', $filename)
1367 or croak "Cannot open '$filename' for writing: $!";
1369 # Write the top half and its MD5 sum
1370 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1372 # Write out anything loaded via external partial class file in @INC
1374 for @{$self->{_ext_storage}->{$class} || []};
1376 # Write out any custom content the user has added
1377 print $fh $custom_content;
1380 or croak "Error closing '$filename': $!";
1383 sub _default_moose_custom_content {
1384 return qq|\n__PACKAGE__->meta->make_immutable;|;
1387 sub _default_custom_content {
1389 my $default = qq|\n\n# You can replace this text with custom|
1390 . qq| content, and it will be preserved on regeneration|;
1391 if ($self->use_moose) {
1392 $default .= $self->_default_moose_custom_content;
1394 $default .= qq|\n1;\n|;
1398 sub _get_custom_content {
1399 my ($self, $class, $filename, $add_default) = @_;
1401 $add_default = 1 unless defined $add_default;
1403 return ($self->_default_custom_content) if ! -f $filename;
1405 open(my $fh, '<', $filename)
1406 or croak "Cannot open '$filename' for reading: $!";
1409 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1412 my ($md5, $ts, $ver);
1414 if(!$md5 && /$mark_re/) {
1418 # Pull out the previous version and timestamp
1419 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1422 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"
1423 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1432 croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1433 . " it does not appear to have been generated by Loader"
1436 # Default custom content:
1437 $buffer ||= $self->_default_custom_content if $add_default;
1439 return ($buffer, $md5, $ver, $ts);
1447 warn "$target: use $_;" if $self->debug;
1448 $self->_raw_stmt($target, "use $_;");
1456 my $blist = join(q{ }, @_);
1458 return unless $blist;
1460 warn "$target: use base qw/$blist/;" if $self->debug;
1461 $self->_raw_stmt($target, "use base qw/$blist/;");
1464 sub _result_namespace {
1465 my ($self, $schema_class, $ns) = @_;
1466 my @result_namespace;
1468 if ($ns =~ /^\+(.*)/) {
1469 # Fully qualified namespace
1470 @result_namespace = ($1)
1473 # Relative namespace
1474 @result_namespace = ($schema_class, $ns);
1477 return wantarray ? @result_namespace : join '::', @result_namespace;
1480 # Create class with applicable bases, setup monikers, etc
1481 sub _make_src_class {
1482 my ($self, $table) = @_;
1484 my $schema = $self->schema;
1485 my $schema_class = $self->schema_class;
1487 my $table_moniker = $self->_table2moniker($table);
1488 my @result_namespace = ($schema_class);
1489 if ($self->use_namespaces) {
1490 my $result_namespace = $self->result_namespace || 'Result';
1491 @result_namespace = $self->_result_namespace(
1496 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1498 if ((my $upgrading_v = $self->_upgrading_from)
1499 || $self->_rewriting) {
1500 local $self->naming->{monikers} = $upgrading_v
1503 my @result_namespace = @result_namespace;
1504 if ($self->_upgrading_from_load_classes) {
1505 @result_namespace = ($schema_class);
1507 elsif (my $ns = $self->_downgrading_to_load_classes) {
1508 @result_namespace = $self->_result_namespace(
1513 elsif ($ns = $self->_rewriting_result_namespace) {
1514 @result_namespace = $self->_result_namespace(
1520 my $old_class = join(q{::}, @result_namespace,
1521 $self->_table2moniker($table));
1523 $self->_upgrading_classes->{$table_class} = $old_class
1524 unless $table_class eq $old_class;
1527 # this was a bad idea, should be ok now without it
1528 # my $table_normalized = lc $table;
1529 # $self->classes->{$table_normalized} = $table_class;
1530 # $self->monikers->{$table_normalized} = $table_moniker;
1532 $self->classes->{$table} = $table_class;
1533 $self->monikers->{$table} = $table_moniker;
1535 $self->_use ($table_class, @{$self->additional_classes});
1536 $self->_inject($table_class, @{$self->left_base_classes});
1538 if (my @components = @{ $self->components }) {
1539 $self->_dbic_stmt($table_class, 'load_components', @components);
1542 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1543 if @{$self->resultset_components};
1544 $self->_inject($table_class, @{$self->additional_base_classes});
1547 sub _resolve_col_accessor_collisions {
1548 my ($self, $col_info) = @_;
1550 my $base = $self->result_base_class || 'DBIx::Class::Core';
1551 my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1555 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1556 eval "require ${class};";
1559 push @methods, @{ Class::Inspector->methods($class) || [] };
1563 @methods{@methods} = ();
1566 $methods{meta} = undef;
1568 while (my ($col, $info) = each %$col_info) {
1569 my $accessor = $info->{accessor} || $col;
1571 next if $accessor eq 'id'; # special case (very common column)
1573 if (exists $methods{$accessor}) {
1574 $info->{accessor} = undef;
1579 sub _make_column_accessor_name {
1580 my ($self, $column_name) = @_;
1582 return join '_', map lc, split_name $column_name;
1585 # Set up metadata (cols, pks, etc)
1586 sub _setup_src_meta {
1587 my ($self, $table) = @_;
1589 my $schema = $self->schema;
1590 my $schema_class = $self->schema_class;
1592 my $table_class = $self->classes->{$table};
1593 my $table_moniker = $self->monikers->{$table};
1595 my $table_name = $table;
1596 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1598 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1599 $table_name = \ $self->_quote_table_name($table_name);
1602 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1604 # be careful to not create refs Data::Dump can "optimize"
1605 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1607 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1609 my $cols = $self->_table_columns($table);
1610 my $col_info = $self->__columns_info_for($table);
1612 while (my ($col, $info) = each %$col_info) {
1614 ($info->{accessor} = $col) =~ s/\W+/_/g;
1618 if ($self->preserve_case) {
1619 while (my ($col, $info) = each %$col_info) {
1620 if ($col ne lc($col)) {
1621 if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
1622 $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
1625 $info->{accessor} = lc($info->{accessor} || $col);
1631 # XXX this needs to go away
1632 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1635 $self->_resolve_col_accessor_collisions($col_info);
1637 my $fks = $self->_table_fk_info($table);
1639 foreach my $fkdef (@$fks) {
1640 for my $col (@{ $fkdef->{local_columns} }) {
1641 $col_info->{$col}{is_foreign_key} = 1;
1645 my $pks = $self->_table_pk_info($table) || [];
1647 foreach my $pkcol (@$pks) {
1648 $col_info->{$pkcol}{is_nullable} = 0;
1654 map { $_, ($col_info->{$_}||{}) } @$cols
1657 my %uniq_tag; # used to eliminate duplicate uniqs
1659 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1660 : carp("$table has no primary key");
1661 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1663 my $uniqs = $self->_table_uniq_info($table) || [];
1665 my ($name, $cols) = @$_;
1666 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1667 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1672 sub __columns_info_for {
1673 my ($self, $table) = @_;
1675 my $result = $self->_columns_info_for($table);
1677 while (my ($col, $info) = each %$result) {
1678 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1679 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1681 $result->{$col} = $info;
1689 Returns a sorted list of loaded tables, using the original database table
1697 return keys %{$self->_tables};
1700 # Make a moniker from a table
1701 sub _default_table2moniker {
1702 no warnings 'uninitialized';
1703 my ($self, $table) = @_;
1705 if ($self->naming->{monikers} eq 'v4') {
1706 return join '', map ucfirst, split /[\W_]+/, lc $table;
1708 elsif ($self->naming->{monikers} eq 'v5') {
1709 return join '', map ucfirst, split /[\W_]+/,
1710 Lingua::EN::Inflect::Number::to_S(lc $table);
1712 elsif ($self->naming->{monikers} eq 'v6') {
1713 (my $as_phrase = lc $table) =~ s/_+/ /g;
1714 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1716 return join '', map ucfirst, split /\W+/, $inflected;
1719 my @words = map lc, split_name $table;
1720 my $as_phrase = join ' ', @words;
1722 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1724 return join '', map ucfirst, split /\W+/, $inflected;
1727 sub _table2moniker {
1728 my ( $self, $table ) = @_;
1732 if( ref $self->moniker_map eq 'HASH' ) {
1733 $moniker = $self->moniker_map->{$table};
1735 elsif( ref $self->moniker_map eq 'CODE' ) {
1736 $moniker = $self->moniker_map->($table);
1739 $moniker ||= $self->_default_table2moniker($table);
1744 sub _load_relationships {
1745 my ($self, $table) = @_;
1747 my $tbl_fk_info = $self->_table_fk_info($table);
1748 foreach my $fkdef (@$tbl_fk_info) {
1749 $fkdef->{remote_source} =
1750 $self->monikers->{delete $fkdef->{remote_table}};
1752 my $tbl_uniq_info = $self->_table_uniq_info($table);
1754 my $local_moniker = $self->monikers->{$table};
1755 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1757 foreach my $src_class (sort keys %$rel_stmts) {
1758 my $src_stmts = $rel_stmts->{$src_class};
1759 foreach my $stmt (@$src_stmts) {
1760 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1765 # Overload these in driver class:
1767 # Returns an arrayref of column names
1768 sub _table_columns { croak "ABSTRACT METHOD" }
1770 # Returns arrayref of pk col names
1771 sub _table_pk_info { croak "ABSTRACT METHOD" }
1773 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1774 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1776 # Returns an arrayref of foreign key constraints, each
1777 # being a hashref with 3 keys:
1778 # local_columns (arrayref), remote_columns (arrayref), remote_table
1779 sub _table_fk_info { croak "ABSTRACT METHOD" }
1781 # Returns an array of lower case table names
1782 sub _tables_list { croak "ABSTRACT METHOD" }
1784 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1790 # generate the pod for this statement, storing it with $self->_pod
1791 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1793 my $args = dump(@_);
1794 $args = '(' . $args . ')' if @_ < 2;
1795 my $stmt = $method . $args . q{;};
1797 warn qq|$class\->$stmt\n| if $self->debug;
1798 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1802 # generates the accompanying pod for a DBIC class method statement,
1803 # storing it with $self->_pod
1809 if ( $method eq 'table' ) {
1811 my $pcm = $self->pod_comment_mode;
1812 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1813 $comment = $self->__table_comment($table);
1814 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1815 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1816 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1817 $self->_pod( $class, "=head1 NAME" );
1818 my $table_descr = $class;
1819 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1820 $self->{_class2table}{ $class } = $table;
1821 $self->_pod( $class, $table_descr );
1822 if ($comment and $comment_in_desc) {
1823 $self->_pod( $class, "=head1 DESCRIPTION" );
1824 $self->_pod( $class, $comment );
1826 $self->_pod_cut( $class );
1827 } elsif ( $method eq 'add_columns' ) {
1828 $self->_pod( $class, "=head1 ACCESSORS" );
1829 my $col_counter = 0;
1831 while( my ($name,$attrs) = splice @cols,0,2 ) {
1833 $self->_pod( $class, '=head2 ' . $name );
1834 $self->_pod( $class,
1836 my $s = $attrs->{$_};
1837 $s = !defined $s ? 'undef' :
1838 length($s) == 0 ? '(empty string)' :
1839 ref($s) eq 'SCALAR' ? $$s :
1846 looks_like_number($s) ? $s :
1851 } sort keys %$attrs,
1854 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter)) {
1855 $self->_pod( $class, $comment );
1858 $self->_pod_cut( $class );
1859 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1860 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1861 my ( $accessor, $rel_class ) = @_;
1862 $self->_pod( $class, "=head2 $accessor" );
1863 $self->_pod( $class, 'Type: ' . $method );
1864 $self->_pod( $class, "Related object: L<$rel_class>" );
1865 $self->_pod_cut( $class );
1866 $self->{_relations_started} { $class } = 1;
1870 sub _filter_comment {
1871 my ($self, $txt) = @_;
1873 $txt = '' if not defined $txt;
1875 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1880 sub __table_comment {
1883 if (my $code = $self->can('_table_comment')) {
1884 return $self->_filter_comment($self->$code(@_));
1890 sub __column_comment {
1893 if (my $code = $self->can('_column_comment')) {
1894 return $self->_filter_comment($self->$code(@_));
1900 # Stores a POD documentation
1902 my ($self, $class, $stmt) = @_;
1903 $self->_raw_stmt( $class, "\n" . $stmt );
1907 my ($self, $class ) = @_;
1908 $self->_raw_stmt( $class, "\n=cut\n" );
1911 # Store a raw source line for a class (for dumping purposes)
1913 my ($self, $class, $stmt) = @_;
1914 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1917 # Like above, but separately for the externally loaded stuff
1919 my ($self, $class, $stmt) = @_;
1920 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1923 sub _quote_table_name {
1924 my ($self, $table) = @_;
1926 my $qt = $self->schema->storage->sql_maker->quote_char;
1928 return $table unless $qt;
1931 return $qt->[0] . $table . $qt->[1];
1934 return $qt . $table . $qt;
1937 sub _custom_column_info {
1938 my ( $self, $table_name, $column_name, $column_info ) = @_;
1940 if (my $code = $self->custom_column_info) {
1941 return $code->($table_name, $column_name, $column_info) || {};
1946 sub _datetime_column_info {
1947 my ( $self, $table_name, $column_name, $column_info ) = @_;
1949 my $type = $column_info->{data_type} || '';
1950 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
1951 or ($type =~ /date|timestamp/i)) {
1952 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
1953 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
1959 my ($self, $name) = @_;
1961 return $self->preserve_case ? $name : lc($name);
1965 my ($self, $name) = @_;
1967 return $self->preserve_case ? $name : uc($name);
1970 sub _unregister_source_for_table {
1971 my ($self, $table) = @_;
1975 my $schema = $self->schema;
1976 # in older DBIC it's a private method
1977 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
1978 $schema->$unregister($self->_table2moniker($table));
1979 delete $self->monikers->{$table};
1980 delete $self->classes->{$table};
1981 delete $self->_upgrading_classes->{$table};
1982 delete $self->{_tables}{$table};
1986 # remove the dump dir from @INC on destruction
1990 @INC = grep $_ ne $self->dump_directory, @INC;
1995 Returns a hashref of loaded table to moniker mappings. There will
1996 be two entries for each table, the original name and the "normalized"
1997 name, in the case that the two are different (such as databases
1998 that like uppercase table names, or preserve your original mixed-case
1999 definitions, or what-have-you).
2003 Returns a hashref of table to class mappings. In some cases it will
2004 contain multiple entries per table for the original and normalized table
2005 names, as above in L</monikers>.
2009 L<DBIx::Class::Schema::Loader>
2013 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2017 This library is free software; you can redistribute it and/or modify it under
2018 the same terms as Perl itself.
2023 # vim:et sts=4 sw=4 tw=0: