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
51 default_resultset_class
55 overwrite_modifications
74 __PACKAGE__->mk_group_accessors('simple', qw/
76 schema_version_to_dump
78 _upgrading_from_load_classes
79 _downgrading_to_load_classes
80 _rewriting_result_namespace
85 pod_comment_spillover_length
93 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
97 See L<DBIx::Class::Schema::Loader>
101 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
102 classes, and implements the common functionality between them.
104 =head1 CONSTRUCTOR OPTIONS
106 These constructor options are the base options for
107 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
109 =head2 skip_relationships
111 Skip setting up relationships. The default is to attempt the loading
114 =head2 skip_load_external
116 Skip loading of other classes in @INC. The default is to merge all other classes
117 with the same name found in @INC into the schema file we are creating.
121 Static schemas (ones dumped to disk) will, by default, use the new-style
122 relationship names and singularized Results, unless you're overwriting an
123 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
124 which case the backward compatible RelBuilder will be activated, and the
125 appropriate monikerization used.
131 will disable the backward-compatible RelBuilder and use
132 the new-style relationship names along with singularized Results, even when
133 overwriting a dump made with an earlier version.
135 The option also takes a hashref:
137 naming => { relationships => 'v7', monikers => 'v7' }
145 How to name relationship accessors.
149 How to name Result classes.
151 =item column_accessors
153 How to name column accessors in Result classes.
163 Latest style, whatever that happens to be.
167 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
171 Monikers singularized as whole words, C<might_have> relationships for FKs on
172 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
174 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
179 All monikers and relationships are inflected using
180 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
181 from relationship names.
183 In general, there is very little difference between v5 and v6 schemas.
187 This mode is identical to C<v6> mode, except that monikerization of CamelCase
188 table names is also done correctly.
190 CamelCase column names in case-preserving mode will also be handled correctly
191 for relationship name inflection. See L</preserve_case>.
193 In this mode, CamelCase L</column_accessors> are normalized based on case
194 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
196 If you don't have any CamelCase table or column names, you can upgrade without
197 breaking any of your code.
201 Dynamic schemas will always default to the 0.04XXX relationship names and won't
202 singularize Results for backward compatibility, to activate the new RelBuilder
203 and singularization put this in your C<Schema.pm> file:
205 __PACKAGE__->naming('current');
207 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
208 next major version upgrade:
210 __PACKAGE__->naming('v7');
214 By default POD will be generated for columns and relationships, using database
215 metadata for the text if available and supported.
217 Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
218 supported for Postgres right now.
220 Set this to C<0> to turn off all POD generation.
222 =head2 pod_comment_mode
224 Controls where table comments appear in the generated POD. Smaller table
225 comments are appended to the C<NAME> section of the documentation, and larger
226 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
227 section to be generated with the comment always, only use C<NAME>, or choose
228 the length threshold at which the comment is forced into the description.
234 Use C<NAME> section only.
238 Force C<DESCRIPTION> always.
242 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
247 =head2 pod_comment_spillover_length
249 When pod_comment_mode is set to C<auto>, this is the length of the comment at
250 which it will be forced into a separate description section.
254 =head2 relationship_attrs
256 Hashref of attributes to pass to each generated relationship, listed
257 by type. Also supports relationship type 'all', containing options to
258 pass to all generated relationships. Attributes set for more specific
259 relationship types override those set in 'all'.
263 relationship_attrs => {
264 belongs_to => { is_deferrable => 0 },
267 use this to turn off DEFERRABLE on your foreign key constraints.
271 If set to true, each constructive L<DBIx::Class> statement the loader
272 decides to execute will be C<warn>-ed before execution.
276 Set the name of the schema to load (schema in the sense that your database
277 vendor means it). Does not currently support loading more than one schema
282 Only load tables matching regex. Best specified as a qr// regex.
286 Exclude tables matching regex. Best specified as a qr// regex.
290 Overrides the default table name to moniker translation. Can be either
291 a hashref of table keys and moniker values, or a coderef for a translator
292 function taking a single scalar table name argument and returning
293 a scalar moniker. If the hash entry does not exist, or the function
294 returns a false value, the code falls back to default behavior
297 The default behavior is to split on case transition and non-alphanumeric
298 boundaries, singularize the resulting phrase, then join the titlecased words
301 Table Name | Moniker Name
302 ---------------------------------
304 luser_group | LuserGroup
305 luser-opts | LuserOpt
306 stations_visited | StationVisited
307 routeChange | RouteChange
309 =head2 column_accessor_map
311 Same as moniker_map, but for column accessor names. If a coderef is
312 passed, the code is called with arguments of
314 the name of the column in the underlying database,
315 default accessor name that DBICSL would ordinarily give this column,
317 table_class => name of the DBIC class we are building,
318 table_moniker => calculated moniker for this table (after moniker_map if present),
319 table_name => name of the database table,
320 full_table_name => schema-qualified name of the database table (RDBMS specific),
321 schema_class => name of the schema class we are building,
322 column_info => hashref of column info (data_type, is_nullable, etc),
325 =head2 inflect_plural
327 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
328 if hash key does not exist or coderef returns false), but acts as a map
329 for pluralizing relationship names. The default behavior is to utilize
330 L<Lingua::EN::Inflect::Phrase/to_PL>.
332 =head2 inflect_singular
334 As L</inflect_plural> above, but for singularizing relationship names.
335 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
337 =head2 schema_base_class
339 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
341 =head2 result_base_class
343 Base class for your table classes (aka result classes). Defaults to
346 =head2 additional_base_classes
348 List of additional base classes all of your table classes will use.
350 =head2 left_base_classes
352 List of additional base classes all of your table classes will use
353 that need to be leftmost.
355 =head2 additional_classes
357 List of additional classes which all of your table classes will use.
361 List of additional components to be loaded into all of your table
362 classes. A good example would be
363 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
365 =head2 use_namespaces
367 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
370 Generate result class names suitable for
371 L<DBIx::Class::Schema/load_namespaces> and call that instead of
372 L<DBIx::Class::Schema/load_classes>. When using this option you can also
373 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
374 C<resultset_namespace>, C<default_resultset_class>), and they will be added
375 to the call (and the generated result class names adjusted appropriately).
377 =head2 dump_directory
379 The value of this option is a perl libdir pathname. Within
380 that directory this module will create a baseline manual
381 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
383 The created schema class will have the same classname as the one on
384 which you are setting this option (and the ResultSource classes will be
385 based on this name as well).
387 Normally you wouldn't hard-code this setting in your schema class, as it
388 is meant for one-time manual usage.
390 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
391 recommended way to access this functionality.
393 =head2 dump_overwrite
395 Deprecated. See L</really_erase_my_files> below, which does *not* mean
396 the same thing as the old C<dump_overwrite> setting from previous releases.
398 =head2 really_erase_my_files
400 Default false. If true, Loader will unconditionally delete any existing
401 files before creating the new ones from scratch when dumping a schema to disk.
403 The default behavior is instead to only replace the top portion of the
404 file, up to and including the final stanza which contains
405 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
406 leaving any customizations you placed after that as they were.
408 When C<really_erase_my_files> is not set, if the output file already exists,
409 but the aforementioned final stanza is not found, or the checksum
410 contained there does not match the generated contents, Loader will
411 croak and not touch the file.
413 You should really be using version control on your schema classes (and all
414 of the rest of your code for that matter). Don't blame me if a bug in this
415 code wipes something out when it shouldn't have, you've been warned.
417 =head2 overwrite_modifications
419 Default false. If false, when updating existing files, Loader will
420 refuse to modify any Loader-generated code that has been modified
421 since its last run (as determined by the checksum Loader put in its
424 If true, Loader will discard any manual modifications that have been
425 made to Loader-generated code.
427 Again, you should be using version control on your schema classes. Be
428 careful with this option.
430 =head2 custom_column_info
432 Hook for adding extra attributes to the
433 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
435 Must be a coderef that returns a hashref with the extra attributes.
437 Receives the table name, column name and column_info.
441 custom_column_info => sub {
442 my ($table_name, $column_name, $column_info) = @_;
444 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
445 return { is_snoopy => 1 };
449 This attribute can also be used to set C<inflate_datetime> on a non-datetime
450 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
452 =head2 datetime_timezone
454 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
455 columns with the DATE/DATETIME/TIMESTAMP data_types.
457 =head2 datetime_locale
459 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
460 columns with the DATE/DATETIME/TIMESTAMP data_types.
464 File in Perl format, which should return a HASH reference, from which to read
469 Usually column names are lowercased, to make them easier to work with in
470 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
473 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
474 case-sensitive collation will turn this option on unconditionally.
476 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
479 =head2 qualify_objects
481 Set to true to prepend the L</db_schema> to table names for C<<
482 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
486 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
487 L<namespace::autoclean>. The default content after the md5 sum also makes the
490 It is safe to upgrade your existing Schema to this option.
492 =head2 col_collision_map
494 This option controls how accessors for column names which collide with perl
495 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
497 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
498 strings which are compiled to regular expressions that map to
499 L<sprintf|perlfunc/sprintf> formats.
503 col_collision_map => 'column_%s'
505 col_collision_map => { '(.*)' => 'column_%s' }
507 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
511 None of these methods are intended for direct invocation by regular
512 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
513 L<DBIx::Class::Schema::Loader>.
517 my $CURRENT_V = 'v7';
520 schema_base_class result_base_class additional_base_classes
521 left_base_classes additional_classes components
524 # ensure that a peice of object data is a valid arrayref, creating
525 # an empty one or encapsulating whatever's there.
526 sub _ensure_arrayref {
531 $self->{$_} = [ $self->{$_} ]
532 unless ref $self->{$_} eq 'ARRAY';
538 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
539 by L<DBIx::Class::Schema::Loader>.
544 my ( $class, %args ) = @_;
546 my $self = { %args };
548 # don't lose undef options
549 for (values %$self) {
550 $_ = 0 unless defined $_;
553 bless $self => $class;
555 if (my $config_file = $self->config_file) {
556 my $config_opts = do $config_file;
558 croak "Error reading config from $config_file: $@" if $@;
560 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
562 while (my ($k, $v) = each %$config_opts) {
563 $self->{$k} = $v unless exists $self->{$k};
567 $self->_ensure_arrayref(qw/additional_classes
568 additional_base_classes
573 $self->_validate_class_args;
575 if ($self->use_moose) {
576 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
577 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
578 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
582 $self->{monikers} = {};
583 $self->{classes} = {};
584 $self->{_upgrading_classes} = {};
586 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
587 $self->{schema} ||= $self->{schema_class};
589 croak "dump_overwrite is deprecated. Please read the"
590 . " DBIx::Class::Schema::Loader::Base documentation"
591 if $self->{dump_overwrite};
593 $self->{dynamic} = ! $self->{dump_directory};
594 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
599 $self->{dump_directory} ||= $self->{temp_directory};
601 $self->real_dump_directory($self->{dump_directory});
603 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
604 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
606 if ((not ref $self->naming) && defined $self->naming) {
607 my $naming_ver = $self->naming;
609 relationships => $naming_ver,
610 monikers => $naming_ver,
611 column_accessors => $naming_ver,
616 for (values %{ $self->naming }) {
617 $_ = $CURRENT_V if $_ eq 'current';
620 $self->{naming} ||= {};
622 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
623 croak 'custom_column_info must be a CODE ref';
626 $self->_check_back_compat;
628 $self->use_namespaces(1) unless defined $self->use_namespaces;
629 $self->generate_pod(1) unless defined $self->generate_pod;
630 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
631 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
633 if (my $col_collision_map = $self->col_collision_map) {
634 if (my $reftype = ref $col_collision_map) {
635 if ($reftype ne 'HASH') {
636 croak "Invalid type $reftype for option 'col_collision_map'";
640 $self->col_collision_map({ '(.*)' => $col_collision_map });
647 sub _check_back_compat {
650 # dynamic schemas will always be in 0.04006 mode, unless overridden
651 if ($self->dynamic) {
652 # just in case, though no one is likely to dump a dynamic schema
653 $self->schema_version_to_dump('0.04006');
655 if (not %{ $self->naming }) {
656 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
658 Dynamic schema detected, will run in 0.04006 mode.
660 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
661 to disable this warning.
663 Also consider setting 'use_namespaces => 1' if/when upgrading.
665 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
670 $self->_upgrading_from('v4');
673 $self->naming->{relationships} ||= 'v4';
674 $self->naming->{monikers} ||= 'v4';
676 if ($self->use_namespaces) {
677 $self->_upgrading_from_load_classes(1);
680 $self->use_namespaces(0);
686 # otherwise check if we need backcompat mode for a static schema
687 my $filename = $self->_get_dump_filename($self->schema_class);
688 return unless -e $filename;
690 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
691 $self->_parse_generated_file($filename);
693 return unless $old_ver;
695 # determine if the existing schema was dumped with use_moose => 1
696 if (! defined $self->use_moose) {
697 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
700 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
701 my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
703 if ($load_classes && (not defined $self->use_namespaces)) {
704 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
706 'load_classes;' static schema detected, turning off 'use_namespaces'.
708 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
709 variable to disable this warning.
711 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
714 $self->use_namespaces(0);
716 elsif ($load_classes && $self->use_namespaces) {
717 $self->_upgrading_from_load_classes(1);
719 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
720 $self->_downgrading_to_load_classes(
721 $result_namespace || 'Result'
724 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
725 if (not $self->result_namespace) {
726 $self->result_namespace($result_namespace || 'Result');
728 elsif ($result_namespace ne $self->result_namespace) {
729 $self->_rewriting_result_namespace(
730 $result_namespace || 'Result'
735 # XXX when we go past .0 this will need fixing
736 my ($v) = $old_ver =~ /([1-9])/;
739 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
741 if (not %{ $self->naming }) {
742 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
744 Version $old_ver static schema detected, turning on backcompat mode.
746 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
747 to disable this warning.
749 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
751 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
752 from version 0.04006.
755 $self->naming->{relationships} ||= $v;
756 $self->naming->{monikers} ||= $v;
757 $self->naming->{column_accessors} ||= $v;
759 $self->schema_version_to_dump($old_ver);
762 $self->_upgrading_from($v);
766 sub _validate_class_args {
770 foreach my $k (@CLASS_ARGS) {
771 next unless $self->$k;
773 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
774 foreach my $c (@classes) {
775 # components default to being under the DBIx::Class namespace unless they
776 # are preceeded with a '+'
777 if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
778 $c = 'DBIx::Class::' . $c;
781 # 1 == installed, 0 == not installed, undef == invalid classname
782 my $installed = Class::Inspector->installed($c);
783 if ( defined($installed) ) {
784 if ( $installed == 0 ) {
785 croak qq/$c, as specified in the loader option "$k", is not installed/;
788 croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
794 sub _find_file_in_inc {
795 my ($self, $file) = @_;
797 foreach my $prefix (@INC) {
798 my $fullpath = File::Spec->catfile($prefix, $file);
799 return $fullpath if -f $fullpath
800 # abs_path throws on Windows for nonexistant files
801 and (try { Cwd::abs_path($fullpath) }) ne
802 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
809 my ($self, $class) = @_;
811 my $class_path = $class;
812 $class_path =~ s{::}{/}g;
813 $class_path .= '.pm';
818 sub _find_class_in_inc {
819 my ($self, $class) = @_;
821 return $self->_find_file_in_inc($self->_class_path($class));
827 return $self->_upgrading_from
828 || $self->_upgrading_from_load_classes
829 || $self->_downgrading_to_load_classes
830 || $self->_rewriting_result_namespace
834 sub _rewrite_old_classnames {
835 my ($self, $code) = @_;
837 return $code unless $self->_rewriting;
839 my %old_classes = reverse %{ $self->_upgrading_classes };
841 my $re = join '|', keys %old_classes;
844 $code =~ s/$re/$old_classes{$1} || $1/eg;
850 my ($self, $class) = @_;
852 return if $self->{skip_load_external};
854 # so that we don't load our own classes, under any circumstances
855 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
857 my $real_inc_path = $self->_find_class_in_inc($class);
859 my $old_class = $self->_upgrading_classes->{$class}
860 if $self->_rewriting;
862 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
863 if $old_class && $old_class ne $class;
865 return unless $real_inc_path || $old_real_inc_path;
867 if ($real_inc_path) {
868 # If we make it to here, we loaded an external definition
869 warn qq/# Loaded external class definition for '$class'\n/
872 my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path);
874 if ($self->dynamic) { # load the class too
875 eval_without_redefine_warnings($code);
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 eval_without_redefine_warnings($code);
920 $self->_ext_stmt($class, $code);
921 $self->_ext_stmt($class,
922 qq|# End of lines loaded from '$old_real_inc_path' |
929 Does the actual schema-construction work.
937 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
945 Rescan the database for changes. Returns a list of the newly added table
948 The schema argument should be the schema class or object to be affected. It
949 should probably be derived from the original schema_class used during L</load>.
954 my ($self, $schema) = @_;
956 $self->{schema} = $schema;
957 $self->_relbuilder->{schema} = $schema;
960 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
962 foreach my $table (@current) {
963 if(!exists $self->{_tables}->{$table}) {
964 push(@created, $table);
969 @current{@current} = ();
970 foreach my $table (keys %{ $self->{_tables} }) {
971 if (not exists $current{$table}) {
972 $self->_unregister_source_for_table($table);
976 delete $self->{_dump_storage};
977 delete $self->{_relations_started};
979 my $loaded = $self->_load_tables(@current);
981 return map { $self->monikers->{$_} } @created;
987 return if $self->{skip_relationships};
989 return $self->{relbuilder} ||= do {
991 no warnings 'uninitialized';
992 my $relbuilder_suff =
998 ->{ $self->naming->{relationships}};
1000 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1001 eval "require $relbuilder_class"; die $@ if $@;
1002 $relbuilder_class->new( $self );
1008 my ($self, @tables) = @_;
1010 # Save the new tables to the tables list
1012 $self->{_tables}->{$_} = 1;
1015 $self->_make_src_class($_) for @tables;
1017 # sanity-check for moniker clashes
1018 my $inverse_moniker_idx;
1019 for (keys %{$self->monikers}) {
1020 push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
1024 for (keys %$inverse_moniker_idx) {
1025 my $tables = $inverse_moniker_idx->{$_};
1027 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1028 join (', ', map { "'$_'" } @$tables),
1035 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1036 . 'Either change the naming style, or supply an explicit moniker_map: '
1037 . join ('; ', @clashes)
1043 $self->_setup_src_meta($_) for @tables;
1045 if(!$self->skip_relationships) {
1046 # The relationship loader needs a working schema
1048 local $self->{dump_directory} = $self->{temp_directory};
1049 $self->_reload_classes(\@tables);
1050 $self->_load_relationships($_) for @tables;
1051 $self->_relbuilder->cleanup;
1054 # Remove that temp dir from INC so it doesn't get reloaded
1055 @INC = grep $_ ne $self->dump_directory, @INC;
1058 $self->_load_external($_)
1059 for map { $self->classes->{$_} } @tables;
1061 # Reload without unloading first to preserve any symbols from external
1063 $self->_reload_classes(\@tables, { unload => 0 });
1065 # Drop temporary cache
1066 delete $self->{_cache};
1071 sub _reload_classes {
1072 my ($self, $tables, $opts) = @_;
1074 my @tables = @$tables;
1076 my $unload = $opts->{unload};
1077 $unload = 1 unless defined $unload;
1079 # so that we don't repeat custom sections
1080 @INC = grep $_ ne $self->dump_directory, @INC;
1082 $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
1084 unshift @INC, $self->dump_directory;
1087 my %have_source = map { $_ => $self->schema->source($_) }
1088 $self->schema->sources;
1090 for my $table (@tables) {
1091 my $moniker = $self->monikers->{$table};
1092 my $class = $self->classes->{$table};
1095 no warnings 'redefine';
1096 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1099 if (my $mc = $self->_moose_metaclass($class)) {
1102 Class::Unload->unload($class) if $unload;
1103 my ($source, $resultset_class);
1105 ($source = $have_source{$moniker})
1106 && ($resultset_class = $source->resultset_class)
1107 && ($resultset_class ne 'DBIx::Class::ResultSet')
1109 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1110 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1113 Class::Unload->unload($resultset_class) if $unload;
1114 $self->_reload_class($resultset_class) if $has_file;
1116 $self->_reload_class($class);
1118 push @to_register, [$moniker, $class];
1121 Class::C3->reinitialize;
1122 for (@to_register) {
1123 $self->schema->register_class(@$_);
1127 sub _moose_metaclass {
1128 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1132 my $mc = try { Class::MOP::class_of($class) }
1135 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1138 # We use this instead of ensure_class_loaded when there are package symbols we
1141 my ($self, $class) = @_;
1143 my $class_path = $self->_class_path($class);
1144 delete $INC{ $class_path };
1146 # kill redefined warnings
1148 eval_without_redefine_warnings ("require $class");
1151 die "Failed to reload class $class: $_";
1155 sub _get_dump_filename {
1156 my ($self, $class) = (@_);
1158 $class =~ s{::}{/}g;
1159 return $self->dump_directory . q{/} . $class . q{.pm};
1162 =head2 get_dump_filename
1166 Returns the full path to the file for a class that the class has been or will
1167 be dumped to. This is a file in a temp dir for a dynamic schema.
1171 sub get_dump_filename {
1172 my ($self, $class) = (@_);
1174 local $self->{dump_directory} = $self->real_dump_directory;
1176 return $self->_get_dump_filename($class);
1179 sub _ensure_dump_subdirs {
1180 my ($self, $class) = (@_);
1182 my @name_parts = split(/::/, $class);
1183 pop @name_parts; # we don't care about the very last element,
1184 # which is a filename
1186 my $dir = $self->dump_directory;
1189 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1191 last if !@name_parts;
1192 $dir = File::Spec->catdir($dir, shift @name_parts);
1197 my ($self, @classes) = @_;
1199 my $schema_class = $self->schema_class;
1200 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1202 my $target_dir = $self->dump_directory;
1203 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1204 unless $self->{dynamic} or $self->{quiet};
1207 qq|package $schema_class;\n\n|
1208 . qq|# Created by DBIx::Class::Schema::Loader\n|
1209 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1211 if ($self->use_moose) {
1212 $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1215 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1218 if ($self->use_namespaces) {
1219 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1220 my $namespace_options;
1222 my @attr = qw/resultset_namespace default_resultset_class/;
1224 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1226 for my $attr (@attr) {
1228 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1231 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1232 $schema_text .= qq|;\n|;
1235 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1239 local $self->{version_to_dump} = $self->schema_version_to_dump;
1240 $self->_write_classfile($schema_class, $schema_text, 1);
1243 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1245 foreach my $src_class (@classes) {
1247 qq|package $src_class;\n\n|
1248 . qq|# Created by DBIx::Class::Schema::Loader\n|
1249 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1250 . qq|use strict;\nuse warnings;\n\n|;
1251 if ($self->use_moose) {
1252 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1254 # these options 'use base' which is compile time
1255 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1256 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1259 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1263 $src_text .= qq|use base '$result_base_class';\n\n|;
1265 $self->_write_classfile($src_class, $src_text);
1268 # remove Result dir if downgrading from use_namespaces, and there are no
1270 if (my $result_ns = $self->_downgrading_to_load_classes
1271 || $self->_rewriting_result_namespace) {
1272 my $result_namespace = $self->_result_namespace(
1277 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1278 $result_dir = $self->dump_directory . '/' . $result_dir;
1280 unless (my @files = glob "$result_dir/*") {
1285 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1290 my ($self, $version, $ts) = @_;
1291 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1294 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1297 sub _write_classfile {
1298 my ($self, $class, $text, $is_schema) = @_;
1300 my $filename = $self->_get_dump_filename($class);
1301 $self->_ensure_dump_subdirs($class);
1303 if (-f $filename && $self->really_erase_my_files) {
1304 warn "Deleting existing file '$filename' due to "
1305 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1309 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1310 = $self->_parse_generated_file($filename);
1312 if (! $old_gen && -f $filename) {
1313 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1314 . " it does not appear to have been generated by Loader"
1317 my $custom_content = $old_custom || '';
1319 # prepend extra custom content from a *renamed* class (singularization effect)
1320 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1321 my $old_filename = $self->_get_dump_filename($renamed_class);
1323 if (-f $old_filename) {
1324 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1326 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1328 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1331 unlink $old_filename;
1335 $custom_content ||= $self->_default_custom_content;
1337 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1338 # If there is already custom content, which does not have the Moose content, add it.
1339 if ($self->use_moose) {
1341 my $non_moose_custom_content = do {
1342 local $self->{use_moose} = 0;
1343 $self->_default_custom_content;
1346 if ($custom_content eq $non_moose_custom_content) {
1347 $custom_content = $self->_default_custom_content;
1349 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1350 $custom_content .= $self->_default_custom_content;
1353 elsif (defined $self->use_moose && $old_gen) {
1354 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'
1355 if $old_gen =~ /use \s+ MooseX?\b/x;
1358 $custom_content = $self->_rewrite_old_classnames($custom_content);
1361 for @{$self->{_dump_storage}->{$class} || []};
1363 # Check and see if the dump is infact differnt
1367 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1368 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1369 return unless $self->_upgrading_from && $is_schema;
1373 $text .= $self->_sig_comment(
1374 $self->version_to_dump,
1375 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1378 open(my $fh, '>', $filename)
1379 or croak "Cannot open '$filename' for writing: $!";
1381 # Write the top half and its MD5 sum
1382 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1384 # Write out anything loaded via external partial class file in @INC
1386 for @{$self->{_ext_storage}->{$class} || []};
1388 # Write out any custom content the user has added
1389 print $fh $custom_content;
1392 or croak "Error closing '$filename': $!";
1395 sub _default_moose_custom_content {
1396 return qq|\n__PACKAGE__->meta->make_immutable;|;
1399 sub _default_custom_content {
1401 my $default = qq|\n\n# You can replace this text with custom|
1402 . qq| code or comments, and it will be preserved on regeneration|;
1403 if ($self->use_moose) {
1404 $default .= $self->_default_moose_custom_content;
1406 $default .= qq|\n1;\n|;
1410 sub _parse_generated_file {
1411 my ($self, $fn) = @_;
1413 return unless -f $fn;
1415 open(my $fh, '<', $fn)
1416 or croak "Cannot open '$fn' for reading: $!";
1419 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1421 my ($md5, $ts, $ver, $gen);
1427 # Pull out the version and timestamp from the line above
1428 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1431 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"
1432 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1441 my $custom = do { local $/; <$fh> }
1446 return ($gen, $md5, $ver, $ts, $custom);
1454 warn "$target: use $_;" if $self->debug;
1455 $self->_raw_stmt($target, "use $_;");
1463 my $blist = join(q{ }, @_);
1465 return unless $blist;
1467 warn "$target: use base qw/$blist/;" if $self->debug;
1468 $self->_raw_stmt($target, "use base qw/$blist/;");
1471 sub _result_namespace {
1472 my ($self, $schema_class, $ns) = @_;
1473 my @result_namespace;
1475 if ($ns =~ /^\+(.*)/) {
1476 # Fully qualified namespace
1477 @result_namespace = ($1)
1480 # Relative namespace
1481 @result_namespace = ($schema_class, $ns);
1484 return wantarray ? @result_namespace : join '::', @result_namespace;
1487 # Create class with applicable bases, setup monikers, etc
1488 sub _make_src_class {
1489 my ($self, $table) = @_;
1491 my $schema = $self->schema;
1492 my $schema_class = $self->schema_class;
1494 my $table_moniker = $self->_table2moniker($table);
1495 my @result_namespace = ($schema_class);
1496 if ($self->use_namespaces) {
1497 my $result_namespace = $self->result_namespace || 'Result';
1498 @result_namespace = $self->_result_namespace(
1503 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1505 if ((my $upgrading_v = $self->_upgrading_from)
1506 || $self->_rewriting) {
1507 local $self->naming->{monikers} = $upgrading_v
1510 my @result_namespace = @result_namespace;
1511 if ($self->_upgrading_from_load_classes) {
1512 @result_namespace = ($schema_class);
1514 elsif (my $ns = $self->_downgrading_to_load_classes) {
1515 @result_namespace = $self->_result_namespace(
1520 elsif ($ns = $self->_rewriting_result_namespace) {
1521 @result_namespace = $self->_result_namespace(
1527 my $old_class = join(q{::}, @result_namespace,
1528 $self->_table2moniker($table));
1530 $self->_upgrading_classes->{$table_class} = $old_class
1531 unless $table_class eq $old_class;
1534 # this was a bad idea, should be ok now without it
1535 # my $table_normalized = lc $table;
1536 # $self->classes->{$table_normalized} = $table_class;
1537 # $self->monikers->{$table_normalized} = $table_moniker;
1539 $self->classes->{$table} = $table_class;
1540 $self->monikers->{$table} = $table_moniker;
1542 $self->_use ($table_class, @{$self->additional_classes});
1543 $self->_inject($table_class, @{$self->left_base_classes});
1545 if (my @components = @{ $self->components }) {
1546 $self->_dbic_stmt($table_class, 'load_components', @components);
1549 $self->_inject($table_class, @{$self->additional_base_classes});
1552 sub _resolve_col_accessor_collisions {
1553 my ($self, $table, $col_info) = @_;
1555 my $base = $self->result_base_class || 'DBIx::Class::Core';
1556 my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1558 my $table_name = ref $table ? $$table : $table;
1562 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1563 eval "require ${class};";
1566 push @methods, @{ Class::Inspector->methods($class) || [] };
1567 push @methods, @{ Class::Inspector->methods('UNIVERSAL') || [] };
1571 @methods{@methods} = ();
1574 $methods{meta} = undef;
1576 while (my ($col, $info) = each %$col_info) {
1577 my $accessor = $info->{accessor} || $col;
1579 next if $accessor eq 'id'; # special case (very common column)
1581 if (exists $methods{$accessor}) {
1584 if (my $map = $self->col_collision_map) {
1585 for my $re (keys %$map) {
1586 if (my @matches = $col =~ /$re/) {
1587 $info->{accessor} = sprintf $map->{$re}, @matches;
1595 Column $col in table $table_name collides with an inherited method.
1596 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1598 $info->{accessor} = undef;
1603 # FIXME: it appears that this method should also check that the
1604 # default accessor (i.e. the column name itself) is not colliding
1605 # with any of these methods
1608 # use the same logic to run moniker_map, column_accessor_map, and
1609 # relationship_name_map
1611 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1613 my $default_ident = $default_code->( $ident, @extra );
1615 if( $map && ref $map eq 'HASH' ) {
1616 $new_ident = $map->{ $ident };
1618 elsif( $map && ref $map eq 'CODE' ) {
1619 $new_ident = $map->( $ident, $default_ident, @extra );
1622 $new_ident ||= $default_ident;
1627 sub _default_column_accessor_name {
1628 my ( $self, $column_name ) = @_;
1630 my $accessor_name = $column_name;
1631 $accessor_name =~ s/\W+/_/g;
1634 if( ($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7 ) {
1635 # older naming just lc'd the col accessor and that's all.
1636 return lc $accessor_name;
1639 return join '_', map lc, split_name $column_name;
1642 sub _make_column_accessor_name {
1643 my ($self, $column_name, $column_context_info ) = @_;
1645 my $accessor = $self->_run_user_map(
1646 $self->column_accessor_map,
1647 sub { $self->_default_column_accessor_name( shift ) },
1649 $column_context_info,
1655 # Set up metadata (cols, pks, etc)
1656 sub _setup_src_meta {
1657 my ($self, $table) = @_;
1659 my $schema = $self->schema;
1660 my $schema_class = $self->schema_class;
1662 my $table_class = $self->classes->{$table};
1663 my $table_moniker = $self->monikers->{$table};
1665 my $table_name = $table;
1666 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1668 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1669 $table_name = \ $self->_quote_table_name($table_name);
1672 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1674 # be careful to not create refs Data::Dump can "optimize"
1675 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1677 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1679 my $cols = $self->_table_columns($table);
1680 my $col_info = $self->__columns_info_for($table);
1682 ### generate all the column accessor names
1683 while (my ($col, $info) = each %$col_info) {
1684 # hashref of other info that could be used by
1685 # user-defined accessor map functions
1687 table_class => $table_class,
1688 table_moniker => $table_moniker,
1689 table_name => $table_name,
1690 full_table_name => $full_table_name,
1691 schema_class => $schema_class,
1692 column_info => $info,
1695 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1698 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1700 # prune any redundant accessor names
1701 while (my ($col, $info) = each %$col_info) {
1702 no warnings 'uninitialized';
1703 delete $info->{accessor} if $info->{accessor} eq $col;
1706 my $fks = $self->_table_fk_info($table);
1708 foreach my $fkdef (@$fks) {
1709 for my $col (@{ $fkdef->{local_columns} }) {
1710 $col_info->{$col}{is_foreign_key} = 1;
1714 my $pks = $self->_table_pk_info($table) || [];
1716 foreach my $pkcol (@$pks) {
1717 $col_info->{$pkcol}{is_nullable} = 0;
1723 map { $_, ($col_info->{$_}||{}) } @$cols
1726 my %uniq_tag; # used to eliminate duplicate uniqs
1728 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1729 : carp("$table has no primary key");
1730 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1732 my $uniqs = $self->_table_uniq_info($table) || [];
1734 my ($name, $cols) = @$_;
1735 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1736 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1741 sub __columns_info_for {
1742 my ($self, $table) = @_;
1744 my $result = $self->_columns_info_for($table);
1746 while (my ($col, $info) = each %$result) {
1747 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1748 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1750 $result->{$col} = $info;
1758 Returns a sorted list of loaded tables, using the original database table
1766 return keys %{$self->_tables};
1769 # Make a moniker from a table
1770 sub _default_table2moniker {
1771 no warnings 'uninitialized';
1772 my ($self, $table) = @_;
1774 if ($self->naming->{monikers} eq 'v4') {
1775 return join '', map ucfirst, split /[\W_]+/, lc $table;
1777 elsif ($self->naming->{monikers} eq 'v5') {
1778 return join '', map ucfirst, split /[\W_]+/,
1779 Lingua::EN::Inflect::Number::to_S(lc $table);
1781 elsif ($self->naming->{monikers} eq 'v6') {
1782 (my $as_phrase = lc $table) =~ s/_+/ /g;
1783 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1785 return join '', map ucfirst, split /\W+/, $inflected;
1788 my @words = map lc, split_name $table;
1789 my $as_phrase = join ' ', @words;
1791 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1793 return join '', map ucfirst, split /\W+/, $inflected;
1796 sub _table2moniker {
1797 my ( $self, $table ) = @_;
1799 $self->_run_user_map(
1801 sub { $self->_default_table2moniker( shift ) },
1806 sub _load_relationships {
1807 my ($self, $table) = @_;
1809 my $tbl_fk_info = $self->_table_fk_info($table);
1810 foreach my $fkdef (@$tbl_fk_info) {
1811 $fkdef->{remote_source} =
1812 $self->monikers->{delete $fkdef->{remote_table}};
1814 my $tbl_uniq_info = $self->_table_uniq_info($table);
1816 my $local_moniker = $self->monikers->{$table};
1817 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1819 foreach my $src_class (sort keys %$rel_stmts) {
1820 my $src_stmts = $rel_stmts->{$src_class};
1821 foreach my $stmt (@$src_stmts) {
1822 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1827 # Overload these in driver class:
1829 # Returns an arrayref of column names
1830 sub _table_columns { croak "ABSTRACT METHOD" }
1832 # Returns arrayref of pk col names
1833 sub _table_pk_info { croak "ABSTRACT METHOD" }
1835 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1836 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1838 # Returns an arrayref of foreign key constraints, each
1839 # being a hashref with 3 keys:
1840 # local_columns (arrayref), remote_columns (arrayref), remote_table
1841 sub _table_fk_info { croak "ABSTRACT METHOD" }
1843 # Returns an array of lower case table names
1844 sub _tables_list { croak "ABSTRACT METHOD" }
1846 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1852 # generate the pod for this statement, storing it with $self->_pod
1853 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1855 my $args = dump(@_);
1856 $args = '(' . $args . ')' if @_ < 2;
1857 my $stmt = $method . $args . q{;};
1859 warn qq|$class\->$stmt\n| if $self->debug;
1860 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1864 # generates the accompanying pod for a DBIC class method statement,
1865 # storing it with $self->_pod
1871 if ( $method eq 'table' ) {
1873 my $pcm = $self->pod_comment_mode;
1874 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1875 $comment = $self->__table_comment($table);
1876 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1877 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1878 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1879 $self->_pod( $class, "=head1 NAME" );
1880 my $table_descr = $class;
1881 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1882 $self->{_class2table}{ $class } = $table;
1883 $self->_pod( $class, $table_descr );
1884 if ($comment and $comment_in_desc) {
1885 $self->_pod( $class, "=head1 DESCRIPTION" );
1886 $self->_pod( $class, $comment );
1888 $self->_pod_cut( $class );
1889 } elsif ( $method eq 'add_columns' ) {
1890 $self->_pod( $class, "=head1 ACCESSORS" );
1891 my $col_counter = 0;
1893 while( my ($name,$attrs) = splice @cols,0,2 ) {
1895 $self->_pod( $class, '=head2 ' . $name );
1896 $self->_pod( $class,
1898 my $s = $attrs->{$_};
1899 $s = !defined $s ? 'undef' :
1900 length($s) == 0 ? '(empty string)' :
1901 ref($s) eq 'SCALAR' ? $$s :
1902 ref($s) ? dumper_squashed $s :
1903 looks_like_number($s) ? $s : qq{'$s'};
1906 } sort keys %$attrs,
1908 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
1909 $self->_pod( $class, $comment );
1912 $self->_pod_cut( $class );
1913 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1914 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1915 my ( $accessor, $rel_class ) = @_;
1916 $self->_pod( $class, "=head2 $accessor" );
1917 $self->_pod( $class, 'Type: ' . $method );
1918 $self->_pod( $class, "Related object: L<$rel_class>" );
1919 $self->_pod_cut( $class );
1920 $self->{_relations_started} { $class } = 1;
1924 sub _filter_comment {
1925 my ($self, $txt) = @_;
1927 $txt = '' if not defined $txt;
1929 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1934 sub __table_comment {
1937 if (my $code = $self->can('_table_comment')) {
1938 return $self->_filter_comment($self->$code(@_));
1944 sub __column_comment {
1947 if (my $code = $self->can('_column_comment')) {
1948 return $self->_filter_comment($self->$code(@_));
1954 # Stores a POD documentation
1956 my ($self, $class, $stmt) = @_;
1957 $self->_raw_stmt( $class, "\n" . $stmt );
1961 my ($self, $class ) = @_;
1962 $self->_raw_stmt( $class, "\n=cut\n" );
1965 # Store a raw source line for a class (for dumping purposes)
1967 my ($self, $class, $stmt) = @_;
1968 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1971 # Like above, but separately for the externally loaded stuff
1973 my ($self, $class, $stmt) = @_;
1974 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1977 sub _quote_table_name {
1978 my ($self, $table) = @_;
1980 my $qt = $self->schema->storage->sql_maker->quote_char;
1982 return $table unless $qt;
1985 return $qt->[0] . $table . $qt->[1];
1988 return $qt . $table . $qt;
1991 sub _custom_column_info {
1992 my ( $self, $table_name, $column_name, $column_info ) = @_;
1994 if (my $code = $self->custom_column_info) {
1995 return $code->($table_name, $column_name, $column_info) || {};
2000 sub _datetime_column_info {
2001 my ( $self, $table_name, $column_name, $column_info ) = @_;
2003 my $type = $column_info->{data_type} || '';
2004 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2005 or ($type =~ /date|timestamp/i)) {
2006 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2007 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2013 my ($self, $name) = @_;
2015 return $self->preserve_case ? $name : lc($name);
2019 my ($self, $name) = @_;
2021 return $self->preserve_case ? $name : uc($name);
2024 sub _unregister_source_for_table {
2025 my ($self, $table) = @_;
2029 my $schema = $self->schema;
2030 # in older DBIC it's a private method
2031 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2032 $schema->$unregister($self->_table2moniker($table));
2033 delete $self->monikers->{$table};
2034 delete $self->classes->{$table};
2035 delete $self->_upgrading_classes->{$table};
2036 delete $self->{_tables}{$table};
2040 # remove the dump dir from @INC on destruction
2044 @INC = grep $_ ne $self->dump_directory, @INC;
2049 Returns a hashref of loaded table to moniker mappings. There will
2050 be two entries for each table, the original name and the "normalized"
2051 name, in the case that the two are different (such as databases
2052 that like uppercase table names, or preserve your original mixed-case
2053 definitions, or what-have-you).
2057 Returns a hashref of table to class mappings. In some cases it will
2058 contain multiple entries per table for the original and normalized table
2059 names, as above in L</monikers>.
2061 =head1 COLUMN ACCESSOR COLLISIONS
2063 Occasionally you may have a column name that collides with a perl method, such
2064 as C<can>. In such cases, the default action is to set the C<accessor> of the
2065 column spec to C<undef>.
2067 You can then name the accessor yourself by placing code such as the following
2070 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2072 Another option is to use the L</col_collision_map> option.
2076 L<DBIx::Class::Schema::Loader>
2080 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2084 This library is free software; you can redistribute it and/or modify it under
2085 the same terms as Perl itself.
2090 # vim:et sts=4 sw=4 tw=0: