1 package DBIx::Class::Schema::Loader::Base;
5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use DBIx::Class::Schema::Loader::RelBuilder;
9 use Data::Dump qw/ dump /;
14 use Lingua::EN::Inflect::Number qw//;
15 use Lingua::EN::Inflect::Phrase qw//;
18 use Class::Inspector ();
19 use Scalar::Util 'looks_like_number';
20 use File::Slurp 'slurp';
21 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/;
22 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
27 our $VERSION = '0.07002';
29 __PACKAGE__->mk_group_ro_accessors('simple', qw/
36 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
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 => 0 },
266 use this to turn off DEFERRABLE on your foreign key constraints.
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::Phrase/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::Phrase/to_S>.
320 =head2 schema_base_class
322 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
324 =head2 result_base_class
326 Base class for your table classes (aka result classes). Defaults to
329 =head2 additional_base_classes
331 List of additional base classes all of your table classes will use.
333 =head2 left_base_classes
335 List of additional base classes all of your table classes will use
336 that need to be leftmost.
338 =head2 additional_classes
340 List of additional classes which all of your table classes will use.
344 List of additional components to be loaded into all of your table
345 classes. A good example would be
346 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
348 =head2 use_namespaces
350 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
353 Generate result class names suitable for
354 L<DBIx::Class::Schema/load_namespaces> and call that instead of
355 L<DBIx::Class::Schema/load_classes>. When using this option you can also
356 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
357 C<resultset_namespace>, C<default_resultset_class>), and they will be added
358 to the call (and the generated result class names adjusted appropriately).
360 =head2 dump_directory
362 The value of this option is a perl libdir pathname. Within
363 that directory this module will create a baseline manual
364 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
366 The created schema class will have the same classname as the one on
367 which you are setting this option (and the ResultSource classes will be
368 based on this name as well).
370 Normally you wouldn't hard-code this setting in your schema class, as it
371 is meant for one-time manual usage.
373 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
374 recommended way to access this functionality.
376 =head2 dump_overwrite
378 Deprecated. See L</really_erase_my_files> below, which does *not* mean
379 the same thing as the old C<dump_overwrite> setting from previous releases.
381 =head2 really_erase_my_files
383 Default false. If true, Loader will unconditionally delete any existing
384 files before creating the new ones from scratch when dumping a schema to disk.
386 The default behavior is instead to only replace the top portion of the
387 file, up to and including the final stanza which contains
388 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
389 leaving any customizations you placed after that as they were.
391 When C<really_erase_my_files> is not set, if the output file already exists,
392 but the aforementioned final stanza is not found, or the checksum
393 contained there does not match the generated contents, Loader will
394 croak and not touch the file.
396 You should really be using version control on your schema classes (and all
397 of the rest of your code for that matter). Don't blame me if a bug in this
398 code wipes something out when it shouldn't have, you've been warned.
400 =head2 overwrite_modifications
402 Default false. If false, when updating existing files, Loader will
403 refuse to modify any Loader-generated code that has been modified
404 since its last run (as determined by the checksum Loader put in its
407 If true, Loader will discard any manual modifications that have been
408 made to Loader-generated code.
410 Again, you should be using version control on your schema classes. Be
411 careful with this option.
413 =head2 custom_column_info
415 Hook for adding extra attributes to the
416 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
418 Must be a coderef that returns a hashref with the extra attributes.
420 Receives the table name, column name and column_info.
424 custom_column_info => sub {
425 my ($table_name, $column_name, $column_info) = @_;
427 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
428 return { is_snoopy => 1 };
432 This attribute can also be used to set C<inflate_datetime> on a non-datetime
433 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
435 =head2 datetime_timezone
437 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
438 columns with the DATE/DATETIME/TIMESTAMP data_types.
440 =head2 datetime_locale
442 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
443 columns with the DATE/DATETIME/TIMESTAMP data_types.
447 File in Perl format, which should return a HASH reference, from which to read
452 Usually column names are lowercased, to make them easier to work with in
453 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
456 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
457 case-sensitive collation will turn this option on unconditionally.
459 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
462 =head2 qualify_objects
464 Set to true to prepend the L</db_schema> to table names for C<<
465 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
469 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
470 L<namespace::autoclean>. The default content after the md5 sum also makes the
473 It is safe to upgrade your existing Schema to this option.
475 =head2 col_collision_map
477 This option controls how accessors for column names which collide with perl
478 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
480 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
481 strings which are compiled to regular expressions that map to
482 L<sprintf|perlfunc/sprintf> formats.
486 col_collision_map => 'column_%s'
488 col_collision_map => { '(.*)' => 'column_%s' }
490 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
494 None of these methods are intended for direct invocation by regular
495 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
496 L<DBIx::Class::Schema::Loader>.
500 my $CURRENT_V = 'v7';
503 schema_base_class result_base_class additional_base_classes
504 left_base_classes additional_classes components
507 # ensure that a peice of object data is a valid arrayref, creating
508 # an empty one or encapsulating whatever's there.
509 sub _ensure_arrayref {
514 $self->{$_} = [ $self->{$_} ]
515 unless ref $self->{$_} eq 'ARRAY';
521 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
522 by L<DBIx::Class::Schema::Loader>.
527 my ( $class, %args ) = @_;
529 my $self = { %args };
531 # don't lose undef options
532 for (values %$self) {
533 $_ = 0 unless defined $_;
536 bless $self => $class;
538 if (my $config_file = $self->config_file) {
539 my $config_opts = do $config_file;
541 croak "Error reading config from $config_file: $@" if $@;
543 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
545 while (my ($k, $v) = each %$config_opts) {
546 $self->{$k} = $v unless exists $self->{$k};
550 $self->_ensure_arrayref(qw/additional_classes
551 additional_base_classes
556 $self->_validate_class_args;
558 if ($self->use_moose) {
559 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
560 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
561 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
565 $self->{monikers} = {};
566 $self->{classes} = {};
567 $self->{_upgrading_classes} = {};
569 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
570 $self->{schema} ||= $self->{schema_class};
572 croak "dump_overwrite is deprecated. Please read the"
573 . " DBIx::Class::Schema::Loader::Base documentation"
574 if $self->{dump_overwrite};
576 $self->{dynamic} = ! $self->{dump_directory};
577 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
582 $self->{dump_directory} ||= $self->{temp_directory};
584 $self->real_dump_directory($self->{dump_directory});
586 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
587 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
589 if ((not ref $self->naming) && defined $self->naming) {
590 my $naming_ver = $self->naming;
592 relationships => $naming_ver,
593 monikers => $naming_ver,
594 column_accessors => $naming_ver,
599 for (values %{ $self->naming }) {
600 $_ = $CURRENT_V if $_ eq 'current';
603 $self->{naming} ||= {};
605 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
606 croak 'custom_column_info must be a CODE ref';
609 $self->_check_back_compat;
611 $self->use_namespaces(1) unless defined $self->use_namespaces;
612 $self->generate_pod(1) unless defined $self->generate_pod;
613 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
614 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
616 if (my $col_collision_map = $self->col_collision_map) {
617 if (my $reftype = ref $col_collision_map) {
618 if ($reftype ne 'HASH') {
619 croak "Invalid type $reftype for option 'col_collision_map'";
623 $self->col_collision_map({ '(.*)' => $col_collision_map });
630 sub _check_back_compat {
633 # dynamic schemas will always be in 0.04006 mode, unless overridden
634 if ($self->dynamic) {
635 # just in case, though no one is likely to dump a dynamic schema
636 $self->schema_version_to_dump('0.04006');
638 if (not %{ $self->naming }) {
639 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
641 Dynamic schema detected, will run in 0.04006 mode.
643 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
644 to disable this warning.
646 Also consider setting 'use_namespaces => 1' if/when upgrading.
648 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
653 $self->_upgrading_from('v4');
656 $self->naming->{relationships} ||= 'v4';
657 $self->naming->{monikers} ||= 'v4';
659 if ($self->use_namespaces) {
660 $self->_upgrading_from_load_classes(1);
663 $self->use_namespaces(0);
669 # otherwise check if we need backcompat mode for a static schema
670 my $filename = $self->_get_dump_filename($self->schema_class);
671 return unless -e $filename;
673 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
674 $self->_parse_generated_file($filename);
676 return unless $old_ver;
678 # determine if the existing schema was dumped with use_moose => 1
679 if (! defined $self->use_moose) {
680 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
683 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
684 my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
686 if ($load_classes && (not defined $self->use_namespaces)) {
687 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
689 'load_classes;' static schema detected, turning off 'use_namespaces'.
691 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
692 variable to disable this warning.
694 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
697 $self->use_namespaces(0);
699 elsif ($load_classes && $self->use_namespaces) {
700 $self->_upgrading_from_load_classes(1);
702 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
703 $self->_downgrading_to_load_classes(
704 $result_namespace || 'Result'
707 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
708 if (not $self->result_namespace) {
709 $self->result_namespace($result_namespace || 'Result');
711 elsif ($result_namespace ne $self->result_namespace) {
712 $self->_rewriting_result_namespace(
713 $result_namespace || 'Result'
718 # XXX when we go past .0 this will need fixing
719 my ($v) = $old_ver =~ /([1-9])/;
722 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
724 if (not %{ $self->naming }) {
725 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
727 Version $old_ver static schema detected, turning on backcompat mode.
729 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
730 to disable this warning.
732 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
734 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
735 from version 0.04006.
738 $self->naming->{relationships} ||= $v;
739 $self->naming->{monikers} ||= $v;
740 $self->naming->{column_accessors} ||= $v;
742 $self->schema_version_to_dump($old_ver);
745 $self->_upgrading_from($v);
749 sub _validate_class_args {
753 foreach my $k (@CLASS_ARGS) {
754 next unless $self->$k;
756 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
757 foreach my $c (@classes) {
758 # components default to being under the DBIx::Class namespace unless they
759 # are preceeded with a '+'
760 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
761 $c = 'DBIx::Class::' . $c;
764 # 1 == installed, 0 == not installed, undef == invalid classname
765 my $installed = Class::Inspector->installed($c);
766 if ( defined($installed) ) {
767 if ( $installed == 0 ) {
768 croak qq/$c, as specified in the loader option "$k", is not installed/;
771 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
777 sub _find_file_in_inc {
778 my ($self, $file) = @_;
780 foreach my $prefix (@INC) {
781 my $fullpath = File::Spec->catfile($prefix, $file);
782 return $fullpath if -f $fullpath
783 # abs_path throws on Windows for nonexistant files
784 and (try { Cwd::abs_path($fullpath) }) ne
785 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
792 my ($self, $class) = @_;
794 my $class_path = $class;
795 $class_path =~ s{::}{/}g;
796 $class_path .= '.pm';
801 sub _find_class_in_inc {
802 my ($self, $class) = @_;
804 return $self->_find_file_in_inc($self->_class_path($class));
810 return $self->_upgrading_from
811 || $self->_upgrading_from_load_classes
812 || $self->_downgrading_to_load_classes
813 || $self->_rewriting_result_namespace
817 sub _rewrite_old_classnames {
818 my ($self, $code) = @_;
820 return $code unless $self->_rewriting;
822 my %old_classes = reverse %{ $self->_upgrading_classes };
824 my $re = join '|', keys %old_classes;
827 $code =~ s/$re/$old_classes{$1} || $1/eg;
833 my ($self, $class) = @_;
835 return if $self->{skip_load_external};
837 # so that we don't load our own classes, under any circumstances
838 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
840 my $real_inc_path = $self->_find_class_in_inc($class);
842 my $old_class = $self->_upgrading_classes->{$class}
843 if $self->_rewriting;
845 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
846 if $old_class && $old_class ne $class;
848 return unless $real_inc_path || $old_real_inc_path;
850 if ($real_inc_path) {
851 # If we make it to here, we loaded an external definition
852 warn qq/# Loaded external class definition for '$class'\n/
855 my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
857 if ($self->dynamic) { # load the class too
858 eval_without_redefine_warnings($code);
861 $self->_ext_stmt($class,
862 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
863 .qq|# They are now part of the custom portion of this file\n|
864 .qq|# for you to hand-edit. If you do not either delete\n|
865 .qq|# this section or remove that file from \@INC, this section\n|
866 .qq|# will be repeated redundantly when you re-create this\n|
867 .qq|# file again via Loader! See skip_load_external to disable\n|
868 .qq|# this feature.\n|
871 $self->_ext_stmt($class, $code);
872 $self->_ext_stmt($class,
873 qq|# End of lines loaded from '$real_inc_path' |
877 if ($old_real_inc_path) {
878 my $code = slurp $old_real_inc_path;
880 $self->_ext_stmt($class, <<"EOF");
882 # These lines were loaded from '$old_real_inc_path',
883 # based on the Result class name that would have been created by an older
884 # version of the Loader. For a static schema, this happens only once during
885 # upgrade. See skip_load_external to disable this feature.
888 $code = $self->_rewrite_old_classnames($code);
890 if ($self->dynamic) {
893 Detected external content in '$old_real_inc_path', a class name that would have
894 been used by an older version of the Loader.
896 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
897 new name of the Result.
899 eval_without_redefine_warnings($code);
903 $self->_ext_stmt($class, $code);
904 $self->_ext_stmt($class,
905 qq|# End of lines loaded from '$old_real_inc_path' |
912 Does the actual schema-construction work.
920 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
928 Rescan the database for changes. Returns a list of the newly added table
931 The schema argument should be the schema class or object to be affected. It
932 should probably be derived from the original schema_class used during L</load>.
937 my ($self, $schema) = @_;
939 $self->{schema} = $schema;
940 $self->_relbuilder->{schema} = $schema;
943 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
945 foreach my $table (@current) {
946 if(!exists $self->{_tables}->{$table}) {
947 push(@created, $table);
952 @current{@current} = ();
953 foreach my $table (keys %{ $self->{_tables} }) {
954 if (not exists $current{$table}) {
955 $self->_unregister_source_for_table($table);
959 delete $self->{_dump_storage};
960 delete $self->{_relations_started};
962 my $loaded = $self->_load_tables(@current);
964 return map { $self->monikers->{$_} } @created;
970 return if $self->{skip_relationships};
972 return $self->{relbuilder} ||= do {
974 no warnings 'uninitialized';
975 my $relbuilder_suff =
981 ->{ $self->naming->{relationships}};
983 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
984 eval "require $relbuilder_class"; die $@ if $@;
985 $relbuilder_class->new( $self );
991 my ($self, @tables) = @_;
993 # Save the new tables to the tables list
995 $self->{_tables}->{$_} = 1;
998 $self->_make_src_class($_) for @tables;
1000 # sanity-check for moniker clashes
1001 my $inverse_moniker_idx;
1002 for (keys %{$self->monikers}) {
1003 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1007 for (keys %$inverse_moniker_idx) {
1008 my $tables = $inverse_moniker_idx->{$_};
1010 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1011 join (', ', map { "'$_'" } @$tables),
1018 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1019 . 'Either change the naming style, or supply an explicit moniker_map: '
1020 . join ('; ', @clashes)
1026 $self->_setup_src_meta($_) for @tables;
1028 if(!$self->skip_relationships) {
1029 # The relationship loader needs a working schema
1031 local $self->{dump_directory} = $self->{temp_directory};
1032 $self->_reload_classes(\@tables);
1033 $self->_load_relationships($_) for @tables;
1034 $self->_relbuilder->cleanup;
1037 # Remove that temp dir from INC so it doesn't get reloaded
1038 @INC = grep $_ ne $self->dump_directory, @INC;
1041 $self->_load_external($_)
1042 for map { $self->classes->{$_} } @tables;
1044 # Reload without unloading first to preserve any symbols from external
1046 $self->_reload_classes(\@tables, { unload => 0 });
1048 # Drop temporary cache
1049 delete $self->{_cache};
1054 sub _reload_classes {
1055 my ($self, $tables, $opts) = @_;
1057 my @tables = @$tables;
1059 my $unload = $opts->{unload};
1060 $unload = 1 unless defined $unload;
1062 # so that we don't repeat custom sections
1063 @INC = grep $_ ne $self->dump_directory, @INC;
1065 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1067 unshift @INC, $self->dump_directory;
1070 my %have_source = map { $_ => $self->schema->source($_) }
1071 $self->schema->sources;
1073 for my $table (@tables) {
1074 my $moniker = $self->monikers->{$table};
1075 my $class = $self->classes->{$table};
1078 no warnings 'redefine';
1079 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1082 if (my $mc = $self->_moose_metaclass($class)) {
1085 Class::Unload->unload($class) if $unload;
1086 my ($source, $resultset_class);
1088 ($source = $have_source{$moniker})
1089 && ($resultset_class = $source->resultset_class)
1090 && ($resultset_class ne 'DBIx::Class::ResultSet')
1092 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1093 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1096 Class::Unload->unload($resultset_class) if $unload;
1097 $self->_reload_class($resultset_class) if $has_file;
1099 $self->_reload_class($class);
1101 push @to_register, [$moniker, $class];
1104 Class::C3->reinitialize;
1105 for (@to_register) {
1106 $self->schema->register_class(@$_);
1110 sub _moose_metaclass {
1111 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1115 my $mc = try { Class::MOP::class_of($class) }
1118 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1121 # We use this instead of ensure_class_loaded when there are package symbols we
1124 my ($self, $class) = @_;
1126 my $class_path = $self->_class_path($class);
1127 delete $INC{ $class_path };
1129 # kill redefined warnings
1131 eval_without_redefine_warnings ("require $class");
1134 die "Failed to reload class $class: $_";
1138 sub _get_dump_filename {
1139 my ($self, $class) = (@_);
1141 $class =~ s{::}{/}g;
1142 return $self->dump_directory . q{/} . $class . q{.pm};
1145 =head2 get_dump_filename
1149 Returns the full path to the file for a class that the class has been or will
1150 be dumped to. This is a file in a temp dir for a dynamic schema.
1154 sub get_dump_filename {
1155 my ($self, $class) = (@_);
1157 local $self->{dump_directory} = $self->real_dump_directory;
1159 return $self->_get_dump_filename($class);
1162 sub _ensure_dump_subdirs {
1163 my ($self, $class) = (@_);
1165 my @name_parts = split(/::/, $class);
1166 pop @name_parts; # we don't care about the very last element,
1167 # which is a filename
1169 my $dir = $self->dump_directory;
1172 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1174 last if !@name_parts;
1175 $dir = File::Spec->catdir($dir, shift @name_parts);
1180 my ($self, @classes) = @_;
1182 my $schema_class = $self->schema_class;
1183 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1185 my $target_dir = $self->dump_directory;
1186 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1187 unless $self->{dynamic} or $self->{quiet};
1190 qq|package $schema_class;\n\n|
1191 . qq|# Created by DBIx::Class::Schema::Loader\n|
1192 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1194 if ($self->use_moose) {
1195 $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1198 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1201 if ($self->use_namespaces) {
1202 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1203 my $namespace_options;
1205 my @attr = qw/resultset_namespace default_resultset_class/;
1207 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1209 for my $attr (@attr) {
1211 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1214 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1215 $schema_text .= qq|;\n|;
1218 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1222 local $self->{version_to_dump} = $self->schema_version_to_dump;
1223 $self->_write_classfile($schema_class, $schema_text, 1);
1226 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1228 foreach my $src_class (@classes) {
1230 qq|package $src_class;\n\n|
1231 . qq|# Created by DBIx::Class::Schema::Loader\n|
1232 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1233 . qq|use strict;\nuse warnings;\n\n|;
1234 if ($self->use_moose) {
1235 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1237 # these options 'use base' which is compile time
1238 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1239 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1242 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1246 $src_text .= qq|use base '$result_base_class';\n\n|;
1248 $self->_write_classfile($src_class, $src_text);
1251 # remove Result dir if downgrading from use_namespaces, and there are no
1253 if (my $result_ns = $self->_downgrading_to_load_classes
1254 || $self->_rewriting_result_namespace) {
1255 my $result_namespace = $self->_result_namespace(
1260 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1261 $result_dir = $self->dump_directory . '/' . $result_dir;
1263 unless (my @files = glob "$result_dir/*") {
1268 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1273 my ($self, $version, $ts) = @_;
1274 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1277 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1280 sub _write_classfile {
1281 my ($self, $class, $text, $is_schema) = @_;
1283 my $filename = $self->_get_dump_filename($class);
1284 $self->_ensure_dump_subdirs($class);
1286 if (-f $filename && $self->really_erase_my_files) {
1287 warn "Deleting existing file '$filename' due to "
1288 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1292 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1293 = $self->_parse_generated_file($filename);
1295 if (! $old_gen && -f $filename) {
1296 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1297 . " it does not appear to have been generated by Loader"
1300 my $custom_content = $old_custom || '';
1302 # prepend extra custom content from a *renamed* class (singularization effect)
1303 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1304 my $old_filename = $self->_get_dump_filename($renamed_class);
1306 if (-f $old_filename) {
1307 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1309 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1311 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1314 unlink $old_filename;
1318 $custom_content ||= $self->_default_custom_content;
1320 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1321 # If there is already custom content, which does not have the Moose content, add it.
1322 if ($self->use_moose) {
1324 my $non_moose_custom_content = do {
1325 local $self->{use_moose} = 0;
1326 $self->_default_custom_content;
1329 if ($custom_content eq $non_moose_custom_content) {
1330 $custom_content = $self->_default_custom_content;
1332 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1333 $custom_content .= $self->_default_custom_content;
1336 elsif (defined $self->use_moose && $old_gen) {
1337 croak 'It is not possible to "downgrade" a schema that was loaded with use_moose => 1 to use_moose => 0, due to differing custom content'
1338 if $old_gen =~ /use \s+ MooseX?\b/x;
1341 $custom_content = $self->_rewrite_old_classnames($custom_content);
1344 for @{$self->{_dump_storage}->{$class} || []};
1346 # Check and see if the dump is infact differnt
1350 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1351 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1352 return unless $self->_upgrading_from && $is_schema;
1356 $text .= $self->_sig_comment(
1357 $self->version_to_dump,
1358 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1361 open(my $fh, '>', $filename)
1362 or croak "Cannot open '$filename' for writing: $!";
1364 # Write the top half and its MD5 sum
1365 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1367 # Write out anything loaded via external partial class file in @INC
1369 for @{$self->{_ext_storage}->{$class} || []};
1371 # Write out any custom content the user has added
1372 print $fh $custom_content;
1375 or croak "Error closing '$filename': $!";
1378 sub _default_moose_custom_content {
1379 return qq|\n__PACKAGE__->meta->make_immutable;|;
1382 sub _default_custom_content {
1384 my $default = qq|\n\n# You can replace this text with custom|
1385 . qq| code or comments, and it will be preserved on regeneration|;
1386 if ($self->use_moose) {
1387 $default .= $self->_default_moose_custom_content;
1389 $default .= qq|\n1;\n|;
1393 sub _parse_generated_file {
1394 my ($self, $fn) = @_;
1396 return unless -f $fn;
1398 open(my $fh, '<', $fn)
1399 or croak "Cannot open '$fn' for reading: $!";
1402 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1404 my ($md5, $ts, $ver, $gen);
1410 # Pull out the version and timestamp from the line above
1411 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1414 croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader. Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
1415 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1424 my $custom = do { local $/; <$fh> }
1429 return ($gen, $md5, $ver, $ts, $custom);
1437 warn "$target: use $_;" if $self->debug;
1438 $self->_raw_stmt($target, "use $_;");
1446 my $blist = join(q{ }, @_);
1448 return unless $blist;
1450 warn "$target: use base qw/$blist/;" if $self->debug;
1451 $self->_raw_stmt($target, "use base qw/$blist/;");
1454 sub _result_namespace {
1455 my ($self, $schema_class, $ns) = @_;
1456 my @result_namespace;
1458 if ($ns =~ /^\+(.*)/) {
1459 # Fully qualified namespace
1460 @result_namespace = ($1)
1463 # Relative namespace
1464 @result_namespace = ($schema_class, $ns);
1467 return wantarray ? @result_namespace : join '::', @result_namespace;
1470 # Create class with applicable bases, setup monikers, etc
1471 sub _make_src_class {
1472 my ($self, $table) = @_;
1474 my $schema = $self->schema;
1475 my $schema_class = $self->schema_class;
1477 my $table_moniker = $self->_table2moniker($table);
1478 my @result_namespace = ($schema_class);
1479 if ($self->use_namespaces) {
1480 my $result_namespace = $self->result_namespace || 'Result';
1481 @result_namespace = $self->_result_namespace(
1486 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1488 if ((my $upgrading_v = $self->_upgrading_from)
1489 || $self->_rewriting) {
1490 local $self->naming->{monikers} = $upgrading_v
1493 my @result_namespace = @result_namespace;
1494 if ($self->_upgrading_from_load_classes) {
1495 @result_namespace = ($schema_class);
1497 elsif (my $ns = $self->_downgrading_to_load_classes) {
1498 @result_namespace = $self->_result_namespace(
1503 elsif ($ns = $self->_rewriting_result_namespace) {
1504 @result_namespace = $self->_result_namespace(
1510 my $old_class = join(q{::}, @result_namespace,
1511 $self->_table2moniker($table));
1513 $self->_upgrading_classes->{$table_class} = $old_class
1514 unless $table_class eq $old_class;
1517 # this was a bad idea, should be ok now without it
1518 # my $table_normalized = lc $table;
1519 # $self->classes->{$table_normalized} = $table_class;
1520 # $self->monikers->{$table_normalized} = $table_moniker;
1522 $self->classes->{$table} = $table_class;
1523 $self->monikers->{$table} = $table_moniker;
1525 $self->_use ($table_class, @{$self->additional_classes});
1526 $self->_inject($table_class, @{$self->left_base_classes});
1528 if (my @components = @{ $self->components }) {
1529 $self->_dbic_stmt($table_class, 'load_components', @components);
1532 $self->_inject($table_class, @{$self->additional_base_classes});
1535 sub _resolve_col_accessor_collisions {
1536 my ($self, $table, $col_info) = @_;
1538 my $base = $self->result_base_class || 'DBIx::Class::Core';
1539 my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1541 my $table_name = ref $table ? $$table : $table;
1545 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1546 eval "require ${class};";
1549 push @methods, @{ Class::Inspector->methods($class) || [] };
1550 push @methods, @{ Class::Inspector->methods('UNIVERSAL') || [] };
1554 @methods{@methods} = ();
1557 $methods{meta} = undef;
1559 while (my ($col, $info) = each %$col_info) {
1560 my $accessor = $info->{accessor} || $col;
1562 next if $accessor eq 'id'; # special case (very common column)
1564 if (exists $methods{$accessor}) {
1567 if (my $map = $self->col_collision_map) {
1568 for my $re (keys %$map) {
1569 if (my @matches = $col =~ /$re/) {
1570 $info->{accessor} = sprintf $map->{$re}, @matches;
1578 Column $col in table $table_name collides with an inherited method.
1579 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1581 $info->{accessor} = undef;
1587 sub _make_column_accessor_name {
1588 my ($self, $column_name) = @_;
1590 return join '_', map lc, split_name $column_name;
1593 # Set up metadata (cols, pks, etc)
1594 sub _setup_src_meta {
1595 my ($self, $table) = @_;
1597 my $schema = $self->schema;
1598 my $schema_class = $self->schema_class;
1600 my $table_class = $self->classes->{$table};
1601 my $table_moniker = $self->monikers->{$table};
1603 my $table_name = $table;
1604 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1606 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1607 $table_name = \ $self->_quote_table_name($table_name);
1610 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1612 # be careful to not create refs Data::Dump can "optimize"
1613 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1615 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1617 my $cols = $self->_table_columns($table);
1618 my $col_info = $self->__columns_info_for($table);
1620 while (my ($col, $info) = each %$col_info) {
1622 ($info->{accessor} = $col) =~ s/\W+/_/g;
1626 if ($self->preserve_case) {
1627 while (my ($col, $info) = each %$col_info) {
1628 if ($col ne lc($col)) {
1629 if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
1630 $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
1633 $info->{accessor} = lc($info->{accessor} || $col);
1639 # XXX this needs to go away
1640 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1643 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1645 my $fks = $self->_table_fk_info($table);
1647 foreach my $fkdef (@$fks) {
1648 for my $col (@{ $fkdef->{local_columns} }) {
1649 $col_info->{$col}{is_foreign_key} = 1;
1653 my $pks = $self->_table_pk_info($table) || [];
1655 foreach my $pkcol (@$pks) {
1656 $col_info->{$pkcol}{is_nullable} = 0;
1662 map { $_, ($col_info->{$_}||{}) } @$cols
1665 my %uniq_tag; # used to eliminate duplicate uniqs
1667 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1668 : carp("$table has no primary key");
1669 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1671 my $uniqs = $self->_table_uniq_info($table) || [];
1673 my ($name, $cols) = @$_;
1674 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1675 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1680 sub __columns_info_for {
1681 my ($self, $table) = @_;
1683 my $result = $self->_columns_info_for($table);
1685 while (my ($col, $info) = each %$result) {
1686 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1687 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1689 $result->{$col} = $info;
1697 Returns a sorted list of loaded tables, using the original database table
1705 return keys %{$self->_tables};
1708 # Make a moniker from a table
1709 sub _default_table2moniker {
1710 no warnings 'uninitialized';
1711 my ($self, $table) = @_;
1713 if ($self->naming->{monikers} eq 'v4') {
1714 return join '', map ucfirst, split /[\W_]+/, lc $table;
1716 elsif ($self->naming->{monikers} eq 'v5') {
1717 return join '', map ucfirst, split /[\W_]+/,
1718 Lingua::EN::Inflect::Number::to_S(lc $table);
1720 elsif ($self->naming->{monikers} eq 'v6') {
1721 (my $as_phrase = lc $table) =~ s/_+/ /g;
1722 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1724 return join '', map ucfirst, split /\W+/, $inflected;
1727 my @words = map lc, split_name $table;
1728 my $as_phrase = join ' ', @words;
1730 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1732 return join '', map ucfirst, split /\W+/, $inflected;
1735 sub _table2moniker {
1736 my ( $self, $table ) = @_;
1740 if( ref $self->moniker_map eq 'HASH' ) {
1741 $moniker = $self->moniker_map->{$table};
1743 elsif( ref $self->moniker_map eq 'CODE' ) {
1744 $moniker = $self->moniker_map->($table);
1747 $moniker ||= $self->_default_table2moniker($table);
1752 sub _load_relationships {
1753 my ($self, $table) = @_;
1755 my $tbl_fk_info = $self->_table_fk_info($table);
1756 foreach my $fkdef (@$tbl_fk_info) {
1757 $fkdef->{remote_source} =
1758 $self->monikers->{delete $fkdef->{remote_table}};
1760 my $tbl_uniq_info = $self->_table_uniq_info($table);
1762 my $local_moniker = $self->monikers->{$table};
1763 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1765 foreach my $src_class (sort keys %$rel_stmts) {
1766 my $src_stmts = $rel_stmts->{$src_class};
1767 foreach my $stmt (@$src_stmts) {
1768 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1773 # Overload these in driver class:
1775 # Returns an arrayref of column names
1776 sub _table_columns { croak "ABSTRACT METHOD" }
1778 # Returns arrayref of pk col names
1779 sub _table_pk_info { croak "ABSTRACT METHOD" }
1781 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1782 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1784 # Returns an arrayref of foreign key constraints, each
1785 # being a hashref with 3 keys:
1786 # local_columns (arrayref), remote_columns (arrayref), remote_table
1787 sub _table_fk_info { croak "ABSTRACT METHOD" }
1789 # Returns an array of lower case table names
1790 sub _tables_list { croak "ABSTRACT METHOD" }
1792 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1798 # generate the pod for this statement, storing it with $self->_pod
1799 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1801 my $args = dump(@_);
1802 $args = '(' . $args . ')' if @_ < 2;
1803 my $stmt = $method . $args . q{;};
1805 warn qq|$class\->$stmt\n| if $self->debug;
1806 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1810 # generates the accompanying pod for a DBIC class method statement,
1811 # storing it with $self->_pod
1817 if ( $method eq 'table' ) {
1819 my $pcm = $self->pod_comment_mode;
1820 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1821 $comment = $self->__table_comment($table);
1822 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1823 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1824 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1825 $self->_pod( $class, "=head1 NAME" );
1826 my $table_descr = $class;
1827 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1828 $self->{_class2table}{ $class } = $table;
1829 $self->_pod( $class, $table_descr );
1830 if ($comment and $comment_in_desc) {
1831 $self->_pod( $class, "=head1 DESCRIPTION" );
1832 $self->_pod( $class, $comment );
1834 $self->_pod_cut( $class );
1835 } elsif ( $method eq 'add_columns' ) {
1836 $self->_pod( $class, "=head1 ACCESSORS" );
1837 my $col_counter = 0;
1839 while( my ($name,$attrs) = splice @cols,0,2 ) {
1841 $self->_pod( $class, '=head2 ' . $name );
1842 $self->_pod( $class,
1844 my $s = $attrs->{$_};
1845 $s = !defined $s ? 'undef' :
1846 length($s) == 0 ? '(empty string)' :
1847 ref($s) eq 'SCALAR' ? $$s :
1848 ref($s) ? dumper_squashed $s :
1849 looks_like_number($s) ? $s : qq{'$s'};
1852 } sort keys %$attrs,
1854 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
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>.
2007 =head1 COLUMN ACCESSOR COLLISIONS
2009 Occasionally you may have a column name that collides with a perl method, such
2010 as C<can>. In such cases, the default action is to set the C<accessor> of the
2011 column spec to C<undef>.
2013 You can then name the accessor yourself by placing code such as the following
2016 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2018 Another option is to use the L</col_collision_map> option.
2022 L<DBIx::Class::Schema::Loader>
2026 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2030 This library is free software; you can redistribute it and/or modify it under
2031 the same terms as Perl itself.
2036 # vim:et sts=4 sw=4 tw=0: