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
63 overwrite_modifications
86 __PACKAGE__->mk_group_accessors('simple', qw/
88 schema_version_to_dump
90 _upgrading_from_load_classes
91 _downgrading_to_load_classes
92 _rewriting_result_namespace
97 pod_comment_spillover_length
103 result_components_map
105 datetime_undef_if_invalid
106 _result_class_methods
108 filter_generated_code
114 my $CURRENT_V = 'v7';
117 schema_components schema_base_class result_base_class
118 additional_base_classes left_base_classes additional_classes components
124 my $CRLF = "\x0d\x0a";
128 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
132 See L<DBIx::Class::Schema::Loader>.
136 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
137 classes, and implements the common functionality between them.
139 =head1 CONSTRUCTOR OPTIONS
141 These constructor options are the base options for
142 L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are:
144 =head2 skip_relationships
146 Skip setting up relationships. The default is to attempt the loading
149 =head2 skip_load_external
151 Skip loading of other classes in @INC. The default is to merge all other classes
152 with the same name found in @INC into the schema file we are creating.
156 Static schemas (ones dumped to disk) will, by default, use the new-style
157 relationship names and singularized Results, unless you're overwriting an
158 existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
159 which case the backward compatible RelBuilder will be activated, and the
160 appropriate monikerization used.
166 will disable the backward-compatible RelBuilder and use
167 the new-style relationship names along with singularized Results, even when
168 overwriting a dump made with an earlier version.
170 The option also takes a hashref:
173 relationships => 'v8',
175 column_accessors => 'v8',
181 naming => { ALL => 'v8', force_ascii => 1 }
189 Set L</relationships>, L</monikers> and L</column_accessors> to the specified
194 How to name relationship accessors.
198 How to name Result classes.
200 =item column_accessors
202 How to name column accessors in Result classes.
206 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
207 L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
218 Latest style, whatever that happens to be.
222 Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
226 Monikers singularized as whole words, C<might_have> relationships for FKs on
227 C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
229 Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
234 All monikers and relationships are inflected using
235 L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
236 from relationship names.
238 In general, there is very little difference between v5 and v6 schemas.
242 This mode is identical to C<v6> mode, except that monikerization of CamelCase
243 table names is also done correctly.
245 CamelCase column names in case-preserving mode will also be handled correctly
246 for relationship name inflection. See L</preserve_case>.
248 In this mode, CamelCase L</column_accessors> are normalized based on case
249 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
251 If you don't have any CamelCase table or column names, you can upgrade without
252 breaking any of your code.
258 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
259 L</naming> explictly until C<0.08> comes out.
261 L</monikers> and L</column_accessors> are created using
262 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
263 L</force_ascii> is set; this is only significant for names with non-C<\w>
264 characters such as C<.>.
266 For relationships, belongs_to accessors are made from column names by stripping
267 postfixes other than C<_id> as well, just C<id>, C<_?ref>, C<_?cd>, C<_?code>
272 For L</monikers>, this option does not inflect the table names but makes
273 monikers based on the actual name. For L</column_accessors> this option does
274 not normalize CamelCase column names to lowercase column accessors, but makes
275 accessors that are the same names as the columns (with any non-\w chars
276 replaced with underscores.)
280 For L</monikers>, singularizes the names using the most current inflector. This
281 is the same as setting the option to L</current>.
285 For L</monikers>, pluralizes the names, using the most current inflector.
289 Dynamic schemas will always default to the 0.04XXX relationship names and won't
290 singularize Results for backward compatibility, to activate the new RelBuilder
291 and singularization put this in your C<Schema.pm> file:
293 __PACKAGE__->naming('current');
295 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
296 next major version upgrade:
298 __PACKAGE__->naming('v7');
302 If true, will not print the usual C<Dumping manual schema ... Schema dump
303 completed.> messages. Does not affect warnings (except for warnings related to
304 L</really_erase_my_files>.)
308 By default POD will be generated for columns and relationships, using database
309 metadata for the text if available and supported.
311 Comment metadata can be stored in two ways.
313 The first is that you can create two tables named C<table_comments> and
314 C<column_comments> respectively. These tables must exist in the same database
315 and schema as the tables they describe. They both need to have columns named
316 C<table_name> and C<comment_text>. The second one needs to have a column named
317 C<column_name>. Then data stored in these tables will be used as a source of
318 metadata about tables and comments.
320 (If you wish you can change the name of these tables with the parameters
321 L</table_comments_table> and L</column_comments_table>.)
323 As a fallback you can use built-in commenting mechanisms. Currently this is
324 only supported for PostgreSQL, Oracle and MySQL. To create comments in
325 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
326 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
327 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
328 restricts the length of comments, and also does not handle complex Unicode
331 Set this to C<0> to turn off all POD generation.
333 =head2 pod_comment_mode
335 Controls where table comments appear in the generated POD. Smaller table
336 comments are appended to the C<NAME> section of the documentation, and larger
337 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
338 section to be generated with the comment always, only use C<NAME>, or choose
339 the length threshold at which the comment is forced into the description.
345 Use C<NAME> section only.
349 Force C<DESCRIPTION> always.
353 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
358 =head2 pod_comment_spillover_length
360 When pod_comment_mode is set to C<auto>, this is the length of the comment at
361 which it will be forced into a separate description section.
365 =head2 table_comments_table
367 The table to look for comments about tables in. By default C<table_comments>.
368 See L</generate_pod> for details.
370 This must not be a fully qualified name, the table will be looked for in the
371 same database and schema as the table whose comment is being retrieved.
373 =head2 column_comments_table
375 The table to look for comments about columns in. By default C<column_comments>.
376 See L</generate_pod> for details.
378 This must not be a fully qualified name, the table will be looked for in the
379 same database and schema as the table/column whose comment is being retrieved.
381 =head2 relationship_attrs
383 Hashref of attributes to pass to each generated relationship, listed
384 by type. Also supports relationship type 'all', containing options to
385 pass to all generated relationships. Attributes set for more specific
386 relationship types override those set in 'all'.
390 relationship_attrs => {
391 belongs_to => { is_deferrable => 0 },
394 use this to turn off DEFERRABLE on your foreign key constraints.
398 If set to true, each constructive L<DBIx::Class> statement the loader
399 decides to execute will be C<warn>-ed before execution.
403 Set the name of the schema to load (schema in the sense that your database
406 Can be set to an arrayref of schema names for multiple schemas, or the special
407 value C<%> for all schemas.
409 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
410 keys and arrays of owners as values, set to the value:
414 for all owners in all databases.
416 You may need to control naming of monikers with L</moniker_parts> if you have
417 name clashes for tables in different schemas/databases.
421 The database table names are represented by the
422 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
423 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
424 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
426 Monikers are created normally based on just the
427 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
428 the table name, but can consist of other parts of the fully qualified name of
431 The L</moniker_parts> option is an arrayref of methods on the table class
432 corresponding to parts of the fully qualified table name, defaulting to
433 C<['name']>, in the order those parts are used to create the moniker name.
435 The C<'name'> entry B<must> be present.
437 Below is a table of supported databases and possible L</moniker_parts>.
441 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
445 =item * Informix, MSSQL, Sybase ASE
447 C<database>, C<schema>, C<name>
453 Only load tables matching regex. Best specified as a qr// regex.
457 Exclude tables matching regex. Best specified as a qr// regex.
461 Overrides the default table name to moniker translation. Can be either
462 a hashref of table keys and moniker values, or a coderef for a translator
463 function taking a single scalar table name argument and returning
464 a scalar moniker. If the hash entry does not exist, or the function
465 returns a false value, the code falls back to default behavior
468 The default behavior is to split on case transition and non-alphanumeric
469 boundaries, singularize the resulting phrase, then join the titlecased words
472 Table Name | Moniker Name
473 ---------------------------------
475 luser_group | LuserGroup
476 luser-opts | LuserOpt
477 stations_visited | StationVisited
478 routeChange | RouteChange
480 =head2 col_accessor_map
482 Same as moniker_map, but for column accessor names. If a coderef is
483 passed, the code is called with arguments of
485 the name of the column in the underlying database,
486 default accessor name that DBICSL would ordinarily give this column,
488 table_class => name of the DBIC class we are building,
489 table_moniker => calculated moniker for this table (after moniker_map if present),
490 table_name => name of the database table,
491 full_table_name => schema-qualified name of the database table (RDBMS specific),
492 schema_class => name of the schema class we are building,
493 column_info => hashref of column info (data_type, is_nullable, etc),
498 Similar in idea to moniker_map, but different in the details. It can be
499 a hashref or a code ref.
501 If it is a hashref, keys can be either the default relationship name, or the
502 moniker. The keys that are the default relationship name should map to the
503 name you want to change the relationship to. Keys that are monikers should map
504 to hashes mapping relationship names to their translation. You can do both at
505 once, and the more specific moniker version will be picked up first. So, for
506 instance, you could have
515 and relationships that would have been named C<bar> will now be named C<baz>
516 except that in the table whose moniker is C<Foo> it will be named C<blat>.
518 If it is a coderef, the argument passed will be a hashref of this form:
521 name => default relationship name,
522 type => the relationship type eg: C<has_many>,
523 local_class => name of the DBIC class we are building,
524 local_moniker => moniker of the DBIC class we are building,
525 local_columns => columns in this table in the relationship,
526 remote_class => name of the DBIC class we are related to,
527 remote_moniker => moniker of the DBIC class we are related to,
528 remote_columns => columns in the other table in the relationship,
531 DBICSL will try to use the value returned as the relationship name.
533 =head2 inflect_plural
535 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
536 if hash key does not exist or coderef returns false), but acts as a map
537 for pluralizing relationship names. The default behavior is to utilize
538 L<Lingua::EN::Inflect::Phrase/to_PL>.
540 =head2 inflect_singular
542 As L</inflect_plural> above, but for singularizing relationship names.
543 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
545 =head2 schema_base_class
547 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
549 =head2 schema_components
551 List of components to load into the Schema class.
553 =head2 result_base_class
555 Base class for your table classes (aka result classes). Defaults to
558 =head2 additional_base_classes
560 List of additional base classes all of your table classes will use.
562 =head2 left_base_classes
564 List of additional base classes all of your table classes will use
565 that need to be leftmost.
567 =head2 additional_classes
569 List of additional classes which all of your table classes will use.
573 List of additional components to be loaded into all of your Result
574 classes. A good example would be
575 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
577 =head2 result_components_map
579 A hashref of moniker keys and component values. Unlike L</components>, which
580 loads the given components into every Result class, this option allows you to
581 load certain components for specified Result classes. For example:
583 result_components_map => {
584 StationVisited => '+YourApp::Schema::Component::StationVisited',
586 '+YourApp::Schema::Component::RouteChange',
587 'InflateColumn::DateTime',
591 You may use this in conjunction with L</components>.
595 List of L<Moose> roles to be applied to all of your Result classes.
597 =head2 result_roles_map
599 A hashref of moniker keys and role values. Unlike L</result_roles>, which
600 applies the given roles to every Result class, this option allows you to apply
601 certain roles for specified Result classes. For example:
603 result_roles_map => {
605 'YourApp::Role::Building',
606 'YourApp::Role::Destination',
608 RouteChange => 'YourApp::Role::TripEvent',
611 You may use this in conjunction with L</result_roles>.
613 =head2 use_namespaces
615 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
618 Generate result class names suitable for
619 L<DBIx::Class::Schema/load_namespaces> and call that instead of
620 L<DBIx::Class::Schema/load_classes>. When using this option you can also
621 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
622 C<resultset_namespace>, C<default_resultset_class>), and they will be added
623 to the call (and the generated result class names adjusted appropriately).
625 =head2 dump_directory
627 The value of this option is a perl libdir pathname. Within
628 that directory this module will create a baseline manual
629 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
631 The created schema class will have the same classname as the one on
632 which you are setting this option (and the ResultSource classes will be
633 based on this name as well).
635 Normally you wouldn't hard-code this setting in your schema class, as it
636 is meant for one-time manual usage.
638 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
639 recommended way to access this functionality.
641 =head2 dump_overwrite
643 Deprecated. See L</really_erase_my_files> below, which does *not* mean
644 the same thing as the old C<dump_overwrite> setting from previous releases.
646 =head2 really_erase_my_files
648 Default false. If true, Loader will unconditionally delete any existing
649 files before creating the new ones from scratch when dumping a schema to disk.
651 The default behavior is instead to only replace the top portion of the
652 file, up to and including the final stanza which contains
653 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
654 leaving any customizations you placed after that as they were.
656 When C<really_erase_my_files> is not set, if the output file already exists,
657 but the aforementioned final stanza is not found, or the checksum
658 contained there does not match the generated contents, Loader will
659 croak and not touch the file.
661 You should really be using version control on your schema classes (and all
662 of the rest of your code for that matter). Don't blame me if a bug in this
663 code wipes something out when it shouldn't have, you've been warned.
665 =head2 overwrite_modifications
667 Default false. If false, when updating existing files, Loader will
668 refuse to modify any Loader-generated code that has been modified
669 since its last run (as determined by the checksum Loader put in its
672 If true, Loader will discard any manual modifications that have been
673 made to Loader-generated code.
675 Again, you should be using version control on your schema classes. Be
676 careful with this option.
678 =head2 custom_column_info
680 Hook for adding extra attributes to the
681 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
683 Must be a coderef that returns a hashref with the extra attributes.
685 Receives the table name, column name and column_info.
689 custom_column_info => sub {
690 my ($table_name, $column_name, $column_info) = @_;
692 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
693 return { is_snoopy => 1 };
697 This attribute can also be used to set C<inflate_datetime> on a non-datetime
698 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
700 =head2 datetime_timezone
702 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
703 columns with the DATE/DATETIME/TIMESTAMP data_types.
705 =head2 datetime_locale
707 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
708 columns with the DATE/DATETIME/TIMESTAMP data_types.
710 =head2 datetime_undef_if_invalid
712 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
713 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
716 The default is recommended to deal with data such as C<00/00/00> which
717 sometimes ends up in such columns in MySQL.
721 File in Perl format, which should return a HASH reference, from which to read
726 Usually column names are lowercased, to make them easier to work with in
727 L<DBIx::Class>. This option lets you turn this behavior off, if the driver
730 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
731 case-sensitive collation will turn this option on unconditionally.
733 Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support
736 =head2 qualify_objects
738 Set to true to prepend the L</db_schema> to table names for C<<
739 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
743 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
744 L<namespace::autoclean> (or L<MooseX::MarkAsMethods>, see below). The default
745 content after the md5 sum also makes the classes immutable.
747 It is safe to upgrade your existing Schema to this option.
749 =head2 only_autoclean
751 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
752 your generated classes. It uses L<namespace::autoclean> to do this, after
753 telling your object's metaclass that any L<overload>s in your class are
754 methods, which will cause namespace::autoclean to spare them from removal.
756 This prevents the "Hey, where'd my overloads go?!" effect.
758 If you don't care about overloads, enabling this option falls back to just using
759 L<namespace::autoclean> itself.
761 If none of the above made any sense, or you don't have some pressing need to
762 only use L<namespace::autoclean>, leaving this set to the default is
765 =head2 col_collision_map
767 This option controls how accessors for column names which collide with perl
768 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
770 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
771 strings which are compiled to regular expressions that map to
772 L<sprintf|perlfunc/sprintf> formats.
776 col_collision_map => 'column_%s'
778 col_collision_map => { '(.*)' => 'column_%s' }
780 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
782 =head2 rel_collision_map
784 Works just like L</col_collision_map>, but for relationship names/accessors
785 rather than column names/accessors.
787 The default is to just append C<_rel> to the relationship name, see
788 L</RELATIONSHIP NAME COLLISIONS>.
790 =head2 uniq_to_primary
792 Automatically promotes the largest unique constraints with non-nullable columns
793 on tables to primary keys, assuming there is only one largest unique
796 =head2 filter_generated_code
798 An optional hook that lets you filter the generated text for various classes
799 through a function that change it in any way that you want. The function will
800 receive the type of file, C<schema> or C<result>, class and code; and returns
801 the new code to use instead. For instance you could add custom comments, or do
802 anything else that you want.
804 The option can also be set to a string, which is then used as a filter program,
807 If this exists but fails to return text matching C</\bpackage\b/>, no file will
810 filter_generated_code => sub {
811 my ($type, $class, $text) = @_;
818 None of these methods are intended for direct invocation by regular
819 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
820 L<DBIx::Class::Schema::Loader>.
824 # ensure that a peice of object data is a valid arrayref, creating
825 # an empty one or encapsulating whatever's there.
826 sub _ensure_arrayref {
831 $self->{$_} = [ $self->{$_} ]
832 unless ref $self->{$_} eq 'ARRAY';
838 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
839 by L<DBIx::Class::Schema::Loader>.
844 my ( $class, %args ) = @_;
846 if (exists $args{column_accessor_map}) {
847 $args{col_accessor_map} = delete $args{column_accessor_map};
850 my $self = { %args };
852 # don't lose undef options
853 for (values %$self) {
854 $_ = 0 unless defined $_;
857 bless $self => $class;
859 if (my $config_file = $self->config_file) {
860 my $config_opts = do $config_file;
862 croak "Error reading config from $config_file: $@" if $@;
864 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
866 while (my ($k, $v) = each %$config_opts) {
867 $self->{$k} = $v unless exists $self->{$k};
871 if (defined $self->{result_component_map}) {
872 if (defined $self->result_components_map) {
873 croak "Specify only one of result_components_map or result_component_map";
875 $self->result_components_map($self->{result_component_map})
878 if (defined $self->{result_role_map}) {
879 if (defined $self->result_roles_map) {
880 croak "Specify only one of result_roles_map or result_role_map";
882 $self->result_roles_map($self->{result_role_map})
885 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
886 if ((not defined $self->use_moose) || (not $self->use_moose))
887 && ((defined $self->result_roles) || (defined $self->result_roles_map));
889 $self->_ensure_arrayref(qw/schema_components
891 additional_base_classes
897 $self->_validate_class_args;
899 croak "result_components_map must be a hash"
900 if defined $self->result_components_map
901 && ref $self->result_components_map ne 'HASH';
903 if ($self->result_components_map) {
904 my %rc_map = %{ $self->result_components_map };
905 foreach my $moniker (keys %rc_map) {
906 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
908 $self->result_components_map(\%rc_map);
911 $self->result_components_map({});
913 $self->_validate_result_components_map;
915 croak "result_roles_map must be a hash"
916 if defined $self->result_roles_map
917 && ref $self->result_roles_map ne 'HASH';
919 if ($self->result_roles_map) {
920 my %rr_map = %{ $self->result_roles_map };
921 foreach my $moniker (keys %rr_map) {
922 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
924 $self->result_roles_map(\%rr_map);
926 $self->result_roles_map({});
928 $self->_validate_result_roles_map;
930 if ($self->use_moose) {
931 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
932 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
933 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
937 $self->{_tables} = {};
938 $self->{monikers} = {};
939 $self->{moniker_to_table} = {};
940 $self->{class_to_table} = {};
941 $self->{classes} = {};
942 $self->{_upgrading_classes} = {};
944 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
945 $self->{schema} ||= $self->{schema_class};
946 $self->{table_comments_table} ||= 'table_comments';
947 $self->{column_comments_table} ||= 'column_comments';
949 croak "dump_overwrite is deprecated. Please read the"
950 . " DBIx::Class::Schema::Loader::Base documentation"
951 if $self->{dump_overwrite};
953 $self->{dynamic} = ! $self->{dump_directory};
954 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
959 $self->{dump_directory} ||= $self->{temp_directory};
961 $self->real_dump_directory($self->{dump_directory});
963 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
964 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
966 if (not defined $self->naming) {
967 $self->naming_set(0);
970 $self->naming_set(1);
973 if ((not ref $self->naming) && defined $self->naming) {
974 my $naming_ver = $self->naming;
976 relationships => $naming_ver,
977 monikers => $naming_ver,
978 column_accessors => $naming_ver,
981 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
982 my $val = delete $self->naming->{ALL};
984 $self->naming->{$_} = $val
985 foreach qw/relationships monikers column_accessors/;
989 foreach my $key (qw/relationships monikers column_accessors/) {
990 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
993 $self->{naming} ||= {};
995 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
996 croak 'custom_column_info must be a CODE ref';
999 $self->_check_back_compat;
1001 $self->use_namespaces(1) unless defined $self->use_namespaces;
1002 $self->generate_pod(1) unless defined $self->generate_pod;
1003 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1004 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1006 if (my $col_collision_map = $self->col_collision_map) {
1007 if (my $reftype = ref $col_collision_map) {
1008 if ($reftype ne 'HASH') {
1009 croak "Invalid type $reftype for option 'col_collision_map'";
1013 $self->col_collision_map({ '(.*)' => $col_collision_map });
1017 if (my $rel_collision_map = $self->rel_collision_map) {
1018 if (my $reftype = ref $rel_collision_map) {
1019 if ($reftype ne 'HASH') {
1020 croak "Invalid type $reftype for option 'rel_collision_map'";
1024 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1028 if (defined(my $rel_name_map = $self->rel_name_map)) {
1029 my $reftype = ref $rel_name_map;
1030 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1031 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1035 if (defined(my $filter = $self->filter_generated_code)) {
1036 my $reftype = ref $filter;
1037 if ($reftype && $reftype ne 'CODE') {
1038 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1042 if (defined $self->db_schema) {
1043 if (ref $self->db_schema eq 'ARRAY') {
1044 if (@{ $self->db_schema } > 1) {
1045 $self->{qualify_objects} = 1;
1047 elsif (@{ $self->db_schema } == 0) {
1048 $self->{db_schema} = undef;
1051 elsif (not ref $self->db_schema) {
1052 if ($self->db_schema eq '%') {
1053 $self->{qualify_objects} = 1;
1056 $self->{db_schema} = [ $self->db_schema ];
1060 if (not $self->moniker_parts) {
1061 $self->moniker_parts(['name']);
1064 if (not ref $self->moniker_parts) {
1065 $self->moniker_parts([ $self->moniker_parts ]);
1067 if (ref $self->moniker_parts ne 'ARRAY') {
1068 croak 'moniker_parts must be an arrayref';
1070 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1071 croak "moniker_parts option *must* contain 'name'";
1078 sub _check_back_compat {
1081 # dynamic schemas will always be in 0.04006 mode, unless overridden
1082 if ($self->dynamic) {
1083 # just in case, though no one is likely to dump a dynamic schema
1084 $self->schema_version_to_dump('0.04006');
1086 if (not $self->naming_set) {
1087 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1089 Dynamic schema detected, will run in 0.04006 mode.
1091 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1092 to disable this warning.
1094 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1099 $self->_upgrading_from('v4');
1102 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1103 $self->use_namespaces(1);
1106 $self->naming->{relationships} ||= 'v4';
1107 $self->naming->{monikers} ||= 'v4';
1109 if ($self->use_namespaces) {
1110 $self->_upgrading_from_load_classes(1);
1113 $self->use_namespaces(0);
1119 # otherwise check if we need backcompat mode for a static schema
1120 my $filename = $self->get_dump_filename($self->schema_class);
1121 return unless -e $filename;
1123 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1124 $self->_parse_generated_file($filename);
1126 return unless $old_ver;
1128 # determine if the existing schema was dumped with use_moose => 1
1129 if (! defined $self->use_moose) {
1130 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1133 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1135 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1136 my $ds = eval $result_namespace;
1138 Could not eval expression '$result_namespace' for result_namespace from
1141 $result_namespace = $ds || '';
1143 if ($load_classes && (not defined $self->use_namespaces)) {
1144 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1146 'load_classes;' static schema detected, turning off 'use_namespaces'.
1148 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1149 variable to disable this warning.
1151 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1154 $self->use_namespaces(0);
1156 elsif ($load_classes && $self->use_namespaces) {
1157 $self->_upgrading_from_load_classes(1);
1159 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1160 $self->_downgrading_to_load_classes(
1161 $result_namespace || 'Result'
1164 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1165 if (not $self->result_namespace) {
1166 $self->result_namespace($result_namespace || 'Result');
1168 elsif ($result_namespace ne $self->result_namespace) {
1169 $self->_rewriting_result_namespace(
1170 $result_namespace || 'Result'
1175 # XXX when we go past .0 this will need fixing
1176 my ($v) = $old_ver =~ /([1-9])/;
1179 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1181 if (not %{ $self->naming }) {
1182 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1184 Version $old_ver static schema detected, turning on backcompat mode.
1186 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1187 to disable this warning.
1189 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1191 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1192 from version 0.04006.
1195 $self->naming->{relationships} ||= $v;
1196 $self->naming->{monikers} ||= $v;
1197 $self->naming->{column_accessors} ||= $v;
1199 $self->schema_version_to_dump($old_ver);
1202 $self->_upgrading_from($v);
1206 sub _validate_class_args {
1209 foreach my $k (@CLASS_ARGS) {
1210 next unless $self->$k;
1212 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1213 $self->_validate_classes($k, \@classes);
1217 sub _validate_result_components_map {
1220 foreach my $classes (values %{ $self->result_components_map }) {
1221 $self->_validate_classes('result_components_map', $classes);
1225 sub _validate_result_roles_map {
1228 foreach my $classes (values %{ $self->result_roles_map }) {
1229 $self->_validate_classes('result_roles_map', $classes);
1233 sub _validate_classes {
1236 my $classes = shift;
1238 # make a copy to not destroy original
1239 my @classes = @$classes;
1241 foreach my $c (@classes) {
1242 # components default to being under the DBIx::Class namespace unless they
1243 # are preceeded with a '+'
1244 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1245 $c = 'DBIx::Class::' . $c;
1248 # 1 == installed, 0 == not installed, undef == invalid classname
1249 my $installed = Class::Inspector->installed($c);
1250 if ( defined($installed) ) {
1251 if ( $installed == 0 ) {
1252 croak qq/$c, as specified in the loader option "$key", is not installed/;
1255 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1261 sub _find_file_in_inc {
1262 my ($self, $file) = @_;
1264 foreach my $prefix (@INC) {
1265 my $fullpath = File::Spec->catfile($prefix, $file);
1266 return $fullpath if -f $fullpath
1267 # abs_path throws on Windows for nonexistant files
1268 and (try { Cwd::abs_path($fullpath) }) ne
1269 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1275 sub _find_class_in_inc {
1276 my ($self, $class) = @_;
1278 return $self->_find_file_in_inc(class_path($class));
1284 return $self->_upgrading_from
1285 || $self->_upgrading_from_load_classes
1286 || $self->_downgrading_to_load_classes
1287 || $self->_rewriting_result_namespace
1291 sub _rewrite_old_classnames {
1292 my ($self, $code) = @_;
1294 return $code unless $self->_rewriting;
1296 my %old_classes = reverse %{ $self->_upgrading_classes };
1298 my $re = join '|', keys %old_classes;
1299 $re = qr/\b($re)\b/;
1301 $code =~ s/$re/$old_classes{$1} || $1/eg;
1306 sub _load_external {
1307 my ($self, $class) = @_;
1309 return if $self->{skip_load_external};
1311 # so that we don't load our own classes, under any circumstances
1312 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1314 my $real_inc_path = $self->_find_class_in_inc($class);
1316 my $old_class = $self->_upgrading_classes->{$class}
1317 if $self->_rewriting;
1319 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1320 if $old_class && $old_class ne $class;
1322 return unless $real_inc_path || $old_real_inc_path;
1324 if ($real_inc_path) {
1325 # If we make it to here, we loaded an external definition
1326 warn qq/# Loaded external class definition for '$class'\n/
1329 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1331 if ($self->dynamic) { # load the class too
1332 eval_package_without_redefine_warnings($class, $code);
1335 $self->_ext_stmt($class,
1336 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1337 .qq|# They are now part of the custom portion of this file\n|
1338 .qq|# for you to hand-edit. If you do not either delete\n|
1339 .qq|# this section or remove that file from \@INC, this section\n|
1340 .qq|# will be repeated redundantly when you re-create this\n|
1341 .qq|# file again via Loader! See skip_load_external to disable\n|
1342 .qq|# this feature.\n|
1345 $self->_ext_stmt($class, $code);
1346 $self->_ext_stmt($class,
1347 qq|# End of lines loaded from '$real_inc_path' |
1351 if ($old_real_inc_path) {
1352 my $code = slurp_file $old_real_inc_path;
1354 $self->_ext_stmt($class, <<"EOF");
1356 # These lines were loaded from '$old_real_inc_path',
1357 # based on the Result class name that would have been created by an older
1358 # version of the Loader. For a static schema, this happens only once during
1359 # upgrade. See skip_load_external to disable this feature.
1362 $code = $self->_rewrite_old_classnames($code);
1364 if ($self->dynamic) {
1367 Detected external content in '$old_real_inc_path', a class name that would have
1368 been used by an older version of the Loader.
1370 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1371 new name of the Result.
1373 eval_package_without_redefine_warnings($class, $code);
1377 $self->_ext_stmt($class, $code);
1378 $self->_ext_stmt($class,
1379 qq|# End of lines loaded from '$old_real_inc_path' |
1386 Does the actual schema-construction work.
1393 $self->_load_tables(
1394 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1402 Rescan the database for changes. Returns a list of the newly added table
1405 The schema argument should be the schema class or object to be affected. It
1406 should probably be derived from the original schema_class used during L</load>.
1411 my ($self, $schema) = @_;
1413 $self->{schema} = $schema;
1414 $self->_relbuilder->{schema} = $schema;
1417 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1419 foreach my $table (@current) {
1420 if(!exists $self->_tables->{$table->sql_name}) {
1421 push(@created, $table);
1426 @current{map $_->sql_name, @current} = ();
1427 foreach my $table (values %{ $self->_tables }) {
1428 if (not exists $current{$table->sql_name}) {
1429 $self->_remove_table($table);
1433 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1435 my $loaded = $self->_load_tables(@current);
1437 foreach my $table (@created) {
1438 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1441 return map { $self->monikers->{$_->sql_name} } @created;
1447 return if $self->{skip_relationships};
1449 return $self->{relbuilder} ||= do {
1450 my $relbuilder_suff =
1457 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1459 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1460 $self->ensure_class_loaded($relbuilder_class);
1461 $relbuilder_class->new($self);
1466 my ($self, @tables) = @_;
1468 # Save the new tables to the tables list
1470 $self->_tables->{$_->sql_name} = $_;
1473 $self->_make_src_class($_) for @tables;
1475 # sanity-check for moniker clashes
1476 my $inverse_moniker_idx;
1477 foreach my $table (values %{ $self->_tables }) {
1478 push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table;
1482 foreach my $moniker (keys %$inverse_moniker_idx) {
1483 my $tables = $inverse_moniker_idx->{$moniker};
1485 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1486 join (', ', map $_->sql_name, @$tables),
1493 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1494 . 'In multi db_schema configurations you may need to set moniker_parts, '
1495 . 'otherwise change the naming style, or supply an explicit moniker_map: '
1496 . join ('; ', @clashes)
1501 $self->_setup_src_meta($_) for @tables;
1503 if(!$self->skip_relationships) {
1504 # The relationship loader needs a working schema
1505 local $self->{quiet} = 1;
1506 local $self->{dump_directory} = $self->{temp_directory};
1507 $self->_reload_classes(\@tables);
1508 $self->_load_relationships(\@tables);
1510 # Remove that temp dir from INC so it doesn't get reloaded
1511 @INC = grep $_ ne $self->dump_directory, @INC;
1514 $self->_load_roles($_) for @tables;
1516 $self->_load_external($_)
1517 for map { $self->classes->{$_->sql_name} } @tables;
1519 # Reload without unloading first to preserve any symbols from external
1521 $self->_reload_classes(\@tables, { unload => 0 });
1523 # Drop temporary cache
1524 delete $self->{_cache};
1529 sub _reload_classes {
1530 my ($self, $tables, $opts) = @_;
1532 my @tables = @$tables;
1534 my $unload = $opts->{unload};
1535 $unload = 1 unless defined $unload;
1537 # so that we don't repeat custom sections
1538 @INC = grep $_ ne $self->dump_directory, @INC;
1540 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1542 unshift @INC, $self->dump_directory;
1545 my %have_source = map { $_ => $self->schema->source($_) }
1546 $self->schema->sources;
1548 for my $table (@tables) {
1549 my $moniker = $self->monikers->{$table->sql_name};
1550 my $class = $self->classes->{$table->sql_name};
1553 no warnings 'redefine';
1554 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1557 if (my $mc = $self->_moose_metaclass($class)) {
1560 Class::Unload->unload($class) if $unload;
1561 my ($source, $resultset_class);
1563 ($source = $have_source{$moniker})
1564 && ($resultset_class = $source->resultset_class)
1565 && ($resultset_class ne 'DBIx::Class::ResultSet')
1567 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1568 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1571 Class::Unload->unload($resultset_class) if $unload;
1572 $self->_reload_class($resultset_class) if $has_file;
1574 $self->_reload_class($class);
1576 push @to_register, [$moniker, $class];
1579 Class::C3->reinitialize;
1580 for (@to_register) {
1581 $self->schema->register_class(@$_);
1585 sub _moose_metaclass {
1586 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1590 my $mc = try { Class::MOP::class_of($class) }
1593 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1596 # We use this instead of ensure_class_loaded when there are package symbols we
1599 my ($self, $class) = @_;
1601 delete $INC{ +class_path($class) };
1604 eval_package_without_redefine_warnings ($class, "require $class");
1607 my $source = slurp_file $self->_get_dump_filename($class);
1608 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1612 sub _get_dump_filename {
1613 my ($self, $class) = (@_);
1615 $class =~ s{::}{/}g;
1616 return $self->dump_directory . q{/} . $class . q{.pm};
1619 =head2 get_dump_filename
1623 Returns the full path to the file for a class that the class has been or will
1624 be dumped to. This is a file in a temp dir for a dynamic schema.
1628 sub get_dump_filename {
1629 my ($self, $class) = (@_);
1631 local $self->{dump_directory} = $self->real_dump_directory;
1633 return $self->_get_dump_filename($class);
1636 sub _ensure_dump_subdirs {
1637 my ($self, $class) = (@_);
1639 my @name_parts = split(/::/, $class);
1640 pop @name_parts; # we don't care about the very last element,
1641 # which is a filename
1643 my $dir = $self->dump_directory;
1646 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1648 last if !@name_parts;
1649 $dir = File::Spec->catdir($dir, shift @name_parts);
1654 my ($self, @classes) = @_;
1656 my $schema_class = $self->schema_class;
1657 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1659 my $target_dir = $self->dump_directory;
1660 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1661 unless $self->dynamic or $self->quiet;
1665 . qq|package $schema_class;\n\n|
1666 . qq|# Created by DBIx::Class::Schema::Loader\n|
1667 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1670 = $self->only_autoclean
1671 ? 'namespace::autoclean'
1672 : 'MooseX::MarkAsMethods autoclean => 1'
1675 if ($self->use_moose) {
1677 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1680 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1683 my @schema_components = @{ $self->schema_components || [] };
1685 if (@schema_components) {
1686 my $schema_components = dump @schema_components;
1687 $schema_components = "($schema_components)" if @schema_components == 1;
1689 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1692 if ($self->use_namespaces) {
1693 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1694 my $namespace_options;
1696 my @attr = qw/resultset_namespace default_resultset_class/;
1698 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1700 for my $attr (@attr) {
1702 my $code = dumper_squashed $self->$attr;
1703 $namespace_options .= qq| $attr => $code,\n|
1706 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1707 $schema_text .= qq|;\n|;
1710 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1714 local $self->{version_to_dump} = $self->schema_version_to_dump;
1715 $self->_write_classfile($schema_class, $schema_text, 1);
1718 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1720 foreach my $src_class (@classes) {
1723 . qq|package $src_class;\n\n|
1724 . qq|# Created by DBIx::Class::Schema::Loader\n|
1725 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1727 $src_text .= $self->_make_pod_heading($src_class);
1729 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1731 $src_text .= $self->_base_class_pod($result_base_class)
1732 unless $result_base_class eq 'DBIx::Class::Core';
1734 if ($self->use_moose) {
1735 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1737 # these options 'use base' which is compile time
1738 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1739 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1742 $src_text .= qq|\nextends '$result_base_class';\n|;
1746 $src_text .= qq|use base '$result_base_class';\n|;
1749 $self->_write_classfile($src_class, $src_text);
1752 # remove Result dir if downgrading from use_namespaces, and there are no
1754 if (my $result_ns = $self->_downgrading_to_load_classes
1755 || $self->_rewriting_result_namespace) {
1756 my $result_namespace = $self->_result_namespace(
1761 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1762 $result_dir = $self->dump_directory . '/' . $result_dir;
1764 unless (my @files = glob "$result_dir/*") {
1769 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1773 my ($self, $version, $ts) = @_;
1774 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1777 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1780 sub _write_classfile {
1781 my ($self, $class, $text, $is_schema) = @_;
1783 my $filename = $self->_get_dump_filename($class);
1784 $self->_ensure_dump_subdirs($class);
1786 if (-f $filename && $self->really_erase_my_files) {
1787 warn "Deleting existing file '$filename' due to "
1788 . "'really_erase_my_files' setting\n" unless $self->quiet;
1792 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1793 = $self->_parse_generated_file($filename);
1795 if (! $old_gen && -f $filename) {
1796 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1797 . " it does not appear to have been generated by Loader"
1800 my $custom_content = $old_custom || '';
1802 # prepend extra custom content from a *renamed* class (singularization effect)
1803 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1804 my $old_filename = $self->_get_dump_filename($renamed_class);
1806 if (-f $old_filename) {
1807 my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
1809 $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
1811 $custom_content = join ("\n", '', $extra_custom, $custom_content)
1814 unlink $old_filename;
1818 $custom_content ||= $self->_default_custom_content($is_schema);
1820 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1821 # If there is already custom content, which does not have the Moose content, add it.
1822 if ($self->use_moose) {
1824 my $non_moose_custom_content = do {
1825 local $self->{use_moose} = 0;
1826 $self->_default_custom_content;
1829 if ($custom_content eq $non_moose_custom_content) {
1830 $custom_content = $self->_default_custom_content($is_schema);
1832 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1833 $custom_content .= $self->_default_custom_content($is_schema);
1836 elsif (defined $self->use_moose && $old_gen) {
1837 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'
1838 if $old_gen =~ /use \s+ MooseX?\b/x;
1841 $custom_content = $self->_rewrite_old_classnames($custom_content);
1844 for @{$self->{_dump_storage}->{$class} || []};
1846 if ($self->filter_generated_code) {
1847 my $filter = $self->filter_generated_code;
1849 if (ref $filter eq 'CODE') {
1851 ($is_schema ? 'schema' : 'result'),
1857 my ($out, $in) = (gensym, gensym);
1859 my $pid = open2($out, $in, $filter)
1860 or croak "Could not open pipe to $filter: $!";
1866 $text = decode('UTF-8', do { local $/; <$out> });
1868 $text =~ s/$CR?$LF/\n/g;
1872 my $exit_code = $? >> 8;
1874 if ($exit_code != 0) {
1875 croak "filter '$filter' exited non-zero: $exit_code";
1878 if (not $text or not $text =~ /\bpackage\b/) {
1879 warn("$class skipped due to filter") if $self->debug;
1884 # Check and see if the dump is in fact different
1888 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1889 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1890 return unless $self->_upgrading_from && $is_schema;
1894 $text .= $self->_sig_comment(
1895 $self->version_to_dump,
1896 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1899 open(my $fh, '>:encoding(UTF-8)', $filename)
1900 or croak "Cannot open '$filename' for writing: $!";
1902 # Write the top half and its MD5 sum
1903 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1905 # Write out anything loaded via external partial class file in @INC
1907 for @{$self->{_ext_storage}->{$class} || []};
1909 # Write out any custom content the user has added
1910 print $fh $custom_content;
1913 or croak "Error closing '$filename': $!";
1916 sub _default_moose_custom_content {
1917 my ($self, $is_schema) = @_;
1919 if (not $is_schema) {
1920 return qq|\n__PACKAGE__->meta->make_immutable;|;
1923 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1926 sub _default_custom_content {
1927 my ($self, $is_schema) = @_;
1928 my $default = qq|\n\n# You can replace this text with custom|
1929 . qq| code or comments, and it will be preserved on regeneration|;
1930 if ($self->use_moose) {
1931 $default .= $self->_default_moose_custom_content($is_schema);
1933 $default .= qq|\n1;\n|;
1937 sub _parse_generated_file {
1938 my ($self, $fn) = @_;
1940 return unless -f $fn;
1942 open(my $fh, '<:encoding(UTF-8)', $fn)
1943 or croak "Cannot open '$fn' for reading: $!";
1946 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
1948 my ($md5, $ts, $ver, $gen);
1954 # Pull out the version and timestamp from the line above
1955 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
1958 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"
1959 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
1968 my $custom = do { local $/; <$fh> }
1972 $custom =~ s/$CRLF|$LF/\n/g;
1976 return ($gen, $md5, $ver, $ts, $custom);
1984 warn "$target: use $_;" if $self->debug;
1985 $self->_raw_stmt($target, "use $_;");
1993 my $blist = join(q{ }, @_);
1995 return unless $blist;
1997 warn "$target: use base qw/$blist/;" if $self->debug;
1998 $self->_raw_stmt($target, "use base qw/$blist/;");
2005 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2007 return unless $rlist;
2009 warn "$target: with $rlist;" if $self->debug;
2010 $self->_raw_stmt($target, "\nwith $rlist;");
2013 sub _result_namespace {
2014 my ($self, $schema_class, $ns) = @_;
2015 my @result_namespace;
2017 $ns = $ns->[0] if ref $ns;
2019 if ($ns =~ /^\+(.*)/) {
2020 # Fully qualified namespace
2021 @result_namespace = ($1)
2024 # Relative namespace
2025 @result_namespace = ($schema_class, $ns);
2028 return wantarray ? @result_namespace : join '::', @result_namespace;
2031 # Create class with applicable bases, setup monikers, etc
2032 sub _make_src_class {
2033 my ($self, $table) = @_;
2035 my $schema = $self->schema;
2036 my $schema_class = $self->schema_class;
2038 my $table_moniker = $self->_table2moniker($table);
2039 my @result_namespace = ($schema_class);
2040 if ($self->use_namespaces) {
2041 my $result_namespace = $self->result_namespace || 'Result';
2042 @result_namespace = $self->_result_namespace(
2047 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2049 if ((my $upgrading_v = $self->_upgrading_from)
2050 || $self->_rewriting) {
2051 local $self->naming->{monikers} = $upgrading_v
2054 my @result_namespace = @result_namespace;
2055 if ($self->_upgrading_from_load_classes) {
2056 @result_namespace = ($schema_class);
2058 elsif (my $ns = $self->_downgrading_to_load_classes) {
2059 @result_namespace = $self->_result_namespace(
2064 elsif ($ns = $self->_rewriting_result_namespace) {
2065 @result_namespace = $self->_result_namespace(
2071 my $old_table_moniker = do {
2072 local $self->naming->{monikers} = $upgrading_v;
2073 $self->_table2moniker($table);
2076 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2078 $self->_upgrading_classes->{$table_class} = $old_class
2079 unless $table_class eq $old_class;
2082 $self->classes->{$table->sql_name} = $table_class;
2083 $self->monikers->{$table->sql_name} = $table_moniker;
2084 $self->moniker_to_table->{$table_moniker} = $table;
2085 $self->class_to_table->{$table_class} = $table;
2087 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2089 $self->_use ($table_class, @{$self->additional_classes});
2091 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2093 $self->_inject($table_class, @{$self->left_base_classes});
2095 my @components = @{ $self->components || [] };
2097 push @components, @{ $self->result_components_map->{$table_moniker} }
2098 if exists $self->result_components_map->{$table_moniker};
2100 my @fq_components = @components;
2101 foreach my $component (@fq_components) {
2102 if ($component !~ s/^\+//) {
2103 $component = "DBIx::Class::$component";
2107 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2109 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2111 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2113 $self->_inject($table_class, @{$self->additional_base_classes});
2116 sub _is_result_class_method {
2117 my ($self, $name, $table) = @_;
2119 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2121 $self->_result_class_methods({})
2122 if not defined $self->_result_class_methods;
2124 if (not exists $self->_result_class_methods->{$table_moniker}) {
2125 my (@methods, %methods);
2126 my $base = $self->result_base_class || 'DBIx::Class::Core';
2128 my @components = @{ $self->components || [] };
2130 push @components, @{ $self->result_components_map->{$table_moniker} }
2131 if exists $self->result_components_map->{$table_moniker};
2133 for my $c (@components) {
2134 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2137 my @roles = @{ $self->result_roles || [] };
2139 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2140 if exists $self->result_roles_map->{$table_moniker};
2142 for my $class ($base, @components,
2143 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2144 $self->ensure_class_loaded($class);
2146 push @methods, @{ Class::Inspector->methods($class) || [] };
2149 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2151 @methods{@methods} = ();
2153 $self->_result_class_methods->{$table_moniker} = \%methods;
2155 my $result_methods = $self->_result_class_methods->{$table_moniker};
2157 return exists $result_methods->{$name};
2160 sub _resolve_col_accessor_collisions {
2161 my ($self, $table, $col_info) = @_;
2163 while (my ($col, $info) = each %$col_info) {
2164 my $accessor = $info->{accessor} || $col;
2166 next if $accessor eq 'id'; # special case (very common column)
2168 if ($self->_is_result_class_method($accessor, $table)) {
2171 if (my $map = $self->col_collision_map) {
2172 for my $re (keys %$map) {
2173 if (my @matches = $col =~ /$re/) {
2174 $info->{accessor} = sprintf $map->{$re}, @matches;
2182 Column '$col' in table '$table' collides with an inherited method.
2183 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2185 $info->{accessor} = undef;
2191 # use the same logic to run moniker_map, col_accessor_map
2193 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2195 my $default_ident = $default_code->( $ident, @extra );
2197 if( $map && ref $map eq 'HASH' ) {
2198 $new_ident = $map->{ $ident };
2200 elsif( $map && ref $map eq 'CODE' ) {
2201 $new_ident = $map->( $ident, $default_ident, @extra );
2204 $new_ident ||= $default_ident;
2209 sub _default_column_accessor_name {
2210 my ( $self, $column_name ) = @_;
2212 my $accessor_name = $self->_to_identifier('column_accessors', $column_name, '_');
2214 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2217 if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
2218 # older naming just lc'd the col accessor and that's all.
2219 return lc $accessor_name;
2221 elsif (($self->naming->{column_accessors}||'') eq 'preserve') {
2222 return $accessor_name;
2225 return join '_', map lc, split_name $column_name;
2228 sub _make_column_accessor_name {
2229 my ($self, $column_name, $column_context_info ) = @_;
2231 my $accessor = $self->_run_user_map(
2232 $self->col_accessor_map,
2233 sub { $self->_default_column_accessor_name( shift ) },
2235 $column_context_info,
2241 # Set up metadata (cols, pks, etc)
2242 sub _setup_src_meta {
2243 my ($self, $table) = @_;
2245 my $schema = $self->schema;
2246 my $schema_class = $self->schema_class;
2248 my $table_class = $self->classes->{$table->sql_name};
2249 my $table_moniker = $self->monikers->{$table->sql_name};
2251 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2253 my $cols = $self->_table_columns($table);
2254 my $col_info = $self->__columns_info_for($table);
2256 ### generate all the column accessor names
2257 while (my ($col, $info) = each %$col_info) {
2258 # hashref of other info that could be used by
2259 # user-defined accessor map functions
2261 table_class => $table_class,
2262 table_moniker => $table_moniker,
2263 table_name => $table,
2264 full_table_name => $table->dbic_name,
2265 schema_class => $schema_class,
2266 column_info => $info,
2269 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2272 $self->_resolve_col_accessor_collisions($table, $col_info);
2274 # prune any redundant accessor names
2275 while (my ($col, $info) = each %$col_info) {
2276 no warnings 'uninitialized';
2277 delete $info->{accessor} if $info->{accessor} eq $col;
2280 my $fks = $self->_table_fk_info($table);
2282 foreach my $fkdef (@$fks) {
2283 for my $col (@{ $fkdef->{local_columns} }) {
2284 $col_info->{$col}{is_foreign_key} = 1;
2288 my $pks = $self->_table_pk_info($table) || [];
2290 my %uniq_tag; # used to eliminate duplicate uniqs
2292 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2294 my $uniqs = $self->_table_uniq_info($table) || [];
2297 foreach my $uniq (@$uniqs) {
2298 my ($name, $cols) = @$uniq;
2299 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2300 push @uniqs, [$name, $cols];
2303 my @non_nullable_uniqs = grep {
2304 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2307 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2308 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2309 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2311 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2312 my @keys = map $_->[1], @by_colnum;
2316 # remove the uniq from list
2317 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2323 foreach my $pkcol (@$pks) {
2324 $col_info->{$pkcol}{is_nullable} = 0;
2330 map { $_, ($col_info->{$_}||{}) } @$cols
2333 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2336 # Sort unique constraints by constraint name for repeatable results (rels
2337 # are sorted as well elsewhere.)
2338 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2340 foreach my $uniq (@uniqs) {
2341 my ($name, $cols) = @$uniq;
2342 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2346 sub __columns_info_for {
2347 my ($self, $table) = @_;
2349 my $result = $self->_columns_info_for($table);
2351 while (my ($col, $info) = each %$result) {
2352 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2353 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2355 $result->{$col} = $info;
2363 Returns a sorted list of loaded tables, using the original database table
2371 return values %{$self->_tables};
2375 my ($self, $naming_key) = @_;
2379 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2383 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2389 sub _to_identifier {
2390 my ($self, $naming_key, $name, $sep_char) = @_;
2392 my $v = $self->_get_naming_v($naming_key);
2394 my $to_identifier = $self->naming->{force_ascii} ?
2395 \&String::ToIdentifier::EN::to_identifier
2396 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2398 return $v >= 8 ? $to_identifier->($name, $sep_char) : $name;
2401 # Make a moniker from a table
2402 sub _default_table2moniker {
2403 my ($self, $table) = @_;
2405 my $v = $self->_get_naming_v('monikers');
2407 my @name_parts = map $table->$_, @{ $self->moniker_parts };
2409 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2413 foreach my $i (0 .. $#name_parts) {
2414 my $part = $name_parts[$i];
2416 if ($i != $name_idx || $v >= 8) {
2417 $part = $self->_to_identifier('monikers', $part, '_');
2420 if ($i == $name_idx && $v == 5) {
2421 $part = Lingua::EN::Inflect::Number::to_S($part);
2424 my @part_parts = map lc, $v > 6 ? split_name $part : split /[\W_]+/, $part;
2426 if ($i == $name_idx && $v >= 6) {
2427 my $as_phrase = join ' ', @part_parts;
2429 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2430 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2432 ($self->naming->{monikers}||'') eq 'preserve' ?
2435 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2437 @part_parts = split /\s+/, $inflected;
2440 push @all_parts, map ucfirst, @part_parts;
2443 return join '', @all_parts;
2446 sub _table2moniker {
2447 my ( $self, $table ) = @_;
2449 $self->_run_user_map(
2451 sub { $self->_default_table2moniker( shift ) },
2456 sub _load_relationships {
2457 my ($self, $tables) = @_;
2461 foreach my $table (@$tables) {
2462 my $local_moniker = $self->monikers->{$table->sql_name};
2464 my $tbl_fk_info = $self->_table_fk_info($table);
2466 foreach my $fkdef (@$tbl_fk_info) {
2467 $fkdef->{local_table} = $table;
2468 $fkdef->{local_moniker} = $local_moniker;
2469 $fkdef->{remote_source} =
2470 $self->monikers->{$fkdef->{remote_table}->sql_name};
2472 my $tbl_uniq_info = $self->_table_uniq_info($table);
2474 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2477 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2479 foreach my $src_class (sort keys %$rel_stmts) {
2481 my @src_stmts = map $_->[1],
2482 sort { $a->[0] cmp $b->[0] }
2483 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2485 foreach my $stmt (@src_stmts) {
2486 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2492 my ($self, $table) = @_;
2494 my $table_moniker = $self->monikers->{$table->sql_name};
2495 my $table_class = $self->classes->{$table->sql_name};
2497 my @roles = @{ $self->result_roles || [] };
2498 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2499 if exists $self->result_roles_map->{$table_moniker};
2502 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2504 $self->_with($table_class, @roles);
2508 # Overload these in driver class:
2510 # Returns an arrayref of column names
2511 sub _table_columns { croak "ABSTRACT METHOD" }
2513 # Returns arrayref of pk col names
2514 sub _table_pk_info { croak "ABSTRACT METHOD" }
2516 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2517 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2519 # Returns an arrayref of foreign key constraints, each
2520 # being a hashref with 3 keys:
2521 # local_columns (arrayref), remote_columns (arrayref), remote_table
2522 sub _table_fk_info { croak "ABSTRACT METHOD" }
2524 # Returns an array of lower case table names
2525 sub _tables_list { croak "ABSTRACT METHOD" }
2527 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2533 # generate the pod for this statement, storing it with $self->_pod
2534 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2536 my $args = dump(@_);
2537 $args = '(' . $args . ')' if @_ < 2;
2538 my $stmt = $method . $args . q{;};
2540 warn qq|$class\->$stmt\n| if $self->debug;
2541 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2545 sub _make_pod_heading {
2546 my ($self, $class) = @_;
2548 return '' if not $self->generate_pod;
2550 my $table = $self->class_to_table->{$class};
2553 my $pcm = $self->pod_comment_mode;
2554 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2555 $comment = $self->__table_comment($table);
2556 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2557 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2558 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2560 $pod .= "=head1 NAME\n\n";
2562 my $table_descr = $class;
2563 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2565 $pod .= "$table_descr\n\n";
2567 if ($comment and $comment_in_desc) {
2568 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2575 # generates the accompanying pod for a DBIC class method statement,
2576 # storing it with $self->_pod
2582 if ($method eq 'table') {
2584 $table = $$table if ref $table eq 'SCALAR';
2585 $self->_pod($class, "=head1 TABLE: C<$table>");
2586 $self->_pod_cut($class);
2588 elsif ( $method eq 'add_columns' ) {
2589 $self->_pod( $class, "=head1 ACCESSORS" );
2590 my $col_counter = 0;
2592 while( my ($name,$attrs) = splice @cols,0,2 ) {
2594 $self->_pod( $class, '=head2 ' . $name );
2595 $self->_pod( $class,
2597 my $s = $attrs->{$_};
2598 $s = !defined $s ? 'undef' :
2599 length($s) == 0 ? '(empty string)' :
2600 ref($s) eq 'SCALAR' ? $$s :
2601 ref($s) ? dumper_squashed $s :
2602 looks_like_number($s) ? $s : qq{'$s'};
2605 } sort keys %$attrs,
2607 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2608 $self->_pod( $class, $comment );
2611 $self->_pod_cut( $class );
2612 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2613 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2614 my ( $accessor, $rel_class ) = @_;
2615 $self->_pod( $class, "=head2 $accessor" );
2616 $self->_pod( $class, 'Type: ' . $method );
2617 $self->_pod( $class, "Related object: L<$rel_class>" );
2618 $self->_pod_cut( $class );
2619 $self->{_relations_started} { $class } = 1;
2621 elsif ($method eq 'add_unique_constraint') {
2622 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2623 unless $self->{_uniqs_started}{$class};
2625 my ($name, $cols) = @_;
2627 $self->_pod($class, "=head2 C<$name>");
2628 $self->_pod($class, '=over 4');
2630 foreach my $col (@$cols) {
2631 $self->_pod($class, "=item \* L</$col>");
2634 $self->_pod($class, '=back');
2635 $self->_pod_cut($class);
2637 $self->{_uniqs_started}{$class} = 1;
2639 elsif ($method eq 'set_primary_key') {
2640 $self->_pod($class, "=head1 PRIMARY KEY");
2641 $self->_pod($class, '=over 4');
2643 foreach my $col (@_) {
2644 $self->_pod($class, "=item \* L</$col>");
2647 $self->_pod($class, '=back');
2648 $self->_pod_cut($class);
2652 sub _pod_class_list {
2653 my ($self, $class, $title, @classes) = @_;
2655 return unless @classes && $self->generate_pod;
2657 $self->_pod($class, "=head1 $title");
2658 $self->_pod($class, '=over 4');
2660 foreach my $link (@classes) {
2661 $self->_pod($class, "=item * L<$link>");
2664 $self->_pod($class, '=back');
2665 $self->_pod_cut($class);
2668 sub _base_class_pod {
2669 my ($self, $base_class) = @_;
2671 return '' unless $self->generate_pod;
2674 =head1 BASE CLASS: L<$base_class>
2681 sub _filter_comment {
2682 my ($self, $txt) = @_;
2684 $txt = '' if not defined $txt;
2686 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2691 sub __table_comment {
2694 if (my $code = $self->can('_table_comment')) {
2695 return $self->_filter_comment($self->$code(@_));
2701 sub __column_comment {
2704 if (my $code = $self->can('_column_comment')) {
2705 return $self->_filter_comment($self->$code(@_));
2711 # Stores a POD documentation
2713 my ($self, $class, $stmt) = @_;
2714 $self->_raw_stmt( $class, "\n" . $stmt );
2718 my ($self, $class ) = @_;
2719 $self->_raw_stmt( $class, "\n=cut\n" );
2722 # Store a raw source line for a class (for dumping purposes)
2724 my ($self, $class, $stmt) = @_;
2725 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2728 # Like above, but separately for the externally loaded stuff
2730 my ($self, $class, $stmt) = @_;
2731 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2734 sub _custom_column_info {
2735 my ( $self, $table_name, $column_name, $column_info ) = @_;
2737 if (my $code = $self->custom_column_info) {
2738 return $code->($table_name, $column_name, $column_info) || {};
2743 sub _datetime_column_info {
2744 my ( $self, $table_name, $column_name, $column_info ) = @_;
2746 my $type = $column_info->{data_type} || '';
2747 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2748 or ($type =~ /date|timestamp/i)) {
2749 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2750 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2756 my ($self, $name) = @_;
2758 return $self->preserve_case ? $name : lc($name);
2762 my ($self, $name) = @_;
2764 return $self->preserve_case ? $name : uc($name);
2768 my ($self, $table) = @_;
2771 my $schema = $self->schema;
2772 # in older DBIC it's a private method
2773 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2774 $schema->$unregister(delete $self->monikers->{$table->sql_name});
2775 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2776 delete $self->_tables->{$table->sql_name};
2780 # remove the dump dir from @INC on destruction
2784 @INC = grep $_ ne $self->dump_directory, @INC;
2789 Returns a hashref of loaded table to moniker mappings. There will
2790 be two entries for each table, the original name and the "normalized"
2791 name, in the case that the two are different (such as databases
2792 that like uppercase table names, or preserve your original mixed-case
2793 definitions, or what-have-you).
2797 Returns a hashref of table to class mappings. In some cases it will
2798 contain multiple entries per table for the original and normalized table
2799 names, as above in L</monikers>.
2801 =head1 NON-ENGLISH DATABASES
2803 If you use the loader on a database with table and column names in a language
2804 other than English, you will want to turn off the English language specific
2807 To do so, use something like this in your laoder options:
2809 naming => { monikers => 'v4' },
2810 inflect_singular => sub { "$_[0]_rel" },
2811 inflect_plural => sub { "$_[0]_rel" },
2813 =head1 COLUMN ACCESSOR COLLISIONS
2815 Occasionally you may have a column name that collides with a perl method, such
2816 as C<can>. In such cases, the default action is to set the C<accessor> of the
2817 column spec to C<undef>.
2819 You can then name the accessor yourself by placing code such as the following
2822 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2824 Another option is to use the L</col_collision_map> option.
2826 =head1 RELATIONSHIP NAME COLLISIONS
2828 In very rare cases, you may get a collision between a generated relationship
2829 name and a method in your Result class, for example if you have a foreign key
2830 called C<belongs_to>.
2832 This is a problem because relationship names are also relationship accessor
2833 methods in L<DBIx::Class>.
2835 The default behavior is to append C<_rel> to the relationship name and print
2836 out a warning that refers to this text.
2838 You can also control the renaming with the L</rel_collision_map> option.
2842 L<DBIx::Class::Schema::Loader>
2846 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2850 This library is free software; you can redistribute it and/or modify it under
2851 the same terms as Perl itself.
2856 # vim:et sts=4 sw=4 tw=0: