1package DBIx::Class::Schema::Loader::Base; 2 3use strict; 4use warnings; 5use base qw/Class::Accessor::Grouped Class::C3::Componentised/; 6use MRO::Compat; 7use mro 'c3'; 8use Carp::Clan qw/^DBIx::Class/; 9use DBIx::Class::Schema::Loader::RelBuilder (); 10use Data::Dump 'dump'; 11use POSIX (); 12use File::Spec (); 13use Cwd (); 14use Digest::MD5 (); 15use Lingua::EN::Inflect::Number (); 16use Lingua::EN::Inflect::Phrase (); 17use String::ToIdentifier::EN (); 18use String::ToIdentifier::EN::Unicode (); 19use File::Temp (); 20use Class::Unload; 21use Class::Inspector (); 22use Scalar::Util 'looks_like_number'; 23use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/; 24use DBIx::Class::Schema::Loader::Optional::Dependencies (); 25use Try::Tiny; 26use DBIx::Class (); 27use Encode qw/encode decode/; 28use List::MoreUtils qw/all any firstidx uniq/; 29use File::Temp 'tempfile'; 30use namespace::clean; 31 32our $VERSION = '0.07033'; 33 34__PACKAGE__->mk_group_ro_accessors('simple', qw/ 35 schema 36 schema_class 37 38 exclude 39 constraint 40 additional_classes 41 additional_base_classes 42 left_base_classes 43 components 44 schema_components 45 skip_relationships 46 skip_load_external 47 moniker_map 48 col_accessor_map 49 custom_column_info 50 inflect_singular 51 inflect_plural 52 debug 53 dump_directory 54 dump_overwrite 55 really_erase_my_files 56 resultset_namespace 57 default_resultset_class 58 schema_base_class 59 result_base_class 60 result_roles 61 use_moose 62 only_autoclean 63 overwrite_modifications 64 65 relationship_attrs 66 67 _tables 68 classes 69 _upgrading_classes 70 monikers 71 dynamic 72 naming 73 datetime_timezone 74 datetime_locale 75 config_file 76 loader_class 77 table_comments_table 78 column_comments_table 79 class_to_table 80 moniker_to_table 81 uniq_to_primary 82 quiet 83/); 84 85 86__PACKAGE__->mk_group_accessors('simple', qw/ 87 version_to_dump 88 schema_version_to_dump 89 _upgrading_from 90 _upgrading_from_load_classes 91 _downgrading_to_load_classes 92 _rewriting_result_namespace 93 use_namespaces 94 result_namespace 95 generate_pod 96 pod_comment_mode 97 pod_comment_spillover_length 98 preserve_case 99 col_collision_map 100 rel_collision_map 101 rel_name_map 102 real_dump_directory 103 result_components_map 104 result_roles_map 105 datetime_undef_if_invalid 106 _result_class_methods 107 naming_set 108 filter_generated_code 109 db_schema 110 qualify_objects 111 moniker_parts 112/); 113 114my $CURRENT_V = 'v7'; 115 116my @CLASS_ARGS = qw( 117 schema_components schema_base_class result_base_class 118 additional_base_classes left_base_classes additional_classes components 119 result_roles 120); 121 122my $CR = "\x0d"; 123my $LF = "\x0a"; 124my $CRLF = "\x0d\x0a"; 125 126=head1 NAME 127 128DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation. 129 130=head1 SYNOPSIS 131 132See L<DBIx::Class::Schema::Loader>. 133 134=head1 DESCRIPTION 135 136This is the base class for the storage-specific C<DBIx::Class::Schema::*> 137classes, and implements the common functionality between them. 138 139=head1 CONSTRUCTOR OPTIONS 140 141These constructor options are the base options for 142L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are: 143 144=head2 skip_relationships 145 146Skip setting up relationships. The default is to attempt the loading 147of relationships. 148 149=head2 skip_load_external 150 151Skip loading of other classes in @INC. The default is to merge all other classes 152with the same name found in @INC into the schema file we are creating. 153 154=head2 naming 155 156Static schemas (ones dumped to disk) will, by default, use the new-style 157relationship names and singularized Results, unless you're overwriting an 158existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in 159which case the backward compatible RelBuilder will be activated, and the 160appropriate monikerization used. 161 162Specifying 163 164 naming => 'current' 165 166will disable the backward-compatible RelBuilder and use 167the new-style relationship names along with singularized Results, even when 168overwriting a dump made with an earlier version. 169 170The option also takes a hashref: 171 172 naming => { 173 relationships => 'v8', 174 monikers => 'v8', 175 column_accessors => 'v8', 176 force_ascii => 1, 177 } 178 179or 180 181 naming => { ALL => 'v8', force_ascii => 1 } 182 183The keys are: 184 185=over 4 186 187=item ALL 188 189Set L</relationships>, L</monikers> and L</column_accessors> to the specified 190value. 191 192=item relationships 193 194How to name relationship accessors. 195 196=item monikers 197 198How to name Result classes. 199 200=item column_accessors 201 202How to name column accessors in Result classes. 203 204=item force_ascii 205 206For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of 207L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to 208ASCII. 209 210=back 211 212The values can be: 213 214=over 4 215 216=item current 217 218Latest style, whatever that happens to be. 219 220=item v4 221 222Unsingularlized monikers, C<has_many> only relationships with no _id stripping. 223 224=item v5 225 226Monikers singularized as whole words, C<might_have> relationships for FKs on 227C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships. 228 229Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for 230the v5 RelBuilder. 231 232=item v6 233 234All monikers and relationships are inflected using 235L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping 236from relationship names. 237 238In general, there is very little difference between v5 and v6 schemas. 239 240=item v7 241 242This mode is identical to C<v6> mode, except that monikerization of CamelCase 243table names is also done better (but best in v8.) 244 245CamelCase column names in case-preserving mode will also be handled better 246for relationship name inflection (but best in v8.) See L</preserve_case>. 247 248In this mode, CamelCase L</column_accessors> are normalized based on case 249transition instead of just being lowercased, so C<FooId> becomes C<foo_id>. 250 251=item v8 252 253(EXPERIMENTAL) 254 255The default mode is L</v7>, to get L</v8> mode, you have to specify it in 256L</naming> explicitly until C<0.08> comes out. 257 258L</monikers> and L</column_accessors> are created using 259L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if 260L</force_ascii> is set; this is only significant for names with non-C<\w> 261characters such as C<.>. 262 263CamelCase identifiers with words in all caps, e.g. C<VLANValidID> are supported 264correctly in this mode. 265 266For relationships, belongs_to accessors are made from column names by stripping 267postfixes other than C<_id> as well, for example just C<Id>, C<_?ref>, C<_?cd>, 268C<_?code> and C<_?num>, case insensitively. 269 270=item preserve 271 272For L</monikers>, this option does not inflect the table names but makes 273monikers based on the actual name. For L</column_accessors> this option does 274not normalize CamelCase column names to lowercase column accessors, but makes 275accessors that are the same names as the columns (with any non-\w chars 276replaced with underscores.) 277 278=item singular 279 280For L</monikers>, singularizes the names using the most current inflector. This 281is the same as setting the option to L</current>. 282 283=item plural 284 285For L</monikers>, pluralizes the names, using the most current inflector. 286 287=back 288 289Dynamic schemas will always default to the 0.04XXX relationship names and won't 290singularize Results for backward compatibility, to activate the new RelBuilder 291and singularization put this in your C<Schema.pm> file: 292 293 __PACKAGE__->naming('current'); 294 295Or if you prefer to use 0.07XXX features but insure that nothing breaks in the 296next major version upgrade: 297 298 __PACKAGE__->naming('v7'); 299 300=head2 quiet 301 302If true, will not print the usual C<Dumping manual schema ... Schema dump 303completed.> messages. Does not affect warnings (except for warnings related to 304L</really_erase_my_files>.) 305 306=head2 generate_pod 307 308By default POD will be generated for columns and relationships, using database 309metadata for the text if available and supported. 310 311Comment metadata can be stored in two ways. 312 313The first is that you can create two tables named C<table_comments> and 314C<column_comments> respectively. These tables must exist in the same database 315and schema as the tables they describe. They both need to have columns named 316C<table_name> and C<comment_text>. The second one needs to have a column named 317C<column_name>. Then data stored in these tables will be used as a source of 318metadata about tables and comments. 319 320(If you wish you can change the name of these tables with the parameters 321L</table_comments_table> and L</column_comments_table>.) 322 323As a fallback you can use built-in commenting mechanisms. Currently this is 324only supported for PostgreSQL, Oracle and MySQL. To create comments in 325PostgreSQL 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 327C<COMMENT '...'> to the end of the column or table definition. Note that MySQL 328restricts the length of comments, and also does not handle complex Unicode 329characters properly. 330 331Set this to C<0> to turn off all POD generation. 332 333=head2 pod_comment_mode 334 335Controls where table comments appear in the generated POD. Smaller table 336comments are appended to the C<NAME> section of the documentation, and larger 337ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION> 338section to be generated with the comment always, only use C<NAME>, or choose 339the length threshold at which the comment is forced into the description. 340 341=over 4 342 343=item name 344 345Use C<NAME> section only. 346 347=item description 348 349Force C<DESCRIPTION> always. 350 351=item auto 352 353Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the 354default. 355 356=back 357 358=head2 pod_comment_spillover_length 359 360When pod_comment_mode is set to C<auto>, this is the length of the comment at 361which it will be forced into a separate description section. 362 363The default is C<60> 364 365=head2 table_comments_table 366 367The table to look for comments about tables in. By default C<table_comments>. 368See L</generate_pod> for details. 369 370This must not be a fully qualified name, the table will be looked for in the 371same database and schema as the table whose comment is being retrieved. 372 373=head2 column_comments_table 374 375The table to look for comments about columns in. By default C<column_comments>. 376See L</generate_pod> for details. 377 378This must not be a fully qualified name, the table will be looked for in the 379same database and schema as the table/column whose comment is being retrieved. 380 381=head2 relationship_attrs 382 383Hashref of attributes to pass to each generated relationship, listed by type. 384Also supports relationship type 'all', containing options to pass to all 385generated relationships. Attributes set for more specific relationship types 386override those set in 'all', and any attributes specified by this option 387override the introspected attributes of the foreign key if any. 388 389For example: 390 391 relationship_attrs => { 392 has_many => { cascade_delete => 1, cascade_copy => 1 }, 393 might_have => { cascade_delete => 1, cascade_copy => 1 }, 394 }, 395 396use this to turn L<DBIx::Class> cascades to on on your 397L<has_many|DBIx::Class::Relationship/has_many> and 398L<might_have|DBIx::Class::Relationship/might_have> relationships, they default 399to off. 400 401Can also be a coderef, for more precise control, in which case the coderef gets 402this hash of parameters (as a list:) 403 404 rel_name # the name of the relationship 405 local_source # the DBIx::Class::ResultSource object for the source the rel is *from* 406 remote_source # the DBIx::Class::ResultSource object for the source the rel is *to* 407 local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from 408 local_cols # an arrayref of column names of columns used in the rel in the source it is from 409 remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to 410 remote_cols # an arrayref of column names of columns used in the rel in the source it is to 411 attrs # the attributes that would be set 412 413it should return the new hashref of attributes, or nothing for no changes. 414 415For example: 416 417 relationship_attrs => sub { 418 my %p = @_; 419 420 say "the relationship name is: $p{rel_name}"; 421 say "the local class is: ", $p{local_source}->result_class; 422 say "the remote class is: ", $p{remote_source}->result_class; 423 say "the local table is: ", $p{local_table}->sql_name; 424 say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}}); 425 say "the remote table is: ", $p{remote_table}->sql_name; 426 say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}}); 427 428 if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') { 429 $p{attrs}{could_be_snoopy} = 1; 430 431 reutrn $p{attrs}; 432 } 433 }, 434 435These are the default attributes: 436 437 has_many => { 438 cascade_delete => 0, 439 cascade_copy => 0, 440 }, 441 might_have => { 442 cascade_delete => 0, 443 cascade_copy => 0, 444 }, 445 belongs_to => { 446 on_delete => 'CASCADE', 447 on_update => 'CASCADE', 448 is_deferrable => 1, 449 }, 450 451For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these 452defaults are overridden by the attributes introspected from the foreign key in 453the database, if this information is available (and the driver is capable of 454retrieving it.) 455 456This information overrides the defaults mentioned above, and is then itself 457overridden by the user's L</relationship_attrs> for C<belongs_to> if any are 458specified. 459 460In general, for most databases, for a plain foreign key with no rules, the 461values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship 462will be: 463 464 on_delete => 'NO ACTION', 465 on_update => 'NO ACTION', 466 is_deferrable => 0, 467 468In the cases where an attribute is not supported by the DB, a value matching 469the actual behavior is used, for example Oracle does not support C<ON UPDATE> 470rules, so C<on_update> is set to C<NO ACTION>. This is done so that the 471behavior of the schema is preserved when cross deploying to a different RDBMS 472such as SQLite for testing. 473 474In the cases where the DB does not support C<DEFERRABLE> foreign keys, the 475value is set to C<1> if L<DBIx::Class> has a working C<< 476$storage->with_deferred_fk_checks >>. This is done so that the same 477L<DBIx::Class> code can be used, and cross deployed from and to such databases. 478 479=head2 debug 480 481If set to true, each constructive L<DBIx::Class> statement the loader 482decides to execute will be C<warn>-ed before execution. 483 484=head2 db_schema 485 486Set the name of the schema to load (schema in the sense that your database 487vendor means it). 488 489Can be set to an arrayref of schema names for multiple schemas, or the special 490value C<%> for all schemas. 491 492For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as 493keys and arrays of owners as values, set to the value: 494 495 { '%' => '%' } 496 497for all owners in all databases. 498 499Name clashes resulting from the same table name in different databases/schemas 500will be resolved automatically by prefixing the moniker with the database 501and/or schema. 502 503To prefix/suffix all monikers with the database and/or schema, see 504L</moniker_parts>. 505 506=head2 moniker_parts 507 508The database table names are represented by the 509L<DBIx::Class::Schema::Loader::Table> class in the loader, the 510L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and 511L<DBIx::Class::Schema::Loader::Table::Informix> for Informix. 512 513Monikers are created normally based on just the 514L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to 515the table name, but can consist of other parts of the fully qualified name of 516the table. 517 518The L</moniker_parts> option is an arrayref of methods on the table class 519corresponding to parts of the fully qualified table name, defaulting to 520C<['name']>, in the order those parts are used to create the moniker name. 521 522The C<'name'> entry B<must> be present. 523 524Below is a table of supported databases and possible L</moniker_parts>. 525 526=over 4 527 528=item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access 529 530C<schema>, C<name> 531 532=item * Informix, MSSQL, Sybase ASE 533 534C<database>, C<schema>, C<name> 535 536=back 537 538=head2 constraint 539 540Only load tables matching regex. Best specified as a qr// regex. 541 542=head2 exclude 543 544Exclude tables matching regex. Best specified as a qr// regex. 545 546=head2 moniker_map 547 548Overrides the default table name to moniker translation. Can be either a 549hashref of table keys and moniker values, or a coderef for a translator 550function taking a L<table object|DBIx::Class::Schema::Loader::Table> argument 551(which stringifies to the unqualified table name) and returning a scalar 552moniker. If the hash entry does not exist, or the function returns a false 553value, the code falls back to default behavior for that table name. 554 555The default behavior is to split on case transition and non-alphanumeric 556boundaries, singularize the resulting phrase, then join the titlecased words 557together. Examples: 558 559 Table Name | Moniker Name 560 --------------------------------- 561 luser | Luser 562 luser_group | LuserGroup 563 luser-opts | LuserOpt 564 stations_visited | StationVisited 565 routeChange | RouteChange 566 567=head2 col_accessor_map 568 569Same as moniker_map, but for column accessor names. If a coderef is 570passed, the code is called with arguments of 571 572 the name of the column in the underlying database, 573 default accessor name that DBICSL would ordinarily give this column, 574 { 575 table_class => name of the DBIC class we are building, 576 table_moniker => calculated moniker for this table (after moniker_map if present), 577 table => table object of interface DBIx::Class::Schema::Loader::Table, 578 full_table_name => schema-qualified name of the database table (RDBMS specific), 579 schema_class => name of the schema class we are building, 580 column_info => hashref of column info (data_type, is_nullable, etc), 581 } 582 583the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the 584unqualified table name. 585 586=head2 rel_name_map 587 588Similar in idea to moniker_map, but different in the details. It can be 589a hashref or a code ref. 590 591If it is a hashref, keys can be either the default relationship name, or the 592moniker. The keys that are the default relationship name should map to the 593name you want to change the relationship to. Keys that are monikers should map 594to hashes mapping relationship names to their translation. You can do both at 595once, and the more specific moniker version will be picked up first. So, for 596instance, you could have 597 598 { 599 bar => "baz", 600 Foo => { 601 bar => "blat", 602 }, 603 } 604 605and relationships that would have been named C<bar> will now be named C<baz> 606except that in the table whose moniker is C<Foo> it will be named C<blat>. 607 608If it is a coderef, the argument passed will be a hashref of this form: 609 610 { 611 name => default relationship name, 612 type => the relationship type eg: C<has_many>, 613 local_class => name of the DBIC class we are building, 614 local_moniker => moniker of the DBIC class we are building, 615 local_columns => columns in this table in the relationship, 616 remote_class => name of the DBIC class we are related to, 617 remote_moniker => moniker of the DBIC class we are related to, 618 remote_columns => columns in the other table in the relationship, 619 } 620 621DBICSL will try to use the value returned as the relationship name. 622 623=head2 inflect_plural 624 625Just like L</moniker_map> above (can be hash/code-ref, falls back to default 626if hash key does not exist or coderef returns false), but acts as a map 627for pluralizing relationship names. The default behavior is to utilize 628L<Lingua::EN::Inflect::Phrase/to_PL>. 629 630=head2 inflect_singular 631 632As L</inflect_plural> above, but for singularizing relationship names. 633Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>. 634 635=head2 schema_base_class 636 637Base class for your schema classes. Defaults to 'DBIx::Class::Schema'. 638 639=head2 schema_components 640 641List of components to load into the Schema class. 642 643=head2 result_base_class 644 645Base class for your table classes (aka result classes). Defaults to 646'DBIx::Class::Core'. 647 648=head2 additional_base_classes 649 650List of additional base classes all of your table classes will use. 651 652=head2 left_base_classes 653 654List of additional base classes all of your table classes will use 655that need to be leftmost. 656 657=head2 additional_classes 658 659List of additional classes which all of your table classes will use. 660 661=head2 components 662 663List of additional components to be loaded into all of your Result 664classes. A good example would be 665L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime> 666 667=head2 result_components_map 668 669A hashref of moniker keys and component values. Unlike L</components>, which 670loads the given components into every Result class, this option allows you to 671load certain components for specified Result classes. For example: 672 673 result_components_map => { 674 StationVisited => '+YourApp::Schema::Component::StationVisited', 675 RouteChange => [ 676 '+YourApp::Schema::Component::RouteChange', 677 'InflateColumn::DateTime', 678 ], 679 } 680 681You may use this in conjunction with L</components>. 682 683=head2 result_roles 684 685List of L<Moose> roles to be applied to all of your Result classes. 686 687=head2 result_roles_map 688 689A hashref of moniker keys and role values. Unlike L</result_roles>, which 690applies the given roles to every Result class, this option allows you to apply 691certain roles for specified Result classes. For example: 692 693 result_roles_map => { 694 StationVisited => [ 695 'YourApp::Role::Building', 696 'YourApp::Role::Destination', 697 ], 698 RouteChange => 'YourApp::Role::TripEvent', 699 } 700 701You may use this in conjunction with L</result_roles>. 702 703=head2 use_namespaces 704 705This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass 706a C<0>. 707 708Generate result class names suitable for 709L<DBIx::Class::Schema/load_namespaces> and call that instead of 710L<DBIx::Class::Schema/load_classes>. When using this option you can also 711specify any of the options for C<load_namespaces> (i.e. C<result_namespace>, 712C<resultset_namespace>, C<default_resultset_class>), and they will be added 713to the call (and the generated result class names adjusted appropriately). 714 715=head2 dump_directory 716 717The value of this option is a perl libdir pathname. Within 718that directory this module will create a baseline manual 719L<DBIx::Class::Schema> module set, based on what it creates at runtime. 720 721The created schema class will have the same classname as the one on 722which you are setting this option (and the ResultSource classes will be 723based on this name as well). 724 725Normally you wouldn't hard-code this setting in your schema class, as it 726is meant for one-time manual usage. 727 728See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the 729recommended way to access this functionality. 730 731=head2 dump_overwrite 732 733Deprecated. See L</really_erase_my_files> below, which does *not* mean 734the same thing as the old C<dump_overwrite> setting from previous releases. 735 736=head2 really_erase_my_files 737 738Default false. If true, Loader will unconditionally delete any existing 739files before creating the new ones from scratch when dumping a schema to disk. 740 741The default behavior is instead to only replace the top portion of the 742file, up to and including the final stanza which contains 743C<# DO NOT MODIFY THE FIRST PART OF THIS FILE> 744leaving any customizations you placed after that as they were. 745 746When C<really_erase_my_files> is not set, if the output file already exists, 747but the aforementioned final stanza is not found, or the checksum 748contained there does not match the generated contents, Loader will 749croak and not touch the file. 750 751You should really be using version control on your schema classes (and all 752of the rest of your code for that matter). Don't blame me if a bug in this 753code wipes something out when it shouldn't have, you've been warned. 754 755=head2 overwrite_modifications 756 757Default false. If false, when updating existing files, Loader will 758refuse to modify any Loader-generated code that has been modified 759since its last run (as determined by the checksum Loader put in its 760comment lines). 761 762If true, Loader will discard any manual modifications that have been 763made to Loader-generated code. 764 765Again, you should be using version control on your schema classes. Be 766careful with this option. 767 768=head2 custom_column_info 769 770Hook for adding extra attributes to the 771L<column_info|DBIx::Class::ResultSource/column_info> for a column. 772 773Must be a coderef that returns a hashref with the extra attributes. 774 775Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which 776stringifies to the unqualified table name), column name and column_info. 777 778For example: 779 780 custom_column_info => sub { 781 my ($table, $column_name, $column_info) = @_; 782 783 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') { 784 return { is_snoopy => 1 }; 785 } 786 }, 787 788This attribute can also be used to set C<inflate_datetime> on a non-datetime 789column so it also receives the L</datetime_timezone> and/or L</datetime_locale>. 790 791=head2 datetime_timezone 792 793Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all 794columns with the DATE/DATETIME/TIMESTAMP data_types. 795 796=head2 datetime_locale 797 798Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all 799columns with the DATE/DATETIME/TIMESTAMP data_types. 800 801=head2 datetime_undef_if_invalid 802 803Pass a C<0> for this option when using MySQL if you B<DON'T> want C<< 804datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and 805TIMESTAMP columns. 806 807The default is recommended to deal with data such as C<00/00/00> which 808sometimes ends up in such columns in MySQL. 809 810=head2 config_file 811 812File in Perl format, which should return a HASH reference, from which to read 813loader options. 814 815=head2 preserve_case 816 817Normally database names are lowercased and split by underscore, use this option 818if you have CamelCase database names. 819 820Drivers for case sensitive databases like Sybase ASE or MSSQL with a 821case-sensitive collation will turn this option on unconditionally. 822 823B<NOTE:> L</naming> = C<v8> is highly recommended with this option as the 824semantics of this mode are much improved for CamelCase database names. 825 826L</naming> = C<v7> or greater is required with this option. 827 828=head2 qualify_objects 829 830Set to true to prepend the L</db_schema> to table names for C<< 831__PACKAGE__->table >> calls, and to some other things like Oracle sequences. 832 833This attribute is automatically set to true for multi db_schema configurations, 834unless explicitly set to false by the user. 835 836=head2 use_moose 837 838Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and 839L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, see below). The default 840content after the md5 sum also makes the classes immutable. 841 842It is safe to upgrade your existing Schema to this option. 843 844=head2 only_autoclean 845 846By default, we use L<MooseX::MarkAsMethods> to remove imported functions from 847your generated classes. It uses L<namespace::autoclean> to do this, after 848telling your object's metaclass that any operator L<overload>s in your class 849are methods, which will cause namespace::autoclean to spare them from removal. 850 851This prevents the "Hey, where'd my overloads go?!" effect. 852 853If you don't care about operator overloads, enabling this option falls back to 854just using L<namespace::autoclean> itself. 855 856If none of the above made any sense, or you don't have some pressing need to 857only use L<namespace::autoclean>, leaving this set to the default is 858recommended. 859 860=head2 col_collision_map 861 862This option controls how accessors for column names which collide with perl 863methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information. 864 865This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of 866strings which are compiled to regular expressions that map to 867L<sprintf|perlfunc/sprintf> formats. 868 869Examples: 870 871 col_collision_map => 'column_%s' 872 873 col_collision_map => { '(.*)' => 'column_%s' } 874 875 col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' } 876 877=head2 rel_collision_map 878 879Works just like L</col_collision_map>, but for relationship names/accessors 880rather than column names/accessors. 881 882The default is to just append C<_rel> to the relationship name, see 883L</RELATIONSHIP NAME COLLISIONS>. 884 885=head2 uniq_to_primary 886 887Automatically promotes the largest unique constraints with non-nullable columns 888on tables to primary keys, assuming there is only one largest unique 889constraint. 890 891=head2 filter_generated_code 892 893An optional hook that lets you filter the generated text for various classes 894through a function that change it in any way that you want. The function will 895receive the type of file, C<schema> or C<result>, class and code; and returns 896the new code to use instead. For instance you could add custom comments, or do 897anything else that you want. 898 899The option can also be set to a string, which is then used as a filter program, 900e.g. C<perltidy>. 901 902If this exists but fails to return text matching C</\bpackage\b/>, no file will 903be generated. 904 905 filter_generated_code => sub { 906 my ($type, $class, $text) = @_; 907 ... 908 return $new_code; 909 } 910 911=head1 METHODS 912 913None of these methods are intended for direct invocation by regular 914users of L<DBIx::Class::Schema::Loader>. Some are proxied via 915L<DBIx::Class::Schema::Loader>. 916 917=cut 918 919# ensure that a peice of object data is a valid arrayref, creating 920# an empty one or encapsulating whatever's there. 921sub _ensure_arrayref { 922 my $self = shift; 923 924 foreach (@_) { 925 $self->{$_} ||= []; 926 $self->{$_} = [ $self->{$_} ] 927 unless ref $self->{$_} eq 'ARRAY'; 928 } 929} 930 931=head2 new 932 933Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally 934by L<DBIx::Class::Schema::Loader>. 935 936=cut 937 938sub new { 939 my ( $class, %args ) = @_; 940 941 if (exists $args{column_accessor_map}) { 942 $args{col_accessor_map} = delete $args{column_accessor_map}; 943 } 944 945 my $self = { %args }; 946 947 # don't lose undef options 948 for (values %$self) { 949 $_ = 0 unless defined $_; 950 } 951 952 bless $self => $class; 953 954 if (my $config_file = $self->config_file) { 955 my $config_opts = do $config_file; 956 957 croak "Error reading config from $config_file: $@" if $@; 958 959 croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH'; 960 961 while (my ($k, $v) = each %$config_opts) { 962 $self->{$k} = $v unless exists $self->{$k}; 963 } 964 } 965 966 if (defined $self->{result_component_map}) { 967 if (defined $self->result_components_map) { 968 croak "Specify only one of result_components_map or result_component_map"; 969 } 970 $self->result_components_map($self->{result_component_map}) 971 } 972 973 if (defined $self->{result_role_map}) { 974 if (defined $self->result_roles_map) { 975 croak "Specify only one of result_roles_map or result_role_map"; 976 } 977 $self->result_roles_map($self->{result_role_map}) 978 } 979 980 croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1" 981 if ((not defined $self->use_moose) || (not $self->use_moose)) 982 && ((defined $self->result_roles) || (defined $self->result_roles_map)); 983 984 $self->_ensure_arrayref(qw/schema_components 985 additional_classes 986 additional_base_classes 987 left_base_classes 988 components 989 result_roles 990 /); 991 992 $self->_validate_class_args; 993 994 croak "result_components_map must be a hash" 995 if defined $self->result_components_map 996 && ref $self->result_components_map ne 'HASH'; 997 998 if ($self->result_components_map) { 999 my %rc_map = %{ $self->result_components_map }; 1000 foreach my $moniker (keys %rc_map) { 1001 $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker}; 1002 } 1003 $self->result_components_map(\%rc_map); 1004 } 1005 else { 1006 $self->result_components_map({}); 1007 } 1008 $self->_validate_result_components_map; 1009 1010 croak "result_roles_map must be a hash" 1011 if defined $self->result_roles_map 1012 && ref $self->result_roles_map ne 'HASH'; 1013 1014 if ($self->result_roles_map) { 1015 my %rr_map = %{ $self->result_roles_map }; 1016 foreach my $moniker (keys %rr_map) { 1017 $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker}; 1018 } 1019 $self->result_roles_map(\%rr_map); 1020 } else { 1021 $self->result_roles_map({}); 1022 } 1023 $self->_validate_result_roles_map; 1024 1025 if ($self->use_moose) { 1026 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) { 1027 die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n", 1028 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose'); 1029 } 1030 } 1031 1032 $self->{_tables} = {}; 1033 $self->{monikers} = {}; 1034 $self->{moniker_to_table} = {}; 1035 $self->{class_to_table} = {}; 1036 $self->{classes} = {}; 1037 $self->{_upgrading_classes} = {}; 1038 1039 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); 1040 $self->{schema} ||= $self->{schema_class}; 1041 $self->{table_comments_table} ||= 'table_comments'; 1042 $self->{column_comments_table} ||= 'column_comments'; 1043 1044 croak "dump_overwrite is deprecated. Please read the" 1045 . " DBIx::Class::Schema::Loader::Base documentation" 1046 if $self->{dump_overwrite}; 1047 1048 $self->{dynamic} = ! $self->{dump_directory}; 1049 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX', 1050 TMPDIR => 1, 1051 CLEANUP => 1, 1052 ); 1053 1054 $self->{dump_directory} ||= $self->{temp_directory}; 1055 1056 $self->real_dump_directory($self->{dump_directory}); 1057 1058 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION); 1059 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION); 1060 1061 if (not defined $self->naming) { 1062 $self->naming_set(0); 1063 } 1064 else { 1065 $self->naming_set(1); 1066 } 1067 1068 if ((not ref $self->naming) && defined $self->naming) { 1069 my $naming_ver = $self->naming; 1070 $self->{naming} = { 1071 relationships => $naming_ver, 1072 monikers => $naming_ver, 1073 column_accessors => $naming_ver, 1074 }; 1075 } 1076 elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) { 1077 my $val = delete $self->naming->{ALL}; 1078 1079 $self->naming->{$_} = $val 1080 foreach qw/relationships monikers column_accessors/; 1081 } 1082 1083 if ($self->naming) { 1084 foreach my $key (qw/relationships monikers column_accessors/) { 1085 $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current'; 1086 } 1087 } 1088 $self->{naming} ||= {}; 1089 1090 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') { 1091 croak 'custom_column_info must be a CODE ref'; 1092 } 1093 1094 $self->_check_back_compat; 1095 1096 $self->use_namespaces(1) unless defined $self->use_namespaces; 1097 $self->generate_pod(1) unless defined $self->generate_pod; 1098 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode; 1099 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length; 1100 1101 if (my $col_collision_map = $self->col_collision_map) { 1102 if (my $reftype = ref $col_collision_map) { 1103 if ($reftype ne 'HASH') { 1104 croak "Invalid type $reftype for option 'col_collision_map'"; 1105 } 1106 } 1107 else { 1108 $self->col_collision_map({ '(.*)' => $col_collision_map }); 1109 } 1110 } 1111 1112 if (my $rel_collision_map = $self->rel_collision_map) { 1113 if (my $reftype = ref $rel_collision_map) { 1114 if ($reftype ne 'HASH') { 1115 croak "Invalid type $reftype for option 'rel_collision_map'"; 1116 } 1117 } 1118 else { 1119 $self->rel_collision_map({ '(.*)' => $rel_collision_map }); 1120 } 1121 } 1122 1123 if (defined(my $rel_name_map = $self->rel_name_map)) { 1124 my $reftype = ref $rel_name_map; 1125 if ($reftype ne 'HASH' && $reftype ne 'CODE') { 1126 croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE"; 1127 } 1128 } 1129 1130 if (defined(my $filter = $self->filter_generated_code)) { 1131 my $reftype = ref $filter; 1132 if ($reftype && $reftype ne 'CODE') { 1133 croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference"; 1134 } 1135 } 1136 1137 if (defined $self->db_schema) { 1138 if (ref $self->db_schema eq 'ARRAY') { 1139 if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) { 1140 $self->{qualify_objects} = 1; 1141 } 1142 elsif (@{ $self->db_schema } == 0) { 1143 $self->{db_schema} = undef; 1144 } 1145 } 1146 elsif (not ref $self->db_schema) { 1147 if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) { 1148 $self->{qualify_objects} = 1; 1149 } 1150 1151 $self->{db_schema} = [ $self->db_schema ]; 1152 } 1153 } 1154 1155 if (not $self->moniker_parts) { 1156 $self->moniker_parts(['name']); 1157 } 1158 else { 1159 if (not ref $self->moniker_parts) { 1160 $self->moniker_parts([ $self->moniker_parts ]); 1161 } 1162 if (ref $self->moniker_parts ne 'ARRAY') { 1163 croak 'moniker_parts must be an arrayref'; 1164 } 1165 if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) { 1166 croak "moniker_parts option *must* contain 'name'"; 1167 } 1168 } 1169 1170 return $self; 1171} 1172 1173sub _check_back_compat { 1174 my ($self) = @_; 1175 1176# dynamic schemas will always be in 0.04006 mode, unless overridden 1177 if ($self->dynamic) { 1178# just in case, though no one is likely to dump a dynamic schema 1179 $self->schema_version_to_dump('0.04006'); 1180 1181 if (not $self->naming_set) { 1182 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; 1183 1184Dynamic schema detected, will run in 0.04006 mode. 1185 1186Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable 1187to disable this warning. 1188 1189See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more 1190details. 1191EOF 1192 } 1193 else { 1194 $self->_upgrading_from('v4'); 1195 } 1196 1197 if ((not defined $self->use_namespaces) && ($self->naming_set)) { 1198 $self->use_namespaces(1); 1199 } 1200 1201 $self->naming->{relationships} ||= 'v4'; 1202 $self->naming->{monikers} ||= 'v4'; 1203 1204 if ($self->use_namespaces) { 1205 $self->_upgrading_from_load_classes(1); 1206 } 1207 else { 1208 $self->use_namespaces(0); 1209 } 1210 1211 return; 1212 } 1213 1214# otherwise check if we need backcompat mode for a static schema 1215 my $filename = $self->get_dump_filename($self->schema_class); 1216 return unless -e $filename; 1217 1218 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) = 1219 $self->_parse_generated_file($filename); 1220 1221 return unless $old_ver; 1222 1223 # determine if the existing schema was dumped with use_moose => 1 1224 if (! defined $self->use_moose) { 1225 $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm; 1226 } 1227 1228 my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0; 1229 1230 my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' }; 1231 my $ds = eval $result_namespace; 1232 die <<"EOF" if $@; 1233Could not eval expression '$result_namespace' for result_namespace from 1234$filename: $@ 1235EOF 1236 $result_namespace = $ds || ''; 1237 1238 if ($load_classes && (not defined $self->use_namespaces)) { 1239 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; 1240 1241'load_classes;' static schema detected, turning off 'use_namespaces'. 1242 1243Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment 1244variable to disable this warning. 1245 1246See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more 1247details. 1248EOF 1249 $self->use_namespaces(0); 1250 } 1251 elsif ($load_classes && $self->use_namespaces) { 1252 $self->_upgrading_from_load_classes(1); 1253 } 1254 elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) { 1255 $self->_downgrading_to_load_classes( 1256 $result_namespace || 'Result' 1257 ); 1258 } 1259 elsif ((not defined $self->use_namespaces) || $self->use_namespaces) { 1260 if (not $self->result_namespace) { 1261 $self->result_namespace($result_namespace || 'Result'); 1262 } 1263 elsif ($result_namespace ne $self->result_namespace) { 1264 $self->_rewriting_result_namespace( 1265 $result_namespace || 'Result' 1266 ); 1267 } 1268 } 1269 1270 # XXX when we go past .0 this will need fixing 1271 my ($v) = $old_ver =~ /([1-9])/; 1272 $v = "v$v"; 1273 1274 return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/); 1275 1276 if (not %{ $self->naming }) { 1277 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; 1278 1279Version $old_ver static schema detected, turning on backcompat mode. 1280 1281Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable 1282to disable this warning. 1283 1284See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base . 1285 1286See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading 1287from version 0.04006. 1288EOF 1289 1290 $self->naming->{relationships} ||= $v; 1291 $self->naming->{monikers} ||= $v; 1292 $self->naming->{column_accessors} ||= $v; 1293 1294 $self->schema_version_to_dump($old_ver); 1295 } 1296 else { 1297 $self->_upgrading_from($v); 1298 } 1299} 1300 1301sub _validate_class_args { 1302 my $self = shift; 1303 1304 foreach my $k (@CLASS_ARGS) { 1305 next unless $self->$k; 1306 1307 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k; 1308 $self->_validate_classes($k, \@classes); 1309 } 1310} 1311 1312sub _validate_result_components_map { 1313 my $self = shift; 1314 1315 foreach my $classes (values %{ $self->result_components_map }) { 1316 $self->_validate_classes('result_components_map', $classes); 1317 } 1318} 1319 1320sub _validate_result_roles_map { 1321 my $self = shift; 1322 1323 foreach my $classes (values %{ $self->result_roles_map }) { 1324 $self->_validate_classes('result_roles_map', $classes); 1325 } 1326} 1327 1328sub _validate_classes { 1329 my $self = shift; 1330 my $key = shift; 1331 my $classes = shift; 1332 1333 # make a copy to not destroy original 1334 my @classes = @$classes; 1335 1336 foreach my $c (@classes) { 1337 # components default to being under the DBIx::Class namespace unless they 1338 # are preceeded with a '+' 1339 if ( $key =~ m/component/ && $c !~ s/^\+// ) { 1340 $c = 'DBIx::Class::' . $c; 1341 } 1342 1343 # 1 == installed, 0 == not installed, undef == invalid classname 1344 my $installed = Class::Inspector->installed($c); 1345 if ( defined($installed) ) { 1346 if ( $installed == 0 ) { 1347 croak qq/$c, as specified in the loader option "$key", is not installed/; 1348 } 1349 } else { 1350 croak qq/$c, as specified in the loader option "$key", is an invalid class name/; 1351 } 1352 } 1353} 1354 1355 1356sub _find_file_in_inc { 1357 my ($self, $file) = @_; 1358 1359 foreach my $prefix (@INC) { 1360 my $fullpath = File::Spec->catfile($prefix, $file); 1361 return $fullpath if -f $fullpath 1362 # abs_path throws on Windows for nonexistant files 1363 and (try { Cwd::abs_path($fullpath) }) ne 1364 ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || ''); 1365 } 1366 1367 return; 1368} 1369 1370sub _find_class_in_inc { 1371 my ($self, $class) = @_; 1372 1373 return $self->_find_file_in_inc(class_path($class)); 1374} 1375 1376sub _rewriting { 1377 my $self = shift; 1378 1379 return $self->_upgrading_from 1380 || $self->_upgrading_from_load_classes 1381 || $self->_downgrading_to_load_classes 1382 || $self->_rewriting_result_namespace 1383 ; 1384} 1385 1386sub _rewrite_old_classnames { 1387 my ($self, $code) = @_; 1388 1389 return $code unless $self->_rewriting; 1390 1391 my %old_classes = reverse %{ $self->_upgrading_classes }; 1392 1393 my $re = join '|', keys %old_classes; 1394 $re = qr/\b($re)\b/; 1395 1396 $code =~ s/$re/$old_classes{$1} || $1/eg; 1397 1398 return $code; 1399} 1400 1401sub _load_external { 1402 my ($self, $class) = @_; 1403 1404 return if $self->{skip_load_external}; 1405 1406 # so that we don't load our own classes, under any circumstances 1407 local *INC = [ grep $_ ne $self->dump_directory, @INC ]; 1408 1409 my $real_inc_path = $self->_find_class_in_inc($class); 1410 1411 my $old_class = $self->_upgrading_classes->{$class} 1412 if $self->_rewriting; 1413 1414 my $old_real_inc_path = $self->_find_class_in_inc($old_class) 1415 if $old_class && $old_class ne $class; 1416 1417 return unless $real_inc_path || $old_real_inc_path; 1418 1419 if ($real_inc_path) { 1420 # If we make it to here, we loaded an external definition 1421 warn qq/# Loaded external class definition for '$class'\n/ 1422 if $self->debug; 1423 1424 my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path); 1425 1426 if ($self->dynamic) { # load the class too 1427 eval_package_without_redefine_warnings($class, $code); 1428 } 1429 1430 $self->_ext_stmt($class, 1431 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n| 1432 .qq|# They are now part of the custom portion of this file\n| 1433 .qq|# for you to hand-edit. If you do not either delete\n| 1434 .qq|# this section or remove that file from \@INC, this section\n| 1435 .qq|# will be repeated redundantly when you re-create this\n| 1436 .qq|# file again via Loader! See skip_load_external to disable\n| 1437 .qq|# this feature.\n| 1438 ); 1439 chomp $code; 1440 $self->_ext_stmt($class, $code); 1441 $self->_ext_stmt($class, 1442 qq|# End of lines loaded from '$real_inc_path' | 1443 ); 1444 } 1445 1446 if ($old_real_inc_path) { 1447 my $code = slurp_file $old_real_inc_path; 1448 1449 $self->_ext_stmt($class, <<"EOF"); 1450 1451# These lines were loaded from '$old_real_inc_path', 1452# based on the Result class name that would have been created by an older 1453# version of the Loader. For a static schema, this happens only once during 1454# upgrade. See skip_load_external to disable this feature. 1455EOF 1456 1457 $code = $self->_rewrite_old_classnames($code); 1458 1459 if ($self->dynamic) { 1460 warn <<"EOF"; 1461 1462Detected external content in '$old_real_inc_path', a class name that would have 1463been used by an older version of the Loader. 1464 1465* PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the 1466new name of the Result. 1467EOF 1468 eval_package_without_redefine_warnings($class, $code); 1469 } 1470 1471 chomp $code; 1472 $self->_ext_stmt($class, $code); 1473 $self->_ext_stmt($class, 1474 qq|# End of lines loaded from '$old_real_inc_path' | 1475 ); 1476 } 1477} 1478 1479=head2 load 1480 1481Does the actual schema-construction work. 1482 1483=cut 1484 1485sub load { 1486 my $self = shift; 1487 1488 $self->_load_tables( 1489 $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude }) 1490 ); 1491} 1492 1493=head2 rescan 1494 1495Arguments: schema 1496 1497Rescan the database for changes. Returns a list of the newly added table 1498monikers. 1499 1500The schema argument should be the schema class or object to be affected. It 1501should probably be derived from the original schema_class used during L</load>. 1502 1503=cut 1504 1505sub rescan { 1506 my ($self, $schema) = @_; 1507 1508 $self->{schema} = $schema; 1509 $self->_relbuilder->{schema} = $schema; 1510 1511 my @created; 1512 my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude }); 1513 1514 foreach my $table (@current) { 1515 if(!exists $self->_tables->{$table->sql_name}) { 1516 push(@created, $table); 1517 } 1518 } 1519 1520 my %current; 1521 @current{map $_->sql_name, @current} = (); 1522 foreach my $table (values %{ $self->_tables }) { 1523 if (not exists $current{$table->sql_name}) { 1524 $self->_remove_table($table); 1525 } 1526 } 1527 1528 delete @$self{qw/_dump_storage _relations_started _uniqs_started/}; 1529 1530 my $loaded = $self->_load_tables(@current); 1531 1532 foreach my $table (@created) { 1533 $self->monikers->{$table->sql_name} = $self->_table2moniker($table); 1534 } 1535 1536 return map { $self->monikers->{$_->sql_name} } @created; 1537} 1538 1539sub _relbuilder { 1540 my ($self) = @_; 1541 1542 return if $self->{skip_relationships}; 1543 1544 return $self->{relbuilder} ||= do { 1545 my $relbuilder_suff = 1546 {qw{ 1547 v4 ::Compat::v0_040 1548 v5 ::Compat::v0_05 1549 v6 ::Compat::v0_06 1550 v7 ::Compat::v0_07 1551 }} 1552 ->{$self->naming->{relationships}||$CURRENT_V} || ''; 1553 1554 my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff; 1555 $self->ensure_class_loaded($relbuilder_class); 1556 $relbuilder_class->new($self); 1557 }; 1558} 1559 1560sub _load_tables { 1561 my ($self, @tables) = @_; 1562 1563 # Save the new tables to the tables list and compute monikers 1564 foreach (@tables) { 1565 $self->_tables->{$_->sql_name} = $_; 1566 $self->monikers->{$_->sql_name} = $self->_table2moniker($_); 1567 } 1568 1569 # check for moniker clashes 1570 my $inverse_moniker_idx; 1571 foreach my $imtable (values %{ $self->_tables }) { 1572 push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable; 1573 } 1574 1575 my @clashes; 1576 foreach my $moniker (keys %$inverse_moniker_idx) { 1577 my $imtables = $inverse_moniker_idx->{$moniker}; 1578 if (@$imtables > 1) { 1579 my $different_databases = 1580 $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1; 1581 1582 my $different_schemas = 1583 (uniq map $_->schema||'', @$imtables) > 1; 1584 1585 if ($different_databases || $different_schemas) { 1586 my ($use_schema, $use_database) = (1, 0); 1587 1588 if ($different_databases) { 1589 $use_database = 1; 1590 1591 # If any monikers are in the same database, we have to distinguish by 1592 # both schema and database. 1593 my %db_counts; 1594 $db_counts{$_}++ for map $_->database, @$imtables; 1595 $use_schema = any { $_ > 1 } values %db_counts; 1596 } 1597 1598 foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; } 1599 1600 my $moniker_parts = [ @{ $self->moniker_parts } ]; 1601 1602 my $have_schema = 1 if any { $_ eq 'schema' } @{ $self->moniker_parts }; 1603 my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts }; 1604 1605 unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema; 1606 unshift @$moniker_parts, 'database' if $use_database && !$have_database; 1607 1608 local $self->{moniker_parts} = $moniker_parts; 1609 1610 my %new_monikers; 1611 1612 foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); } 1613 foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; } 1614 1615 # check if there are still clashes 1616 my %by_moniker; 1617 1618 while (my ($t, $m) = each %new_monikers) { 1619 push @{ $by_moniker{$m} }, $t; 1620 } 1621 1622 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) { 1623 push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'", 1624 join (', ', @{ $by_moniker{$m} }), 1625 $m, 1626 ); 1627 } 1628 } 1629 else { 1630 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'", 1631 join (', ', map $_->sql_name, @$imtables), 1632 $moniker, 1633 ); 1634 } 1635 } 1636 } 1637 1638 if (@clashes) { 1639 die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. ' 1640 . 'Change the naming style, or supply an explicit moniker_map: ' 1641 . join ('; ', @clashes) 1642 . "\n" 1643 ; 1644 } 1645 1646 foreach my $tbl (@tables) { $self->_make_src_class($tbl); } 1647 foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); } 1648 1649 if(!$self->skip_relationships) { 1650 # The relationship loader needs a working schema 1651 local $self->{quiet} = 1; 1652 local $self->{dump_directory} = $self->{temp_directory}; 1653 $self->_reload_classes(\@tables); 1654 $self->_load_relationships(\@tables); 1655 1656 # Remove that temp dir from INC so it doesn't get reloaded 1657 @INC = grep $_ ne $self->dump_directory, @INC; 1658 } 1659 1660 foreach my $tbl (@tables) { $self->_load_roles($tbl); } 1661 foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); } 1662 1663 # Reload without unloading first to preserve any symbols from external 1664 # packages. 1665 $self->_reload_classes(\@tables, { unload => 0 }); 1666 1667 # Drop temporary cache 1668 delete $self->{_cache}; 1669 1670 return \@tables; 1671} 1672 1673sub _reload_classes { 1674 my ($self, $tables, $opts) = @_; 1675 1676 my @tables = @$tables; 1677 1678 my $unload = $opts->{unload}; 1679 $unload = 1 unless defined $unload; 1680 1681 # so that we don't repeat custom sections 1682 @INC = grep $_ ne $self->dump_directory, @INC; 1683 1684 $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables); 1685 1686 unshift @INC, $self->dump_directory; 1687 1688 my @to_register; 1689 my %have_source = map { $_ => $self->schema->source($_) } 1690 $self->schema->sources; 1691 1692 for my $table (@tables) { 1693 my $moniker = $self->monikers->{$table->sql_name}; 1694 my $class = $self->classes->{$table->sql_name}; 1695 1696 { 1697 no warnings 'redefine'; 1698 local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below 1699 use warnings; 1700 1701 if (my $mc = $self->_moose_metaclass($class)) { 1702 $mc->make_mutable; 1703 } 1704 Class::Unload->unload($class) if $unload; 1705 my ($source, $resultset_class); 1706 if ( 1707 ($source = $have_source{$moniker}) 1708 && ($resultset_class = $source->resultset_class) 1709 && ($resultset_class ne 'DBIx::Class::ResultSet') 1710 ) { 1711 my $has_file = Class::Inspector->loaded_filename($resultset_class); 1712 if (my $mc = $self->_moose_metaclass($resultset_class)) { 1713 $mc->make_mutable; 1714 } 1715 Class::Unload->unload($resultset_class) if $unload; 1716 $self->_reload_class($resultset_class) if $has_file; 1717 } 1718 $self->_reload_class($class); 1719 } 1720 push @to_register, [$moniker, $class]; 1721 } 1722 1723 Class::C3->reinitialize; 1724 for (@to_register) { 1725 $self->schema->register_class(@$_); 1726 } 1727} 1728 1729sub _moose_metaclass { 1730 return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place 1731 1732 my $class = $_[1]; 1733 1734 my $mc = try { Class::MOP::class_of($class) } 1735 or return undef; 1736 1737 return $mc->isa('Moose::Meta::Class') ? $mc : undef; 1738} 1739 1740# We use this instead of ensure_class_loaded when there are package symbols we 1741# want to preserve. 1742sub _reload_class { 1743 my ($self, $class) = @_; 1744 1745 delete $INC{ +class_path($class) }; 1746 1747 try { 1748 eval_package_without_redefine_warnings ($class, "require $class"); 1749 } 1750 catch { 1751 my $source = slurp_file $self->_get_dump_filename($class); 1752 die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source"; 1753 }; 1754} 1755 1756sub _get_dump_filename { 1757 my ($self, $class) = (@_); 1758 1759 $class =~ s{::}{/}g; 1760 return $self->dump_directory . q{/} . $class . q{.pm}; 1761} 1762 1763=head2 get_dump_filename 1764 1765Arguments: class 1766 1767Returns the full path to the file for a class that the class has been or will 1768be dumped to. This is a file in a temp dir for a dynamic schema. 1769 1770=cut 1771 1772sub get_dump_filename { 1773 my ($self, $class) = (@_); 1774 1775 local $self->{dump_directory} = $self->real_dump_directory; 1776 1777 return $self->_get_dump_filename($class); 1778} 1779 1780sub _ensure_dump_subdirs { 1781 my ($self, $class) = (@_); 1782 1783 my @name_parts = split(/::/, $class); 1784 pop @name_parts; # we don't care about the very last element, 1785 # which is a filename 1786 1787 my $dir = $self->dump_directory; 1788 while (1) { 1789 if(!-d $dir) { 1790 mkdir($dir) or croak "mkdir('$dir') failed: $!"; 1791 } 1792 last if !@name_parts; 1793 $dir = File::Spec->catdir($dir, shift @name_parts); 1794 } 1795} 1796 1797sub _dump_to_dir { 1798 my ($self, @classes) = @_; 1799 1800 my $schema_class = $self->schema_class; 1801 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema'; 1802 1803 my $target_dir = $self->dump_directory; 1804 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n" 1805 unless $self->dynamic or $self->quiet; 1806 1807 my $schema_text = 1808 qq|use utf8;\n| 1809 . qq|package $schema_class;\n\n| 1810 . qq|# Created by DBIx::Class::Schema::Loader\n| 1811 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|; 1812 1813 my $autoclean 1814 = $self->only_autoclean 1815 ? 'namespace::autoclean' 1816 : 'MooseX::MarkAsMethods autoclean => 1' 1817 ; 1818 1819 if ($self->use_moose) { 1820 1821 $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|; 1822 } 1823 else { 1824 $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|; 1825 } 1826 1827 my @schema_components = @{ $self->schema_components || [] }; 1828 1829 if (@schema_components) { 1830 my $schema_components = dump @schema_components; 1831 $schema_components = "($schema_components)" if @schema_components == 1; 1832 1833 $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n"; 1834 } 1835 1836 if ($self->use_namespaces) { 1837 $schema_text .= qq|__PACKAGE__->load_namespaces|; 1838 my $namespace_options; 1839 1840 my @attr = qw/resultset_namespace default_resultset_class/; 1841 1842 unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result'; 1843 1844 for my $attr (@attr) { 1845 if ($self->$attr) { 1846 my $code = dumper_squashed $self->$attr; 1847 $namespace_options .= qq| $attr => $code,\n| 1848 } 1849 } 1850 $schema_text .= qq|(\n$namespace_options)| if $namespace_options; 1851 $schema_text .= qq|;\n|; 1852 } 1853 else { 1854 $schema_text .= qq|__PACKAGE__->load_classes;\n|; 1855 } 1856 1857 { 1858 local $self->{version_to_dump} = $self->schema_version_to_dump; 1859 $self->_write_classfile($schema_class, $schema_text, 1); 1860 } 1861 1862 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core'; 1863 1864 foreach my $src_class (@classes) { 1865 my $src_text = 1866 qq|use utf8;\n| 1867 . qq|package $src_class;\n\n| 1868 . qq|# Created by DBIx::Class::Schema::Loader\n| 1869 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|; 1870 1871 $src_text .= $self->_make_pod_heading($src_class); 1872 1873 $src_text .= qq|use strict;\nuse warnings;\n\n|; 1874 1875 $src_text .= $self->_base_class_pod($result_base_class) 1876 unless $result_base_class eq 'DBIx::Class::Core'; 1877 1878 if ($self->use_moose) { 1879 $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|; 1880 1881 # these options 'use base' which is compile time 1882 if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) { 1883 $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|; 1884 } 1885 else { 1886 $src_text .= qq|\nextends '$result_base_class';\n|; 1887 } 1888 } 1889 else { 1890 $src_text .= qq|use base '$result_base_class';\n|; 1891 } 1892 1893 $self->_write_classfile($src_class, $src_text); 1894 } 1895 1896 # remove Result dir if downgrading from use_namespaces, and there are no 1897 # files left. 1898 if (my $result_ns = $self->_downgrading_to_load_classes 1899 || $self->_rewriting_result_namespace) { 1900 my $result_namespace = $self->_result_namespace( 1901 $schema_class, 1902 $result_ns, 1903 ); 1904 1905 (my $result_dir = $result_namespace) =~ s{::}{/}g; 1906 $result_dir = $self->dump_directory . '/' . $result_dir; 1907 1908 unless (my @files = glob "$result_dir/*") { 1909 rmdir $result_dir; 1910 } 1911 } 1912 1913 warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet; 1914} 1915 1916sub _sig_comment { 1917 my ($self, $version, $ts) = @_; 1918 return qq|\n\n# Created by DBIx::Class::Schema::Loader| 1919 . qq| v| . $version 1920 . q| @ | . $ts 1921 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|; 1922} 1923 1924sub _write_classfile { 1925 my ($self, $class, $text, $is_schema) = @_; 1926 1927 my $filename = $self->_get_dump_filename($class); 1928 $self->_ensure_dump_subdirs($class); 1929 1930 if (-f $filename && $self->really_erase_my_files) { 1931 warn "Deleting existing file '$filename' due to " 1932 . "'really_erase_my_files' setting\n" unless $self->quiet; 1933 unlink($filename); 1934 } 1935 1936 my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) 1937 = $self->_parse_generated_file($filename); 1938 1939 if (! $old_gen && -f $filename) { 1940 croak "Cannot overwrite '$filename' without 'really_erase_my_files'," 1941 . " it does not appear to have been generated by Loader" 1942 } 1943 1944 my $custom_content = $old_custom || ''; 1945 1946 # Use custom content from a renamed class, the class names in it are 1947 # rewritten below. 1948 if (my $renamed_class = $self->_upgrading_classes->{$class}) { 1949 my $old_filename = $self->_get_dump_filename($renamed_class); 1950 1951 if (-f $old_filename) { 1952 $custom_content = ($self->_parse_generated_file ($old_filename))[4]; 1953 1954 unlink $old_filename; 1955 } 1956 } 1957 1958 $custom_content ||= $self->_default_custom_content($is_schema); 1959 1960 # If upgrading to use_moose=1 replace default custom content with default Moose custom content. 1961 # If there is already custom content, which does not have the Moose content, add it. 1962 if ($self->use_moose) { 1963 1964 my $non_moose_custom_content = do { 1965 local $self->{use_moose} = 0; 1966 $self->_default_custom_content; 1967 }; 1968 1969 if ($custom_content eq $non_moose_custom_content) { 1970 $custom_content = $self->_default_custom_content($is_schema); 1971 } 1972 elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) { 1973 $custom_content .= $self->_default_custom_content($is_schema); 1974 } 1975 } 1976 elsif (defined $self->use_moose && $old_gen) { 1977 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' 1978 if $old_gen =~ /use \s+ MooseX?\b/x; 1979 } 1980 1981 $custom_content = $self->_rewrite_old_classnames($custom_content); 1982 1983 $text .= qq|$_\n| 1984 for @{$self->{_dump_storage}->{$class} || []}; 1985 1986 if ($self->filter_generated_code) { 1987 my $filter = $self->filter_generated_code; 1988 1989 if (ref $filter eq 'CODE') { 1990 $text = $filter->( 1991 ($is_schema ? 'schema' : 'result'), 1992 $class, 1993 $text 1994 ); 1995 } 1996 else { 1997 my ($fh, $temp_file) = tempfile(); 1998 1999 binmode $fh, ':encoding(UTF-8)'; 2000 print $fh $text; 2001 close $fh; 2002 2003 open my $out, qq{$filter < "$temp_file"|} 2004 or croak "Could not open pipe to $filter: $!"; 2005 2006 $text = decode('UTF-8', do { local $/; <$out> }); 2007 2008 $text =~ s/$CR?$LF/\n/g; 2009 2010 close $out; 2011 2012 my $exit_code = $? >> 8; 2013 2014 unlink $temp_file 2015 or croak "Could not remove temporary file '$temp_file': $!"; 2016 2017 if ($exit_code != 0) { 2018 croak "filter '$filter' exited non-zero: $exit_code"; 2019 } 2020 } 2021 if (not $text or not $text =~ /\bpackage\b/) { 2022 warn("$class skipped due to filter") if $self->debug; 2023 return; 2024 } 2025 } 2026 2027 # Check and see if the dump is in fact different 2028 2029 my $compare_to; 2030 if ($old_md5) { 2031 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts); 2032 if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) { 2033 return unless $self->_upgrading_from && $is_schema; 2034 } 2035 } 2036 2037 $text .= $self->_sig_comment( 2038 $self->version_to_dump, 2039 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime) 2040 ); 2041 2042 open(my $fh, '>:encoding(UTF-8)', $filename) 2043 or croak "Cannot open '$filename' for writing: $!"; 2044 2045 # Write the top half and its MD5 sum 2046 print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n"; 2047 2048 # Write out anything loaded via external partial class file in @INC 2049 print $fh qq|$_\n| 2050 for @{$self->{_ext_storage}->{$class} || []}; 2051 2052 # Write out any custom content the user has added 2053 print $fh $custom_content; 2054 2055 close($fh) 2056 or croak "Error closing '$filename': $!"; 2057} 2058 2059sub _default_moose_custom_content { 2060 my ($self, $is_schema) = @_; 2061 2062 if (not $is_schema) { 2063 return qq|\n__PACKAGE__->meta->make_immutable;|; 2064 } 2065 2066 return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|; 2067} 2068 2069sub _default_custom_content { 2070 my ($self, $is_schema) = @_; 2071 my $default = qq|\n\n# You can replace this text with custom| 2072 . qq| code or comments, and it will be preserved on regeneration|; 2073 if ($self->use_moose) { 2074 $default .= $self->_default_moose_custom_content($is_schema); 2075 } 2076 $default .= qq|\n1;\n|; 2077 return $default; 2078} 2079 2080sub _parse_generated_file { 2081 my ($self, $fn) = @_; 2082 2083 return unless -f $fn; 2084 2085 open(my $fh, '<:encoding(UTF-8)', $fn) 2086 or croak "Cannot open '$fn' for reading: $!"; 2087 2088 my $mark_re = 2089 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n}; 2090 2091 my ($md5, $ts, $ver, $gen); 2092 while(<$fh>) { 2093 if(/$mark_re/) { 2094 my $pre_md5 = $1; 2095 $md5 = $2; 2096 2097 # Pull out the version and timestamp from the line above 2098 ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m; 2099 2100 $gen .= $pre_md5; 2101 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" 2102 if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5; 2103 2104 last; 2105 } 2106 else { 2107 $gen .= $_; 2108 } 2109 } 2110 2111 my $custom = do { local $/; <$fh> } 2112 if $md5; 2113 2114 $custom ||= ''; 2115 $custom =~ s/$CRLF|$LF/\n/g; 2116 2117 close $fh; 2118 2119 return ($gen, $md5, $ver, $ts, $custom); 2120} 2121 2122sub _use { 2123 my $self = shift; 2124 my $target = shift; 2125 2126 foreach (@_) { 2127 warn "$target: use $_;" if $self->debug; 2128 $self->_raw_stmt($target, "use $_;"); 2129 } 2130} 2131 2132sub _inject { 2133 my $self = shift; 2134 my $target = shift; 2135 2136 my $blist = join(q{ }, @_); 2137 2138 return unless $blist; 2139 2140 warn "$target: use base qw/$blist/;" if $self->debug; 2141 $self->_raw_stmt($target, "use base qw/$blist/;"); 2142} 2143 2144sub _with { 2145 my $self = shift; 2146 my $target = shift; 2147 2148 my $rlist = join(q{, }, map { qq{'$_'} } @_); 2149 2150 return unless $rlist; 2151 2152 warn "$target: with $rlist;" if $self->debug; 2153 $self->_raw_stmt($target, "\nwith $rlist;"); 2154} 2155 2156sub _result_namespace { 2157 my ($self, $schema_class, $ns) = @_; 2158 my @result_namespace; 2159 2160 $ns = $ns->[0] if ref $ns; 2161 2162 if ($ns =~ /^\+(.*)/) { 2163 # Fully qualified namespace 2164 @result_namespace = ($1) 2165 } 2166 else { 2167 # Relative namespace 2168 @result_namespace = ($schema_class, $ns); 2169 } 2170 2171 return wantarray ? @result_namespace : join '::', @result_namespace; 2172} 2173 2174# Create class with applicable bases, setup monikers, etc 2175sub _make_src_class { 2176 my ($self, $table) = @_; 2177 2178 my $schema = $self->schema; 2179 my $schema_class = $self->schema_class; 2180 2181 my $table_moniker = $self->monikers->{$table->sql_name}; 2182 my @result_namespace = ($schema_class); 2183 if ($self->use_namespaces) { 2184 my $result_namespace = $self->result_namespace || 'Result'; 2185 @result_namespace = $self->_result_namespace( 2186 $schema_class, 2187 $result_namespace, 2188 ); 2189 } 2190 my $table_class = join(q{::}, @result_namespace, $table_moniker); 2191 2192 if ((my $upgrading_v = $self->_upgrading_from) 2193 || $self->_rewriting) { 2194 local $self->naming->{monikers} = $upgrading_v 2195 if $upgrading_v; 2196 2197 my @result_namespace = @result_namespace; 2198 if ($self->_upgrading_from_load_classes) { 2199 @result_namespace = ($schema_class); 2200 } 2201 elsif (my $ns = $self->_downgrading_to_load_classes) { 2202 @result_namespace = $self->_result_namespace( 2203 $schema_class, 2204 $ns, 2205 ); 2206 } 2207 elsif ($ns = $self->_rewriting_result_namespace) { 2208 @result_namespace = $self->_result_namespace( 2209 $schema_class, 2210 $ns, 2211 ); 2212 } 2213 2214 my $old_table_moniker = do { 2215 local $self->naming->{monikers} = $upgrading_v; 2216 $self->_table2moniker($table); 2217 }; 2218 2219 my $old_class = join(q{::}, @result_namespace, $old_table_moniker); 2220 2221 $self->_upgrading_classes->{$table_class} = $old_class 2222 unless $table_class eq $old_class; 2223 } 2224 2225 $self->classes->{$table->sql_name} = $table_class; 2226 $self->moniker_to_table->{$table_moniker} = $table; 2227 $self->class_to_table->{$table_class} = $table; 2228 2229 $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes}); 2230 2231 $self->_use ($table_class, @{$self->additional_classes}); 2232 2233 $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_classes}); 2234 2235 $self->_inject($table_class, @{$self->left_base_classes}); 2236 2237 my @components = @{ $self->components || [] }; 2238 2239 push @components, @{ $self->result_components_map->{$table_moniker} } 2240 if exists $self->result_components_map->{$table_moniker}; 2241 2242 my @fq_components = @components; 2243 foreach my $component (@fq_components) { 2244 if ($component !~ s/^\+//) { 2245 $component = "DBIx::Class::$component"; 2246 } 2247 } 2248 2249 $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components); 2250 2251 $self->_dbic_stmt($table_class, 'load_components', @components) if @components; 2252 2253 $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes}); 2254 2255 $self->_inject($table_class, @{$self->additional_base_classes}); 2256} 2257 2258sub _is_result_class_method { 2259 my ($self, $name, $table) = @_; 2260 2261 my $table_moniker = $table ? $self->monikers->{$table->sql_name} : ''; 2262 2263 $self->_result_class_methods({}) 2264 if not defined $self->_result_class_methods; 2265 2266 if (not exists $self->_result_class_methods->{$table_moniker}) { 2267 my (@methods, %methods); 2268 my $base = $self->result_base_class || 'DBIx::Class::Core'; 2269 2270 my @components = @{ $self->components || [] }; 2271 2272 push @components, @{ $self->result_components_map->{$table_moniker} } 2273 if exists $self->result_components_map->{$table_moniker}; 2274 2275 for my $c (@components) { 2276 $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c"; 2277 } 2278 2279 my @roles = @{ $self->result_roles || [] }; 2280 2281 push @roles, @{ $self->result_roles_map->{$table_moniker} } 2282 if exists $self->result_roles_map->{$table_moniker}; 2283 2284 for my $class ($base, @components, 2285 ($self->use_moose ? 'Moose::Object' : ()), @roles) { 2286 $self->ensure_class_loaded($class); 2287 2288 push @methods, @{ Class::Inspector->methods($class) || [] }; 2289 } 2290 2291 push @methods, @{ Class::Inspector->methods('UNIVERSAL') }; 2292 2293 @methods{@methods} = (); 2294 2295 $self->_result_class_methods->{$table_moniker} = \%methods; 2296 } 2297 my $result_methods = $self->_result_class_methods->{$table_moniker}; 2298 2299 return exists $result_methods->{$name}; 2300} 2301 2302sub _resolve_col_accessor_collisions { 2303 my ($self, $table, $col_info) = @_; 2304 2305 while (my ($col, $info) = each %$col_info) { 2306 my $accessor = $info->{accessor} || $col; 2307 2308 next if $accessor eq 'id'; # special case (very common column) 2309 2310 if ($self->_is_result_class_method($accessor, $table)) { 2311 my $mapped = 0; 2312 2313 if (my $map = $self->col_collision_map) { 2314 for my $re (keys %$map) { 2315 if (my @matches = $col =~ /$re/) { 2316 $info->{accessor} = sprintf $map->{$re}, @matches; 2317 $mapped = 1; 2318 } 2319 } 2320 } 2321 2322 if (not $mapped) { 2323 warn <<"EOF"; 2324Column '$col' in table '$table' collides with an inherited method. 2325See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base . 2326EOF 2327 $info->{accessor} = undef; 2328 } 2329 } 2330 } 2331} 2332 2333# use the same logic to run moniker_map, col_accessor_map 2334sub _run_user_map { 2335 my ( $self, $map, $default_code, $ident, @extra ) = @_; 2336 2337 my $default_ident = $default_code->( $ident, @extra ); 2338 my $new_ident; 2339 if( $map && ref $map eq 'HASH' ) { 2340 $new_ident = $map->{ $ident }; 2341 } 2342 elsif( $map && ref $map eq 'CODE' ) { 2343 $new_ident = $map->( $ident, $default_ident, @extra ); 2344 } 2345 2346 $new_ident ||= $default_ident; 2347 2348 return $new_ident; 2349} 2350 2351sub _default_column_accessor_name { 2352 my ( $self, $column_name ) = @_; 2353 2354 my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve'; 2355 2356 my $v = $self->_get_naming_v('column_accessors'); 2357 2358 my $accessor_name = $preserve ? 2359 $self->_to_identifier('column_accessors', $column_name) # assume CamelCase 2360 : 2361 $self->_to_identifier('column_accessors', $column_name, '_'); 2362 2363 $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier 2364 # takes care of it 2365 2366 if ($preserve) { 2367 return $accessor_name; 2368 } 2369 elsif ($v < 7 || (not $self->preserve_case)) { 2370 # older naming just lc'd the col accessor and that's all. 2371 return lc $accessor_name; 2372 } 2373 2374 return join '_', map lc, split_name $column_name, $v; 2375} 2376 2377sub _make_column_accessor_name { 2378 my ($self, $column_name, $column_context_info ) = @_; 2379 2380 my $accessor = $self->_run_user_map( 2381 $self->col_accessor_map, 2382 sub { $self->_default_column_accessor_name( shift ) }, 2383 $column_name, 2384 $column_context_info, 2385 ); 2386 2387 return $accessor; 2388} 2389 2390# Set up metadata (cols, pks, etc) 2391sub _setup_src_meta { 2392 my ($self, $table) = @_; 2393 2394 my $schema = $self->schema; 2395 my $schema_class = $self->schema_class; 2396 2397 my $table_class = $self->classes->{$table->sql_name}; 2398 my $table_moniker = $self->monikers->{$table->sql_name}; 2399 2400 $self->_dbic_stmt($table_class, 'table', $table->dbic_name); 2401 2402 my $cols = $self->_table_columns($table); 2403 my $col_info = $self->__columns_info_for($table); 2404 2405 ### generate all the column accessor names 2406 while (my ($col, $info) = each %$col_info) { 2407 # hashref of other info that could be used by 2408 # user-defined accessor map functions 2409 my $context = { 2410 table_class => $table_class, 2411 table_moniker => $table_moniker, 2412 table_name => $table, 2413 full_table_name => $table->dbic_name, 2414 schema_class => $schema_class, 2415 column_info => $info, 2416 }; 2417 2418 $info->{accessor} = $self->_make_column_accessor_name( $col, $context ); 2419 } 2420 2421 $self->_resolve_col_accessor_collisions($table, $col_info); 2422 2423 # prune any redundant accessor names 2424 while (my ($col, $info) = each %$col_info) { 2425 no warnings 'uninitialized'; 2426 delete $info->{accessor} if $info->{accessor} eq $col; 2427 } 2428 2429 my $fks = $self->_table_fk_info($table); 2430 2431 foreach my $fkdef (@$fks) { 2432 for my $col (@{ $fkdef->{local_columns} }) { 2433 $col_info->{$col}{is_foreign_key} = 1; 2434 } 2435 } 2436 2437 my $pks = $self->_table_pk_info($table) || []; 2438 2439 my %uniq_tag; # used to eliminate duplicate uniqs 2440 2441 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq 2442 2443 my $uniqs = $self->_table_uniq_info($table) || []; 2444 my @uniqs; 2445 2446 foreach my $uniq (@$uniqs) { 2447 my ($name, $cols) = @$uniq; 2448 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates 2449 push @uniqs, [$name, $cols]; 2450 } 2451 2452 my @non_nullable_uniqs = grep { 2453 all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] } 2454 } @uniqs; 2455 2456 if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) { 2457 my @by_colnum = sort { $b->[0] <=> $a->[0] } 2458 map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs; 2459 2460 if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) { 2461 my @keys = map $_->[1], @by_colnum; 2462 2463 my $pk = $keys[0]; 2464 2465 # remove the uniq from list 2466 @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs; 2467 2468 $pks = $pk->[1]; 2469 } 2470 } 2471 2472 foreach my $pkcol (@$pks) { 2473 $col_info->{$pkcol}{is_nullable} = 0; 2474 } 2475 2476 $self->_dbic_stmt( 2477 $table_class, 2478 'add_columns', 2479 map { $_, ($col_info->{$_}||{}) } @$cols 2480 ); 2481 2482 $self->_dbic_stmt($table_class, 'set_primary_key', @$pks) 2483 if @$pks; 2484 2485 # Sort unique constraints by constraint name for repeatable results (rels 2486 # are sorted as well elsewhere.) 2487 @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs; 2488 2489 foreach my $uniq (@uniqs) { 2490 my ($name, $cols) = @$uniq; 2491 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols); 2492 } 2493} 2494 2495sub __columns_info_for { 2496 my ($self, $table) = @_; 2497 2498 my $result = $self->_columns_info_for($table); 2499 2500 while (my ($col, $info) = each %$result) { 2501 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } }; 2502 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } }; 2503 2504 $result->{$col} = $info; 2505 } 2506 2507 return $result; 2508} 2509 2510=head2 tables 2511 2512Returns a sorted list of loaded tables, using the original database table 2513names. 2514 2515=cut 2516 2517sub tables { 2518 my $self = shift; 2519 2520 return values %{$self->_tables}; 2521} 2522 2523sub _get_naming_v { 2524 my ($self, $naming_key) = @_; 2525 2526 my $v; 2527 2528 if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) { 2529 $v = $1; 2530 } 2531 else { 2532 ($v) = $CURRENT_V =~ /^v(\d+)\z/; 2533 } 2534 2535 return $v; 2536} 2537 2538sub _to_identifier { 2539 my ($self, $naming_key, $name, $sep_char, $force) = @_; 2540 2541 my $v = $self->_get_naming_v($naming_key); 2542 2543 my $to_identifier = $self->naming->{force_ascii} ? 2544 \&String::ToIdentifier::EN::to_identifier 2545 : \&String::ToIdentifier::EN::Unicode::to_identifier; 2546 2547 return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name; 2548} 2549 2550# Make a moniker from a table 2551sub _default_table2moniker { 2552 my ($self, $table) = @_; 2553 2554 my $v = $self->_get_naming_v('monikers'); 2555 2556 my @name_parts = map $table->$_, @{ $self->moniker_parts }; 2557 2558 my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts }; 2559 2560 my @all_parts; 2561 2562 foreach my $i (0 .. $#name_parts) { 2563 my $part = $name_parts[$i]; 2564 2565 if ($i != $name_idx || $v >= 8) { 2566 $part = $self->_to_identifier('monikers', $part, '_', 1); 2567 } 2568 2569 if ($i == $name_idx && $v == 5) { 2570 $part = Lingua::EN::Inflect::Number::to_S($part); 2571 } 2572 2573 my @part_parts = map lc, $v > 6 ? 2574 # use v8 semantics for all moniker parts except name 2575 ($i == $name_idx ? split_name $part, $v : split_name $part) 2576 : split /[\W_]+/, $part; 2577 2578 if ($i == $name_idx && $v >= 6) { 2579 my $as_phrase = join ' ', @part_parts; 2580 2581 my $inflected = ($self->naming->{monikers}||'') eq 'plural' ? 2582 Lingua::EN::Inflect::Phrase::to_PL($as_phrase) 2583 : 2584 ($self->naming->{monikers}||'') eq 'preserve' ? 2585 $as_phrase 2586 : 2587 Lingua::EN::Inflect::Phrase::to_S($as_phrase); 2588 2589 @part_parts = split /\s+/, $inflected; 2590 } 2591 2592 push @all_parts, map ucfirst, @part_parts; 2593 } 2594 2595 return join '', @all_parts; 2596} 2597 2598sub _table2moniker { 2599 my ( $self, $table ) = @_; 2600 2601 $self->_run_user_map( 2602 $self->moniker_map, 2603 sub { $self->_default_table2moniker( shift ) }, 2604 $table 2605 ); 2606} 2607 2608sub _load_relationships { 2609 my ($self, $tables) = @_; 2610 2611 my @tables; 2612 2613 foreach my $table (@$tables) { 2614 my $local_moniker = $self->monikers->{$table->sql_name}; 2615 2616 my $tbl_fk_info = $self->_table_fk_info($table); 2617 2618 foreach my $fkdef (@$tbl_fk_info) { 2619 $fkdef->{local_table} = $table; 2620 $fkdef->{local_moniker} = $local_moniker; 2621 $fkdef->{remote_source} = 2622 $self->monikers->{$fkdef->{remote_table}->sql_name}; 2623 } 2624 my $tbl_uniq_info = $self->_table_uniq_info($table); 2625 2626 push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ]; 2627 } 2628 2629 my $rel_stmts = $self->_relbuilder->generate_code(\@tables); 2630 2631 foreach my $src_class (sort keys %$rel_stmts) { 2632 # sort by rel name 2633 my @src_stmts = map $_->[2], 2634 sort { 2635 $a->[0] <=> $b->[0] 2636 || 2637 $a->[1] cmp $b->[1] 2638 } map [ 2639 ($_->{method} eq 'many_to_many' ? 1 : 0), 2640 $_->{args}[0], 2641 $_, 2642 ], @{ $rel_stmts->{$src_class} }; 2643 2644 foreach my $stmt (@src_stmts) { 2645 $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}}); 2646 } 2647 } 2648} 2649 2650sub _load_roles { 2651 my ($self, $table) = @_; 2652 2653 my $table_moniker = $self->monikers->{$table->sql_name}; 2654 my $table_class = $self->classes->{$table->sql_name}; 2655 2656 my @roles = @{ $self->result_roles || [] }; 2657 push @roles, @{ $self->result_roles_map->{$table_moniker} } 2658 if exists $self->result_roles_map->{$table_moniker}; 2659 2660 if (@roles) { 2661 $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles); 2662 2663 $self->_with($table_class, @roles); 2664 } 2665} 2666 2667# Overload these in driver class: 2668 2669# Returns an arrayref of column names 2670sub _table_columns { croak "ABSTRACT METHOD" } 2671 2672# Returns arrayref of pk col names 2673sub _table_pk_info { croak "ABSTRACT METHOD" } 2674 2675# Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ] 2676sub _table_uniq_info { croak "ABSTRACT METHOD" } 2677 2678# Returns an arrayref of foreign key constraints, each 2679# being a hashref with 3 keys: 2680# local_columns (arrayref), remote_columns (arrayref), remote_table 2681sub _table_fk_info { croak "ABSTRACT METHOD" } 2682 2683# Returns an array of lower case table names 2684sub _tables_list { croak "ABSTRACT METHOD" } 2685 2686# Execute a constructive DBIC class method, with debug/dump_to_dir hooks. 2687sub _dbic_stmt { 2688 my $self = shift; 2689 my $class = shift; 2690 my $method = shift; 2691 2692 # generate the pod for this statement, storing it with $self->_pod 2693 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod; 2694 2695 my $args = dump(@_); 2696 $args = '(' . $args . ')' if @_ < 2; 2697 my $stmt = $method . $args . q{;}; 2698 2699 warn qq|$class\->$stmt\n| if $self->debug; 2700 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt); 2701 return; 2702} 2703 2704sub _make_pod_heading { 2705 my ($self, $class) = @_; 2706 2707 return '' if not $self->generate_pod; 2708 2709 my $table = $self->class_to_table->{$class}; 2710 my $pod; 2711 2712 my $pcm = $self->pod_comment_mode; 2713 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc); 2714 $comment = $self->__table_comment($table); 2715 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length); 2716 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows)); 2717 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows)); 2718 2719 $pod .= "=head1 NAME\n\n"; 2720 2721 my $table_descr = $class; 2722 $table_descr .= " - " . $comment if $comment and $comment_in_name; 2723 2724 $pod .= "$table_descr\n\n"; 2725 2726 if ($comment and $comment_in_desc) { 2727 $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n"; 2728 } 2729 $pod .= "=cut\n\n"; 2730 2731 return $pod; 2732} 2733 2734# generates the accompanying pod for a DBIC class method statement, 2735# storing it with $self->_pod 2736sub _make_pod { 2737 my $self = shift; 2738 my $class = shift; 2739 my $method = shift; 2740 2741 if ($method eq 'table') { 2742 my $table = $_[0]; 2743 $table = $$table if ref $table eq 'SCALAR'; 2744 $self->_pod($class, "=head1 TABLE: C<$table>"); 2745 $self->_pod_cut($class); 2746 } 2747 elsif ( $method eq 'add_columns' ) { 2748 $self->_pod( $class, "=head1 ACCESSORS" ); 2749 my $col_counter = 0; 2750 my @cols = @_; 2751 while( my ($name,$attrs) = splice @cols,0,2 ) { 2752 $col_counter++; 2753 $self->_pod( $class, '=head2 ' . $name ); 2754 $self->_pod( $class, 2755 join "\n", map { 2756 my $s = $attrs->{$_}; 2757 $s = !defined $s ? 'undef' : 2758 length($s) == 0 ? '(empty string)' : 2759 ref($s) eq 'SCALAR' ? $$s : 2760 ref($s) ? dumper_squashed $s : 2761 looks_like_number($s) ? $s : qq{'$s'}; 2762 2763 " $_: $s" 2764 } sort keys %$attrs, 2765 ); 2766 if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) { 2767 $self->_pod( $class, $comment ); 2768 } 2769 } 2770 $self->_pod_cut( $class ); 2771 } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) { 2772 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ; 2773 my ( $accessor, $rel_class ) = @_; 2774 $self->_pod( $class, "=head2 $accessor" ); 2775 $self->_pod( $class, 'Type: ' . $method ); 2776 $self->_pod( $class, "Related object: L<$rel_class>" ); 2777 $self->_pod_cut( $class ); 2778 $self->{_relations_started} { $class } = 1; 2779 } elsif ( $method eq 'many_to_many' ) { 2780 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ; 2781 my ( $accessor, $rel1, $rel2 ) = @_; 2782 $self->_pod( $class, "=head2 $accessor" ); 2783 $self->_pod( $class, 'Type: many_to_many' ); 2784 $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" ); 2785 $self->_pod_cut( $class ); 2786 $self->{_relations_started} { $class } = 1; 2787 } 2788 elsif ($method eq 'add_unique_constraint') { 2789 $self->_pod($class, '=head1 UNIQUE CONSTRAINTS') 2790 unless $self->{_uniqs_started}{$class}; 2791 2792 my ($name, $cols) = @_; 2793 2794 $self->_pod($class, "=head2 C<$name>"); 2795 $self->_pod($class, '=over 4'); 2796 2797 foreach my $col (@$cols) { 2798 $self->_pod($class, "=item \* L</$col>"); 2799 } 2800 2801 $self->_pod($class, '=back'); 2802 $self->_pod_cut($class); 2803 2804 $self->{_uniqs_started}{$class} = 1; 2805 } 2806 elsif ($method eq 'set_primary_key') { 2807 $self->_pod($class, "=head1 PRIMARY KEY"); 2808 $self->_pod($class, '=over 4'); 2809 2810 foreach my $col (@_) { 2811 $self->_pod($class, "=item \* L</$col>"); 2812 } 2813 2814 $self->_pod($class, '=back'); 2815 $self->_pod_cut($class); 2816 } 2817} 2818 2819sub _pod_class_list { 2820 my ($self, $class, $title, @classes) = @_; 2821 2822 return unless @classes && $self->generate_pod; 2823 2824 $self->_pod($class, "=head1 $title"); 2825 $self->_pod($class, '=over 4'); 2826 2827 foreach my $link (@classes) { 2828 $self->_pod($class, "=item * L<$link>"); 2829 } 2830 2831 $self->_pod($class, '=back'); 2832 $self->_pod_cut($class); 2833} 2834 2835sub _base_class_pod { 2836 my ($self, $base_class) = @_; 2837 2838 return '' unless $self->generate_pod; 2839 2840 return <<"EOF" 2841=head1 BASE CLASS: L<$base_class> 2842 2843=cut 2844 2845EOF 2846} 2847 2848sub _filter_comment { 2849 my ($self, $txt) = @_; 2850 2851 $txt = '' if not defined $txt; 2852 2853 $txt =~ s/(?:\015?\012|\015\012?)/\n/g; 2854 2855 return $txt; 2856} 2857 2858sub __table_comment { 2859 my $self = shift; 2860 2861 if (my $code = $self->can('_table_comment')) { 2862 return $self->_filter_comment($self->$code(@_)); 2863 } 2864 2865 return ''; 2866} 2867 2868sub __column_comment { 2869 my $self = shift; 2870 2871 if (my $code = $self->can('_column_comment')) { 2872 return $self->_filter_comment($self->$code(@_)); 2873 } 2874 2875 return ''; 2876} 2877 2878# Stores a POD documentation 2879sub _pod { 2880 my ($self, $class, $stmt) = @_; 2881 $self->_raw_stmt( $class, "\n" . $stmt ); 2882} 2883 2884sub _pod_cut { 2885 my ($self, $class ) = @_; 2886 $self->_raw_stmt( $class, "\n=cut\n" ); 2887} 2888 2889# Store a raw source line for a class (for dumping purposes) 2890sub _raw_stmt { 2891 my ($self, $class, $stmt) = @_; 2892 push(@{$self->{_dump_storage}->{$class}}, $stmt); 2893} 2894 2895# Like above, but separately for the externally loaded stuff 2896sub _ext_stmt { 2897 my ($self, $class, $stmt) = @_; 2898 push(@{$self->{_ext_storage}->{$class}}, $stmt); 2899} 2900 2901sub _custom_column_info { 2902 my ( $self, $table_name, $column_name, $column_info ) = @_; 2903 2904 if (my $code = $self->custom_column_info) { 2905 return $code->($table_name, $column_name, $column_info) || {}; 2906 } 2907 return {}; 2908} 2909 2910sub _datetime_column_info { 2911 my ( $self, $table_name, $column_name, $column_info ) = @_; 2912 my $result = {}; 2913 my $type = $column_info->{data_type} || ''; 2914 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/}) 2915 or ($type =~ /date|timestamp/i)) { 2916 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone; 2917 $result->{locale} = $self->datetime_locale if $self->datetime_locale; 2918 } 2919 return $result; 2920} 2921 2922sub _lc { 2923 my ($self, $name) = @_; 2924 2925 return $self->preserve_case ? $name : lc($name); 2926} 2927 2928sub _uc { 2929 my ($self, $name) = @_; 2930 2931 return $self->preserve_case ? $name : uc($name); 2932} 2933 2934sub _remove_table { 2935 my ($self, $table) = @_; 2936 2937 try { 2938 my $schema = $self->schema; 2939 # in older DBIC it's a private method 2940 my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source'); 2941 $schema->$unregister(delete $self->monikers->{$table->sql_name}); 2942 delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}}; 2943 delete $self->_tables->{$table->sql_name}; 2944 }; 2945} 2946 2947# remove the dump dir from @INC on destruction 2948sub DESTROY { 2949 my $self = shift; 2950 2951 @INC = grep $_ ne $self->dump_directory, @INC; 2952} 2953 2954=head2 monikers 2955 2956Returns a hashref of loaded table to moniker mappings. There will 2957be two entries for each table, the original name and the "normalized" 2958name, in the case that the two are different (such as databases 2959that like uppercase table names, or preserve your original mixed-case 2960definitions, or what-have-you). 2961 2962=head2 classes 2963 2964Returns a hashref of table to class mappings. In some cases it will 2965contain multiple entries per table for the original and normalized table 2966names, as above in L</monikers>. 2967 2968=head1 NON-ENGLISH DATABASES 2969 2970If you use the loader on a database with table and column names in a language 2971other than English, you will want to turn off the English language specific 2972heuristics. 2973 2974To do so, use something like this in your loader options: 2975 2976 naming => { monikers => 'v4' }, 2977 inflect_singular => sub { "$_[0]_rel" }, 2978 inflect_plural => sub { "$_[0]_rel" }, 2979 2980=head1 COLUMN ACCESSOR COLLISIONS 2981 2982Occasionally you may have a column name that collides with a perl method, such 2983as C<can>. In such cases, the default action is to set the C<accessor> of the 2984column spec to C<undef>. 2985 2986You can then name the accessor yourself by placing code such as the following 2987below the md5: 2988 2989 __PACKAGE__->add_column('+can' => { accessor => 'my_can' }); 2990 2991Another option is to use the L</col_collision_map> option. 2992 2993=head1 RELATIONSHIP NAME COLLISIONS 2994 2995In very rare cases, you may get a collision between a generated relationship 2996name and a method in your Result class, for example if you have a foreign key 2997called C<belongs_to>. 2998 2999This is a problem because relationship names are also relationship accessor 3000methods in L<DBIx::Class>. 3001 3002The default behavior is to append C<_rel> to the relationship name and print 3003out a warning that refers to this text. 3004 3005You can also control the renaming with the L</rel_collision_map> option. 3006 3007=head1 SEE ALSO 3008 3009L<DBIx::Class::Schema::Loader>, L<dbicdump> 3010 3011=head1 AUTHOR 3012 3013See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 3014 3015=head1 LICENSE 3016 3017This library is free software; you can redistribute it and/or modify it under 3018the same terms as Perl itself. 3019 3020=cut 3021 30221; 3023# vim:et sts=4 sw=4 tw=0: 3024