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 my $source = slurp $self->_get_dump_filename($class);
1152 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1156 sub _get_dump_filename {
1157 my ($self, $class) = (@_);
1159 $class =~ s{::}{/}g;
1160 return $self->dump_directory . q{/} . $class . q{.pm};
1163 =head2 get_dump_filename
1167 Returns the full path to the file for a class that the class has been or will
1168 be dumped to. This is a file in a temp dir for a dynamic schema.
1172 sub get_dump_filename {
1173 my ($self, $class) = (@_);
1175 local $self->{dump_directory} = $self->real_dump_directory;
1177 return $self->_get_dump_filename($class);
1180 sub _ensure_dump_subdirs {
1181 my ($self, $class) = (@_);
1183 my @name_parts = split(/::/, $class);
1184 pop @name_parts; # we don't care about the very last element,
1185 # which is a filename
1187 my $dir = $self->dump_directory;
1190 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1192 last if !@name_parts;
1193 $dir = File::Spec->catdir($dir, shift @name_parts);
1198 my ($self, @classes) = @_;
1200 my $schema_class = $self->schema_class;
1201 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1203 my $target_dir = $self->dump_directory;
1204 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1205 unless $self->{dynamic} or $self->{quiet};
1208 qq|package $schema_class;\n\n|
1209 . qq|# Created by DBIx::Class::Schema::Loader\n|
1210 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1212 if ($self->use_moose) {
1213 $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1216 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1219 if ($self->use_namespaces) {
1220 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1221 my $namespace_options;
1223 my @attr = qw/resultset_namespace default_resultset_class/;
1225 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1227 for my $attr (@attr) {
1229 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n|
1232 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1233 $schema_text .= qq|;\n|;
1236 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1240 local $self->{version_to_dump} = $self->schema_version_to_dump;
1241 $self->_write_classfile($schema_class, $schema_text, 1);
1244 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1246 foreach my $src_class (@classes) {
1248 qq|package $src_class;\n\n|
1249 . qq|# Created by DBIx::Class::Schema::Loader\n|
1250 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
1251 . qq|use strict;\nuse warnings;\n\n|;
1252 if ($self->use_moose) {
1253 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1255 # these options 'use base' which is compile time
1256 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1257 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
1260 $src_text .= qq|\nextends '$result_base_class';\n\n|;
1264 $src_text .= qq|use base '$result_base_class';\n\n|;
1266 $self->_write_classfile($src_class, $src_text);
1269 # remove Result dir if downgrading from use_namespaces, and there are no
1271 if (my $result_ns = $self->_downgrading_to_load_classes
1272 || $self->_rewriting_result_namespace) {
1273 my $result_namespace = $self->_result_namespace(
1278 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1279 $result_dir = $self->dump_directory . '/' . $result_dir;
1281 unless (my @files = glob "$result_dir/*") {
1286 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
1291 my ($self, $version, $ts) = @_;
1292 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1295 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1298 sub _write_classfile {
1299 my ($self, $class, $text, $is_schema) = @_;
1301 my $filename = $self->_get_dump_filename($class);
1302 $self->_ensure_dump_subdirs($class);
1304 if (-f $filename && $self->really_erase_my_files) {
1305 warn "Deleting existing file '$filename' due to "
1306 . "'really_erase_my_files' setting\n" unless $self->{quiet};
1310 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1311 = $self->_parse_generated_file($filename);
1313 if (! $old_gen && -f $filename) {
1314 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1315 . " it does not appear to have been generated by Loader"
1318 my $custom_content = $old_custom || '';
1320 # prepend extra custom content from a *renamed* class (singularization effect)
1321 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1322 my $old_filename = $self->_get_dump_filename($renamed_class);
1324 if (-f $old_filename) {
1325 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1327 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1329 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1332 unlink $old_filename;
1336 $custom_content ||= $self->_default_custom_content;
1338 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1339 # If there is already custom content, which does not have the Moose content, add it.
1340 if ($self->use_moose) {
1342 my $non_moose_custom_content = do {
1343 local $self->{use_moose} = 0;
1344 $self->_default_custom_content;
1347 if ($custom_content eq $non_moose_custom_content) {
1348 $custom_content = $self->_default_custom_content;
1350 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
1351 $custom_content .= $self->_default_custom_content;
1354 elsif (defined $self->use_moose && $old_gen) {
1355 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'
1356 if $old_gen =~ /use \s+ MooseX?\b/x;
1359 $custom_content = $self->_rewrite_old_classnames($custom_content);
1362 for @{$self->{_dump_storage}->{$class} || []};
1364 # Check and see if the dump is infact differnt
1368 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1369 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
1370 return unless $self->_upgrading_from && $is_schema;
1374 $text .= $self->_sig_comment(
1375 $self->version_to_dump,
1376 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1379 open(my $fh, '>', $filename)
1380 or croak "Cannot open '$filename' for writing: $!";
1382 # Write the top half and its MD5 sum
1383 print $fh $text . Digest::MD5::md5_base64($text) . "\n";
1385 # Write out anything loaded via external partial class file in @INC
1387 for @{$self->{_ext_storage}->{$class} || []};
1389 # Write out any custom content the user has added
1390 print $fh $custom_content;
1393 or croak "Error closing '$filename': $!";
1396 sub _default_moose_custom_content {
1397 return qq|\n__PACKAGE__->meta->make_immutable;|;
1400 sub _default_custom_content {
1402 my $default = qq|\n\n# You can replace this text with custom|
1403 . qq| code or comments, and it will be preserved on regeneration|;
1404 if ($self->use_moose) {
1405 $default .= $self->_default_moose_custom_content;
1407 $default .= qq|\n1;\n|;
1411 sub _parse_generated_file {
1412 my ($self, $fn) = @_;
1414 return unless -f $fn;
1416 open(my $fh, '<', $fn)
1417 or croak "Cannot open '$fn' for reading: $!";
1420 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1422 my ($md5, $ts, $ver, $gen);
1428 # Pull out the version and timestamp from the line above
1429 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
1432 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"
1433 if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
1442 my $custom = do { local $/; <$fh> }
1447 return ($gen, $md5, $ver, $ts, $custom);
1455 warn "$target: use $_;" if $self->debug;
1456 $self->_raw_stmt($target, "use $_;");
1464 my $blist = join(q{ }, @_);
1466 return unless $blist;
1468 warn "$target: use base qw/$blist/;" if $self->debug;
1469 $self->_raw_stmt($target, "use base qw/$blist/;");
1472 sub _result_namespace {
1473 my ($self, $schema_class, $ns) = @_;
1474 my @result_namespace;
1476 if ($ns =~ /^\+(.*)/) {
1477 # Fully qualified namespace
1478 @result_namespace = ($1)
1481 # Relative namespace
1482 @result_namespace = ($schema_class, $ns);
1485 return wantarray ? @result_namespace : join '::', @result_namespace;
1488 # Create class with applicable bases, setup monikers, etc
1489 sub _make_src_class {
1490 my ($self, $table) = @_;
1492 my $schema = $self->schema;
1493 my $schema_class = $self->schema_class;
1495 my $table_moniker = $self->_table2moniker($table);
1496 my @result_namespace = ($schema_class);
1497 if ($self->use_namespaces) {
1498 my $result_namespace = $self->result_namespace || 'Result';
1499 @result_namespace = $self->_result_namespace(
1504 my $table_class = join(q{::}, @result_namespace, $table_moniker);
1506 if ((my $upgrading_v = $self->_upgrading_from)
1507 || $self->_rewriting) {
1508 local $self->naming->{monikers} = $upgrading_v
1511 my @result_namespace = @result_namespace;
1512 if ($self->_upgrading_from_load_classes) {
1513 @result_namespace = ($schema_class);
1515 elsif (my $ns = $self->_downgrading_to_load_classes) {
1516 @result_namespace = $self->_result_namespace(
1521 elsif ($ns = $self->_rewriting_result_namespace) {
1522 @result_namespace = $self->_result_namespace(
1528 my $old_class = join(q{::}, @result_namespace,
1529 $self->_table2moniker($table));
1531 $self->_upgrading_classes->{$table_class} = $old_class
1532 unless $table_class eq $old_class;
1535 # this was a bad idea, should be ok now without it
1536 # my $table_normalized = lc $table;
1537 # $self->classes->{$table_normalized} = $table_class;
1538 # $self->monikers->{$table_normalized} = $table_moniker;
1540 $self->classes->{$table} = $table_class;
1541 $self->monikers->{$table} = $table_moniker;
1543 $self->_use ($table_class, @{$self->additional_classes});
1544 $self->_inject($table_class, @{$self->left_base_classes});
1546 if (my @components = @{ $self->components }) {
1547 $self->_dbic_stmt($table_class, 'load_components', @components);
1550 $self->_inject($table_class, @{$self->additional_base_classes});
1553 sub _resolve_col_accessor_collisions {
1554 my ($self, $table, $col_info) = @_;
1556 my $base = $self->result_base_class || 'DBIx::Class::Core';
1557 my @components = map "DBIx::Class::$_", @{ $self->components || [] };
1559 my $table_name = ref $table ? $$table : $table;
1563 for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
1564 eval "require ${class};";
1567 push @methods, @{ Class::Inspector->methods($class) || [] };
1570 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
1573 @methods{@methods} = ();
1576 $methods{meta} = undef;
1578 while (my ($col, $info) = each %$col_info) {
1579 my $accessor = $info->{accessor} || $col;
1581 next if $accessor eq 'id'; # special case (very common column)
1583 if (exists $methods{$accessor}) {
1586 if (my $map = $self->col_collision_map) {
1587 for my $re (keys %$map) {
1588 if (my @matches = $col =~ /$re/) {
1589 $info->{accessor} = sprintf $map->{$re}, @matches;
1597 Column $col in table $table_name collides with an inherited method.
1598 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
1600 $info->{accessor} = undef;
1606 # use the same logic to run moniker_map, column_accessor_map, and
1607 # relationship_name_map
1609 my ( $self, $map, $default_code, $ident, @extra ) = @_;
1611 my $default_ident = $default_code->( $ident, @extra );
1613 if( $map && ref $map eq 'HASH' ) {
1614 $new_ident = $map->{ $ident };
1616 elsif( $map && ref $map eq 'CODE' ) {
1617 $new_ident = $map->( $ident, $default_ident, @extra );
1620 $new_ident ||= $default_ident;
1625 sub _default_column_accessor_name {
1626 my ( $self, $column_name ) = @_;
1628 my $accessor_name = $column_name;
1629 $accessor_name =~ s/\W+/_/g;
1631 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
1632 # older naming just lc'd the col accessor and that's all.
1633 return lc $accessor_name;
1636 return join '_', map lc, split_name $column_name;
1640 sub _make_column_accessor_name {
1641 my ($self, $column_name, $column_context_info ) = @_;
1643 my $accessor = $self->_run_user_map(
1644 $self->column_accessor_map,
1645 sub { $self->_default_column_accessor_name( shift ) },
1647 $column_context_info,
1653 # Set up metadata (cols, pks, etc)
1654 sub _setup_src_meta {
1655 my ($self, $table) = @_;
1657 my $schema = $self->schema;
1658 my $schema_class = $self->schema_class;
1660 my $table_class = $self->classes->{$table};
1661 my $table_moniker = $self->monikers->{$table};
1663 my $table_name = $table;
1664 my $name_sep = $self->schema->storage->sql_maker->name_sep;
1666 if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1667 $table_name = \ $self->_quote_table_name($table_name);
1670 my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name);
1672 # be careful to not create refs Data::Dump can "optimize"
1673 $full_table_name = \do {"".$full_table_name} if ref $table_name;
1675 $self->_dbic_stmt($table_class, 'table', $full_table_name);
1677 my $cols = $self->_table_columns($table);
1678 my $col_info = $self->__columns_info_for($table);
1680 ### generate all the column accessor names
1681 while (my ($col, $info) = each %$col_info) {
1682 # hashref of other info that could be used by
1683 # user-defined accessor map functions
1685 table_class => $table_class,
1686 table_moniker => $table_moniker,
1687 table_name => $table_name,
1688 full_table_name => $full_table_name,
1689 schema_class => $schema_class,
1690 column_info => $info,
1693 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
1696 $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
1698 # prune any redundant accessor names
1699 while (my ($col, $info) = each %$col_info) {
1700 no warnings 'uninitialized';
1701 delete $info->{accessor} if $info->{accessor} eq $col;
1704 my $fks = $self->_table_fk_info($table);
1706 foreach my $fkdef (@$fks) {
1707 for my $col (@{ $fkdef->{local_columns} }) {
1708 $col_info->{$col}{is_foreign_key} = 1;
1712 my $pks = $self->_table_pk_info($table) || [];
1714 foreach my $pkcol (@$pks) {
1715 $col_info->{$pkcol}{is_nullable} = 0;
1721 map { $_, ($col_info->{$_}||{}) } @$cols
1724 my %uniq_tag; # used to eliminate duplicate uniqs
1726 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1727 : carp("$table has no primary key");
1728 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1730 my $uniqs = $self->_table_uniq_info($table) || [];
1732 my ($name, $cols) = @$_;
1733 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1734 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1739 sub __columns_info_for {
1740 my ($self, $table) = @_;
1742 my $result = $self->_columns_info_for($table);
1744 while (my ($col, $info) = each %$result) {
1745 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
1746 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
1748 $result->{$col} = $info;
1756 Returns a sorted list of loaded tables, using the original database table
1764 return keys %{$self->_tables};
1767 # Make a moniker from a table
1768 sub _default_table2moniker {
1769 no warnings 'uninitialized';
1770 my ($self, $table) = @_;
1772 if ($self->naming->{monikers} eq 'v4') {
1773 return join '', map ucfirst, split /[\W_]+/, lc $table;
1775 elsif ($self->naming->{monikers} eq 'v5') {
1776 return join '', map ucfirst, split /[\W_]+/,
1777 Lingua::EN::Inflect::Number::to_S(lc $table);
1779 elsif ($self->naming->{monikers} eq 'v6') {
1780 (my $as_phrase = lc $table) =~ s/_+/ /g;
1781 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1783 return join '', map ucfirst, split /\W+/, $inflected;
1786 my @words = map lc, split_name $table;
1787 my $as_phrase = join ' ', @words;
1789 my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
1791 return join '', map ucfirst, split /\W+/, $inflected;
1794 sub _table2moniker {
1795 my ( $self, $table ) = @_;
1797 $self->_run_user_map(
1799 sub { $self->_default_table2moniker( shift ) },
1804 sub _load_relationships {
1805 my ($self, $table) = @_;
1807 my $tbl_fk_info = $self->_table_fk_info($table);
1808 foreach my $fkdef (@$tbl_fk_info) {
1809 $fkdef->{remote_source} =
1810 $self->monikers->{delete $fkdef->{remote_table}};
1812 my $tbl_uniq_info = $self->_table_uniq_info($table);
1814 my $local_moniker = $self->monikers->{$table};
1815 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1817 foreach my $src_class (sort keys %$rel_stmts) {
1818 my $src_stmts = $rel_stmts->{$src_class};
1819 foreach my $stmt (@$src_stmts) {
1820 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1825 # Overload these in driver class:
1827 # Returns an arrayref of column names
1828 sub _table_columns { croak "ABSTRACT METHOD" }
1830 # Returns arrayref of pk col names
1831 sub _table_pk_info { croak "ABSTRACT METHOD" }
1833 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1834 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1836 # Returns an arrayref of foreign key constraints, each
1837 # being a hashref with 3 keys:
1838 # local_columns (arrayref), remote_columns (arrayref), remote_table
1839 sub _table_fk_info { croak "ABSTRACT METHOD" }
1841 # Returns an array of lower case table names
1842 sub _tables_list { croak "ABSTRACT METHOD" }
1844 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1850 # generate the pod for this statement, storing it with $self->_pod
1851 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
1853 my $args = dump(@_);
1854 $args = '(' . $args . ')' if @_ < 2;
1855 my $stmt = $method . $args . q{;};
1857 warn qq|$class\->$stmt\n| if $self->debug;
1858 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1862 # generates the accompanying pod for a DBIC class method statement,
1863 # storing it with $self->_pod
1869 if ( $method eq 'table' ) {
1871 my $pcm = $self->pod_comment_mode;
1872 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
1873 $comment = $self->__table_comment($table);
1874 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
1875 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
1876 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
1877 $self->_pod( $class, "=head1 NAME" );
1878 my $table_descr = $class;
1879 $table_descr .= " - " . $comment if $comment and $comment_in_name;
1880 $self->{_class2table}{ $class } = $table;
1881 $self->_pod( $class, $table_descr );
1882 if ($comment and $comment_in_desc) {
1883 $self->_pod( $class, "=head1 DESCRIPTION" );
1884 $self->_pod( $class, $comment );
1886 $self->_pod_cut( $class );
1887 } elsif ( $method eq 'add_columns' ) {
1888 $self->_pod( $class, "=head1 ACCESSORS" );
1889 my $col_counter = 0;
1891 while( my ($name,$attrs) = splice @cols,0,2 ) {
1893 $self->_pod( $class, '=head2 ' . $name );
1894 $self->_pod( $class,
1896 my $s = $attrs->{$_};
1897 $s = !defined $s ? 'undef' :
1898 length($s) == 0 ? '(empty string)' :
1899 ref($s) eq 'SCALAR' ? $$s :
1900 ref($s) ? dumper_squashed $s :
1901 looks_like_number($s) ? $s : qq{'$s'};
1904 } sort keys %$attrs,
1906 if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
1907 $self->_pod( $class, $comment );
1910 $self->_pod_cut( $class );
1911 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1912 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1913 my ( $accessor, $rel_class ) = @_;
1914 $self->_pod( $class, "=head2 $accessor" );
1915 $self->_pod( $class, 'Type: ' . $method );
1916 $self->_pod( $class, "Related object: L<$rel_class>" );
1917 $self->_pod_cut( $class );
1918 $self->{_relations_started} { $class } = 1;
1922 sub _filter_comment {
1923 my ($self, $txt) = @_;
1925 $txt = '' if not defined $txt;
1927 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
1932 sub __table_comment {
1935 if (my $code = $self->can('_table_comment')) {
1936 return $self->_filter_comment($self->$code(@_));
1942 sub __column_comment {
1945 if (my $code = $self->can('_column_comment')) {
1946 return $self->_filter_comment($self->$code(@_));
1952 # Stores a POD documentation
1954 my ($self, $class, $stmt) = @_;
1955 $self->_raw_stmt( $class, "\n" . $stmt );
1959 my ($self, $class ) = @_;
1960 $self->_raw_stmt( $class, "\n=cut\n" );
1963 # Store a raw source line for a class (for dumping purposes)
1965 my ($self, $class, $stmt) = @_;
1966 push(@{$self->{_dump_storage}->{$class}}, $stmt);
1969 # Like above, but separately for the externally loaded stuff
1971 my ($self, $class, $stmt) = @_;
1972 push(@{$self->{_ext_storage}->{$class}}, $stmt);
1975 sub _quote_table_name {
1976 my ($self, $table) = @_;
1978 my $qt = $self->schema->storage->sql_maker->quote_char;
1980 return $table unless $qt;
1983 return $qt->[0] . $table . $qt->[1];
1986 return $qt . $table . $qt;
1989 sub _custom_column_info {
1990 my ( $self, $table_name, $column_name, $column_info ) = @_;
1992 if (my $code = $self->custom_column_info) {
1993 return $code->($table_name, $column_name, $column_info) || {};
1998 sub _datetime_column_info {
1999 my ( $self, $table_name, $column_name, $column_info ) = @_;
2001 my $type = $column_info->{data_type} || '';
2002 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2003 or ($type =~ /date|timestamp/i)) {
2004 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2005 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2011 my ($self, $name) = @_;
2013 return $self->preserve_case ? $name : lc($name);
2017 my ($self, $name) = @_;
2019 return $self->preserve_case ? $name : uc($name);
2022 sub _unregister_source_for_table {
2023 my ($self, $table) = @_;
2027 my $schema = $self->schema;
2028 # in older DBIC it's a private method
2029 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2030 $schema->$unregister($self->_table2moniker($table));
2031 delete $self->monikers->{$table};
2032 delete $self->classes->{$table};
2033 delete $self->_upgrading_classes->{$table};
2034 delete $self->{_tables}{$table};
2038 # remove the dump dir from @INC on destruction
2042 @INC = grep $_ ne $self->dump_directory, @INC;
2047 Returns a hashref of loaded table to moniker mappings. There will
2048 be two entries for each table, the original name and the "normalized"
2049 name, in the case that the two are different (such as databases
2050 that like uppercase table names, or preserve your original mixed-case
2051 definitions, or what-have-you).
2055 Returns a hashref of table to class mappings. In some cases it will
2056 contain multiple entries per table for the original and normalized table
2057 names, as above in L</monikers>.
2059 =head1 COLUMN ACCESSOR COLLISIONS
2061 Occasionally you may have a column name that collides with a perl method, such
2062 as C<can>. In such cases, the default action is to set the C<accessor> of the
2063 column spec to C<undef>.
2065 You can then name the accessor yourself by placing code such as the following
2068 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2070 Another option is to use the L</col_collision_map> option.
2074 L<DBIx::Class::Schema::Loader>
2078 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2082 This library is free software; you can redistribute it and/or modify it under
2083 the same terms as Perl itself.
2088 # vim:et sts=4 sw=4 tw=0: