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 any firstidx uniq/;
28 use File::Temp 'tempfile';
31 our $VERSION = '0.07014';
33 __PACKAGE__->mk_group_ro_accessors('simple', qw/
40 additional_base_classes
56 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 CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported
266 correctly in this mode.
268 For relationships, belongs_to accessors are made from column names by stripping
269 postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>,
270 C<_?code> and C<_?num>, case insensitively.
274 For L</monikers>, this option does not inflect the table names but makes
275 monikers based on the actual name. For L</column_accessors> this option does
276 not normalize CamelCase column names to lowercase column accessors, but makes
277 accessors that are the same names as the columns (with any non-\w chars
278 replaced with underscores.)
282 For L</monikers>, singularizes the names using the most current inflector. This
283 is the same as setting the option to L</current>.
287 For L</monikers>, pluralizes the names, using the most current inflector.
291 Dynamic schemas will always default to the 0.04XXX relationship names and won't
292 singularize Results for backward compatibility, to activate the new RelBuilder
293 and singularization put this in your C<Schema.pm> file:
295 __PACKAGE__->naming('current');
297 Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
298 next major version upgrade:
300 __PACKAGE__->naming('v7');
304 If true, will not print the usual C<Dumping manual schema ... Schema dump
305 completed.> messages. Does not affect warnings (except for warnings related to
306 L</really_erase_my_files>.)
310 By default POD will be generated for columns and relationships, using database
311 metadata for the text if available and supported.
313 Comment metadata can be stored in two ways.
315 The first is that you can create two tables named C<table_comments> and
316 C<column_comments> respectively. These tables must exist in the same database
317 and schema as the tables they describe. They both need to have columns named
318 C<table_name> and C<comment_text>. The second one needs to have a column named
319 C<column_name>. Then data stored in these tables will be used as a source of
320 metadata about tables and comments.
322 (If you wish you can change the name of these tables with the parameters
323 L</table_comments_table> and L</column_comments_table>.)
325 As a fallback you can use built-in commenting mechanisms. Currently this is
326 only supported for PostgreSQL, Oracle and MySQL. To create comments in
327 PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
328 '...'>, the same syntax is used in Oracle. To create comments in MySQL you add
329 C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
330 restricts the length of comments, and also does not handle complex Unicode
333 Set this to C<0> to turn off all POD generation.
335 =head2 pod_comment_mode
337 Controls where table comments appear in the generated POD. Smaller table
338 comments are appended to the C<NAME> section of the documentation, and larger
339 ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION>
340 section to be generated with the comment always, only use C<NAME>, or choose
341 the length threshold at which the comment is forced into the description.
347 Use C<NAME> section only.
351 Force C<DESCRIPTION> always.
355 Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the
360 =head2 pod_comment_spillover_length
362 When pod_comment_mode is set to C<auto>, this is the length of the comment at
363 which it will be forced into a separate description section.
367 =head2 table_comments_table
369 The table to look for comments about tables in. By default C<table_comments>.
370 See L</generate_pod> for details.
372 This must not be a fully qualified name, the table will be looked for in the
373 same database and schema as the table whose comment is being retrieved.
375 =head2 column_comments_table
377 The table to look for comments about columns in. By default C<column_comments>.
378 See L</generate_pod> for details.
380 This must not be a fully qualified name, the table will be looked for in the
381 same database and schema as the table/column whose comment is being retrieved.
383 =head2 relationship_attrs
385 Hashref of attributes to pass to each generated relationship, listed
386 by type. Also supports relationship type 'all', containing options to
387 pass to all generated relationships. Attributes set for more specific
388 relationship types override those set in 'all'.
392 relationship_attrs => {
393 belongs_to => { is_deferrable => 0 },
396 use this to turn off DEFERRABLE on your foreign key constraints.
400 If set to true, each constructive L<DBIx::Class> statement the loader
401 decides to execute will be C<warn>-ed before execution.
405 Set the name of the schema to load (schema in the sense that your database
408 Can be set to an arrayref of schema names for multiple schemas, or the special
409 value C<%> for all schemas.
411 For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as
412 keys and arrays of owners as values, set to the value:
416 for all owners in all databases.
418 Name clashes resulting from the same table name in different databases/schemas
419 will be resolved automatically by prefixing the moniker with the database
422 To prefix/suffix all monikers with the database and/or schema, see
427 The database table names are represented by the
428 L<DBIx::Class::Schema::Loader::Table> class in the loader, the
429 L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
430 L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
432 Monikers are created normally based on just the
433 L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
434 the table name, but can consist of other parts of the fully qualified name of
437 The L</moniker_parts> option is an arrayref of methods on the table class
438 corresponding to parts of the fully qualified table name, defaulting to
439 C<['name']>, in the order those parts are used to create the moniker name.
441 The C<'name'> entry B<must> be present.
443 Below is a table of supported databases and possible L</moniker_parts>.
447 =item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
451 =item * Informix, MSSQL, Sybase ASE
453 C<database>, C<schema>, C<name>
459 Only load tables matching regex. Best specified as a qr// regex.
463 Exclude tables matching regex. Best specified as a qr// regex.
467 Overrides the default table name to moniker translation. Can be either a
468 hashref of table keys and moniker values, or a coderef for a translator
469 function taking a L<table object|DBIx::Class::Schema::Loader::Table> argument
470 (which stringifies to the unqualified table name) and returning a scalar
471 moniker. If the hash entry does not exist, or the function returns a false
472 value, the code falls back to default behavior for that table name.
474 The default behavior is to split on case transition and non-alphanumeric
475 boundaries, singularize the resulting phrase, then join the titlecased words
478 Table Name | Moniker Name
479 ---------------------------------
481 luser_group | LuserGroup
482 luser-opts | LuserOpt
483 stations_visited | StationVisited
484 routeChange | RouteChange
486 =head2 col_accessor_map
488 Same as moniker_map, but for column accessor names. If a coderef is
489 passed, the code is called with arguments of
491 the name of the column in the underlying database,
492 default accessor name that DBICSL would ordinarily give this column,
494 table_class => name of the DBIC class we are building,
495 table_moniker => calculated moniker for this table (after moniker_map if present),
496 table => table object of interface DBIx::Class::Schema::Loader::Table,
497 full_table_name => schema-qualified name of the database table (RDBMS specific),
498 schema_class => name of the schema class we are building,
499 column_info => hashref of column info (data_type, is_nullable, etc),
502 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
503 unqualified table name.
507 Similar in idea to moniker_map, but different in the details. It can be
508 a hashref or a code ref.
510 If it is a hashref, keys can be either the default relationship name, or the
511 moniker. The keys that are the default relationship name should map to the
512 name you want to change the relationship to. Keys that are monikers should map
513 to hashes mapping relationship names to their translation. You can do both at
514 once, and the more specific moniker version will be picked up first. So, for
515 instance, you could have
524 and relationships that would have been named C<bar> will now be named C<baz>
525 except that in the table whose moniker is C<Foo> it will be named C<blat>.
527 If it is a coderef, the argument passed will be a hashref of this form:
530 name => default relationship name,
531 type => the relationship type eg: C<has_many>,
532 local_class => name of the DBIC class we are building,
533 local_moniker => moniker of the DBIC class we are building,
534 local_columns => columns in this table in the relationship,
535 remote_class => name of the DBIC class we are related to,
536 remote_moniker => moniker of the DBIC class we are related to,
537 remote_columns => columns in the other table in the relationship,
540 DBICSL will try to use the value returned as the relationship name.
542 =head2 inflect_plural
544 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
545 if hash key does not exist or coderef returns false), but acts as a map
546 for pluralizing relationship names. The default behavior is to utilize
547 L<Lingua::EN::Inflect::Phrase/to_PL>.
549 =head2 inflect_singular
551 As L</inflect_plural> above, but for singularizing relationship names.
552 Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
554 =head2 schema_base_class
556 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
558 =head2 schema_components
560 List of components to load into the Schema class.
562 =head2 result_base_class
564 Base class for your table classes (aka result classes). Defaults to
567 =head2 additional_base_classes
569 List of additional base classes all of your table classes will use.
571 =head2 left_base_classes
573 List of additional base classes all of your table classes will use
574 that need to be leftmost.
576 =head2 additional_classes
578 List of additional classes which all of your table classes will use.
582 List of additional components to be loaded into all of your Result
583 classes. A good example would be
584 L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
586 =head2 result_components_map
588 A hashref of moniker keys and component values. Unlike L</components>, which
589 loads the given components into every Result class, this option allows you to
590 load certain components for specified Result classes. For example:
592 result_components_map => {
593 StationVisited => '+YourApp::Schema::Component::StationVisited',
595 '+YourApp::Schema::Component::RouteChange',
596 'InflateColumn::DateTime',
600 You may use this in conjunction with L</components>.
604 List of L<Moose> roles to be applied to all of your Result classes.
606 =head2 result_roles_map
608 A hashref of moniker keys and role values. Unlike L</result_roles>, which
609 applies the given roles to every Result class, this option allows you to apply
610 certain roles for specified Result classes. For example:
612 result_roles_map => {
614 'YourApp::Role::Building',
615 'YourApp::Role::Destination',
617 RouteChange => 'YourApp::Role::TripEvent',
620 You may use this in conjunction with L</result_roles>.
622 =head2 use_namespaces
624 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
627 Generate result class names suitable for
628 L<DBIx::Class::Schema/load_namespaces> and call that instead of
629 L<DBIx::Class::Schema/load_classes>. When using this option you can also
630 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
631 C<resultset_namespace>, C<default_resultset_class>), and they will be added
632 to the call (and the generated result class names adjusted appropriately).
634 =head2 dump_directory
636 The value of this option is a perl libdir pathname. Within
637 that directory this module will create a baseline manual
638 L<DBIx::Class::Schema> module set, based on what it creates at runtime.
640 The created schema class will have the same classname as the one on
641 which you are setting this option (and the ResultSource classes will be
642 based on this name as well).
644 Normally you wouldn't hard-code this setting in your schema class, as it
645 is meant for one-time manual usage.
647 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
648 recommended way to access this functionality.
650 =head2 dump_overwrite
652 Deprecated. See L</really_erase_my_files> below, which does *not* mean
653 the same thing as the old C<dump_overwrite> setting from previous releases.
655 =head2 really_erase_my_files
657 Default false. If true, Loader will unconditionally delete any existing
658 files before creating the new ones from scratch when dumping a schema to disk.
660 The default behavior is instead to only replace the top portion of the
661 file, up to and including the final stanza which contains
662 C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
663 leaving any customizations you placed after that as they were.
665 When C<really_erase_my_files> is not set, if the output file already exists,
666 but the aforementioned final stanza is not found, or the checksum
667 contained there does not match the generated contents, Loader will
668 croak and not touch the file.
670 You should really be using version control on your schema classes (and all
671 of the rest of your code for that matter). Don't blame me if a bug in this
672 code wipes something out when it shouldn't have, you've been warned.
674 =head2 overwrite_modifications
676 Default false. If false, when updating existing files, Loader will
677 refuse to modify any Loader-generated code that has been modified
678 since its last run (as determined by the checksum Loader put in its
681 If true, Loader will discard any manual modifications that have been
682 made to Loader-generated code.
684 Again, you should be using version control on your schema classes. Be
685 careful with this option.
687 =head2 custom_column_info
689 Hook for adding extra attributes to the
690 L<column_info|DBIx::Class::ResultSource/column_info> for a column.
692 Must be a coderef that returns a hashref with the extra attributes.
694 Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
695 stringifies to the unqualified table name), column name and column_info.
699 custom_column_info => sub {
700 my ($table, $column_name, $column_info) = @_;
702 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
703 return { is_snoopy => 1 };
707 This attribute can also be used to set C<inflate_datetime> on a non-datetime
708 column so it also receives the L</datetime_timezone> and/or L</datetime_locale>.
710 =head2 datetime_timezone
712 Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all
713 columns with the DATE/DATETIME/TIMESTAMP data_types.
715 =head2 datetime_locale
717 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
718 columns with the DATE/DATETIME/TIMESTAMP data_types.
720 =head2 datetime_undef_if_invalid
722 Pass a C<0> for this option when using MySQL if you B<DON'T> want C<<
723 datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and
726 The default is recommended to deal with data such as C<00/00/00> which
727 sometimes ends up in such columns in MySQL.
731 File in Perl format, which should return a HASH reference, from which to read
736 Normally database names are lowercased and split by underscore, use this option
737 if you have CamelCase database names.
739 Drivers for case sensitive databases like Sybase ASE or MSSQL with a
740 case-sensitive collation will turn this option on unconditionally.
742 B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
743 semantics of this mode are much improved for CamelCase database names.
745 L</naming> = C<v7> or greater is required with this option.
747 =head2 qualify_objects
749 Set to true to prepend the L</db_schema> to table names for C<<
750 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
752 This attribute is automatically set to true for multi db_schema configurations.
756 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
757 L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default
758 content after the md5 sum also makes the classes immutable.
760 It is safe to upgrade your existing Schema to this option.
762 =head2 only_autoclean
764 By default, we use L<MooseX::MarkAsMethods> to remove imported functions from
765 your generated classes. It uses L<namespace::autoclean> to do this, after
766 telling your object's metaclass that any operator L<overload>s in your class
767 are methods, which will cause namespace::autoclean to spare them from removal.
769 This prevents the "Hey, where'd my overloads go?!" effect.
771 If you don't care about operator overloads, enabling this option falls back to
772 just using L<namespace::autoclean> itself.
774 If none of the above made any sense, or you don't have some pressing need to
775 only use L<namespace::autoclean>, leaving this set to the default is
778 =head2 col_collision_map
780 This option controls how accessors for column names which collide with perl
781 methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
783 This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
784 strings which are compiled to regular expressions that map to
785 L<sprintf|perlfunc/sprintf> formats.
789 col_collision_map => 'column_%s'
791 col_collision_map => { '(.*)' => 'column_%s' }
793 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
795 =head2 rel_collision_map
797 Works just like L</col_collision_map>, but for relationship names/accessors
798 rather than column names/accessors.
800 The default is to just append C<_rel> to the relationship name, see
801 L</RELATIONSHIP NAME COLLISIONS>.
803 =head2 uniq_to_primary
805 Automatically promotes the largest unique constraints with non-nullable columns
806 on tables to primary keys, assuming there is only one largest unique
809 =head2 filter_generated_code
811 An optional hook that lets you filter the generated text for various classes
812 through a function that change it in any way that you want. The function will
813 receive the type of file, C<schema> or C<result>, class and code; and returns
814 the new code to use instead. For instance you could add custom comments, or do
815 anything else that you want.
817 The option can also be set to a string, which is then used as a filter program,
820 If this exists but fails to return text matching C</\bpackage\b/>, no file will
823 filter_generated_code => sub {
824 my ($type, $class, $text) = @_;
831 None of these methods are intended for direct invocation by regular
832 users of L<DBIx::Class::Schema::Loader>. Some are proxied via
833 L<DBIx::Class::Schema::Loader>.
837 # ensure that a peice of object data is a valid arrayref, creating
838 # an empty one or encapsulating whatever's there.
839 sub _ensure_arrayref {
844 $self->{$_} = [ $self->{$_} ]
845 unless ref $self->{$_} eq 'ARRAY';
851 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
852 by L<DBIx::Class::Schema::Loader>.
857 my ( $class, %args ) = @_;
859 if (exists $args{column_accessor_map}) {
860 $args{col_accessor_map} = delete $args{column_accessor_map};
863 my $self = { %args };
865 # don't lose undef options
866 for (values %$self) {
867 $_ = 0 unless defined $_;
870 bless $self => $class;
872 if (my $config_file = $self->config_file) {
873 my $config_opts = do $config_file;
875 croak "Error reading config from $config_file: $@" if $@;
877 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
879 while (my ($k, $v) = each %$config_opts) {
880 $self->{$k} = $v unless exists $self->{$k};
884 if (defined $self->{result_component_map}) {
885 if (defined $self->result_components_map) {
886 croak "Specify only one of result_components_map or result_component_map";
888 $self->result_components_map($self->{result_component_map})
891 if (defined $self->{result_role_map}) {
892 if (defined $self->result_roles_map) {
893 croak "Specify only one of result_roles_map or result_role_map";
895 $self->result_roles_map($self->{result_role_map})
898 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
899 if ((not defined $self->use_moose) || (not $self->use_moose))
900 && ((defined $self->result_roles) || (defined $self->result_roles_map));
902 $self->_ensure_arrayref(qw/schema_components
904 additional_base_classes
910 $self->_validate_class_args;
912 croak "result_components_map must be a hash"
913 if defined $self->result_components_map
914 && ref $self->result_components_map ne 'HASH';
916 if ($self->result_components_map) {
917 my %rc_map = %{ $self->result_components_map };
918 foreach my $moniker (keys %rc_map) {
919 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker};
921 $self->result_components_map(\%rc_map);
924 $self->result_components_map({});
926 $self->_validate_result_components_map;
928 croak "result_roles_map must be a hash"
929 if defined $self->result_roles_map
930 && ref $self->result_roles_map ne 'HASH';
932 if ($self->result_roles_map) {
933 my %rr_map = %{ $self->result_roles_map };
934 foreach my $moniker (keys %rr_map) {
935 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker};
937 $self->result_roles_map(\%rr_map);
939 $self->result_roles_map({});
941 $self->_validate_result_roles_map;
943 if ($self->use_moose) {
944 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) {
945 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
946 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
950 $self->{_tables} = {};
951 $self->{monikers} = {};
952 $self->{moniker_to_table} = {};
953 $self->{class_to_table} = {};
954 $self->{classes} = {};
955 $self->{_upgrading_classes} = {};
957 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
958 $self->{schema} ||= $self->{schema_class};
959 $self->{table_comments_table} ||= 'table_comments';
960 $self->{column_comments_table} ||= 'column_comments';
962 croak "dump_overwrite is deprecated. Please read the"
963 . " DBIx::Class::Schema::Loader::Base documentation"
964 if $self->{dump_overwrite};
966 $self->{dynamic} = ! $self->{dump_directory};
967 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
972 $self->{dump_directory} ||= $self->{temp_directory};
974 $self->real_dump_directory($self->{dump_directory});
976 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
977 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
979 if (not defined $self->naming) {
980 $self->naming_set(0);
983 $self->naming_set(1);
986 if ((not ref $self->naming) && defined $self->naming) {
987 my $naming_ver = $self->naming;
989 relationships => $naming_ver,
990 monikers => $naming_ver,
991 column_accessors => $naming_ver,
994 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) {
995 my $val = delete $self->naming->{ALL};
997 $self->naming->{$_} = $val
998 foreach qw/relationships monikers column_accessors/;
1001 if ($self->naming) {
1002 foreach my $key (qw/relationships monikers column_accessors/) {
1003 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current';
1006 $self->{naming} ||= {};
1008 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') {
1009 croak 'custom_column_info must be a CODE ref';
1012 $self->_check_back_compat;
1014 $self->use_namespaces(1) unless defined $self->use_namespaces;
1015 $self->generate_pod(1) unless defined $self->generate_pod;
1016 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
1017 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
1019 if (my $col_collision_map = $self->col_collision_map) {
1020 if (my $reftype = ref $col_collision_map) {
1021 if ($reftype ne 'HASH') {
1022 croak "Invalid type $reftype for option 'col_collision_map'";
1026 $self->col_collision_map({ '(.*)' => $col_collision_map });
1030 if (my $rel_collision_map = $self->rel_collision_map) {
1031 if (my $reftype = ref $rel_collision_map) {
1032 if ($reftype ne 'HASH') {
1033 croak "Invalid type $reftype for option 'rel_collision_map'";
1037 $self->rel_collision_map({ '(.*)' => $rel_collision_map });
1041 if (defined(my $rel_name_map = $self->rel_name_map)) {
1042 my $reftype = ref $rel_name_map;
1043 if ($reftype ne 'HASH' && $reftype ne 'CODE') {
1044 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE";
1048 if (defined(my $filter = $self->filter_generated_code)) {
1049 my $reftype = ref $filter;
1050 if ($reftype && $reftype ne 'CODE') {
1051 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
1055 if (defined $self->db_schema) {
1056 if (ref $self->db_schema eq 'ARRAY') {
1057 if (@{ $self->db_schema } > 1) {
1058 $self->{qualify_objects} = 1;
1060 elsif (@{ $self->db_schema } == 0) {
1061 $self->{db_schema} = undef;
1064 elsif (not ref $self->db_schema) {
1065 if ($self->db_schema eq '%') {
1066 $self->{qualify_objects} = 1;
1069 $self->{db_schema} = [ $self->db_schema ];
1073 if (not $self->moniker_parts) {
1074 $self->moniker_parts(['name']);
1077 if (not ref $self->moniker_parts) {
1078 $self->moniker_parts([ $self->moniker_parts ]);
1080 if (ref $self->moniker_parts ne 'ARRAY') {
1081 croak 'moniker_parts must be an arrayref';
1083 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
1084 croak "moniker_parts option *must* contain 'name'";
1091 sub _check_back_compat {
1094 # dynamic schemas will always be in 0.04006 mode, unless overridden
1095 if ($self->dynamic) {
1096 # just in case, though no one is likely to dump a dynamic schema
1097 $self->schema_version_to_dump('0.04006');
1099 if (not $self->naming_set) {
1100 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1102 Dynamic schema detected, will run in 0.04006 mode.
1104 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1105 to disable this warning.
1107 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1112 $self->_upgrading_from('v4');
1115 if ((not defined $self->use_namespaces) && ($self->naming_set)) {
1116 $self->use_namespaces(1);
1119 $self->naming->{relationships} ||= 'v4';
1120 $self->naming->{monikers} ||= 'v4';
1122 if ($self->use_namespaces) {
1123 $self->_upgrading_from_load_classes(1);
1126 $self->use_namespaces(0);
1132 # otherwise check if we need backcompat mode for a static schema
1133 my $filename = $self->get_dump_filename($self->schema_class);
1134 return unless -e $filename;
1136 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
1137 $self->_parse_generated_file($filename);
1139 return unless $old_ver;
1141 # determine if the existing schema was dumped with use_moose => 1
1142 if (! defined $self->use_moose) {
1143 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
1146 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
1148 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' };
1149 my $ds = eval $result_namespace;
1151 Could not eval expression '$result_namespace' for result_namespace from
1154 $result_namespace = $ds || '';
1156 if ($load_classes && (not defined $self->use_namespaces)) {
1157 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1159 'load_classes;' static schema detected, turning off 'use_namespaces'.
1161 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
1162 variable to disable this warning.
1164 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
1167 $self->use_namespaces(0);
1169 elsif ($load_classes && $self->use_namespaces) {
1170 $self->_upgrading_from_load_classes(1);
1172 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
1173 $self->_downgrading_to_load_classes(
1174 $result_namespace || 'Result'
1177 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
1178 if (not $self->result_namespace) {
1179 $self->result_namespace($result_namespace || 'Result');
1181 elsif ($result_namespace ne $self->result_namespace) {
1182 $self->_rewriting_result_namespace(
1183 $result_namespace || 'Result'
1188 # XXX when we go past .0 this will need fixing
1189 my ($v) = $old_ver =~ /([1-9])/;
1192 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
1194 if (not %{ $self->naming }) {
1195 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
1197 Version $old_ver static schema detected, turning on backcompat mode.
1199 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
1200 to disable this warning.
1202 See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
1204 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
1205 from version 0.04006.
1208 $self->naming->{relationships} ||= $v;
1209 $self->naming->{monikers} ||= $v;
1210 $self->naming->{column_accessors} ||= $v;
1212 $self->schema_version_to_dump($old_ver);
1215 $self->_upgrading_from($v);
1219 sub _validate_class_args {
1222 foreach my $k (@CLASS_ARGS) {
1223 next unless $self->$k;
1225 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
1226 $self->_validate_classes($k, \@classes);
1230 sub _validate_result_components_map {
1233 foreach my $classes (values %{ $self->result_components_map }) {
1234 $self->_validate_classes('result_components_map', $classes);
1238 sub _validate_result_roles_map {
1241 foreach my $classes (values %{ $self->result_roles_map }) {
1242 $self->_validate_classes('result_roles_map', $classes);
1246 sub _validate_classes {
1249 my $classes = shift;
1251 # make a copy to not destroy original
1252 my @classes = @$classes;
1254 foreach my $c (@classes) {
1255 # components default to being under the DBIx::Class namespace unless they
1256 # are preceeded with a '+'
1257 if ( $key =~ m/component/ && $c !~ s/^\+// ) {
1258 $c = 'DBIx::Class::' . $c;
1261 # 1 == installed, 0 == not installed, undef == invalid classname
1262 my $installed = Class::Inspector->installed($c);
1263 if ( defined($installed) ) {
1264 if ( $installed == 0 ) {
1265 croak qq/$c, as specified in the loader option "$key", is not installed/;
1268 croak qq/$c, as specified in the loader option "$key", is an invalid class name/;
1274 sub _find_file_in_inc {
1275 my ($self, $file) = @_;
1277 foreach my $prefix (@INC) {
1278 my $fullpath = File::Spec->catfile($prefix, $file);
1279 return $fullpath if -f $fullpath
1280 # abs_path throws on Windows for nonexistant files
1281 and (try { Cwd::abs_path($fullpath) }) ne
1282 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
1288 sub _find_class_in_inc {
1289 my ($self, $class) = @_;
1291 return $self->_find_file_in_inc(class_path($class));
1297 return $self->_upgrading_from
1298 || $self->_upgrading_from_load_classes
1299 || $self->_downgrading_to_load_classes
1300 || $self->_rewriting_result_namespace
1304 sub _rewrite_old_classnames {
1305 my ($self, $code) = @_;
1307 return $code unless $self->_rewriting;
1309 my %old_classes = reverse %{ $self->_upgrading_classes };
1311 my $re = join '|', keys %old_classes;
1312 $re = qr/\b($re)\b/;
1314 $code =~ s/$re/$old_classes{$1} || $1/eg;
1319 sub _load_external {
1320 my ($self, $class) = @_;
1322 return if $self->{skip_load_external};
1324 # so that we don't load our own classes, under any circumstances
1325 local *INC = [ grep $_ ne $self->dump_directory, @INC ];
1327 my $real_inc_path = $self->_find_class_in_inc($class);
1329 my $old_class = $self->_upgrading_classes->{$class}
1330 if $self->_rewriting;
1332 my $old_real_inc_path = $self->_find_class_in_inc($old_class)
1333 if $old_class && $old_class ne $class;
1335 return unless $real_inc_path || $old_real_inc_path;
1337 if ($real_inc_path) {
1338 # If we make it to here, we loaded an external definition
1339 warn qq/# Loaded external class definition for '$class'\n/
1342 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
1344 if ($self->dynamic) { # load the class too
1345 eval_package_without_redefine_warnings($class, $code);
1348 $self->_ext_stmt($class,
1349 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
1350 .qq|# They are now part of the custom portion of this file\n|
1351 .qq|# for you to hand-edit. If you do not either delete\n|
1352 .qq|# this section or remove that file from \@INC, this section\n|
1353 .qq|# will be repeated redundantly when you re-create this\n|
1354 .qq|# file again via Loader! See skip_load_external to disable\n|
1355 .qq|# this feature.\n|
1358 $self->_ext_stmt($class, $code);
1359 $self->_ext_stmt($class,
1360 qq|# End of lines loaded from '$real_inc_path' |
1364 if ($old_real_inc_path) {
1365 my $code = slurp_file $old_real_inc_path;
1367 $self->_ext_stmt($class, <<"EOF");
1369 # These lines were loaded from '$old_real_inc_path',
1370 # based on the Result class name that would have been created by an older
1371 # version of the Loader. For a static schema, this happens only once during
1372 # upgrade. See skip_load_external to disable this feature.
1375 $code = $self->_rewrite_old_classnames($code);
1377 if ($self->dynamic) {
1380 Detected external content in '$old_real_inc_path', a class name that would have
1381 been used by an older version of the Loader.
1383 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
1384 new name of the Result.
1386 eval_package_without_redefine_warnings($class, $code);
1390 $self->_ext_stmt($class, $code);
1391 $self->_ext_stmt($class,
1392 qq|# End of lines loaded from '$old_real_inc_path' |
1399 Does the actual schema-construction work.
1406 $self->_load_tables(
1407 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
1415 Rescan the database for changes. Returns a list of the newly added table
1418 The schema argument should be the schema class or object to be affected. It
1419 should probably be derived from the original schema_class used during L</load>.
1424 my ($self, $schema) = @_;
1426 $self->{schema} = $schema;
1427 $self->_relbuilder->{schema} = $schema;
1430 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
1432 foreach my $table (@current) {
1433 if(!exists $self->_tables->{$table->sql_name}) {
1434 push(@created, $table);
1439 @current{map $_->sql_name, @current} = ();
1440 foreach my $table (values %{ $self->_tables }) {
1441 if (not exists $current{$table->sql_name}) {
1442 $self->_remove_table($table);
1446 delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
1448 my $loaded = $self->_load_tables(@current);
1450 foreach my $table (@created) {
1451 $self->monikers->{$table->sql_name} = $self->_table2moniker($table);
1454 return map { $self->monikers->{$_->sql_name} } @created;
1460 return if $self->{skip_relationships};
1462 return $self->{relbuilder} ||= do {
1463 my $relbuilder_suff =
1470 ->{$self->naming->{relationships}||$CURRENT_V} || '';
1472 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
1473 $self->ensure_class_loaded($relbuilder_class);
1474 $relbuilder_class->new($self);
1479 my ($self, @tables) = @_;
1481 # Save the new tables to the tables list and compute monikers
1483 $self->_tables->{$_->sql_name} = $_;
1484 $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
1487 # check for moniker clashes
1488 my $inverse_moniker_idx;
1489 foreach my $table (values %{ $self->_tables }) {
1490 push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table;
1494 foreach my $moniker (keys %$inverse_moniker_idx) {
1495 my $tables = $inverse_moniker_idx->{$moniker};
1497 my $different_databases =
1498 $tables->[0]->can('database') && (uniq map $_->database||'', @$tables) > 1;
1500 my $different_schemas =
1501 (uniq map $_->schema||'', @$tables) > 1;
1503 if ($different_databases || $different_schemas) {
1504 my ($use_schema, $use_database) = (1, 0);
1506 if ($different_databases) {
1509 # If any monikers are in the same database, we have to distinguish by
1510 # both schema and database.
1512 $db_counts{$_}++ for map $_->database, @$tables;
1513 $use_schema = any { $_ > 1 } values %db_counts;
1516 delete $self->monikers->{$_->sql_name} for @$tables;
1518 my $moniker_parts = [ @{ $self->moniker_parts } ];
1520 my $have_schema = 1 if any { $_ eq 'schema' } @{ $self->moniker_parts };
1521 my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts };
1523 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema;
1524 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
1526 local $self->{moniker_parts} = $moniker_parts;
1530 $new_monikers{$_->sql_name} = $self->_table2moniker($_) for @$tables;
1532 $self->monikers->{$_} = $new_monikers{$_} for map $_->sql_name, @$tables;
1534 # check if there are still clashes
1537 while (my ($t, $m) = each %new_monikers) {
1538 push @{ $by_moniker{$m} }, $t;
1541 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
1542 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
1543 join (', ', @{ $by_moniker{$m} }),
1549 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
1550 join (', ', map $_->sql_name, @$tables),
1558 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
1559 . 'Change the naming style, or supply an explicit moniker_map: '
1560 . join ('; ', @clashes)
1565 $self->_make_src_class($_) for @tables;
1567 $self->_setup_src_meta($_) for @tables;
1569 if(!$self->skip_relationships) {
1570 # The relationship loader needs a working schema
1571 local $self->{quiet} = 1;
1572 local $self->{dump_directory} = $self->{temp_directory};
1573 $self->_reload_classes(\@tables);
1574 $self->_load_relationships(\@tables);
1576 # Remove that temp dir from INC so it doesn't get reloaded
1577 @INC = grep $_ ne $self->dump_directory, @INC;
1580 $self->_load_roles($_) for @tables;
1582 $self->_load_external($_)
1583 for map { $self->classes->{$_->sql_name} } @tables;
1585 # Reload without unloading first to preserve any symbols from external
1587 $self->_reload_classes(\@tables, { unload => 0 });
1589 # Drop temporary cache
1590 delete $self->{_cache};
1595 sub _reload_classes {
1596 my ($self, $tables, $opts) = @_;
1598 my @tables = @$tables;
1600 my $unload = $opts->{unload};
1601 $unload = 1 unless defined $unload;
1603 # so that we don't repeat custom sections
1604 @INC = grep $_ ne $self->dump_directory, @INC;
1606 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
1608 unshift @INC, $self->dump_directory;
1611 my %have_source = map { $_ => $self->schema->source($_) }
1612 $self->schema->sources;
1614 for my $table (@tables) {
1615 my $moniker = $self->monikers->{$table->sql_name};
1616 my $class = $self->classes->{$table->sql_name};
1619 no warnings 'redefine';
1620 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
1623 if (my $mc = $self->_moose_metaclass($class)) {
1626 Class::Unload->unload($class) if $unload;
1627 my ($source, $resultset_class);
1629 ($source = $have_source{$moniker})
1630 && ($resultset_class = $source->resultset_class)
1631 && ($resultset_class ne 'DBIx::Class::ResultSet')
1633 my $has_file = Class::Inspector->loaded_filename($resultset_class);
1634 if (my $mc = $self->_moose_metaclass($resultset_class)) {
1637 Class::Unload->unload($resultset_class) if $unload;
1638 $self->_reload_class($resultset_class) if $has_file;
1640 $self->_reload_class($class);
1642 push @to_register, [$moniker, $class];
1645 Class::C3->reinitialize;
1646 for (@to_register) {
1647 $self->schema->register_class(@$_);
1651 sub _moose_metaclass {
1652 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
1656 my $mc = try { Class::MOP::class_of($class) }
1659 return $mc->isa('Moose::Meta::Class') ? $mc : undef;
1662 # We use this instead of ensure_class_loaded when there are package symbols we
1665 my ($self, $class) = @_;
1667 delete $INC{ +class_path($class) };
1670 eval_package_without_redefine_warnings ($class, "require $class");
1673 my $source = slurp_file $self->_get_dump_filename($class);
1674 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
1678 sub _get_dump_filename {
1679 my ($self, $class) = (@_);
1681 $class =~ s{::}{/}g;
1682 return $self->dump_directory . q{/} . $class . q{.pm};
1685 =head2 get_dump_filename
1689 Returns the full path to the file for a class that the class has been or will
1690 be dumped to. This is a file in a temp dir for a dynamic schema.
1694 sub get_dump_filename {
1695 my ($self, $class) = (@_);
1697 local $self->{dump_directory} = $self->real_dump_directory;
1699 return $self->_get_dump_filename($class);
1702 sub _ensure_dump_subdirs {
1703 my ($self, $class) = (@_);
1705 my @name_parts = split(/::/, $class);
1706 pop @name_parts; # we don't care about the very last element,
1707 # which is a filename
1709 my $dir = $self->dump_directory;
1712 mkdir($dir) or croak "mkdir('$dir') failed: $!";
1714 last if !@name_parts;
1715 $dir = File::Spec->catdir($dir, shift @name_parts);
1720 my ($self, @classes) = @_;
1722 my $schema_class = $self->schema_class;
1723 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
1725 my $target_dir = $self->dump_directory;
1726 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
1727 unless $self->dynamic or $self->quiet;
1731 . qq|package $schema_class;\n\n|
1732 . qq|# Created by DBIx::Class::Schema::Loader\n|
1733 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1736 = $self->only_autoclean
1737 ? 'namespace::autoclean'
1738 : 'MooseX::MarkAsMethods autoclean => 1'
1741 if ($self->use_moose) {
1743 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|;
1746 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
1749 my @schema_components = @{ $self->schema_components || [] };
1751 if (@schema_components) {
1752 my $schema_components = dump @schema_components;
1753 $schema_components = "($schema_components)" if @schema_components == 1;
1755 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
1758 if ($self->use_namespaces) {
1759 $schema_text .= qq|__PACKAGE__->load_namespaces|;
1760 my $namespace_options;
1762 my @attr = qw/resultset_namespace default_resultset_class/;
1764 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
1766 for my $attr (@attr) {
1768 my $code = dumper_squashed $self->$attr;
1769 $namespace_options .= qq| $attr => $code,\n|
1772 $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
1773 $schema_text .= qq|;\n|;
1776 $schema_text .= qq|__PACKAGE__->load_classes;\n|;
1780 local $self->{version_to_dump} = $self->schema_version_to_dump;
1781 $self->_write_classfile($schema_class, $schema_text, 1);
1784 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
1786 foreach my $src_class (@classes) {
1789 . qq|package $src_class;\n\n|
1790 . qq|# Created by DBIx::Class::Schema::Loader\n|
1791 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
1793 $src_text .= $self->_make_pod_heading($src_class);
1795 $src_text .= qq|use strict;\nuse warnings;\n\n|;
1797 $src_text .= $self->_base_class_pod($result_base_class)
1798 unless $result_base_class eq 'DBIx::Class::Core';
1800 if ($self->use_moose) {
1801 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|;
1803 # these options 'use base' which is compile time
1804 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
1805 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|;
1808 $src_text .= qq|\nextends '$result_base_class';\n|;
1812 $src_text .= qq|use base '$result_base_class';\n|;
1815 $self->_write_classfile($src_class, $src_text);
1818 # remove Result dir if downgrading from use_namespaces, and there are no
1820 if (my $result_ns = $self->_downgrading_to_load_classes
1821 || $self->_rewriting_result_namespace) {
1822 my $result_namespace = $self->_result_namespace(
1827 (my $result_dir = $result_namespace) =~ s{::}{/}g;
1828 $result_dir = $self->dump_directory . '/' . $result_dir;
1830 unless (my @files = glob "$result_dir/*") {
1835 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
1839 my ($self, $version, $ts) = @_;
1840 return qq|\n\n# Created by DBIx::Class::Schema::Loader|
1843 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
1846 sub _write_classfile {
1847 my ($self, $class, $text, $is_schema) = @_;
1849 my $filename = $self->_get_dump_filename($class);
1850 $self->_ensure_dump_subdirs($class);
1852 if (-f $filename && $self->really_erase_my_files) {
1853 warn "Deleting existing file '$filename' due to "
1854 . "'really_erase_my_files' setting\n" unless $self->quiet;
1858 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
1859 = $self->_parse_generated_file($filename);
1861 if (! $old_gen && -f $filename) {
1862 croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
1863 . " it does not appear to have been generated by Loader"
1866 my $custom_content = $old_custom || '';
1868 # Use custom content from a renamed class, the class names in it are
1870 if (my $renamed_class = $self->_upgrading_classes->{$class}) {
1871 my $old_filename = $self->_get_dump_filename($renamed_class);
1873 if (-f $old_filename) {
1874 $custom_content = ($self->_parse_generated_file ($old_filename))[4];
1876 unlink $old_filename;
1880 $custom_content ||= $self->_default_custom_content($is_schema);
1882 # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
1883 # If there is already custom content, which does not have the Moose content, add it.
1884 if ($self->use_moose) {
1886 my $non_moose_custom_content = do {
1887 local $self->{use_moose} = 0;
1888 $self->_default_custom_content;
1891 if ($custom_content eq $non_moose_custom_content) {
1892 $custom_content = $self->_default_custom_content($is_schema);
1894 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) {
1895 $custom_content .= $self->_default_custom_content($is_schema);
1898 elsif (defined $self->use_moose && $old_gen) {
1899 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'
1900 if $old_gen =~ /use \s+ MooseX?\b/x;
1903 $custom_content = $self->_rewrite_old_classnames($custom_content);
1906 for @{$self->{_dump_storage}->{$class} || []};
1908 if ($self->filter_generated_code) {
1909 my $filter = $self->filter_generated_code;
1911 if (ref $filter eq 'CODE') {
1913 ($is_schema ? 'schema' : 'result'),
1919 my ($fh, $temp_file) = tempfile();
1921 binmode $fh, ':encoding(UTF-8)';
1925 open my $out, qq{$filter < "$temp_file"|}
1926 or croak "Could not open pipe to $filter: $!";
1928 $text = decode('UTF-8', do { local $/; <$out> });
1930 $text =~ s/$CR?$LF/\n/g;
1934 my $exit_code = $? >> 8;
1937 or croak "Could not remove temporary file '$temp_file': $!";
1939 if ($exit_code != 0) {
1940 croak "filter '$filter' exited non-zero: $exit_code";
1943 if (not $text or not $text =~ /\bpackage\b/) {
1944 warn("$class skipped due to filter") if $self->debug;
1949 # Check and see if the dump is in fact different
1953 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
1954 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) {
1955 return unless $self->_upgrading_from && $is_schema;
1959 $text .= $self->_sig_comment(
1960 $self->version_to_dump,
1961 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
1964 open(my $fh, '>:encoding(UTF-8)', $filename)
1965 or croak "Cannot open '$filename' for writing: $!";
1967 # Write the top half and its MD5 sum
1968 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n";
1970 # Write out anything loaded via external partial class file in @INC
1972 for @{$self->{_ext_storage}->{$class} || []};
1974 # Write out any custom content the user has added
1975 print $fh $custom_content;
1978 or croak "Error closing '$filename': $!";
1981 sub _default_moose_custom_content {
1982 my ($self, $is_schema) = @_;
1984 if (not $is_schema) {
1985 return qq|\n__PACKAGE__->meta->make_immutable;|;
1988 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
1991 sub _default_custom_content {
1992 my ($self, $is_schema) = @_;
1993 my $default = qq|\n\n# You can replace this text with custom|
1994 . qq| code or comments, and it will be preserved on regeneration|;
1995 if ($self->use_moose) {
1996 $default .= $self->_default_moose_custom_content($is_schema);
1998 $default .= qq|\n1;\n|;
2002 sub _parse_generated_file {
2003 my ($self, $fn) = @_;
2005 return unless -f $fn;
2007 open(my $fh, '<:encoding(UTF-8)', $fn)
2008 or croak "Cannot open '$fn' for reading: $!";
2011 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
2013 my ($md5, $ts, $ver, $gen);
2019 # Pull out the version and timestamp from the line above
2020 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
2023 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"
2024 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5;
2033 my $custom = do { local $/; <$fh> }
2037 $custom =~ s/$CRLF|$LF/\n/g;
2041 return ($gen, $md5, $ver, $ts, $custom);
2049 warn "$target: use $_;" if $self->debug;
2050 $self->_raw_stmt($target, "use $_;");
2058 my $blist = join(q{ }, @_);
2060 return unless $blist;
2062 warn "$target: use base qw/$blist/;" if $self->debug;
2063 $self->_raw_stmt($target, "use base qw/$blist/;");
2070 my $rlist = join(q{, }, map { qq{'$_'} } @_);
2072 return unless $rlist;
2074 warn "$target: with $rlist;" if $self->debug;
2075 $self->_raw_stmt($target, "\nwith $rlist;");
2078 sub _result_namespace {
2079 my ($self, $schema_class, $ns) = @_;
2080 my @result_namespace;
2082 $ns = $ns->[0] if ref $ns;
2084 if ($ns =~ /^\+(.*)/) {
2085 # Fully qualified namespace
2086 @result_namespace = ($1)
2089 # Relative namespace
2090 @result_namespace = ($schema_class, $ns);
2093 return wantarray ? @result_namespace : join '::', @result_namespace;
2096 # Create class with applicable bases, setup monikers, etc
2097 sub _make_src_class {
2098 my ($self, $table) = @_;
2100 my $schema = $self->schema;
2101 my $schema_class = $self->schema_class;
2103 my $table_moniker = $self->monikers->{$table->sql_name};
2104 my @result_namespace = ($schema_class);
2105 if ($self->use_namespaces) {
2106 my $result_namespace = $self->result_namespace || 'Result';
2107 @result_namespace = $self->_result_namespace(
2112 my $table_class = join(q{::}, @result_namespace, $table_moniker);
2114 if ((my $upgrading_v = $self->_upgrading_from)
2115 || $self->_rewriting) {
2116 local $self->naming->{monikers} = $upgrading_v
2119 my @result_namespace = @result_namespace;
2120 if ($self->_upgrading_from_load_classes) {
2121 @result_namespace = ($schema_class);
2123 elsif (my $ns = $self->_downgrading_to_load_classes) {
2124 @result_namespace = $self->_result_namespace(
2129 elsif ($ns = $self->_rewriting_result_namespace) {
2130 @result_namespace = $self->_result_namespace(
2136 my $old_table_moniker = do {
2137 local $self->naming->{monikers} = $upgrading_v;
2138 $self->_table2moniker($table);
2141 my $old_class = join(q{::}, @result_namespace, $old_table_moniker);
2143 $self->_upgrading_classes->{$table_class} = $old_class
2144 unless $table_class eq $old_class;
2147 $self->classes->{$table->sql_name} = $table_class;
2148 $self->moniker_to_table->{$table_moniker} = $table;
2149 $self->class_to_table->{$table_class} = $table;
2151 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes});
2153 $self->_use ($table_class, @{$self->additional_classes});
2155 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes});
2157 $self->_inject($table_class, @{$self->left_base_classes});
2159 my @components = @{ $self->components || [] };
2161 push @components, @{ $self->result_components_map->{$table_moniker} }
2162 if exists $self->result_components_map->{$table_moniker};
2164 my @fq_components = @components;
2165 foreach my $component (@fq_components) {
2166 if ($component !~ s/^\+//) {
2167 $component = "DBIx::Class::$component";
2171 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components);
2173 $self->_dbic_stmt($table_class, 'load_components', @components) if @components;
2175 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes});
2177 $self->_inject($table_class, @{$self->additional_base_classes});
2180 sub _is_result_class_method {
2181 my ($self, $name, $table) = @_;
2183 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
2185 $self->_result_class_methods({})
2186 if not defined $self->_result_class_methods;
2188 if (not exists $self->_result_class_methods->{$table_moniker}) {
2189 my (@methods, %methods);
2190 my $base = $self->result_base_class || 'DBIx::Class::Core';
2192 my @components = @{ $self->components || [] };
2194 push @components, @{ $self->result_components_map->{$table_moniker} }
2195 if exists $self->result_components_map->{$table_moniker};
2197 for my $c (@components) {
2198 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c";
2201 my @roles = @{ $self->result_roles || [] };
2203 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2204 if exists $self->result_roles_map->{$table_moniker};
2206 for my $class ($base, @components,
2207 ($self->use_moose ? 'Moose::Object' : ()), @roles) {
2208 $self->ensure_class_loaded($class);
2210 push @methods, @{ Class::Inspector->methods($class) || [] };
2213 push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
2215 @methods{@methods} = ();
2217 $self->_result_class_methods->{$table_moniker} = \%methods;
2219 my $result_methods = $self->_result_class_methods->{$table_moniker};
2221 return exists $result_methods->{$name};
2224 sub _resolve_col_accessor_collisions {
2225 my ($self, $table, $col_info) = @_;
2227 while (my ($col, $info) = each %$col_info) {
2228 my $accessor = $info->{accessor} || $col;
2230 next if $accessor eq 'id'; # special case (very common column)
2232 if ($self->_is_result_class_method($accessor, $table)) {
2235 if (my $map = $self->col_collision_map) {
2236 for my $re (keys %$map) {
2237 if (my @matches = $col =~ /$re/) {
2238 $info->{accessor} = sprintf $map->{$re}, @matches;
2246 Column '$col' in table '$table' collides with an inherited method.
2247 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
2249 $info->{accessor} = undef;
2255 # use the same logic to run moniker_map, col_accessor_map
2257 my ( $self, $map, $default_code, $ident, @extra ) = @_;
2259 my $default_ident = $default_code->( $ident, @extra );
2261 if( $map && ref $map eq 'HASH' ) {
2262 $new_ident = $map->{ $ident };
2264 elsif( $map && ref $map eq 'CODE' ) {
2265 $new_ident = $map->( $ident, $default_ident, @extra );
2268 $new_ident ||= $default_ident;
2273 sub _default_column_accessor_name {
2274 my ( $self, $column_name ) = @_;
2276 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
2278 my $v = $self->_get_naming_v('column_accessors');
2280 my $accessor_name = $preserve ?
2281 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase
2283 $self->_to_identifier('column_accessors', $column_name, '_');
2285 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier
2289 return $accessor_name;
2291 elsif ($v < 7 || (not $self->preserve_case)) {
2292 # older naming just lc'd the col accessor and that's all.
2293 return lc $accessor_name;
2296 return join '_', map lc, split_name $column_name, $v;
2299 sub _make_column_accessor_name {
2300 my ($self, $column_name, $column_context_info ) = @_;
2302 my $accessor = $self->_run_user_map(
2303 $self->col_accessor_map,
2304 sub { $self->_default_column_accessor_name( shift ) },
2306 $column_context_info,
2312 # Set up metadata (cols, pks, etc)
2313 sub _setup_src_meta {
2314 my ($self, $table) = @_;
2316 my $schema = $self->schema;
2317 my $schema_class = $self->schema_class;
2319 my $table_class = $self->classes->{$table->sql_name};
2320 my $table_moniker = $self->monikers->{$table->sql_name};
2322 $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
2324 my $cols = $self->_table_columns($table);
2325 my $col_info = $self->__columns_info_for($table);
2327 ### generate all the column accessor names
2328 while (my ($col, $info) = each %$col_info) {
2329 # hashref of other info that could be used by
2330 # user-defined accessor map functions
2332 table_class => $table_class,
2333 table_moniker => $table_moniker,
2334 table_name => $table,
2335 full_table_name => $table->dbic_name,
2336 schema_class => $schema_class,
2337 column_info => $info,
2340 $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
2343 $self->_resolve_col_accessor_collisions($table, $col_info);
2345 # prune any redundant accessor names
2346 while (my ($col, $info) = each %$col_info) {
2347 no warnings 'uninitialized';
2348 delete $info->{accessor} if $info->{accessor} eq $col;
2351 my $fks = $self->_table_fk_info($table);
2353 foreach my $fkdef (@$fks) {
2354 for my $col (@{ $fkdef->{local_columns} }) {
2355 $col_info->{$col}{is_foreign_key} = 1;
2359 my $pks = $self->_table_pk_info($table) || [];
2361 my %uniq_tag; # used to eliminate duplicate uniqs
2363 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
2365 my $uniqs = $self->_table_uniq_info($table) || [];
2368 foreach my $uniq (@$uniqs) {
2369 my ($name, $cols) = @$uniq;
2370 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
2371 push @uniqs, [$name, $cols];
2374 my @non_nullable_uniqs = grep {
2375 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
2378 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
2379 my @by_colnum = sort { $b->[0] <=> $a->[0] }
2380 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
2382 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
2383 my @keys = map $_->[1], @by_colnum;
2387 # remove the uniq from list
2388 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
2394 foreach my $pkcol (@$pks) {
2395 $col_info->{$pkcol}{is_nullable} = 0;
2401 map { $_, ($col_info->{$_}||{}) } @$cols
2404 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
2407 # Sort unique constraints by constraint name for repeatable results (rels
2408 # are sorted as well elsewhere.)
2409 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
2411 foreach my $uniq (@uniqs) {
2412 my ($name, $cols) = @$uniq;
2413 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
2417 sub __columns_info_for {
2418 my ($self, $table) = @_;
2420 my $result = $self->_columns_info_for($table);
2422 while (my ($col, $info) = each %$result) {
2423 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } };
2424 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } };
2426 $result->{$col} = $info;
2434 Returns a sorted list of loaded tables, using the original database table
2442 return values %{$self->_tables};
2446 my ($self, $naming_key) = @_;
2450 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
2454 ($v) = $CURRENT_V =~ /^v(\d+)\z/;
2460 sub _to_identifier {
2461 my ($self, $naming_key, $name, $sep_char, $force) = @_;
2463 my $v = $self->_get_naming_v($naming_key);
2465 my $to_identifier = $self->naming->{force_ascii} ?
2466 \&String::ToIdentifier::EN::to_identifier
2467 : \&String::ToIdentifier::EN::Unicode::to_identifier;
2469 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
2472 # Make a moniker from a table
2473 sub _default_table2moniker {
2474 my ($self, $table) = @_;
2476 my $v = $self->_get_naming_v('monikers');
2478 my @name_parts = map $table->$_, @{ $self->moniker_parts };
2480 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
2484 foreach my $i (0 .. $#name_parts) {
2485 my $part = $name_parts[$i];
2487 if ($i != $name_idx || $v >= 8) {
2488 $part = $self->_to_identifier('monikers', $part, '_', 1);
2491 if ($i == $name_idx && $v == 5) {
2492 $part = Lingua::EN::Inflect::Number::to_S($part);
2495 my @part_parts = map lc, $v > 6 ?
2496 # use v8 semantics for all moniker parts except name
2497 ($i == $name_idx ? split_name $part, $v : split_name $part)
2498 : split /[\W_]+/, $part;
2500 if ($i == $name_idx && $v >= 6) {
2501 my $as_phrase = join ' ', @part_parts;
2503 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ?
2504 Lingua::EN::Inflect::Phrase::to_PL($as_phrase)
2506 ($self->naming->{monikers}||'') eq 'preserve' ?
2509 Lingua::EN::Inflect::Phrase::to_S($as_phrase);
2511 @part_parts = split /\s+/, $inflected;
2514 push @all_parts, map ucfirst, @part_parts;
2517 return join '', @all_parts;
2520 sub _table2moniker {
2521 my ( $self, $table ) = @_;
2523 $self->_run_user_map(
2525 sub { $self->_default_table2moniker( shift ) },
2530 sub _load_relationships {
2531 my ($self, $tables) = @_;
2535 foreach my $table (@$tables) {
2536 my $local_moniker = $self->monikers->{$table->sql_name};
2538 my $tbl_fk_info = $self->_table_fk_info($table);
2540 foreach my $fkdef (@$tbl_fk_info) {
2541 $fkdef->{local_table} = $table;
2542 $fkdef->{local_moniker} = $local_moniker;
2543 $fkdef->{remote_source} =
2544 $self->monikers->{$fkdef->{remote_table}->sql_name};
2546 my $tbl_uniq_info = $self->_table_uniq_info($table);
2548 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
2551 my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
2553 foreach my $src_class (sort keys %$rel_stmts) {
2555 my @src_stmts = map $_->[1],
2556 sort { $a->[0] cmp $b->[0] }
2557 map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
2559 foreach my $stmt (@src_stmts) {
2560 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
2566 my ($self, $table) = @_;
2568 my $table_moniker = $self->monikers->{$table->sql_name};
2569 my $table_class = $self->classes->{$table->sql_name};
2571 my @roles = @{ $self->result_roles || [] };
2572 push @roles, @{ $self->result_roles_map->{$table_moniker} }
2573 if exists $self->result_roles_map->{$table_moniker};
2576 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
2578 $self->_with($table_class, @roles);
2582 # Overload these in driver class:
2584 # Returns an arrayref of column names
2585 sub _table_columns { croak "ABSTRACT METHOD" }
2587 # Returns arrayref of pk col names
2588 sub _table_pk_info { croak "ABSTRACT METHOD" }
2590 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
2591 sub _table_uniq_info { croak "ABSTRACT METHOD" }
2593 # Returns an arrayref of foreign key constraints, each
2594 # being a hashref with 3 keys:
2595 # local_columns (arrayref), remote_columns (arrayref), remote_table
2596 sub _table_fk_info { croak "ABSTRACT METHOD" }
2598 # Returns an array of lower case table names
2599 sub _tables_list { croak "ABSTRACT METHOD" }
2601 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
2607 # generate the pod for this statement, storing it with $self->_pod
2608 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod;
2610 my $args = dump(@_);
2611 $args = '(' . $args . ')' if @_ < 2;
2612 my $stmt = $method . $args . q{;};
2614 warn qq|$class\->$stmt\n| if $self->debug;
2615 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
2619 sub _make_pod_heading {
2620 my ($self, $class) = @_;
2622 return '' if not $self->generate_pod;
2624 my $table = $self->class_to_table->{$class};
2627 my $pcm = $self->pod_comment_mode;
2628 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
2629 $comment = $self->__table_comment($table);
2630 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length);
2631 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows));
2632 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows));
2634 $pod .= "=head1 NAME\n\n";
2636 my $table_descr = $class;
2637 $table_descr .= " - " . $comment if $comment and $comment_in_name;
2639 $pod .= "$table_descr\n\n";
2641 if ($comment and $comment_in_desc) {
2642 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n";
2649 # generates the accompanying pod for a DBIC class method statement,
2650 # storing it with $self->_pod
2656 if ($method eq 'table') {
2658 $table = $$table if ref $table eq 'SCALAR';
2659 $self->_pod($class, "=head1 TABLE: C<$table>");
2660 $self->_pod_cut($class);
2662 elsif ( $method eq 'add_columns' ) {
2663 $self->_pod( $class, "=head1 ACCESSORS" );
2664 my $col_counter = 0;
2666 while( my ($name,$attrs) = splice @cols,0,2 ) {
2668 $self->_pod( $class, '=head2 ' . $name );
2669 $self->_pod( $class,
2671 my $s = $attrs->{$_};
2672 $s = !defined $s ? 'undef' :
2673 length($s) == 0 ? '(empty string)' :
2674 ref($s) eq 'SCALAR' ? $$s :
2675 ref($s) ? dumper_squashed $s :
2676 looks_like_number($s) ? $s : qq{'$s'};
2679 } sort keys %$attrs,
2681 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) {
2682 $self->_pod( $class, $comment );
2685 $self->_pod_cut( $class );
2686 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
2687 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
2688 my ( $accessor, $rel_class ) = @_;
2689 $self->_pod( $class, "=head2 $accessor" );
2690 $self->_pod( $class, 'Type: ' . $method );
2691 $self->_pod( $class, "Related object: L<$rel_class>" );
2692 $self->_pod_cut( $class );
2693 $self->{_relations_started} { $class } = 1;
2695 elsif ($method eq 'add_unique_constraint') {
2696 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
2697 unless $self->{_uniqs_started}{$class};
2699 my ($name, $cols) = @_;
2701 $self->_pod($class, "=head2 C<$name>");
2702 $self->_pod($class, '=over 4');
2704 foreach my $col (@$cols) {
2705 $self->_pod($class, "=item \* L</$col>");
2708 $self->_pod($class, '=back');
2709 $self->_pod_cut($class);
2711 $self->{_uniqs_started}{$class} = 1;
2713 elsif ($method eq 'set_primary_key') {
2714 $self->_pod($class, "=head1 PRIMARY KEY");
2715 $self->_pod($class, '=over 4');
2717 foreach my $col (@_) {
2718 $self->_pod($class, "=item \* L</$col>");
2721 $self->_pod($class, '=back');
2722 $self->_pod_cut($class);
2726 sub _pod_class_list {
2727 my ($self, $class, $title, @classes) = @_;
2729 return unless @classes && $self->generate_pod;
2731 $self->_pod($class, "=head1 $title");
2732 $self->_pod($class, '=over 4');
2734 foreach my $link (@classes) {
2735 $self->_pod($class, "=item * L<$link>");
2738 $self->_pod($class, '=back');
2739 $self->_pod_cut($class);
2742 sub _base_class_pod {
2743 my ($self, $base_class) = @_;
2745 return '' unless $self->generate_pod;
2748 =head1 BASE CLASS: L<$base_class>
2755 sub _filter_comment {
2756 my ($self, $txt) = @_;
2758 $txt = '' if not defined $txt;
2760 $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
2765 sub __table_comment {
2768 if (my $code = $self->can('_table_comment')) {
2769 return $self->_filter_comment($self->$code(@_));
2775 sub __column_comment {
2778 if (my $code = $self->can('_column_comment')) {
2779 return $self->_filter_comment($self->$code(@_));
2785 # Stores a POD documentation
2787 my ($self, $class, $stmt) = @_;
2788 $self->_raw_stmt( $class, "\n" . $stmt );
2792 my ($self, $class ) = @_;
2793 $self->_raw_stmt( $class, "\n=cut\n" );
2796 # Store a raw source line for a class (for dumping purposes)
2798 my ($self, $class, $stmt) = @_;
2799 push(@{$self->{_dump_storage}->{$class}}, $stmt);
2802 # Like above, but separately for the externally loaded stuff
2804 my ($self, $class, $stmt) = @_;
2805 push(@{$self->{_ext_storage}->{$class}}, $stmt);
2808 sub _custom_column_info {
2809 my ( $self, $table_name, $column_name, $column_info ) = @_;
2811 if (my $code = $self->custom_column_info) {
2812 return $code->($table_name, $column_name, $column_info) || {};
2817 sub _datetime_column_info {
2818 my ( $self, $table_name, $column_name, $column_info ) = @_;
2820 my $type = $column_info->{data_type} || '';
2821 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/})
2822 or ($type =~ /date|timestamp/i)) {
2823 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone;
2824 $result->{locale} = $self->datetime_locale if $self->datetime_locale;
2830 my ($self, $name) = @_;
2832 return $self->preserve_case ? $name : lc($name);
2836 my ($self, $name) = @_;
2838 return $self->preserve_case ? $name : uc($name);
2842 my ($self, $table) = @_;
2845 my $schema = $self->schema;
2846 # in older DBIC it's a private method
2847 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
2848 $schema->$unregister(delete $self->monikers->{$table->sql_name});
2849 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}};
2850 delete $self->_tables->{$table->sql_name};
2854 # remove the dump dir from @INC on destruction
2858 @INC = grep $_ ne $self->dump_directory, @INC;
2863 Returns a hashref of loaded table to moniker mappings. There will
2864 be two entries for each table, the original name and the "normalized"
2865 name, in the case that the two are different (such as databases
2866 that like uppercase table names, or preserve your original mixed-case
2867 definitions, or what-have-you).
2871 Returns a hashref of table to class mappings. In some cases it will
2872 contain multiple entries per table for the original and normalized table
2873 names, as above in L</monikers>.
2875 =head1 NON-ENGLISH DATABASES
2877 If you use the loader on a database with table and column names in a language
2878 other than English, you will want to turn off the English language specific
2881 To do so, use something like this in your loader options:
2883 naming => { monikers => 'v4' },
2884 inflect_singular => sub { "$_[0]_rel" },
2885 inflect_plural => sub { "$_[0]_rel" },
2887 =head1 COLUMN ACCESSOR COLLISIONS
2889 Occasionally you may have a column name that collides with a perl method, such
2890 as C<can>. In such cases, the default action is to set the C<accessor> of the
2891 column spec to C<undef>.
2893 You can then name the accessor yourself by placing code such as the following
2896 __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
2898 Another option is to use the L</col_collision_map> option.
2900 =head1 RELATIONSHIP NAME COLLISIONS
2902 In very rare cases, you may get a collision between a generated relationship
2903 name and a method in your Result class, for example if you have a foreign key
2904 called C<belongs_to>.
2906 This is a problem because relationship names are also relationship accessor
2907 methods in L<DBIx::Class>.
2909 The default behavior is to append C<_rel> to the relationship name and print
2910 out a warning that refers to this text.
2912 You can also control the renaming with the L</rel_collision_map> option.
2916 L<DBIx::Class::Schema::Loader>, L<dbicdump>
2920 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
2924 This library is free software; you can redistribute it and/or modify it under
2925 the same terms as Perl itself.
2930 # vim:et sts=4 sw=4 tw=0: