1package DBIx::Class::Schema::Loader::Base; 2 3use strict; 4use warnings; 5use base qw/Class::Accessor::Grouped Class::C3::Componentised/; 6use Class::C3; 7use Carp::Clan qw/^DBIx::Class/; 8use DBIx::Class::Schema::Loader::RelBuilder; 9use Data::Dump qw/ dump /; 10use POSIX qw//; 11use File::Spec qw//; 12use Cwd qw//; 13use Digest::MD5 qw//; 14use Lingua::EN::Inflect::Number qw//; 15use File::Temp qw//; 16use Class::Unload; 17use Class::Inspector (); 18require DBIx::Class; 19 20our $VERSION = '0.05003'; 21 22__PACKAGE__->mk_group_ro_accessors('simple', qw/ 23 schema 24 schema_class 25 26 exclude 27 constraint 28 additional_classes 29 additional_base_classes 30 left_base_classes 31 components 32 resultset_components 33 skip_relationships 34 skip_load_external 35 moniker_map 36 custom_column_info 37 inflect_singular 38 inflect_plural 39 debug 40 dump_directory 41 dump_overwrite 42 really_erase_my_files 43 resultset_namespace 44 default_resultset_class 45 schema_base_class 46 result_base_class 47 overwrite_modifications 48 49 relationship_attrs 50 51 db_schema 52 _tables 53 classes 54 _upgrading_classes 55 monikers 56 dynamic 57 naming 58 datetime_timezone 59 datetime_locale 60/); 61 62 63__PACKAGE__->mk_group_accessors('simple', qw/ 64 version_to_dump 65 schema_version_to_dump 66 _upgrading_from 67 _upgrading_from_load_classes 68 _downgrading_to_load_classes 69 _rewriting_result_namespace 70 use_namespaces 71 result_namespace 72 generate_pod 73 pod_comment_mode 74 pod_comment_spillover_length 75/); 76 77=head1 NAME 78 79DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation. 80 81=head1 SYNOPSIS 82 83See L<DBIx::Class::Schema::Loader> 84 85=head1 DESCRIPTION 86 87This is the base class for the storage-specific C<DBIx::Class::Schema::*> 88classes, and implements the common functionality between them. 89 90=head1 CONSTRUCTOR OPTIONS 91 92These constructor options are the base options for 93L<DBIx::Class::Schema::Loader/loader_options>. Available constructor options are: 94 95=head2 skip_relationships 96 97Skip setting up relationships. The default is to attempt the loading 98of relationships. 99 100=head2 skip_load_external 101 102Skip loading of other classes in @INC. The default is to merge all other classes 103with the same name found in @INC into the schema file we are creating. 104 105=head2 naming 106 107Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX 108relationship names and singularized Results, unless you're overwriting an 109existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in 110which case the backward compatible RelBuilder will be activated, and 111singularization will be turned off. 112 113Specifying 114 115 naming => 'v5' 116 117will disable the backward-compatible RelBuilder and use 118the new-style relationship names along with singularized Results, even when 119overwriting a dump made with an earlier version. 120 121The option also takes a hashref: 122 123 naming => { relationships => 'v5', monikers => 'v4' } 124 125The keys are: 126 127=over 4 128 129=item relationships 130 131How to name relationship accessors. 132 133=item monikers 134 135How to name Result classes. 136 137=back 138 139The values can be: 140 141=over 4 142 143=item current 144 145Latest default style, whatever that happens to be. 146 147=item v5 148 149Version 0.05XXX style. 150 151=item v4 152 153Version 0.04XXX style. 154 155=back 156 157Dynamic schemas will always default to the 0.04XXX relationship names and won't 158singularize Results for backward compatibility, to activate the new RelBuilder 159and singularization put this in your C<Schema.pm> file: 160 161 __PACKAGE__->naming('current'); 162 163Or if you prefer to use 0.05XXX features but insure that nothing breaks in the 164next major version upgrade: 165 166 __PACKAGE__->naming('v5'); 167 168=head2 generate_pod 169 170By default POD will be generated for columns and relationships, using database 171metadata for the text if available and supported. 172 173Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only 174supported for Postgres right now. 175 176Set this to C<0> to turn off all POD generation. 177 178=head2 pod_comment_mode 179 180Controls where table comments appear in the generated POD. Smaller table 181comments are appended to the C<NAME> section of the documentation, and larger 182ones are inserted into C<DESCRIPTION> instead. You can force a C<DESCRIPTION> 183section to be generated with the comment always, only use C<NAME>, or choose 184the length threshold at which the comment is forced into the description. 185 186=over 4 187 188=item name 189 190Use C<NAME> section only. 191 192=item description 193 194Force C<DESCRIPTION> always. 195 196=item auto 197 198Use C<DESCRIPTION> if length > L</pod_comment_spillover_length>, this is the 199default. 200 201=back 202 203=head2 pod_comment_spillover_length 204 205When pod_comment_mode is set to C<auto>, this is the length of the comment at 206which it will be forced into a separate description section. 207 208The default is C<60> 209 210=head2 relationship_attrs 211 212Hashref of attributes to pass to each generated relationship, listed 213by type. Also supports relationship type 'all', containing options to 214pass to all generated relationships. Attributes set for more specific 215relationship types override those set in 'all'. 216 217For example: 218 219 relationship_attrs => { 220 all => { cascade_delete => 0 }, 221 has_many => { cascade_delete => 1 }, 222 }, 223 224will set the C<cascade_delete> option to 0 for all generated relationships, 225except for C<has_many>, which will have cascade_delete as 1. 226 227NOTE: this option is not supported if v4 backward-compatible naming is 228set either globally (naming => 'v4') or just for relationships. 229 230=head2 debug 231 232If set to true, each constructive L<DBIx::Class> statement the loader 233decides to execute will be C<warn>-ed before execution. 234 235=head2 db_schema 236 237Set the name of the schema to load (schema in the sense that your database 238vendor means it). Does not currently support loading more than one schema 239name. 240 241=head2 constraint 242 243Only load tables matching regex. Best specified as a qr// regex. 244 245=head2 exclude 246 247Exclude tables matching regex. Best specified as a qr// regex. 248 249=head2 moniker_map 250 251Overrides the default table name to moniker translation. Can be either 252a hashref of table keys and moniker values, or a coderef for a translator 253function taking a single scalar table name argument and returning 254a scalar moniker. If the hash entry does not exist, or the function 255returns a false value, the code falls back to default behavior 256for that table name. 257 258The default behavior is to singularize the table name, and: C<join '', map 259ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything, 260split up the table name into chunks anywhere a non-alpha-numeric character 261occurs, change the case of first letter of each chunk to upper case, and put 262the chunks back together. Examples: 263 264 Table Name | Moniker Name 265 --------------------------- 266 luser | Luser 267 luser_group | LuserGroup 268 luser-opts | LuserOpt 269 270=head2 inflect_plural 271 272Just like L</moniker_map> above (can be hash/code-ref, falls back to default 273if hash key does not exist or coderef returns false), but acts as a map 274for pluralizing relationship names. The default behavior is to utilize 275L<Lingua::EN::Inflect::Number/to_PL>. 276 277=head2 inflect_singular 278 279As L</inflect_plural> above, but for singularizing relationship names. 280Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>. 281 282=head2 schema_base_class 283 284Base class for your schema classes. Defaults to 'DBIx::Class::Schema'. 285 286=head2 result_base_class 287 288Base class for your table classes (aka result classes). Defaults to 289'DBIx::Class::Core'. 290 291=head2 additional_base_classes 292 293List of additional base classes all of your table classes will use. 294 295=head2 left_base_classes 296 297List of additional base classes all of your table classes will use 298that need to be leftmost. 299 300=head2 additional_classes 301 302List of additional classes which all of your table classes will use. 303 304=head2 components 305 306List of additional components to be loaded into all of your table 307classes. A good example would be C<ResultSetManager>. 308 309=head2 resultset_components 310 311List of additional ResultSet components to be loaded into your table 312classes. A good example would be C<AlwaysRS>. Component 313C<ResultSetManager> will be automatically added to the above 314C<components> list if this option is set. 315 316=head2 use_namespaces 317 318This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass 319a C<0>. 320 321Generate result class names suitable for 322L<DBIx::Class::Schema/load_namespaces> and call that instead of 323L<DBIx::Class::Schema/load_classes>. When using this option you can also 324specify any of the options for C<load_namespaces> (i.e. C<result_namespace>, 325C<resultset_namespace>, C<default_resultset_class>), and they will be added 326to the call (and the generated result class names adjusted appropriately). 327 328=head2 dump_directory 329 330This option is designed to be a tool to help you transition from this 331loader to a manually-defined schema when you decide it's time to do so. 332 333The value of this option is a perl libdir pathname. Within 334that directory this module will create a baseline manual 335L<DBIx::Class::Schema> module set, based on what it creates at runtime 336in memory. 337 338The created schema class will have the same classname as the one on 339which you are setting this option (and the ResultSource classes will be 340based on this name as well). 341 342Normally you wouldn't hard-code this setting in your schema class, as it 343is meant for one-time manual usage. 344 345See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the 346recommended way to access this functionality. 347 348=head2 dump_overwrite 349 350Deprecated. See L</really_erase_my_files> below, which does *not* mean 351the same thing as the old C<dump_overwrite> setting from previous releases. 352 353=head2 really_erase_my_files 354 355Default false. If true, Loader will unconditionally delete any existing 356files before creating the new ones from scratch when dumping a schema to disk. 357 358The default behavior is instead to only replace the top portion of the 359file, up to and including the final stanza which contains 360C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!> 361leaving any customizations you placed after that as they were. 362 363When C<really_erase_my_files> is not set, if the output file already exists, 364but the aforementioned final stanza is not found, or the checksum 365contained there does not match the generated contents, Loader will 366croak and not touch the file. 367 368You should really be using version control on your schema classes (and all 369of the rest of your code for that matter). Don't blame me if a bug in this 370code wipes something out when it shouldn't have, you've been warned. 371 372=head2 overwrite_modifications 373 374Default false. If false, when updating existing files, Loader will 375refuse to modify any Loader-generated code that has been modified 376since its last run (as determined by the checksum Loader put in its 377comment lines). 378 379If true, Loader will discard any manual modifications that have been 380made to Loader-generated code. 381 382Again, you should be using version control on your schema classes. Be 383careful with this option. 384 385=head2 custom_column_info 386 387Hook for adding extra attributes to the 388L<column_info|DBIx::Class::ResultSource/column_info> for a column. 389 390Must be a coderef that returns a hashref with the extra attributes. 391 392Receives the table name, column name and column_info. 393 394For example: 395 396 custom_column_info => sub { 397 my ($table_name, $column_name, $column_info) = @_; 398 399 if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') { 400 return { is_snoopy => 1 }; 401 } 402 }, 403 404This attribute can also be used to set C<inflate_datetime> on a non-datetime 405column so it also receives the L</datetime_timezone> and/or L</datetime_locale>. 406 407=head2 datetime_timezone 408 409Sets the timezone attribute for L<DBIx::Class::InflateColumn::DateTime> for all 410columns with the DATE/DATETIME/TIMESTAMP data_types. 411 412=head2 datetime_locale 413 414Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all 415columns with the DATE/DATETIME/TIMESTAMP data_types. 416 417=head1 METHODS 418 419None of these methods are intended for direct invocation by regular 420users of L<DBIx::Class::Schema::Loader>. Some are proxied via 421L<DBIx::Class::Schema::Loader>. 422 423=cut 424 425use constant CURRENT_V => 'v5'; 426 427use constant CLASS_ARGS => qw( 428 schema_base_class result_base_class additional_base_classes 429 left_base_classes additional_classes components resultset_components 430); 431 432# ensure that a peice of object data is a valid arrayref, creating 433# an empty one or encapsulating whatever's there. 434sub _ensure_arrayref { 435 my $self = shift; 436 437 foreach (@_) { 438 $self->{$_} ||= []; 439 $self->{$_} = [ $self->{$_} ] 440 unless ref $self->{$_} eq 'ARRAY'; 441 } 442} 443 444=head2 new 445 446Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally 447by L<DBIx::Class::Schema::Loader>. 448 449=cut 450 451sub new { 452 my ( $class, %args ) = @_; 453 454 my $self = { %args }; 455 456 bless $self => $class; 457 458 $self->_ensure_arrayref(qw/additional_classes 459 additional_base_classes 460 left_base_classes 461 components 462 resultset_components 463 /); 464 465 $self->_validate_class_args; 466 467 push(@{$self->{components}}, 'ResultSetManager') 468 if @{$self->{resultset_components}}; 469 470 $self->{monikers} = {}; 471 $self->{classes} = {}; 472 $self->{_upgrading_classes} = {}; 473 474 $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); 475 $self->{schema} ||= $self->{schema_class}; 476 477 croak "dump_overwrite is deprecated. Please read the" 478 . " DBIx::Class::Schema::Loader::Base documentation" 479 if $self->{dump_overwrite}; 480 481 $self->{dynamic} = ! $self->{dump_directory}; 482 $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX', 483 TMPDIR => 1, 484 CLEANUP => 1, 485 ); 486 487 $self->{dump_directory} ||= $self->{temp_directory}; 488 489 $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION); 490 $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION); 491 492 if ((not ref $self->naming) && defined $self->naming) { 493 my $naming_ver = $self->naming; 494 $self->{naming} = { 495 relationships => $naming_ver, 496 monikers => $naming_ver, 497 }; 498 } 499 500 if ($self->naming) { 501 for (values %{ $self->naming }) { 502 $_ = CURRENT_V if $_ eq 'current'; 503 } 504 } 505 $self->{naming} ||= {}; 506 507 if ($self->custom_column_info && ref $self->custom_column_info ne 'CODE') { 508 croak 'custom_column_info must be a CODE ref'; 509 } 510 511 $self->_check_back_compat; 512 513 $self->use_namespaces(1) unless defined $self->use_namespaces; 514 $self->generate_pod(1) unless defined $self->generate_pod; 515 $self->pod_comment_mode('auto') unless defined $self->pod_comment_mode; 516 $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length; 517 518 $self; 519} 520 521sub _check_back_compat { 522 my ($self) = @_; 523 524# dynamic schemas will always be in 0.04006 mode, unless overridden 525 if ($self->dynamic) { 526# just in case, though no one is likely to dump a dynamic schema 527 $self->schema_version_to_dump('0.04006'); 528 529 if (not %{ $self->naming }) { 530 warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; 531 532Dynamic schema detected, will run in 0.04006 mode. 533 534Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable 535to disable this warning. 536 537Also consider setting 'use_namespaces => 1' if/when upgrading. 538 539See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more 540details. 541EOF 542 } 543 else { 544 $self->_upgrading_from('v4'); 545 } 546 547 $self->naming->{relationships} ||= 'v4'; 548 $self->naming->{monikers} ||= 'v4'; 549 550 if ($self->use_namespaces) { 551 $self->_upgrading_from_load_classes(1); 552 } 553 else { 554 $self->use_namespaces(0); 555 } 556 557 return; 558 } 559 560# otherwise check if we need backcompat mode for a static schema 561 my $filename = $self->_get_dump_filename($self->schema_class); 562 return unless -e $filename; 563 564 open(my $fh, '<', $filename) 565 or croak "Cannot open '$filename' for reading: $!"; 566 567 my $load_classes = 0; 568 my $result_namespace = ''; 569 570 while (<$fh>) { 571 if (/^__PACKAGE__->load_classes;/) { 572 $load_classes = 1; 573 } elsif (/result_namespace => '([^']+)'/) { 574 $result_namespace = $1; 575 } elsif (my ($real_ver) = 576 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) { 577 578 if ($load_classes && (not defined $self->use_namespaces)) { 579 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; 580 581'load_classes;' static schema detected, turning off 'use_namespaces'. 582 583Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment 584variable to disable this warning. 585 586See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more 587details. 588EOF 589 $self->use_namespaces(0); 590 } 591 elsif ($load_classes && $self->use_namespaces) { 592 $self->_upgrading_from_load_classes(1); 593 } 594 elsif ((not $load_classes) && defined $self->use_namespaces 595 && (not $self->use_namespaces)) { 596 $self->_downgrading_to_load_classes( 597 $result_namespace || 'Result' 598 ); 599 } 600 elsif ((not defined $self->use_namespaces) 601 || $self->use_namespaces) { 602 if (not $self->result_namespace) { 603 $self->result_namespace($result_namespace || 'Result'); 604 } 605 elsif ($result_namespace ne $self->result_namespace) { 606 $self->_rewriting_result_namespace( 607 $result_namespace || 'Result' 608 ); 609 } 610 } 611 612 # XXX when we go past .0 this will need fixing 613 my ($v) = $real_ver =~ /([1-9])/; 614 $v = "v$v"; 615 616 last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/; 617 618 if (not %{ $self->naming }) { 619 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; 620 621Version $real_ver static schema detected, turning on backcompat mode. 622 623Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable 624to disable this warning. 625 626See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more 627details. 628EOF 629 } 630 else { 631 $self->_upgrading_from($v); 632 last; 633 } 634 635 $self->naming->{relationships} ||= $v; 636 $self->naming->{monikers} ||= $v; 637 638 $self->schema_version_to_dump($real_ver); 639 640 last; 641 } 642 } 643 close $fh; 644} 645 646sub _validate_class_args { 647 my $self = shift; 648 my $args = shift; 649 650 foreach my $k (CLASS_ARGS) { 651 next unless $self->$k; 652 653 my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k; 654 foreach my $c (@classes) { 655 # components default to being under the DBIx::Class namespace unless they 656 # are preceeded with a '+' 657 if ( $k =~ m/components$/ && $c !~ s/^\+// ) { 658 $c = 'DBIx::Class::' . $c; 659 } 660 661 # 1 == installed, 0 == not installed, undef == invalid classname 662 my $installed = Class::Inspector->installed($c); 663 if ( defined($installed) ) { 664 if ( $installed == 0 ) { 665 croak qq/$c, as specified in the loader option "$k", is not installed/; 666 } 667 } else { 668 croak qq/$c, as specified in the loader option "$k", is an invalid class name/; 669 } 670 } 671 } 672} 673 674sub _find_file_in_inc { 675 my ($self, $file) = @_; 676 677 foreach my $prefix (@INC) { 678 my $fullpath = File::Spec->catfile($prefix, $file); 679 return $fullpath if -f $fullpath 680 # abs_path throws on Windows for nonexistant files 681 and eval { Cwd::abs_path($fullpath) } ne 682 (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || ''); 683 } 684 685 return; 686} 687 688sub _class_path { 689 my ($self, $class) = @_; 690 691 my $class_path = $class; 692 $class_path =~ s{::}{/}g; 693 $class_path .= '.pm'; 694 695 return $class_path; 696} 697 698sub _find_class_in_inc { 699 my ($self, $class) = @_; 700 701 return $self->_find_file_in_inc($self->_class_path($class)); 702} 703 704sub _rewriting { 705 my $self = shift; 706 707 return $self->_upgrading_from 708 || $self->_upgrading_from_load_classes 709 || $self->_downgrading_to_load_classes 710 || $self->_rewriting_result_namespace 711 ; 712} 713 714sub _rewrite_old_classnames { 715 my ($self, $code) = @_; 716 717 return $code unless $self->_rewriting; 718 719 my %old_classes = reverse %{ $self->_upgrading_classes }; 720 721 my $re = join '|', keys %old_classes; 722 $re = qr/\b($re)\b/; 723 724 $code =~ s/$re/$old_classes{$1} || $1/eg; 725 726 return $code; 727} 728 729sub _load_external { 730 my ($self, $class) = @_; 731 732 return if $self->{skip_load_external}; 733 734 # so that we don't load our own classes, under any circumstances 735 local *INC = [ grep $_ ne $self->dump_directory, @INC ]; 736 737 my $real_inc_path = $self->_find_class_in_inc($class); 738 739 my $old_class = $self->_upgrading_classes->{$class} 740 if $self->_rewriting; 741 742 my $old_real_inc_path = $self->_find_class_in_inc($old_class) 743 if $old_class && $old_class ne $class; 744 745 return unless $real_inc_path || $old_real_inc_path; 746 747 if ($real_inc_path) { 748 # If we make it to here, we loaded an external definition 749 warn qq/# Loaded external class definition for '$class'\n/ 750 if $self->debug; 751 752 open(my $fh, '<', $real_inc_path) 753 or croak "Failed to open '$real_inc_path' for reading: $!"; 754 my $code = do { local $/; <$fh> }; 755 close($fh) 756 or croak "Failed to close $real_inc_path: $!"; 757 $code = $self->_rewrite_old_classnames($code); 758 759 if ($self->dynamic) { # load the class too 760 # kill redefined warnings 761 my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; 762 local $SIG{__WARN__} = sub { 763 $warn_handler->(@_) 764 unless $_[0] =~ /^Subroutine \S+ redefined/; 765 }; 766 eval $code; 767 die $@ if $@; 768 } 769 770 $self->_ext_stmt($class, 771 qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n| 772 .qq|# They are now part of the custom portion of this file\n| 773 .qq|# for you to hand-edit. If you do not either delete\n| 774 .qq|# this section or remove that file from \@INC, this section\n| 775 .qq|# will be repeated redundantly when you re-create this\n| 776 .qq|# file again via Loader! See skip_load_external to disable\n| 777 .qq|# this feature.\n| 778 ); 779 chomp $code; 780 $self->_ext_stmt($class, $code); 781 $self->_ext_stmt($class, 782 qq|# End of lines loaded from '$real_inc_path' | 783 ); 784 } 785 786 if ($old_real_inc_path) { 787 open(my $fh, '<', $old_real_inc_path) 788 or croak "Failed to open '$old_real_inc_path' for reading: $!"; 789 $self->_ext_stmt($class, <<"EOF"); 790 791# These lines were loaded from '$old_real_inc_path', 792# based on the Result class name that would have been created by an 0.04006 793# version of the Loader. For a static schema, this happens only once during 794# upgrade. See skip_load_external to disable this feature. 795EOF 796 797 my $code = do { 798 local ($/, @ARGV) = (undef, $old_real_inc_path); <> 799 }; 800 $code = $self->_rewrite_old_classnames($code); 801 802 if ($self->dynamic) { 803 warn <<"EOF"; 804 805Detected external content in '$old_real_inc_path', a class name that would have 806been used by an 0.04006 version of the Loader. 807 808* PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the 809new name of the Result. 810EOF 811 # kill redefined warnings 812 my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; 813 local $SIG{__WARN__} = sub { 814 $warn_handler->(@_) 815 unless $_[0] =~ /^Subroutine \S+ redefined/; 816 }; 817 eval $code; 818 die $@ if $@; 819 } 820 821 chomp $code; 822 $self->_ext_stmt($class, $code); 823 $self->_ext_stmt($class, 824 qq|# End of lines loaded from '$old_real_inc_path' | 825 ); 826 } 827} 828 829=head2 load 830 831Does the actual schema-construction work. 832 833=cut 834 835sub load { 836 my $self = shift; 837 838 $self->_load_tables($self->_tables_list); 839} 840 841=head2 rescan 842 843Arguments: schema 844 845Rescan the database for newly added tables. Does 846not process drops or changes. Returns a list of 847the newly added table monikers. 848 849The schema argument should be the schema class 850or object to be affected. It should probably 851be derived from the original schema_class used 852during L</load>. 853 854=cut 855 856sub rescan { 857 my ($self, $schema) = @_; 858 859 $self->{schema} = $schema; 860 $self->_relbuilder->{schema} = $schema; 861 862 my @created; 863 my @current = $self->_tables_list; 864 foreach my $table ($self->_tables_list) { 865 if(!exists $self->{_tables}->{$table}) { 866 push(@created, $table); 867 } 868 } 869 870 my $loaded = $self->_load_tables(@created); 871 872 return map { $self->monikers->{$_} } @$loaded; 873} 874 875sub _relbuilder { 876 no warnings 'uninitialized'; 877 my ($self) = @_; 878 879 return if $self->{skip_relationships}; 880 881 if ($self->naming->{relationships} eq 'v4') { 882 require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040; 883 return $self->{relbuilder} ||= 884 DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new( 885 $self->schema, $self->inflect_plural, $self->inflect_singular 886 ); 887 } 888 889 $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new ( 890 $self->schema, 891 $self->inflect_plural, 892 $self->inflect_singular, 893 $self->relationship_attrs, 894 ); 895} 896 897sub _load_tables { 898 my ($self, @tables) = @_; 899 900 # First, use _tables_list with constraint and exclude 901 # to get a list of tables to operate on 902 903 my $constraint = $self->constraint; 904 my $exclude = $self->exclude; 905 906 @tables = grep { /$constraint/ } @tables if $constraint; 907 @tables = grep { ! /$exclude/ } @tables if $exclude; 908 909 # Save the new tables to the tables list 910 foreach (@tables) { 911 $self->{_tables}->{$_} = 1; 912 } 913 914 $self->_make_src_class($_) for @tables; 915 $self->_setup_src_meta($_) for @tables; 916 917 if(!$self->skip_relationships) { 918 # The relationship loader needs a working schema 919 $self->{quiet} = 1; 920 local $self->{dump_directory} = $self->{temp_directory}; 921 $self->_reload_classes(\@tables); 922 $self->_load_relationships($_) for @tables; 923 $self->{quiet} = 0; 924 925 # Remove that temp dir from INC so it doesn't get reloaded 926 @INC = grep $_ ne $self->dump_directory, @INC; 927 } 928 929 $self->_load_external($_) 930 for map { $self->classes->{$_} } @tables; 931 932 # Reload without unloading first to preserve any symbols from external 933 # packages. 934 $self->_reload_classes(\@tables, 0); 935 936 # Drop temporary cache 937 delete $self->{_cache}; 938 939 return \@tables; 940} 941 942sub _reload_classes { 943 my ($self, $tables, $unload) = @_; 944 945 my @tables = @$tables; 946 $unload = 1 unless defined $unload; 947 948 # so that we don't repeat custom sections 949 @INC = grep $_ ne $self->dump_directory, @INC; 950 951 $self->_dump_to_dir(map { $self->classes->{$_} } @tables); 952 953 unshift @INC, $self->dump_directory; 954 955 my @to_register; 956 my %have_source = map { $_ => $self->schema->source($_) } 957 $self->schema->sources; 958 959 for my $table (@tables) { 960 my $moniker = $self->monikers->{$table}; 961 my $class = $self->classes->{$table}; 962 963 { 964 no warnings 'redefine'; 965 local *Class::C3::reinitialize = sub {}; 966 use warnings; 967 968 Class::Unload->unload($class) if $unload; 969 my ($source, $resultset_class); 970 if ( 971 ($source = $have_source{$moniker}) 972 && ($resultset_class = $source->resultset_class) 973 && ($resultset_class ne 'DBIx::Class::ResultSet') 974 ) { 975 my $has_file = Class::Inspector->loaded_filename($resultset_class); 976 Class::Unload->unload($resultset_class) if $unload; 977 $self->_reload_class($resultset_class) if $has_file; 978 } 979 $self->_reload_class($class); 980 } 981 push @to_register, [$moniker, $class]; 982 } 983 984 Class::C3->reinitialize; 985 for (@to_register) { 986 $self->schema->register_class(@$_); 987 } 988} 989 990# We use this instead of ensure_class_loaded when there are package symbols we 991# want to preserve. 992sub _reload_class { 993 my ($self, $class) = @_; 994 995 my $class_path = $self->_class_path($class); 996 delete $INC{ $class_path }; 997 998# kill redefined warnings 999 my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; 1000 local $SIG{__WARN__} = sub { 1001 $warn_handler->(@_) 1002 unless $_[0] =~ /^Subroutine \S+ redefined/; 1003 }; 1004 eval "require $class;"; 1005} 1006 1007sub _get_dump_filename { 1008 my ($self, $class) = (@_); 1009 1010 $class =~ s{::}{/}g; 1011 return $self->dump_directory . q{/} . $class . q{.pm}; 1012} 1013 1014sub _ensure_dump_subdirs { 1015 my ($self, $class) = (@_); 1016 1017 my @name_parts = split(/::/, $class); 1018 pop @name_parts; # we don't care about the very last element, 1019 # which is a filename 1020 1021 my $dir = $self->dump_directory; 1022 while (1) { 1023 if(!-d $dir) { 1024 mkdir($dir) or croak "mkdir('$dir') failed: $!"; 1025 } 1026 last if !@name_parts; 1027 $dir = File::Spec->catdir($dir, shift @name_parts); 1028 } 1029} 1030 1031sub _dump_to_dir { 1032 my ($self, @classes) = @_; 1033 1034 my $schema_class = $self->schema_class; 1035 my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema'; 1036 1037 my $target_dir = $self->dump_directory; 1038 warn "Dumping manual schema for $schema_class to directory $target_dir ...\n" 1039 unless $self->{dynamic} or $self->{quiet}; 1040 1041 my $schema_text = 1042 qq|package $schema_class;\n\n| 1043 . qq|# Created by DBIx::Class::Schema::Loader\n| 1044 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n| 1045 . qq|use strict;\nuse warnings;\n\n| 1046 . qq|use base '$schema_base_class';\n\n|; 1047 1048 if ($self->use_namespaces) { 1049 $schema_text .= qq|__PACKAGE__->load_namespaces|; 1050 my $namespace_options; 1051 for my $attr (qw(result_namespace 1052 resultset_namespace 1053 default_resultset_class)) { 1054 if ($self->$attr) { 1055 $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n| 1056 } 1057 } 1058 $schema_text .= qq|(\n$namespace_options)| if $namespace_options; 1059 $schema_text .= qq|;\n|; 1060 } 1061 else { 1062 $schema_text .= qq|__PACKAGE__->load_classes;\n|; 1063 } 1064 1065 { 1066 local $self->{version_to_dump} = $self->schema_version_to_dump; 1067 $self->_write_classfile($schema_class, $schema_text, 1); 1068 } 1069 1070 my $result_base_class = $self->result_base_class || 'DBIx::Class::Core'; 1071 1072 foreach my $src_class (@classes) { 1073 my $src_text = 1074 qq|package $src_class;\n\n| 1075 . qq|# Created by DBIx::Class::Schema::Loader\n| 1076 . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n| 1077 . qq|use strict;\nuse warnings;\n\n| 1078 . qq|use base '$result_base_class';\n\n|; 1079 1080 $self->_write_classfile($src_class, $src_text); 1081 } 1082 1083 # remove Result dir if downgrading from use_namespaces, and there are no 1084 # files left. 1085 if (my $result_ns = $self->_downgrading_to_load_classes 1086 || $self->_rewriting_result_namespace) { 1087 my $result_namespace = $self->_result_namespace( 1088 $schema_class, 1089 $result_ns, 1090 ); 1091 1092 (my $result_dir = $result_namespace) =~ s{::}{/}g; 1093 $result_dir = $self->dump_directory . '/' . $result_dir; 1094 1095 unless (my @files = glob "$result_dir/*") { 1096 rmdir $result_dir; 1097 } 1098 } 1099 1100 warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet}; 1101 1102} 1103 1104sub _sig_comment { 1105 my ($self, $version, $ts) = @_; 1106 return qq|\n\n# Created by DBIx::Class::Schema::Loader| 1107 . qq| v| . $version 1108 . q| @ | . $ts 1109 . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|; 1110} 1111 1112sub _write_classfile { 1113 my ($self, $class, $text, $is_schema) = @_; 1114 1115 my $filename = $self->_get_dump_filename($class); 1116 $self->_ensure_dump_subdirs($class); 1117 1118 if (-f $filename && $self->really_erase_my_files) { 1119 warn "Deleting existing file '$filename' due to " 1120 . "'really_erase_my_files' setting\n" unless $self->{quiet}; 1121 unlink($filename); 1122 } 1123 1124 my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename); 1125 1126 if (my $old_class = $self->_upgrading_classes->{$class}) { 1127 my $old_filename = $self->_get_dump_filename($old_class); 1128 1129 my ($old_custom_content) = $self->_get_custom_content( 1130 $old_class, $old_filename, 0 # do not add default comment 1131 ); 1132 1133 $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//; 1134 1135 if ($old_custom_content) { 1136 $custom_content = 1137 "\n" . $old_custom_content . "\n" . $custom_content; 1138 } 1139 1140 unlink $old_filename; 1141 } 1142 1143 $custom_content = $self->_rewrite_old_classnames($custom_content); 1144 1145 $text .= qq|$_\n| 1146 for @{$self->{_dump_storage}->{$class} || []}; 1147 1148 # Check and see if the dump is infact differnt 1149 1150 my $compare_to; 1151 if ($old_md5) { 1152 $compare_to = $text . $self->_sig_comment($old_ver, $old_ts); 1153 1154 1155 if (Digest::MD5::md5_base64($compare_to) eq $old_md5) { 1156 return unless $self->_upgrading_from && $is_schema; 1157 } 1158 } 1159 1160 $text .= $self->_sig_comment( 1161 $self->version_to_dump, 1162 POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime) 1163 ); 1164 1165 open(my $fh, '>', $filename) 1166 or croak "Cannot open '$filename' for writing: $!"; 1167 1168 # Write the top half and its MD5 sum 1169 print $fh $text . Digest::MD5::md5_base64($text) . "\n"; 1170 1171 # Write out anything loaded via external partial class file in @INC 1172 print $fh qq|$_\n| 1173 for @{$self->{_ext_storage}->{$class} || []}; 1174 1175 # Write out any custom content the user has added 1176 print $fh $custom_content; 1177 1178 close($fh) 1179 or croak "Error closing '$filename': $!"; 1180} 1181 1182sub _default_custom_content { 1183 return qq|\n\n# You can replace this text with custom| 1184 . qq| content, and it will be preserved on regeneration| 1185 . qq|\n1;\n|; 1186} 1187 1188sub _get_custom_content { 1189 my ($self, $class, $filename, $add_default) = @_; 1190 1191 $add_default = 1 unless defined $add_default; 1192 1193 return ($self->_default_custom_content) if ! -f $filename; 1194 1195 open(my $fh, '<', $filename) 1196 or croak "Cannot open '$filename' for reading: $!"; 1197 1198 my $mark_re = 1199 qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n}; 1200 1201 my $buffer = ''; 1202 my ($md5, $ts, $ver); 1203 while(<$fh>) { 1204 if(!$md5 && /$mark_re/) { 1205 $md5 = $2; 1206 my $line = $1; 1207 1208 # Pull out the previous version and timestamp 1209 ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s; 1210 1211 $buffer .= $line; 1212 croak "Checksum mismatch in '$filename', 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" 1213 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5; 1214 1215 $buffer = ''; 1216 } 1217 else { 1218 $buffer .= $_; 1219 } 1220 } 1221 1222 croak "Cannot not overwrite '$filename' without 'really_erase_my_files'," 1223 . " it does not appear to have been generated by Loader" 1224 if !$md5; 1225 1226 # Default custom content: 1227 $buffer ||= $self->_default_custom_content if $add_default; 1228 1229 return ($buffer, $md5, $ver, $ts); 1230} 1231 1232sub _use { 1233 my $self = shift; 1234 my $target = shift; 1235 1236 foreach (@_) { 1237 warn "$target: use $_;" if $self->debug; 1238 $self->_raw_stmt($target, "use $_;"); 1239 } 1240} 1241 1242sub _inject { 1243 my $self = shift; 1244 my $target = shift; 1245 my $schema_class = $self->schema_class; 1246 1247 my $blist = join(q{ }, @_); 1248 warn "$target: use base qw/ $blist /;" if $self->debug && @_; 1249 $self->_raw_stmt($target, "use base qw/ $blist /;") if @_; 1250} 1251 1252sub _result_namespace { 1253 my ($self, $schema_class, $ns) = @_; 1254 my @result_namespace; 1255 1256 if ($ns =~ /^\+(.*)/) { 1257 # Fully qualified namespace 1258 @result_namespace = ($1) 1259 } 1260 else { 1261 # Relative namespace 1262 @result_namespace = ($schema_class, $ns); 1263 } 1264 1265 return wantarray ? @result_namespace : join '::', @result_namespace; 1266} 1267 1268# Create class with applicable bases, setup monikers, etc 1269sub _make_src_class { 1270 my ($self, $table) = @_; 1271 1272 my $schema = $self->schema; 1273 my $schema_class = $self->schema_class; 1274 1275 my $table_moniker = $self->_table2moniker($table); 1276 my @result_namespace = ($schema_class); 1277 if ($self->use_namespaces) { 1278 my $result_namespace = $self->result_namespace || 'Result'; 1279 @result_namespace = $self->_result_namespace( 1280 $schema_class, 1281 $result_namespace, 1282 ); 1283 } 1284 my $table_class = join(q{::}, @result_namespace, $table_moniker); 1285 1286 if ((my $upgrading_v = $self->_upgrading_from) 1287 || $self->_rewriting) { 1288 local $self->naming->{monikers} = $upgrading_v 1289 if $upgrading_v; 1290 1291 my @result_namespace = @result_namespace; 1292 if ($self->_upgrading_from_load_classes) { 1293 @result_namespace = ($schema_class); 1294 } 1295 elsif (my $ns = $self->_downgrading_to_load_classes) { 1296 @result_namespace = $self->_result_namespace( 1297 $schema_class, 1298 $ns, 1299 ); 1300 } 1301 elsif ($ns = $self->_rewriting_result_namespace) { 1302 @result_namespace = $self->_result_namespace( 1303 $schema_class, 1304 $ns, 1305 ); 1306 } 1307 1308 my $old_class = join(q{::}, @result_namespace, 1309 $self->_table2moniker($table)); 1310 1311 $self->_upgrading_classes->{$table_class} = $old_class 1312 unless $table_class eq $old_class; 1313 } 1314 1315 my $table_normalized = lc $table; 1316 $self->classes->{$table} = $table_class; 1317 $self->classes->{$table_normalized} = $table_class; 1318 $self->monikers->{$table} = $table_moniker; 1319 $self->monikers->{$table_normalized} = $table_moniker; 1320 1321 $self->_use ($table_class, @{$self->additional_classes}); 1322 $self->_inject($table_class, @{$self->left_base_classes}); 1323 1324 if (my @components = @{ $self->components }) { 1325 $self->_dbic_stmt($table_class, 'load_components', @components); 1326 } 1327 1328 $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components}) 1329 if @{$self->resultset_components}; 1330 $self->_inject($table_class, @{$self->additional_base_classes}); 1331} 1332 1333# Set up metadata (cols, pks, etc) 1334sub _setup_src_meta { 1335 my ($self, $table) = @_; 1336 1337 my $schema = $self->schema; 1338 my $schema_class = $self->schema_class; 1339 1340 my $table_class = $self->classes->{$table}; 1341 my $table_moniker = $self->monikers->{$table}; 1342 1343 my $table_name = $table; 1344 my $name_sep = $self->schema->storage->sql_maker->name_sep; 1345 1346 if ($name_sep && $table_name =~ /\Q$name_sep\E/) { 1347 $table_name = \ $self->_quote_table_name($table_name); 1348 } 1349 1350 $self->_dbic_stmt($table_class,'table',$table_name); 1351 1352 my $cols = $self->_table_columns($table); 1353 my $col_info; 1354 eval { $col_info = $self->__columns_info_for($table) }; 1355 if($@) { 1356 $self->_dbic_stmt($table_class,'add_columns',@$cols); 1357 } 1358 else { 1359 if ($self->_is_case_sensitive) { 1360 for my $col (keys %$col_info) { 1361 $col_info->{$col}{accessor} = lc $col 1362 if $col ne lc($col); 1363 } 1364 } else { 1365 $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info }; 1366 } 1367 1368 my $fks = $self->_table_fk_info($table); 1369 1370 for my $fkdef (@$fks) { 1371 for my $col (@{ $fkdef->{local_columns} }) { 1372 $col_info->{$col}{is_foreign_key} = 1; 1373 } 1374 } 1375 $self->_dbic_stmt( 1376 $table_class, 1377 'add_columns', 1378 map { $_, ($col_info->{$_}||{}) } @$cols 1379 ); 1380 } 1381 1382 my %uniq_tag; # used to eliminate duplicate uniqs 1383 1384 my $pks = $self->_table_pk_info($table) || []; 1385 @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks) 1386 : carp("$table has no primary key"); 1387 $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq 1388 1389 my $uniqs = $self->_table_uniq_info($table) || []; 1390 for (@$uniqs) { 1391 my ($name, $cols) = @$_; 1392 next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates 1393 $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols); 1394 } 1395 1396} 1397 1398sub __columns_info_for { 1399 my ($self, $table) = @_; 1400 1401 my $result = $self->_columns_info_for($table); 1402 1403 while (my ($col, $info) = each %$result) { 1404 $info = { %$info, %{ $self->_custom_column_info ($table, $col, $info) } }; 1405 $info = { %$info, %{ $self->_datetime_column_info($table, $col, $info) } }; 1406 1407 $result->{$col} = $info; 1408 } 1409 1410 return $result; 1411} 1412 1413=head2 tables 1414 1415Returns a sorted list of loaded tables, using the original database table 1416names. 1417 1418=cut 1419 1420sub tables { 1421 my $self = shift; 1422 1423 return keys %{$self->_tables}; 1424} 1425 1426# Make a moniker from a table 1427sub _default_table2moniker { 1428 no warnings 'uninitialized'; 1429 my ($self, $table) = @_; 1430 1431 if ($self->naming->{monikers} eq 'v4') { 1432 return join '', map ucfirst, split /[\W_]+/, lc $table; 1433 } 1434 1435 return join '', map ucfirst, split /[\W_]+/, 1436 Lingua::EN::Inflect::Number::to_S(lc $table); 1437} 1438 1439sub _table2moniker { 1440 my ( $self, $table ) = @_; 1441 1442 my $moniker; 1443 1444 if( ref $self->moniker_map eq 'HASH' ) { 1445 $moniker = $self->moniker_map->{$table}; 1446 } 1447 elsif( ref $self->moniker_map eq 'CODE' ) { 1448 $moniker = $self->moniker_map->($table); 1449 } 1450 1451 $moniker ||= $self->_default_table2moniker($table); 1452 1453 return $moniker; 1454} 1455 1456sub _load_relationships { 1457 my ($self, $table) = @_; 1458 1459 my $tbl_fk_info = $self->_table_fk_info($table); 1460 foreach my $fkdef (@$tbl_fk_info) { 1461 $fkdef->{remote_source} = 1462 $self->monikers->{delete $fkdef->{remote_table}}; 1463 } 1464 my $tbl_uniq_info = $self->_table_uniq_info($table); 1465 1466 my $local_moniker = $self->monikers->{$table}; 1467 my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info); 1468 1469 foreach my $src_class (sort keys %$rel_stmts) { 1470 my $src_stmts = $rel_stmts->{$src_class}; 1471 foreach my $stmt (@$src_stmts) { 1472 $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}}); 1473 } 1474 } 1475} 1476 1477# Overload these in driver class: 1478 1479# Returns an arrayref of column names 1480sub _table_columns { croak "ABSTRACT METHOD" } 1481 1482# Returns arrayref of pk col names 1483sub _table_pk_info { croak "ABSTRACT METHOD" } 1484 1485# Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ] 1486sub _table_uniq_info { croak "ABSTRACT METHOD" } 1487 1488# Returns an arrayref of foreign key constraints, each 1489# being a hashref with 3 keys: 1490# local_columns (arrayref), remote_columns (arrayref), remote_table 1491sub _table_fk_info { croak "ABSTRACT METHOD" } 1492 1493# Returns an array of lower case table names 1494sub _tables_list { croak "ABSTRACT METHOD" } 1495 1496# Execute a constructive DBIC class method, with debug/dump_to_dir hooks. 1497sub _dbic_stmt { 1498 my $self = shift; 1499 my $class = shift; 1500 my $method = shift; 1501 1502 # generate the pod for this statement, storing it with $self->_pod 1503 $self->_make_pod( $class, $method, @_ ) if $self->generate_pod; 1504 1505 my $args = dump(@_); 1506 $args = '(' . $args . ')' if @_ < 2; 1507 my $stmt = $method . $args . q{;}; 1508 1509 warn qq|$class\->$stmt\n| if $self->debug; 1510 $self->_raw_stmt($class, '__PACKAGE__->' . $stmt); 1511 return; 1512} 1513 1514# generates the accompanying pod for a DBIC class method statement, 1515# storing it with $self->_pod 1516sub _make_pod { 1517 my $self = shift; 1518 my $class = shift; 1519 my $method = shift; 1520 1521 if ( $method eq 'table' ) { 1522 my ($table) = @_; 1523 my $pcm = $self->pod_comment_mode; 1524 my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc); 1525 if ( $self->can('_table_comment') ) { 1526 $comment = $self->_table_comment($table); 1527 $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length); 1528 $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows)); 1529 $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows)); 1530 } 1531 $self->_pod( $class, "=head1 NAME" ); 1532 my $table_descr = $class; 1533 $table_descr .= " - " . $comment if $comment and $comment_in_name; 1534 $self->{_class2table}{ $class } = $table; 1535 $self->_pod( $class, $table_descr ); 1536 if ($comment and $comment_in_desc) { 1537 $self->_pod( $class, "=head1 DESCRIPTION" ); 1538 $self->_pod( $class, $comment ); 1539 } 1540 $self->_pod_cut( $class ); 1541 } elsif ( $method eq 'add_columns' ) { 1542 $self->_pod( $class, "=head1 ACCESSORS" ); 1543 my $col_counter = 0; 1544 my @cols = @_; 1545 while( my ($name,$attrs) = splice @cols,0,2 ) { 1546 $col_counter++; 1547 $self->_pod( $class, '=head2 ' . $name ); 1548 $self->_pod( $class, 1549 join "\n", map { 1550 my $s = $attrs->{$_}; 1551 $s = !defined $s ? 'undef' : 1552 length($s) == 0 ? '(empty string)' : 1553 ref($s) eq 'SCALAR' ? $$s : 1554 $s 1555 ; 1556 1557 " $_: $s" 1558 } sort keys %$attrs, 1559 ); 1560 1561 if( $self->can('_column_comment') 1562 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter) 1563 ) { 1564 $self->_pod( $class, $comment ); 1565 } 1566 } 1567 $self->_pod_cut( $class ); 1568 } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) { 1569 $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ; 1570 my ( $accessor, $rel_class ) = @_; 1571 $self->_pod( $class, "=head2 $accessor" ); 1572 $self->_pod( $class, 'Type: ' . $method ); 1573 $self->_pod( $class, "Related object: L<$rel_class>" ); 1574 $self->_pod_cut( $class ); 1575 $self->{_relations_started} { $class } = 1; 1576 } 1577} 1578 1579# Stores a POD documentation 1580sub _pod { 1581 my ($self, $class, $stmt) = @_; 1582 $self->_raw_stmt( $class, "\n" . $stmt ); 1583} 1584 1585sub _pod_cut { 1586 my ($self, $class ) = @_; 1587 $self->_raw_stmt( $class, "\n=cut\n" ); 1588} 1589 1590# Store a raw source line for a class (for dumping purposes) 1591sub _raw_stmt { 1592 my ($self, $class, $stmt) = @_; 1593 push(@{$self->{_dump_storage}->{$class}}, $stmt); 1594} 1595 1596# Like above, but separately for the externally loaded stuff 1597sub _ext_stmt { 1598 my ($self, $class, $stmt) = @_; 1599 push(@{$self->{_ext_storage}->{$class}}, $stmt); 1600} 1601 1602sub _quote_table_name { 1603 my ($self, $table) = @_; 1604 1605 my $qt = $self->schema->storage->sql_maker->quote_char; 1606 1607 return $table unless $qt; 1608 1609 if (ref $qt) { 1610 return $qt->[0] . $table . $qt->[1]; 1611 } 1612 1613 return $qt . $table . $qt; 1614} 1615 1616sub _is_case_sensitive { 0 } 1617 1618sub _custom_column_info { 1619 my ( $self, $table_name, $column_name, $column_info ) = @_; 1620 1621 if (my $code = $self->custom_column_info) { 1622 return $code->($table_name, $column_name, $column_info) || {}; 1623 } 1624 return {}; 1625} 1626 1627sub _datetime_column_info { 1628 my ( $self, $table_name, $column_name, $column_info ) = @_; 1629 my $result = {}; 1630 my $type = $column_info->{data_type} || ''; 1631 if ((grep $_, @{ $column_info }{map "inflate_$_", qw/date datetime timestamp/}) 1632 or ($type =~ /date|timestamp/i)) { 1633 $result->{timezone} = $self->datetime_timezone if $self->datetime_timezone; 1634 $result->{locale} = $self->datetime_locale if $self->datetime_locale; 1635 } 1636 return $result; 1637} 1638 1639# remove the dump dir from @INC on destruction 1640sub DESTROY { 1641 my $self = shift; 1642 1643 @INC = grep $_ ne $self->dump_directory, @INC; 1644} 1645 1646=head2 monikers 1647 1648Returns a hashref of loaded table to moniker mappings. There will 1649be two entries for each table, the original name and the "normalized" 1650name, in the case that the two are different (such as databases 1651that like uppercase table names, or preserve your original mixed-case 1652definitions, or what-have-you). 1653 1654=head2 classes 1655 1656Returns a hashref of table to class mappings. In some cases it will 1657contain multiple entries per table for the original and normalized table 1658names, as above in L</monikers>. 1659 1660=head1 SEE ALSO 1661 1662L<DBIx::Class::Schema::Loader> 1663 1664=head1 AUTHOR 1665 1666See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 1667 1668=head1 LICENSE 1669 1670This library is free software; you can redistribute it and/or modify it under 1671the same terms as Perl itself. 1672 1673=cut 1674 16751; 1676