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 ();
14 use Lingua::EN::Inflect::Number ();
15 use Lingua::EN::Inflect::Phrase ();
16 use String::ToIdentifier::EN ();
17 use String::ToIdentifier::EN::Unicode ();
20 use Class::Inspector ();
21 use Scalar::Util 'looks_like_number';
22 use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
23 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
26 use Encode qw/encode decode/;
27 use List::MoreUtils qw/all firstidx/;
32 our $VERSION = '0.07010';
34 __PACKAGE__->mk_group_ro_accessors('simple', qw/
41 additional_base_classes
57 default_resultset_class
62 overwrite_modifications
85 __PACKAGE__->mk_group_accessors('simple', qw/
87 schema_version_to_dump
89 _upgrading_from_load_classes
90 _downgrading_to_load_classes
91 _rewriting_result_namespace
96 pod_comment_spillover_length
102 result_components_map
104 datetime_undef_if_invalid
105 _result_class_methods
107 filter_generated_code
113 my $CURRENT_V = 'v7';
116 schema_components schema_base_class result_base_class
117 additional_base_classes left_base_classes additional_classes components
123 my $CRLF = "\x0d\x0a";
127 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
131 See L<DBIx::Class::Schema::Loader>.
135 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
136 classes, and implements the common functionality between them.
138 =head1 CONSTRUCTOR OPTIONS
140 These constructor options are the base options for
141 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
143 =head2 skip_relationships
145 Skip setting up relationships. The default is to attempt the loading
148 =head2 skip_load_external
150 Skip loading of other classes in @INC. The default is to merge all other classes
151 with the same name found in @INC into the schema file we are creating.
155 Static schemas (ones dumped to disk) will, by default, use the new-style
156 relationship names and singularized Results, unless you're overwriting an
157 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
158 which case the backward compatible RelBuilder will be activated, and the
159 appropriate monikerization used.
165 will disable the backward-compatible RelBuilder and use
166 the new-style relationship names along with singularized Results, even when
167 overwriting a dump made with an earlier version.
169 The option also takes a hashref:
172 relationships => 'v8',
174 column_accessors => 'v8',
180 naming => { ALL => 'v8', force_ascii => 1 }
188 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
193 How to name relationship accessors.
197 How to name Result classes.
199 =item column_accessors
201 How to name column accessors in Result classes.
205 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
206 L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
217 Latest style, whatever that happens to be.
221 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
225 Monikers singularized as whole words, C<might_have> relationships for FKs on
226 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
228 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
233 All monikers and relationships are inflected using
234 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
235 from relationship names.
237 In general, there is very little difference between v5 and v6 schemas.
241 This mode is identical to C<v6> mode, except that monikerization of CamelCase
242 table names is also done correctly.
244 CamelCase column names in case-preserving mode will also be handled correctly
245 for relationship name inflection. See L</preserve_case>.
247 In this mode, CamelCase L</column_accessors> are normalized based on case
248 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
250 If you don't have any CamelCase table or column names, you can upgrade without
251 breaking any of your code.
257 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
258 L</naming> explictly until C<0.08> comes out.
260 L</monikers> and L</column_accessors> are created using
261 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
262 L</force_ascii> is set; this is only significant for names with non-C<\w>
263 characters such as C<.>.
265 For relationships, belongs_to accessors are made from column names by stripping
266 postfixes other than C<_id> as well, just C<id>, C<_?ref>, C<_?cd>, C<_?code>
271 For L</monikers>, this option does not inflect the table names but makes
272 monikers based on the actual name. For L</column_accessors> this option does
273 not normalize CamelCase column names to lowercase column accessors, but makes
274 accessors that are the same names as the columns (with any non-\w chars
275 replaced with underscores.)
279 For L</monikers>, singularizes the names using the most current inflector. This
280 is the same as setting the option to L</current>.
284 For L</monikers>, pluralizes the names, using the most current inflector.
288 Dynamic schemas will always default to the 0.04XXX relationship names and won't
289 singularize Results for backward compatibility, to activate the new RelBuilder
290 and singularization put this in your C<Schema.pm> file:
292 __PACKAGE__->naming('current');
294 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
295 next major version upgrade:
297 __PACKAGE__->naming('v7');
301 If true, will not print the usual C<Dumping manual schema ... Schema dump
302 completed.> messages. Does not affect warnings (except for warnings related to
303 L</really_erase_my_files>.)
307 By default POD will be generated for columns and relationships, using database
308 metadata for the text if available and supported.
310 Comment metadata can be stored in two ways.
312 The first is that you can create two tables named C<table_comments> and
313 C<column_comments> respectively. These tables must exist in the same database
314 and schema as the tables they describe. They both need to have columns named
315 C<table_name> and C<comment_text>. The second one needs to have a column named
316 C<column_name>. Then data stored in these tables will be used as a source of
317 metadata about tables and comments.
319 (If you wish you can change the name of these tables with the parameters
320 L</table_comments_table> and L</column_comments_table>.)
322 As a fallback you can use built-in commenting mechanisms. Currently this is
323 only supported for PostgreSQL, Oracle and MySQL. To create comments in
324 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
325 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
326 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
327 restricts the length of comments, and also does not handle complex Unicode
330 Set this to C<0> to turn off all POD generation.
332 =head2 pod_comment_mode
334 Controls where table comments appear in the generated POD. Smaller table
335 comments are appended to the C<NAME> section of the documentation, and larger
336 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
337 section to be generated with the comment always, only use C<NAME>, or choose
338 the length threshold at which the comment is forced into the description.
344 Use C<NAME> section only.
348 Force C<DESCRIPTION> always.
352 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
357 =head2 pod_comment_spillover_length
359 When pod_comment_mode is set to C<auto>, this is the length of the comment at
360 which it will be forced into a separate description section.
364 =head2 table_comments_table
366 The table to look for comments about tables in. By default C<table_comments>.
367 See L</generate_pod> for details.
369 This must not be a fully qualified name, the table will be looked for in the
370 same database and schema as the table whose comment is being retrieved.
372 =head2 column_comments_table
374 The table to look for comments about columns in. By default C<column_comments>.
375 See L</generate_pod> for details.
377 This must not be a fully qualified name, the table will be looked for in the
378 same database and schema as the table/column whose comment is being retrieved.
380 =head2 relationship_attrs
382 Hashref of attributes to pass to each generated relationship, listed
383 by type. Also supports relationship type 'all', containing options to
384 pass to all generated relationships. Attributes set for more specific
385 relationship types override those set in 'all'.
389 relationship_attrs => {
390 belongs_to => { is_deferrable => 0 },
393 use this to turn off DEFERRABLE on your foreign key constraints.
397 If set to true, each constructive L<DBIx::Class> statement the loader
398 decides to execute will be C<warn>-ed before execution.
402 Set the name of the schema to load (schema in the sense that your database
405 Can be set to an arrayref of schema names for multiple schemas, or the special
406 value C<%> for all schemas.
408 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
409 keys and arrays of owners as values, set to the value:
413 for all owners in all databases.
415 You may need to control naming of monikers with L</moniker_parts> if you have
416 name clashes for tables in different schemas/databases.
420 The database table names are represented by the
421 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
422 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
423 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
425 Monikers are created normally based on just the
426 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
427 the table name, but can consist of other parts of the fully qualified name of
430 The L</moniker_parts> option is an arrayref of methods on the table class
431 corresponding to parts of the fully qualified table name, defaulting to
432 C<['name']>, in the order those parts are used to create the moniker name.
434 The C<'name'> entry B<must> be present.
436 Below is a table of supported databases and possible L</moniker_parts>.
440 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
444 =item * Informix, MSSQL, Sybase ASE
446 C<database>, C<schema>, C<name>
452 Only load tables matching regex. Best specified as a qr// regex.
456 Exclude tables matching regex. Best specified as a qr// regex.
460 Overrides the default table name to moniker translation. Can be either
461 a hashref of table keys and moniker values, or a coderef for a translator
462 function taking a single scalar table name argument and returning
463 a scalar moniker. If the hash entry does not exist, or the function
464 returns a false value, the code falls back to default behavior
467 The default behavior is to split on case transition and non-alphanumeric
468 boundaries, singularize the resulting phrase, then join the titlecased words
471 Table Name | Moniker Name
472 ---------------------------------
474 luser_group | LuserGroup
475 luser-opts | LuserOpt
476 stations_visited | StationVisited
477 routeChange | RouteChange
479 =head2 col_accessor_map
481 Same as moniker_map, but for column accessor names. If a coderef is
482 passed, the code is called with arguments of
484 the name of the column in the underlying database,
485 default accessor name that DBICSL would ordinarily give this column,
487 table_class => name of the DBIC class we are building,
488 table_moniker => calculated moniker for this table (after moniker_map if present),
489 table_name => name of the database table,
490 full_table_name => schema-qualified name of the database table (RDBMS specific),
491 schema_class => name of the schema class we are building,
492 column_info => hashref of column info (data_type, is_nullable, etc),
497 Similar in idea to moniker_map, but different in the details. It can be
498 a hashref or a code ref.
500 If it is a hashref, keys can be either the default relationship name, or the
501 moniker. The keys that are the default relationship name should map to the
502 name you want to change the relationship to. Keys that are monikers should map
503 to hashes mapping relationship names to their translation. You can do both at
504 once, and the more specific moniker version will be picked up first. So, for
505 instance, you could have
514 and relationships that would have been named C<bar> will now be named C<baz>
515 except that in the table whose moniker is C<Foo> it will be named C<blat>.
517 If it is a coderef, the argument passed will be a hashref of this form:
520 name => default relationship name,
521 type => the relationship type eg: C<has_many>,
522 local_class => name of the DBIC class we are building,
523 local_moniker => moniker of the DBIC class we are building,
524 local_columns => columns in this table in the relationship,
525 remote_class => name of the DBIC class we are related to,
526 remote_moniker => moniker of the DBIC class we are related to,
527 remote_columns => columns in the other table in the relationship,
530 DBICSL will try to use the value returned as the relationship name.
532 =head2 inflect_plural
534 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
535 if hash key does not exist or coderef returns false), but acts as a map
536 for pluralizing relationship names. The default behavior is to utilize
537 L<Lingua::EN::Inflect::Phrase/to_PL>.
539 =head2 inflect_singular
541 As L</inflect_plural> above, but for singularizing relationship names.
542 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
544 =head2 schema_base_class
546 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
548 =head2 schema_components
550 List of components to load into the Schema class.
552 =head2 result_base_class
554 Base class for your table classes (aka result classes). Defaults to
557 =head2 additional_base_classes
559 List of additional base classes all of your table classes will use.
561 =head2 left_base_classes
563 List of additional base classes all of your table classes will use
564 that need to be leftmost.
566 =head2 additional_classes
568 List of additional classes which all of your table classes will use.
572 List of additional components to be loaded into all of your Result
573 classes. A good example would be
574 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
576 =head2 result_components_map
578 A hashref of moniker keys and component values. Unlike L</components>, which
579 loads the given components into every Result class, this option allows you to
580 load certain components for specified Result classes. For example:
582 result_components_map => {
583 StationVisited => '+YourApp::Schema::Component::StationVisited',
585 '+YourApp::Schema::Component::RouteChange',
586 'InflateColumn::DateTime',
590 You may use this in conjunction with L</components>.
594 List of L<Moose> roles to be applied to all of your Result classes.
596 =head2 result_roles_map
598 A hashref of moniker keys and role values. Unlike L</result_roles>, which
599 applies the given roles to every Result class, this option allows you to apply
600 certain roles for specified Result classes. For example:
602 result_roles_map => {
604 'YourApp::Role::Building',
605 'YourApp::Role::Destination',
607 RouteChange => 'YourApp::Role::TripEvent',
610 You may use this in conjunction with L</result_roles>.
612 =head2 use_namespaces
614 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
617 Generate result class names suitable for
618 L<DBIx::Class::Schema/load_namespaces> and call that instead of
619 L<DBIx::Class::Schema/load_classes>. When using this option you can also
620 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
621 C<resultset_namespace>, C<default_resultset_class>), and they will be added
622 to the call (and the generated result class names adjusted appropriately).
624 =head2 dump_directory
626 The value of this option is a perl libdir pathname. Within
627 that directory this module will create a baseline manual
628 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
630 The created schema class will have the same classname as the one on
631 which you are setting this option (and the ResultSource classes will be
632 based on this name as well).
634 Normally you wouldn't hard-code this setting in your schema class, as it
635 is meant for one-time manual usage.
637 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
638 recommended way to access this functionality.
640 =head2 dump_overwrite
642 Deprecated. See L</really_erase_my_files> below, which does *not* mean
643 the same thing as the old C<dump_overwrite> setting from previous releases.
645 =head2 really_erase_my_files
647 Default false. If true, Loader will unconditionally delete any existing
648 files before creating the new ones from scratch when dumping a schema to disk.
650 The default behavior is instead to only replace the top portion of the
651 file, up to and including the final stanza which contains
652 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
653 leaving any customizations you placed after that as they were.
655 When C<really_erase_my_files> is not set, if the output file already exists,
656 but the aforementioned final stanza is not found, or the checksum
657 contained there does not match the generated contents, Loader will
658 croak and not touch the file.
660 You should really be using version control on your schema classes (and all
661 of the rest of your code for that matter). Don't blame me if a bug in this
662 code wipes something out when it shouldn't have, you've been warned.
664 =head2 overwrite_modifications
666 Default false. If false, when updating existing files, Loader will
667 refuse to modify any Loader-generated code that has been modified
668 since its last run (as determined by the checksum Loader put in its
671 If true, Loader will discard any manual modifications that have been
672 made to Loader-generated code.
674 Again, you should be using version control on your schema classes. Be
675 careful with this option.
677 =head2 custom_column_info
679 Hook for adding extra attributes to the
680 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
682 Must be a coderef that returns a hashref with the extra attributes.
684 Receives the table name, column name and column_info.
688 custom_column_info => sub {
689 my ($table_name, $column_name, $column_info) = @_;
691 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
692 return { is_snoopy => 1 };
696 This attribute can also be used to set C<inflate_datetime> on a non-datetime
697 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
699 =head2 datetime_timezone
701 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
702 columns with the DATE/DATETIME/TIMESTAMP data_types.
704 =head2 datetime_locale
706 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
707 columns with the DATE/DATETIME/TIMESTAMP data_types.
709 =head2 datetime_undef_if_invalid
711 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
712 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
715 The default is recommended to deal with data such as C<00/00/00> which
716 sometimes ends up in such columns in MySQL.
720 File in Perl format, which should return a HASH reference, from which to read
725 Usually column names are lowercased, to make them easier to work with in
726 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
729 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
730 case-sensitive collation will turn this option on unconditionally.
732 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
735 =head2 qualify_objects
737 Set to true to prepend the L</db_schema> to table names for C<<
738 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
742 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
743 L<namespace::autoclean>. The default content after the md5 sum also makes the
746 It is safe to upgrade your existing Schema to this option.
748 =head2 col_collision_map
750 This option controls how accessors for column names which collide with perl
751 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
753 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
754 strings which are compiled to regular expressions that map to
755 L<sprintf|perlfunc/sprintf> formats.
759 col_collision_map => 'column_%s'
761 col_collision_map => { '(.*)' => 'column_%s' }
763 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
765 =head2 rel_collision_map
767 Works just like L</col_collision_map>, but for relationship names/accessors
768 rather than column names/accessors.
770 The default is to just append C<_rel> to the relationship name, see
771 L</RELATIONSHIP NAME COLLISIONS>.
773 =head2 uniq_to_primary
775 Automatically promotes the largest unique constraints with non-nullable columns
776 on tables to primary keys, assuming there is only one largest unique
779 =head2 filter_generated_code
781 An optional hook that lets you filter the generated text for various classes
782 through a function that change it in any way that you want. The function will
783 receive the type of file, C<schema> or C<result>, class and code; and returns
784 the new code to use instead. For instance you could add custom comments, or do
785 anything else that you want.
787 The option can also be set to a string, which is then used as a filter program,
790 If this exists but fails to return text matching C</\bpackage\b/>, no file will
793 filter_generated_code => sub {
794 my ($type, $class, $text) = @_;
801 None of these methods are intended for direct invocation by regular
802 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
803 L<DBIx::Class::Schema::Loader>.
807 # ensure that a peice of object data is a valid arrayref, creating
808 # an empty one or encapsulating whatever's there.
809 sub _ensure_arrayref {
814 $self->{$_} = [ $self->{$_} ]
815 unless ref $self->{$_} eq 'ARRAY';
821 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
822 by L<DBIx::Class::Schema::Loader>.
827 my ( $class, %args ) = @_;
829 if (exists $args{column_accessor_map}) {
830 $args{col_accessor_map} = delete $args{column_accessor_map};
833 my $self = { %args };
835 # don't lose undef options
836 for (values %$self) {
837 $_ = 0 unless defined $_;
840 bless $self => $class;
842 if (my $config_file = $self->config_file) {
843 my $config_opts = do $config_file;
845 croak "Error reading config from $config_file: $@" if $@;
847 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
849 while (my ($k, $v) = each %$config_opts) {
850 $self->{$k} = $v unless exists $self->{$k};
854 if (defined $self->{result_component_map}) {
855 if (defined $self->result_components_map) {
856 croak "Specify only one of result_components_map or result_component_map";
858 $self->result_components_map($self->{result_component_map})
861 if (defined $self->{result_role_map}) {
862 if (defined $self->result_roles_map) {
863 croak "Specify only one of result_roles_map or result_role_map";
865 $self->result_roles_map($self->{result_role_map})
868 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
869 if ((not defined $self->use_moose) || (not $self->use_moose))
870 && ((defined $self->result_roles) || (defined $self->result_roles_map));
872 $self->_ensure_arrayref(qw/schema_components
874 additional_base_classes
880 $self->_validate_class_args;
882 croak "result_components_map must be a hash"
883 if defined $self->result_components_map
884 && ref $self->result_components_map ne 'HASH';
886 if ($self->result_components_map) {
887 my %rc_map = %{ $self->result_components_map };
888 foreach my $moniker (keys %rc_map) {
889 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
891 $self->result_components_map(\%rc_map);
894 $self->result_components_map({});
896 $self->_validate_result_components_map;
898 croak "result_roles_map must be a hash"
899 if defined $self->result_roles_map
900 && ref $self->result_roles_map ne 'HASH';
902 if ($self->result_roles_map) {
903 my %rr_map = %{ $self->result_roles_map };
904 foreach my $moniker (keys %rr_map) {
905 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
907 $self->result_roles_map(\%rr_map);
909 $self->result_roles_map({});
911 $self->_validate_result_roles_map;
913 if ($self->use_moose) {
914 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
915 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
916 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
920 $self->{_tables} = {};
921 $self->{monikers} = {};
922 $self->{moniker_to_table} = {};
923 $self->{class_to_table} = {};
924 $self->{classes} = {};
925 $self->{_upgrading_classes} = {};
927 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
928 $self->{schema} ||= $self->{schema_class};
929 $self->{table_comments_table} ||= 'table_comments';
930 $self->{column_comments_table} ||= 'column_comments';
932 croak "dump_overwrite is deprecated. Please read the"
933 . " DBIx::Class::Schema::Loader::Base documentation"
934 if $self->{dump_overwrite};
936 $self->{dynamic} = ! $self->{dump_directory};
937 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
942 $self->{dump_directory} ||= $self->{temp_directory};
944 $self->real_dump_directory($self->{dump_directory});
946 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
947 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
949 if (not defined $self->naming) {
950 $self->naming_set(0);
953 $self->naming_set(1);
956 if ((not ref $self->naming) && defined $self->naming) {
957 my $naming_ver = $self->naming;
959 relationships => $naming_ver,
960 monikers => $naming_ver,
961 column_accessors => $naming_ver,
964 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
965 my $val = delete $self->naming->{ALL};
967 $self->naming->{$_} = $val
968 foreach qw/relationships monikers column_accessors/;
972 foreach my $key (qw/relationships monikers column_accessors/) {
973 $self->naming->{$key} = $CURRENT_V if $self->naming->{$key} eq 'current';
976 $self->{naming} ||= {};
978 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
979 croak 'custom_column_info must be a CODE ref';
982 $self->_check_back_compat;
984 $self->use_namespaces(1) unless defined $self->use_namespaces;
985 $self->generate_pod(1) unless defined $self->generate_pod;
986 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
987 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
989 if (my $col_collision_map = $self->col_collision_map) {
990 if (my $reftype = ref $col_collision_map) {
991 if ($reftype ne 'HASH') {
992 croak "Invalid type $reftype for option 'col_collision_map'";
996 $self->col_collision_map({ '(.*)' => $col_collision_map });
1000 if (my $rel_collision_map = $self->rel_collision_map) {
1001 if (my $reftype = ref $rel_collision_map) {
1002 if ($reftype ne 'HASH') {
1003 croak "Invalid type $reftype for option 'rel_collision_map'";
1007 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1011 if (defined(my $rel_name_map = $self->rel_name_map)) {
1012 my $reftype = ref $rel_name_map;
1013 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1014 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1018 if (defined(my $filter = $self->filter_generated_code)) {
1019 my $reftype = ref $filter;
1020 if ($reftype && $reftype ne 'CODE') {
1021 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1025 if (defined $self->db_schema) {
1026 if (ref $self->db_schema eq 'ARRAY') {
1027 if (@{ $self->db_schema } > 1) {
1028 $self->{qualify_objects} = 1;
1030 elsif (@{ $self->db_schema } == 0) {
1031 $self->{db_schema} = undef;
1034 elsif (not ref $self->db_schema) {
1035 if ($self->db_schema eq '%') {
1036 $self->{qualify_objects} = 1;
1039 $self->{db_schema} = [ $self->db_schema ];
1043 if (not $self->moniker_parts) {
1044 $self->moniker_parts(['name']);
1047 if (not ref $self->moniker_parts) {
1048 $self->moniker_parts([ $self->moniker_parts ]);
1050 if (ref $self->moniker_parts ne 'ARRAY') {
1051 croak 'moniker_parts must be an arrayref';
1053 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1054 croak "moniker_parts option *must* contain 'name'";
1061 sub _check_back_compat {
1064 # dynamic schemas will always be in 0.04006 mode, unless overridden
1065 if ($self->dynamic) {
1066 # just in case, though no one is likely to dump a dynamic schema
1067 $self->schema_version_to_dump('0.04006');
1069 if (not $self->naming_set) {
1070 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1072 Dynamic schema detected, will run in 0.04006 mode.
1074 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1075 to disable this warning.
1077 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1082 $self->_upgrading_from('v4');
1085 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1086 $self->use_namespaces(1);
1089 $self->naming->{relationships} ||= 'v4';
1090 $self->naming->{monikers} ||= 'v4';
1092 if ($self->use_namespaces) {
1093 $self->_upgrading_from_load_classes(1);
1096 $self->use_namespaces(0);
1102 # otherwise check if we need backcompat mode for a static schema
1103 my $filename = $self->get_dump_filename($self->schema_class);
1104 return unless -e $filename;
1106 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1107 $self->_parse_generated_file($filename);
1109 return unless $old_ver;
1111 # determine if the existing schema was dumped with use_moose => 1
1112 if (! defined $self->use_moose) {
1113 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1116 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1118 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1119 my $ds = eval $result_namespace;
1121 Could not eval expression '$result_namespace' for result_namespace from
1124 $result_namespace = $ds || '';
1126 if ($load_classes && (not defined $self->use_namespaces)) {
1127 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1129 'load_classes;' static schema detected, turning off 'use_namespaces'.
1131 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1132 variable to disable this warning.
1134 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1137 $self->use_namespaces(0);
1139 elsif ($load_classes && $self->use_namespaces) {
1140 $self->_upgrading_from_load_classes(1);
1142 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1143 $self->_downgrading_to_load_classes(
1144 $result_namespace || 'Result'
1147 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1148 if (not $self->result_namespace) {
1149 $self->result_namespace($result_namespace || 'Result');
1151 elsif ($result_namespace ne $self->result_namespace) {
1152 $self->_rewriting_result_namespace(
1153 $result_namespace || 'Result'
1158 # XXX when we go past .0 this will need fixing
1159 my ($v) = $old_ver =~ /([1-9])/;
1162 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1164 if (not %{ $self->naming }) {
1165 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1167 Version $old_ver static schema detected, turning on backcompat mode.
1169 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1170 to disable this warning.
1172 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1174 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1175 from version 0.04006.
1178 $self->naming->{relationships} ||= $v;
1179 $self->naming->{monikers} ||= $v;
1180 $self->naming->{column_accessors} ||= $v;
1182 $self->schema_version_to_dump($old_ver);
1185 $self->_upgrading_from($v);
1189 sub _validate_class_args {
1192 foreach my $k (@CLASS_ARGS) {
1193 next unless $self->$k;
1195 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1196 $self->_validate_classes($k, \@classes);
1200 sub _validate_result_components_map {
1203 foreach my $classes (values %{ $self->result_components_map }) {
1204 $self->_validate_classes('result_components_map', $classes);
1208 sub _validate_result_roles_map {
1211 foreach my $classes (values %{ $self->result_roles_map }) {
1212 $self->_validate_classes('result_roles_map', $classes);
1216 sub _validate_classes {
1219 my $classes = shift;
1221 # make a copy to not destroy original
1222 my @classes = @$classes;
1224 foreach my $c (@classes) {
1225 # components default to being under the DBIx::Class namespace unless they
1226 # are preceeded with a '+'
1227 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1228 $c = 'DBIx::Class::' . $c;
1231 # 1 == installed, 0 == not installed, undef == invalid classname
1232 my $installed = Class::Inspector->installed($c);
1233 if ( defined($installed) ) {
1234 if ( $installed == 0 ) {
1235 croak qq/$c, as specified in the loader option "$key", is not installed/;
1238 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1244 sub _find_file_in_inc {
1245 my ($self, $file) = @_;
1247 foreach my $prefix (@INC) {
1248 my $fullpath = File::Spec->catfile($prefix, $file);
1249 return $fullpath if -f $fullpath
1250 # abs_path throws on Windows for nonexistant files
1251 and (try { Cwd::abs_path($fullpath) }) ne
1252 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1258 sub _find_class_in_inc {
1259 my ($self, $class) = @_;
1261 return $self->_find_file_in_inc(class_path($class));
1267 return $self->_upgrading_from
1268 || $self->_upgrading_from_load_classes
1269 || $self->_downgrading_to_load_classes
1270 || $self->_rewriting_result_namespace
1274 sub _rewrite_old_classnames {
1275 my ($self, $code) = @_;
1277 return $code unless $self->_rewriting;
1279 my %old_classes = reverse %{ $self->_upgrading_classes };
1281 my $re = join '|', keys %old_classes;
1282 $re = qr/\b($re)\b/;
1284 $code =~ s/$re/$old_classes{$1} || $1/eg;
1289 sub _load_external {
1290 my ($self, $class) = @_;
1292 return if $self->{skip_load_external};
1294 # so that we don't load our own classes, under any circumstances
1295 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1297 my $real_inc_path = $self->_find_class_in_inc($class);
1299 my $old_class = $self->_upgrading_classes->{$class}
1300 if $self->_rewriting;
1302 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1303 if $old_class && $old_class ne $class;
1305 return unless $real_inc_path || $old_real_inc_path;
1307 if ($real_inc_path) {
1308 # If we make it to here, we loaded an external definition
1309 warn qq/# Loaded external class definition for '$class'\n/
1312 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1314 if ($self->dynamic) { # load the class too
1315 eval_package_without_redefine_warnings($class, $code);
1318 $self->_ext_stmt($class,
1319 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1320 .qq|# They are now part of the custom portion of this file\n|
1321 .qq|# for you to hand-edit. If you do not either delete\n|
1322 .qq|# this section or remove that file from \@INC, this section\n|
1323 .qq|# will be repeated redundantly when you re-create this\n|
1324 .qq|# file again via Loader! See skip_load_external to disable\n|
1325 .qq|# this feature.\n|
1328 $self->_ext_stmt($class, $code);
1329 $self->_ext_stmt($class,
1330 qq|# End of lines loaded from '$real_inc_path' |
1334 if ($old_real_inc_path) {
1335 my $code = slurp_file $old_real_inc_path;
1337 $self->_ext_stmt($class, <<"EOF");
1339 # These lines were loaded from '$old_real_inc_path',
1340 # based on the Result class name that would have been created by an older
1341 # version of the Loader. For a static schema, this happens only once during
1342 # upgrade. See skip_load_external to disable this feature.
1345 $code = $self->_rewrite_old_classnames($code);
1347 if ($self->dynamic) {
1350 Detected external content in '$old_real_inc_path', a class name that would have
1351 been used by an older version of the Loader.
1353 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1354 new name of the Result.
1356 eval_package_without_redefine_warnings($class, $code);
1360 $self->_ext_stmt($class, $code);
1361 $self->_ext_stmt($class,
1362 qq|# End of lines loaded from '$old_real_inc_path' |
1369 Does the actual schema-construction work.
1376 $self->_load_tables(
1377 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1385 Rescan the database for changes. Returns a list of the newly added table
1388 The schema argument should be the schema class or object to be affected. It
1389 should probably be derived from the original schema_class used during L</load>.
1394 my ($self, $schema) = @_;
1396 $self->{schema} = $schema;
1397 $self->_relbuilder->{schema} = $schema;
1400 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1402 foreach my $table (@current) {
1403 if(!exists $self->_tables->{$table->sql_name}) {
1404 push(@created, $table);
1409 @current{map $_->sql_name, @current} = ();
1410 foreach my $table (values %{ $self->_tables }) {
1411 if (not exists $current{$table->sql_name}) {
1412 $self->_remove_table($table);
1416 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1418 my $loaded = $self->_load_tables(@current);
1420 foreach my $table (@created) {
1421 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1424 return map { $self->monikers->{$_->sql_name} } @created;
1430 return if $self->{skip_relationships};
1432 return $self->{relbuilder} ||= do {
1433 my $relbuilder_suff =
1440 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1442 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1443 $self->ensure_class_loaded($relbuilder_class);
1444 $relbuilder_class->new($self);
1449 my ($self, @tables) = @_;
1451 # Save the new tables to the tables list
1453 $self->_tables->{$_->sql_name} = $_;
1456 $self->_make_src_class($_) for @tables;
1458 # sanity-check for moniker clashes
1459 my $inverse_moniker_idx;
1460 foreach my $table (values %{ $self->_tables }) {
1461 push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table;
1465 foreach my $moniker (keys %$inverse_moniker_idx) {
1466 my $tables = $inverse_moniker_idx->{$moniker};
1468 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1469 join (', ', map $_->sql_name, @$tables),
1476 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1477 . 'In multi db_schema configurations you may need to set moniker_parts, '
1478 . 'otherwise change the naming style, or supply an explicit moniker_map: '
1479 . join ('; ', @clashes)
1484 $self->_setup_src_meta($_) for @tables;
1486 if(!$self->skip_relationships) {
1487 # The relationship loader needs a working schema
1488 local $self->{quiet} = 1;
1489 local $self->{dump_directory} = $self->{temp_directory};
1490 $self->_reload_classes(\@tables);
1491 $self->_load_relationships(\@tables);
1493 # Remove that temp dir from INC so it doesn't get reloaded
1494 @INC = grep $_ ne $self->dump_directory, @INC;
1497 $self->_load_roles($_) for @tables;
1499 $self->_load_external($_)
1500 for map { $self->classes->{$_->sql_name} } @tables;
1502 # Reload without unloading first to preserve any symbols from external
1504 $self->_reload_classes(\@tables, { unload => 0 });
1506 # Drop temporary cache
1507 delete $self->{_cache};
1512 sub _reload_classes {
1513 my ($self, $tables, $opts) = @_;
1515 my @tables = @$tables;
1517 my $unload = $opts->{unload};
1518 $unload = 1 unless defined $unload;
1520 # so that we don't repeat custom sections
1521 @INC = grep $_ ne $self->dump_directory, @INC;
1523 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1525 unshift @INC, $self->dump_directory;
1528 my %have_source = map { $_ => $self->schema->source($_) }
1529 $self->schema->sources;
1531 for my $table (@tables) {
1532 my $moniker = $self->monikers->{$table->sql_name};
1533 my $class = $self->classes->{$table->sql_name};
1536 no warnings 'redefine';
1537 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1540 if (my $mc = $self->_moose_metaclass($class)) {
1543 Class::Unload->unload($class) if $unload;
1544 my ($source, $resultset_class);
1546 ($source = $have_source{$moniker})
1547 && ($resultset_class = $source->resultset_class)
1548 && ($resultset_class ne 'DBIx::Class::ResultSet')
1550 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1551 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1554 Class::Unload->unload($resultset_class) if $unload;
1555 $self->_reload_class($resultset_class) if $has_file;
1557 $self->_reload_class($class);
1559 push @to_register, [$moniker, $class];
1562 Class::C3->reinitialize;
1563 for (@to_register) {
1564 $self->schema->register_class(@$_);
1568 sub _moose_metaclass {
1569 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1573 my $mc = try { Class::MOP::class_of($class) }
1576 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1579 # We use this instead of ensure_class_loaded when there are package symbols we
1582 my ($self, $class) = @_;
1584 delete $INC{ +class_path($class) };
1587 eval_package_without_redefine_warnings ($class, "require $class");
1590 my $source = slurp_file $self->_get_dump_filename($class);
1591 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1595 sub _get_dump_filename {
1596 my ($self, $class) = (@_);
1598 $class =~ s{::}{/}g;
1599 return $self->dump_directory . q{/} . $class . q{.pm};
1602 =head2 get_dump_filename
1606 Returns the full path to the file for a class that the class has been or will
1607 be dumped to. This is a file in a temp dir for a dynamic schema.
1611 sub get_dump_filename {
1612 my ($self, $class) = (@_);
1614 local $self->{dump_directory} = $self->real_dump_directory;
1616 return $self->_get_dump_filename($class);
1619 sub _ensure_dump_subdirs {
1620 my ($self, $class) = (@_);
1622 my @name_parts = split(/::/, $class);
1623 pop @name_parts; # we don't care about the very last element,
1624 # which is a filename
1626 my $dir = $self->dump_directory;
1629 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1631 last if !@name_parts;
1632 $dir = File::Spec->catdir($dir, shift @name_parts);
1637 my ($self, @classes) = @_;
1639 my $schema_class = $self->schema_class;
1640 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1642 my $target_dir = $self->dump_directory;
1643 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1644 unless $self->dynamic or $self->quiet;
1648 . qq|package $schema_class;\n\n|
1649 . qq|# Created by DBIx::Class::Schema::Loader\n|
1650 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1652 if ($self->use_moose) {
1653 $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
1656 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1659 my @schema_components = @{ $self->schema_components || [] };
1661 if (@schema_components) {
1662 my $schema_components = dump @schema_components;
1663 $schema_components = "($schema_components)" if @schema_components == 1;
1665 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1668 if ($self->use_namespaces) {
1669 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1670 my $namespace_options;
1672 my @attr = qw/resultset_namespace default_resultset_class/;
1674 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1676 for my $attr (@attr) {
1678 my $code = dumper_squashed $self->$attr;
1679 $namespace_options .= qq| $attr => $code,\n|
1682 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1683 $schema_text .= qq|;\n|;
1686 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1690 local $self->{version_to_dump} = $self->schema_version_to_dump;
1691 $self->_write_classfile($schema_class, $schema_text, 1);
1694 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1696 foreach my $src_class (@classes) {
1699 . qq|package $src_class;\n\n|
1700 . qq|# Created by DBIx::Class::Schema::Loader\n|
1701 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1703 $src_text .= $self->_make_pod_heading($src_class);
1705 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1707 $src_text .= $self->_base_class_pod($result_base_class)
1708 unless $result_base_class eq 'DBIx::Class::Core';
1710 if ($self->use_moose) {
1711 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
1713 # these options 'use base' which is compile time
1714 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1715 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1718 $src_text .= qq|\nextends '$result_base_class';\n|;
1722 $src_text .= qq|use base '$result_base_class';\n|;
1725 $self->_write_classfile($src_class, $src_text);
1728 # remove Result dir if downgrading from use_namespaces, and there are no
1730 if (my $result_ns = $self->_downgrading_to_load_classes
1731 || $self->_rewriting_result_namespace) {
1732 my $result_namespace = $self->_result_namespace(
1737 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1738 $result_dir = $self->dump_directory . '/' . $result_dir;
1740 unless (my @files = glob "$result_dir/*") {
1745 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1749 my ($self, $version, $ts) = @_;
1750 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1753 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1756 sub _write_classfile {
1757 my ($self, $class, $text, $is_schema) = @_;
1759 my $filename = $self->_get_dump_filename($class);
1760 $self->_ensure_dump_subdirs($class);
1762 if (-f $filename && $self->really_erase_my_files) {
1763 warn "Deleting existing file '$filename' due to "
1764 . "'really_erase_my_files' setting\n" unless $self->quiet;
1768 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1769 = $self->_parse_generated_file($filename);
1771 if (! $old_gen && -f $filename) {
1772 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1773 . " it does not appear to have been generated by Loader"
1776 my $custom_content = $old_custom || '';
1778 # prepend extra custom content from a *renamed* class (singularization effect)
1779 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1780 my $old_filename = $self->_get_dump_filename($renamed_class);
1782 if (-f $old_filename) {
1783 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1785 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1787 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1790 unlink $old_filename;
1794 $custom_content ||= $self->_default_custom_content($is_schema);
1796 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1797 # If there is already custom content, which does not have the Moose content, add it.
1798 if ($self->use_moose) {
1800 my $non_moose_custom_content = do {
1801 local $self->{use_moose} = 0;
1802 $self->_default_custom_content;
1805 if ($custom_content eq $non_moose_custom_content) {
1806 $custom_content = $self->_default_custom_content($is_schema);
1808 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1809 $custom_content .= $self->_default_custom_content($is_schema);
1812 elsif (defined $self->use_moose && $old_gen) {
1813 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'
1814 if $old_gen =~ /use \s+ MooseX?\b/x;
1817 $custom_content = $self->_rewrite_old_classnames($custom_content);
1820 for @{$self->{_dump_storage}->{$class} || []};
1822 if ($self->filter_generated_code) {
1823 my $filter = $self->filter_generated_code;
1825 if (ref $filter eq 'CODE') {
1827 ($is_schema ? 'schema' : 'result'),
1833 my ($out, $in) = (gensym, gensym);
1835 my $pid = open2($out, $in, $filter)
1836 or croak "Could not open pipe to $filter: $!";
1842 $text = decode('UTF-8', do { local $/; <$out> });
1844 $text =~ s/$CR?$LF/\n/g;
1848 my $exit_code = $? >> 8;
1850 if ($exit_code != 0) {
1851 croak "filter '$filter' exited non-zero: $exit_code";
1854 if (not $text or not $text =~ /\bpackage\b/) {
1855 warn("$class skipped due to filter") if $self->debug;
1860 # Check and see if the dump is in fact different
1864 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1865 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1866 return unless $self->_upgrading_from && $is_schema;
1870 $text .= $self->_sig_comment(
1871 $self->version_to_dump,
1872 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1875 open(my $fh, '>:encoding(UTF-8)', $filename)
1876 or croak "Cannot open '$filename' for writing: $!";
1878 # Write the top half and its MD5 sum
1879 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1881 # Write out anything loaded via external partial class file in @INC
1883 for @{$self->{_ext_storage}->{$class} || []};
1885 # Write out any custom content the user has added
1886 print $fh $custom_content;
1889 or croak "Error closing '$filename': $!";
1892 sub _default_moose_custom_content {
1893 my ($self, $is_schema) = @_;
1895 if (not $is_schema) {
1896 return qq|\n__PACKAGE__->meta->make_immutable;|;
1899 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1902 sub _default_custom_content {
1903 my ($self, $is_schema) = @_;
1904 my $default = qq|\n\n# You can replace this text with custom|
1905 . qq| code or comments, and it will be preserved on regeneration|;
1906 if ($self->use_moose) {
1907 $default .= $self->_default_moose_custom_content($is_schema);
1909 $default .= qq|\n1;\n|;
1913 sub _parse_generated_file {
1914 my ($self, $fn) = @_;
1916 return unless -f $fn;
1918 open(my $fh, '<:encoding(UTF-8)', $fn)
1919 or croak "Cannot open '$fn' for reading: $!";
1922 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
1924 my ($md5, $ts, $ver, $gen);
1930 # Pull out the version and timestamp from the line above
1931 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
1934 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"
1935 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1944 my $custom = do { local $/; <$fh> }
1948 $custom =~ s/$CRLF|$LF/\n/g;
1952 return ($gen, $md5, $ver, $ts, $custom);
1960 warn "$target: use $_;" if $self->debug;
1961 $self->_raw_stmt($target, "use $_;");
1969 my $blist = join(q{ }, @_);
1971 return unless $blist;
1973 warn "$target: use base qw/$blist/;" if $self->debug;
1974 $self->_raw_stmt($target, "use base qw/$blist/;");
1981 my $rlist = join(q{, }, map { qq{'$_'} } @_);
1983 return unless $rlist;
1985 warn "$target: with $rlist;" if $self->debug;
1986 $self->_raw_stmt($target, "\nwith $rlist;");
1989 sub _result_namespace {
1990 my ($self, $schema_class, $ns) = @_;
1991 my @result_namespace;
1993 $ns = $ns->[0] if ref $ns;
1995 if ($ns =~ /^\+(.*)/) {
1996 # Fully qualified namespace
1997 @result_namespace = ($1)
2000 # Relative namespace
2001 @result_namespace = ($schema_class, $ns);
2004 return wantarray ? @result_namespace : join '::', @result_namespace;
2007 # Create class with applicable bases, setup monikers, etc
2008 sub _make_src_class {
2009 my ($self, $table) = @_;
2011 my $schema = $self->schema;
2012 my $schema_class = $self->schema_class;
2014 my $table_moniker = $self->_table2moniker($table);
2015 my @result_namespace = ($schema_class);
2016 if ($self->use_namespaces) {
2017 my $result_namespace = $self->result_namespace || 'Result';
2018 @result_namespace = $self->_result_namespace(
2023 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2025 if ((my $upgrading_v = $self->_upgrading_from)
2026 || $self->_rewriting) {
2027 local $self->naming->{monikers} = $upgrading_v
2030 my @result_namespace = @result_namespace;
2031 if ($self->_upgrading_from_load_classes) {
2032 @result_namespace = ($schema_class);
2034 elsif (my $ns = $self->_downgrading_to_load_classes) {
2035 @result_namespace = $self->_result_namespace(
2040 elsif ($ns = $self->_rewriting_result_namespace) {
2041 @result_namespace = $self->_result_namespace(
2047 my $old_table_moniker = do {
2048 local $self->naming->{monikers} = $upgrading_v;
2049 $self->_table2moniker($table);
2052 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2054 $self->_upgrading_classes->{$table_class} = $old_class
2055 unless $table_class eq $old_class;
2058 $self->classes->{$table->sql_name} = $table_class;
2059 $self->monikers->{$table->sql_name} = $table_moniker;
2060 $self->moniker_to_table->{$table_moniker} = $table;
2061 $self->class_to_table->{$table_class} = $table;
2063 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2065 $self->_use ($table_class, @{$self->additional_classes});
2067 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2069 $self->_inject($table_class, @{$self->left_base_classes});
2071 my @components = @{ $self->components || [] };
2073 push @components, @{ $self->result_components_map->{$table_moniker} }
2074 if exists $self->result_components_map->{$table_moniker};
2076 my @fq_components = @components;
2077 foreach my $component (@fq_components) {
2078 if ($component !~ s/^\+//) {
2079 $component = "DBIx::Class::$component";
2083 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2085 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2087 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2089 $self->_inject($table_class, @{$self->additional_base_classes});
2092 sub _is_result_class_method {
2093 my ($self, $name, $table) = @_;
2095 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2097 $self->_result_class_methods({})
2098 if not defined $self->_result_class_methods;
2100 if (not exists $self->_result_class_methods->{$table_moniker}) {
2101 my (@methods, %methods);
2102 my $base = $self->result_base_class || 'DBIx::Class::Core';
2104 my @components = @{ $self->components || [] };
2106 push @components, @{ $self->result_components_map->{$table_moniker} }
2107 if exists $self->result_components_map->{$table_moniker};
2109 for my $c (@components) {
2110 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2113 my @roles = @{ $self->result_roles || [] };
2115 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2116 if exists $self->result_roles_map->{$table_moniker};
2118 for my $class ($base, @components,
2119 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2120 $self->ensure_class_loaded($class);
2122 push @methods, @{ Class::Inspector->methods($class) || [] };
2125 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2127 @methods{@methods} = ();
2129 $self->_result_class_methods->{$table_moniker} = \%methods;
2131 my $result_methods = $self->_result_class_methods->{$table_moniker};
2133 return exists $result_methods->{$name};
2136 sub _resolve_col_accessor_collisions {
2137 my ($self, $table, $col_info) = @_;
2139 while (my ($col, $info) = each %$col_info) {
2140 my $accessor = $info->{accessor} || $col;
2142 next if $accessor eq 'id'; # special case (very common column)
2144 if ($self->_is_result_class_method($accessor, $table)) {
2147 if (my $map = $self->col_collision_map) {
2148 for my $re (keys %$map) {
2149 if (my @matches = $col =~ /$re/) {
2150 $info->{accessor} = sprintf $map->{$re}, @matches;
2158 Column '$col' in table '$table' collides with an inherited method.
2159 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2161 $info->{accessor} = undef;
2167 # use the same logic to run moniker_map, col_accessor_map
2169 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2171 my $default_ident = $default_code->( $ident, @extra );
2173 if( $map && ref $map eq 'HASH' ) {
2174 $new_ident = $map->{ $ident };
2176 elsif( $map && ref $map eq 'CODE' ) {
2177 $new_ident = $map->( $ident, $default_ident, @extra );
2180 $new_ident ||= $default_ident;
2185 sub _default_column_accessor_name {
2186 my ( $self, $column_name ) = @_;
2188 my $accessor_name = $self->_to_identifier('column_accessors', $column_name, '_');
2190 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2193 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
2194 # older naming just lc'd the col accessor and that's all.
2195 return lc $accessor_name;
2197 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
2198 return $accessor_name;
2201 return join '_', map lc, split_name $column_name;
2204 sub _make_column_accessor_name {
2205 my ($self, $column_name, $column_context_info ) = @_;
2207 my $accessor = $self->_run_user_map(
2208 $self->col_accessor_map,
2209 sub { $self->_default_column_accessor_name( shift ) },
2211 $column_context_info,
2217 # Set up metadata (cols, pks, etc)
2218 sub _setup_src_meta {
2219 my ($self, $table) = @_;
2221 my $schema = $self->schema;
2222 my $schema_class = $self->schema_class;
2224 my $table_class = $self->classes->{$table->sql_name};
2225 my $table_moniker = $self->monikers->{$table->sql_name};
2227 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2229 my $cols = $self->_table_columns($table);
2230 my $col_info = $self->__columns_info_for($table);
2232 ### generate all the column accessor names
2233 while (my ($col, $info) = each %$col_info) {
2234 # hashref of other info that could be used by
2235 # user-defined accessor map functions
2237 table_class => $table_class,
2238 table_moniker => $table_moniker,
2239 table_name => $table,
2240 full_table_name => $table->dbic_name,
2241 schema_class => $schema_class,
2242 column_info => $info,
2245 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2248 $self->_resolve_col_accessor_collisions($table, $col_info);
2250 # prune any redundant accessor names
2251 while (my ($col, $info) = each %$col_info) {
2252 no warnings 'uninitialized';
2253 delete $info->{accessor} if $info->{accessor} eq $col;
2256 my $fks = $self->_table_fk_info($table);
2258 foreach my $fkdef (@$fks) {
2259 for my $col (@{ $fkdef->{local_columns} }) {
2260 $col_info->{$col}{is_foreign_key} = 1;
2264 my $pks = $self->_table_pk_info($table) || [];
2266 my %uniq_tag; # used to eliminate duplicate uniqs
2268 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2270 my $uniqs = $self->_table_uniq_info($table) || [];
2273 foreach my $uniq (@$uniqs) {
2274 my ($name, $cols) = @$uniq;
2275 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2276 push @uniqs, [$name, $cols];
2279 my @non_nullable_uniqs = grep {
2280 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2283 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2284 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2285 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2287 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2288 my @keys = map $_->[1], @by_colnum;
2292 # remove the uniq from list
2293 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2299 foreach my $pkcol (@$pks) {
2300 $col_info->{$pkcol}{is_nullable} = 0;
2306 map { $_, ($col_info->{$_}||{}) } @$cols
2309 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2312 # Sort unique constraints by constraint name for repeatable results (rels
2313 # are sorted as well elsewhere.)
2314 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2316 foreach my $uniq (@uniqs) {
2317 my ($name, $cols) = @$uniq;
2318 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2322 sub __columns_info_for {
2323 my ($self, $table) = @_;
2325 my $result = $self->_columns_info_for($table);
2327 while (my ($col, $info) = each %$result) {
2328 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2329 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2331 $result->{$col} = $info;
2339 Returns a sorted list of loaded tables, using the original database table
2347 return values %{$self->_tables};
2350 sub _to_identifier {
2351 my ($self, $naming_key, $name, $sep_char) = @_;
2353 my ($v) = ($self->naming->{$naming_key}||$CURRENT_V) =~ /^v(\d+)\z/;
2355 my $to_identifier = $self->naming->{force_ascii} ?
2356 \&String::ToIdentifier::EN::to_identifier
2357 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2359 return $v >= 8 ? $to_identifier->($name, $sep_char) : $name;
2362 # Make a moniker from a table
2363 sub _default_table2moniker {
2364 my ($self, $table) = @_;
2366 my ($v) = ($self->naming->{monikers}||$CURRENT_V) =~ /^v(\d+)\z/;
2368 my @name_parts = map $table->$_, @{ $self->moniker_parts };
2370 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2374 foreach my $i (0 .. $#name_parts) {
2375 my $part = $name_parts[$i];
2377 if ($i != $name_idx || $v >= 8) {
2378 $part = $self->_to_identifier->('monikers', $part, '_');
2381 if ($i == $name_idx && $v == 5) {
2382 $part = Lingua::EN::Inflect::Number::to_S($part);
2385 my @part_parts = map lc, $v > 6 ? split_name $part : split /[\W_]+/, $part;
2387 if ($i == $name_idx && $v >= 6) {
2388 my $as_phrase = join ' ', @part_parts;
2390 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2391 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2393 ($self->naming->{monikers}||'') eq 'preserve' ?
2396 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2398 @part_parts = split /\s+/, $inflected;
2401 push @all_parts, map ucfirst, @part_parts;
2404 return join '', @all_parts;
2407 sub _table2moniker {
2408 my ( $self, $table ) = @_;
2410 $self->_run_user_map(
2412 sub { $self->_default_table2moniker( shift ) },
2417 sub _load_relationships {
2418 my ($self, $tables) = @_;
2422 foreach my $table (@$tables) {
2423 my $local_moniker = $self->monikers->{$table->sql_name};
2425 my $tbl_fk_info = $self->_table_fk_info($table);
2427 foreach my $fkdef (@$tbl_fk_info) {
2428 $fkdef->{local_table} = $table;
2429 $fkdef->{local_moniker} = $local_moniker;
2430 $fkdef->{remote_source} =
2431 $self->monikers->{$fkdef->{remote_table}->sql_name};
2433 my $tbl_uniq_info = $self->_table_uniq_info($table);
2435 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2438 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2440 foreach my $src_class (sort keys %$rel_stmts) {
2442 my @src_stmts = map $_->[1],
2443 sort { $a->[0] cmp $b->[0] }
2444 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2446 foreach my $stmt (@src_stmts) {
2447 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2453 my ($self, $table) = @_;
2455 my $table_moniker = $self->monikers->{$table->sql_name};
2456 my $table_class = $self->classes->{$table->sql_name};
2458 my @roles = @{ $self->result_roles || [] };
2459 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2460 if exists $self->result_roles_map->{$table_moniker};
2463 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2465 $self->_with($table_class, @roles);
2469 # Overload these in driver class:
2471 # Returns an arrayref of column names
2472 sub _table_columns { croak "ABSTRACT METHOD" }
2474 # Returns arrayref of pk col names
2475 sub _table_pk_info { croak "ABSTRACT METHOD" }
2477 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2478 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2480 # Returns an arrayref of foreign key constraints, each
2481 # being a hashref with 3 keys:
2482 # local_columns (arrayref), remote_columns (arrayref), remote_table
2483 sub _table_fk_info { croak "ABSTRACT METHOD" }
2485 # Returns an array of lower case table names
2486 sub _tables_list { croak "ABSTRACT METHOD" }
2488 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2494 # generate the pod for this statement, storing it with $self->_pod
2495 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2497 my $args = dump(@_);
2498 $args = '(' . $args . ')' if @_ < 2;
2499 my $stmt = $method . $args . q{;};
2501 warn qq|$class\->$stmt\n| if $self->debug;
2502 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2506 sub _make_pod_heading {
2507 my ($self, $class) = @_;
2509 return '' if not $self->generate_pod;
2511 my $table = $self->class_to_table->{$class};
2514 my $pcm = $self->pod_comment_mode;
2515 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2516 $comment = $self->__table_comment($table);
2517 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2518 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2519 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2521 $pod .= "=head1 NAME\n\n";
2523 my $table_descr = $class;
2524 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2526 $pod .= "$table_descr\n\n";
2528 if ($comment and $comment_in_desc) {
2529 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2536 # generates the accompanying pod for a DBIC class method statement,
2537 # storing it with $self->_pod
2543 if ($method eq 'table') {
2545 $table = $$table if ref $table eq 'SCALAR';
2546 $self->_pod($class, "=head1 TABLE: C<$table>");
2547 $self->_pod_cut($class);
2549 elsif ( $method eq 'add_columns' ) {
2550 $self->_pod( $class, "=head1 ACCESSORS" );
2551 my $col_counter = 0;
2553 while( my ($name,$attrs) = splice @cols,0,2 ) {
2555 $self->_pod( $class, '=head2 ' . $name );
2556 $self->_pod( $class,
2558 my $s = $attrs->{$_};
2559 $s = !defined $s ? 'undef' :
2560 length($s) == 0 ? '(empty string)' :
2561 ref($s) eq 'SCALAR' ? $$s :
2562 ref($s) ? dumper_squashed $s :
2563 looks_like_number($s) ? $s : qq{'$s'};
2566 } sort keys %$attrs,
2568 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2569 $self->_pod( $class, $comment );
2572 $self->_pod_cut( $class );
2573 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2574 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2575 my ( $accessor, $rel_class ) = @_;
2576 $self->_pod( $class, "=head2 $accessor" );
2577 $self->_pod( $class, 'Type: ' . $method );
2578 $self->_pod( $class, "Related object: L<$rel_class>" );
2579 $self->_pod_cut( $class );
2580 $self->{_relations_started} { $class } = 1;
2582 elsif ($method eq 'add_unique_constraint') {
2583 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2584 unless $self->{_uniqs_started}{$class};
2586 my ($name, $cols) = @_;
2588 $self->_pod($class, "=head2 C<$name>");
2589 $self->_pod($class, '=over 4');
2591 foreach my $col (@$cols) {
2592 $self->_pod($class, "=item \* L</$col>");
2595 $self->_pod($class, '=back');
2596 $self->_pod_cut($class);
2598 $self->{_uniqs_started}{$class} = 1;
2600 elsif ($method eq 'set_primary_key') {
2601 $self->_pod($class, "=head1 PRIMARY KEY");
2602 $self->_pod($class, '=over 4');
2604 foreach my $col (@_) {
2605 $self->_pod($class, "=item \* L</$col>");
2608 $self->_pod($class, '=back');
2609 $self->_pod_cut($class);
2613 sub _pod_class_list {
2614 my ($self, $class, $title, @classes) = @_;
2616 return unless @classes && $self->generate_pod;
2618 $self->_pod($class, "=head1 $title");
2619 $self->_pod($class, '=over 4');
2621 foreach my $link (@classes) {
2622 $self->_pod($class, "=item * L<$link>");
2625 $self->_pod($class, '=back');
2626 $self->_pod_cut($class);
2629 sub _base_class_pod {
2630 my ($self, $base_class) = @_;
2632 return '' unless $self->generate_pod;
2635 =head1 BASE CLASS: L<$base_class>
2642 sub _filter_comment {
2643 my ($self, $txt) = @_;
2645 $txt = '' if not defined $txt;
2647 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2652 sub __table_comment {
2655 if (my $code = $self->can('_table_comment')) {
2656 return $self->_filter_comment($self->$code(@_));
2662 sub __column_comment {
2665 if (my $code = $self->can('_column_comment')) {
2666 return $self->_filter_comment($self->$code(@_));
2672 # Stores a POD documentation
2674 my ($self, $class, $stmt) = @_;
2675 $self->_raw_stmt( $class, "\n" . $stmt );
2679 my ($self, $class ) = @_;
2680 $self->_raw_stmt( $class, "\n=cut\n" );
2683 # Store a raw source line for a class (for dumping purposes)
2685 my ($self, $class, $stmt) = @_;
2686 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2689 # Like above, but separately for the externally loaded stuff
2691 my ($self, $class, $stmt) = @_;
2692 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2695 sub _custom_column_info {
2696 my ( $self, $table_name, $column_name, $column_info ) = @_;
2698 if (my $code = $self->custom_column_info) {
2699 return $code->($table_name, $column_name, $column_info) || {};
2704 sub _datetime_column_info {
2705 my ( $self, $table_name, $column_name, $column_info ) = @_;
2707 my $type = $column_info->{data_type} || '';
2708 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2709 or ($type =~ /date|timestamp/i)) {
2710 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2711 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2717 my ($self, $name) = @_;
2719 return $self->preserve_case ? $name : lc($name);
2723 my ($self, $name) = @_;
2725 return $self->preserve_case ? $name : uc($name);
2729 my ($self, $table) = @_;
2732 my $schema = $self->schema;
2733 # in older DBIC it's a private method
2734 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2735 $schema->$unregister(delete $self->monikers->{$table->sql_name});
2736 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2737 delete $self->_tables->{$table->sql_name};
2741 # remove the dump dir from @INC on destruction
2745 @INC = grep $_ ne $self->dump_directory, @INC;
2750 Returns a hashref of loaded table to moniker mappings. There will
2751 be two entries for each table, the original name and the "normalized"
2752 name, in the case that the two are different (such as databases
2753 that like uppercase table names, or preserve your original mixed-case
2754 definitions, or what-have-you).
2758 Returns a hashref of table to class mappings. In some cases it will
2759 contain multiple entries per table for the original and normalized table
2760 names, as above in L</monikers>.
2762 =head1 NON-ENGLISH DATABASES
2764 If you use the loader on a database with table and column names in a language
2765 other than English, you will want to turn off the English language specific
2768 To do so, use something like this in your laoder options:
2770 naming => { monikers => 'v4' },
2771 inflect_singular => sub { "$_[0]_rel" },
2772 inflect_plural => sub { "$_[0]_rel" },
2774 =head1 COLUMN ACCESSOR COLLISIONS
2776 Occasionally you may have a column name that collides with a perl method, such
2777 as C<can>. In such cases, the default action is to set the C<accessor> of the
2778 column spec to C<undef>.
2780 You can then name the accessor yourself by placing code such as the following
2783 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2785 Another option is to use the L</col_collision_map> option.
2787 =head1 RELATIONSHIP NAME COLLISIONS
2789 In very rare cases, you may get a collision between a generated relationship
2790 name and a method in your Result class, for example if you have a foreign key
2791 called C<belongs_to>.
2793 This is a problem because relationship names are also relationship accessor
2794 methods in L<DBIx::Class>.
2796 The default behavior is to append C<_rel> to the relationship name and print
2797 out a warning that refers to this text.
2799 You can also control the renaming with the L</rel_collision_map> option.
2803 L<DBIx::Class::Schema::Loader>
2807 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2811 This library is free software; you can redistribute it and/or modify it under
2812 the same terms as Perl itself.
2817 # vim:et sts=4 sw=4 tw=0: