lib/DBIx/Class/Schema/Loader/Base.pm

   1 package DBIx::Class::Schema::Loader::Base;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/Class::Accessor::Fast/;
   6 use Class::C3;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use UNIVERSAL::require;
   9 use DBIx::Class::Schema::Loader::RelBuilder;
  10 use Data::Dump qw/ dump /;
  11 use POSIX qw//;
  12 use File::Spec qw//;
  13 use Cwd qw//;
  14 use Digest::MD5 qw//;
  15 require DBIx::Class;
  16
  17 our $VERSION = '0.03999_01';
  18
  19 __PACKAGE__->mk_ro_accessors(qw/
  20                                 schema
  21                                 schema_class
  22
  23                                 exclude
  24                                 constraint
  25                                 additional_classes
  26                                 additional_base_classes
  27                                 left_base_classes
  28                                 components
  29                                 resultset_components
  30                                 skip_relationships
  31                                 moniker_map
  32                                 inflect_singular
  33                                 inflect_plural
  34                                 debug
  35                                 dump_directory
  36                                 dump_overwrite
  37
  38                                 db_schema
  39                                 _tables
  40                                 classes
  41                                 monikers
  42                              /);
  43
  44 =head1 NAME
  45
  46 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  47
  48 =head1 SYNOPSIS
  49
  50 See L<DBIx::Class::Schema::Loader>
  51
  52 =head1 DESCRIPTION
  53
  54 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  55 classes, and implements the common functionality between them.
  56
  57 =head1 CONSTRUCTOR OPTIONS
  58
  59 These constructor options are the base options for
  60 L<DBIx::Class::Schema::Loader/loader_opts>.  Available constructor options are:
  61
  62 =head2 skip_relationships
  63
  64 Skip setting up relationships.  The default is to attempt the loading
  65 of relationships.
  66
  67 =head2 debug
  68
  69 If set to true, each constructive L<DBIx::Class> statement the loader
  70 decides to execute will be C<warn>-ed before execution.
  71
  72 =head2 db_schema
  73
  74 Set the name of the schema to load (schema in the sense that your database
  75 vendor means it).  Does not currently support loading more than one schema
  76 name.
  77
  78 =head2 constraint
  79
  80 Only load tables matching regex.  Best specified as a qr// regex.
  81
  82 =head2 exclude
  83
  84 Exclude tables matching regex.  Best specified as a qr// regex.
  85
  86 =head2 moniker_map
  87
  88 Overrides the default table name to moniker translation.  Can be either
  89 a hashref of table keys and moniker values, or a coderef for a translator
  90 function taking a single scalar table name argument and returning
  91 a scalar moniker.  If the hash entry does not exist, or the function
  92 returns a false value, the code falls back to default behavior
  93 for that table name.
  94
  95 The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
  96 which is to say: lowercase everything, split up the table name into chunks
  97 anywhere a non-alpha-numeric character occurs, change the case of first letter
  98 of each chunk to upper case, and put the chunks back together.  Examples:
  99
 100     Table Name  | Moniker Name
 101     ---------------------------
 102     luser       | Luser
 103     luser_group | LuserGroup
 104     luser-opts  | LuserOpts
 105
 106 =head2 inflect_plural
 107
 108 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 109 if hash key does not exist or coderef returns false), but acts as a map
 110 for pluralizing relationship names.  The default behavior is to utilize
 111 L<Lingua::EN::Inflect::Number/to_PL>.
 112
 113 =head2 inflect_singular
 114
 115 As L</inflect_plural> above, but for singularizing relationship names.
 116 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 117
 118 =head2 additional_base_classes
 119
 120 List of additional base classes all of your table classes will use.
 121
 122 =head2 left_base_classes
 123
 124 List of additional base classes all of your table classes will use
 125 that need to be leftmost.
 126
 127 =head2 additional_classes
 128
 129 List of additional classes which all of your table classes will use.
 130
 131 =head2 components
 132
 133 List of additional components to be loaded into all of your table
 134 classes.  A good example would be C<ResultSetManager>.
 135
 136 =head2 resultset_components
 137
 138 List of additional ResultSet components to be loaded into your table
 139 classes.  A good example would be C<AlwaysRS>.  Component
 140 C<ResultSetManager> will be automatically added to the above
 141 C<components> list if this option is set.
 142
 143 =head2 dump_directory
 144
 145 This option is designed to be a tool to help you transition from this
 146 loader to a manually-defined schema when you decide it's time to do so.
 147
 148 The value of this option is a perl libdir pathname.  Within
 149 that directory this module will create a baseline manual
 150 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 151 in memory.
 152
 153 The created schema class will have the same classname as the one on
 154 which you are setting this option (and the ResultSource classes will be
 155 based on this name as well).
 156
 157 Normally you wouldn't hard-code this setting in your schema class, as it
 158 is meant for one-time manual usage.
 159
 160 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 161 recommended way to access this functionality.
 162
 163 =head2 dump_overwrite
 164
 165 Default false.  If true, Loader will unconditionally delete any existing
 166 files before creating the new ones from scratch when dumping a schema to disk.
 167
 168 The default behavior is instead to only replace the top portion of the
 169 file, up to and including the final stanza which contains
 170 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
 171 leaving any customizations you placed after that as they were.
 172
 173 When C<dump_overwrite> is not set, if the output file already exists,
 174 but the aforementioned final stanza is not found, or the checksum
 175 contained there does not match the generated contents, Loader will
 176 croak and not touch the file.
 177
 178 =head1 METHODS
 179
 180 None of these methods are intended for direct invocation by regular
 181 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
 182 can also be found via standard L<DBIx::Class::Schema> methods somehow.
 183
 184 =cut
 185
 186 # ensure that a peice of object data is a valid arrayref, creating
 187 # an empty one or encapsulating whatever's there.
 188 sub _ensure_arrayref {
 189     my $self = shift;
 190
 191     foreach (@_) {
 192         $self->{$_} ||= [];
 193         $self->{$_} = [ $self->{$_} ]
 194             unless ref $self->{$_} eq 'ARRAY';
 195     }
 196 }
 197
 198 =head2 new
 199
 200 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 201 by L<DBIx::Class::Schema::Loader>.
 202
 203 =cut
 204
 205 sub new {
 206     my ( $class, %args ) = @_;
 207
 208     my $self = { %args };
 209
 210     bless $self => $class;
 211
 212     $self->{db_schema}  ||= '';
 213     $self->_ensure_arrayref(qw/additional_classes
 214                                additional_base_classes
 215                                left_base_classes
 216                                components
 217                                resultset_components
 218                               /);
 219
 220     push(@{$self->{components}}, 'ResultSetManager')
 221         if @{$self->{resultset_components}};
 222
 223     $self->{monikers} = {};
 224     $self->{classes} = {};
 225
 226     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 227     $self->{schema} ||= $self->{schema_class};
 228
 229     $self;
 230 }
 231
 232 sub _find_file_in_inc {
 233     my ($self, $file) = @_;
 234
 235     foreach my $prefix (@INC) {
 236         my $fullpath = $prefix . '/' . $file;
 237         return $fullpath if -f $fullpath;
 238     }
 239
 240     return;
 241 }
 242
 243 sub _load_external {
 244     my $self = shift;
 245
 246     foreach my $class ($self->schema_class, values %{$self->classes}) {
 247         my $class_path = $class;
 248         $class_path =~ s{::}{/}g;
 249         $class_path .= '.pm';
 250
 251         my $inc_path = $self->_find_file_in_inc($class_path);
 252
 253         next if !$inc_path;
 254
 255         my $real_dump_path = $self->dump_directory
 256             ? Cwd::abs_path(
 257                   File::Spec->catfile($self->dump_directory, $class_path)
 258               )
 259             : '';
 260         my $real_inc_path = Cwd::abs_path($inc_path);
 261         next if $real_inc_path eq $real_dump_path;
 262
 263         $class->require;
 264         croak "Failed to load external class definition"
 265             . " for '$class': $@"
 266                 if $@;
 267
 268         # If we make it to here, we loaded an external definition
 269         warn qq/# Loaded external class definition for '$class'\n/
 270             if $self->debug;
 271
 272         # The rest is only relevant when dumping
 273         next if !$self->dump_directory;
 274
 275         croak 'Failed to locate actual external module file for '
 276               . "'$class'"
 277                   if !$real_inc_path;
 278         open(my $fh, '<', $real_inc_path)
 279             or croak "Failed to open '$real_inc_path' for reading: $!";
 280         $self->_ext_stmt($class,
 281             qq|# These lines were loaded from '$real_inc_path' found in \@INC.|
 282             .q|# They are now part of the custom portion of this file|
 283             .q|# for you to hand-edit.  If you do not either delete|
 284             .q|# this section or remove that file from @INC, this section|
 285             .q|# will be repeated redundantly when you re-create this|
 286             .q|# file again via Loader!|
 287         );
 288         while(<$fh>) {
 289             chomp;
 290             $self->_ext_stmt($class, $_);
 291         }
 292         $self->_ext_stmt($class,
 293             q|# End of lines loaded from '$real_inc_path' |
 294         );
 295         close($fh)
 296             or croak "Failed to close $real_inc_path: $!";
 297     }
 298 }
 299
 300 =head2 load
 301
 302 Does the actual schema-construction work.
 303
 304 =cut
 305
 306 sub load {
 307     my $self = shift;
 308
 309     $self->_load_classes;
 310     $self->_load_relationships if ! $self->skip_relationships;
 311     $self->_load_external;
 312     $self->_dump_to_dir if $self->dump_directory;
 313
 314     # Drop temporary cache
 315     delete $self->{_cache};
 316
 317     1;
 318 }
 319
 320 sub _get_dump_filename {
 321     my ($self, $class) = (@_);
 322
 323     $class =~ s{::}{/}g;
 324     return $self->dump_directory . q{/} . $class . q{.pm};
 325 }
 326
 327 sub _ensure_dump_subdirs {
 328     my ($self, $class) = (@_);
 329
 330     my @name_parts = split(/::/, $class);
 331     pop @name_parts; # we don't care about the very last element,
 332                      # which is a filename
 333
 334     my $dir = $self->dump_directory;
 335     while (1) {
 336         if(!-d $dir) {
 337             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 338         }
 339         last if !@name_parts;
 340         $dir = File::Spec->catdir($dir, shift @name_parts);
 341     }
 342 }
 343
 344 sub _dump_to_dir {
 345     my ($self) = @_;
 346
 347     my $target_dir = $self->dump_directory;
 348
 349     my $schema_class = $self->schema_class;
 350
 351     croak "Must specify target directory for dumping!" if ! $target_dir;
 352
 353     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n";
 354
 355     my $schema_text =
 356           qq|package $schema_class;\n\n|
 357         . qq|use strict;\nuse warnings;\n\n|
 358         . qq|use base 'DBIx::Class::Schema';\n\n|
 359         . qq|__PACKAGE__->load_classes;\n|;
 360
 361     $self->_write_classfile($schema_class, $schema_text);
 362
 363     foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
 364         my $src_text =
 365               qq|package $src_class;\n\n|
 366             . qq|use strict;\nuse warnings;\n\n|
 367             . qq|use base 'DBIx::Class';\n\n|;
 368
 369         $self->_write_classfile($src_class, $src_text);
 370     }
 371
 372     warn "Schema dump completed.\n";
 373 }
 374
 375 sub _write_classfile {
 376     my ($self, $class, $text) = @_;
 377
 378     my $filename = $self->_get_dump_filename($class);
 379     $self->_ensure_dump_subdirs($class);
 380
 381     if (-f $filename && $self->dump_overwrite) {
 382         warn "Deleting existing file '$filename' due to "
 383             . "'dump_overwrite' setting\n";
 384         unlink($filename);
 385     }
 386
 387     my $custom_content = $self->_get_custom_content($class, $filename);
 388
 389     $custom_content ||= qq|\n# You can replace this text with custom|
 390         . qq| content, and it will be preserved on regeneration|
 391         . qq|\n1;\n|;
 392
 393     $text .= qq|$_\n|
 394         for @{$self->{_dump_storage}->{$class} || []};
 395
 396     $text .= qq|\n\n# Created by DBIx::Class::Schema::Loader|
 397         . qq| v| . $DBIx::Class::Schema::Loader::VERSION
 398         . q| @ | . POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
 399         . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 400
 401     open(my $fh, '>', $filename)
 402         or croak "Cannot open '$filename' for writing: $!";
 403
 404     # Write the top half and its MD5 sum
 405     print $fh $text . Digest::MD5::md5_base64($text) . "\n\n";
 406
 407     # Write out anything loaded via external partial class file in @INC
 408     print $fh qq|$_\n|
 409         for @{$self->{_ext_storage}->{$class} || []};
 410
 411     print $fh $custom_content;
 412
 413     close($fh)
 414         or croak "Cannot close '$filename': $!";
 415 }
 416
 417 sub _get_custom_content {
 418     my ($self, $class, $filename) = @_;
 419
 420     return if ! -f $filename;
 421     open(my $fh, '<', $filename)
 422         or croak "Cannot open '$filename' for reading: $!";
 423
 424     my $mark_re =
 425         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
 426
 427     my $found = 0;
 428     my $buffer = '';
 429     while(<$fh>) {
 430         if(!$found && /$mark_re/) {
 431             $found = 1;
 432             $buffer .= $1;
 433             croak "Checksum mismatch in '$filename'"
 434                 if Digest::MD5::md5_base64($buffer) ne $2;
 435
 436             $buffer = '';
 437         }
 438         else {
 439             $buffer .= $_;
 440         }
 441     }
 442
 443     croak "Cannot not overwrite '$filename' without 'dump_overwrite',"
 444         . " it does not appear to have been generated by Loader"
 445             if !$found;
 446
 447     return $buffer;
 448 }
 449
 450 sub _use {
 451     my $self = shift;
 452     my $target = shift;
 453     my $evalstr;
 454
 455     foreach (@_) {
 456         warn "$target: use $_;" if $self->debug;
 457         $self->_raw_stmt($target, "use $_;");
 458         $_->require or croak ($_ . "->require: $@");
 459         $evalstr .= "package $target; use $_;";
 460     }
 461     eval $evalstr if $evalstr;
 462     croak $@ if $@;
 463 }
 464
 465 sub _inject {
 466     my $self = shift;
 467     my $target = shift;
 468     my $schema_class = $self->schema_class;
 469
 470     my $blist = join(q{ }, @_);
 471     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
 472     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
 473     foreach (@_) {
 474         $_->require or croak ($_ . "->require: $@");
 475         $schema_class->inject_base($target, $_);
 476     }
 477 }
 478
 479 # Load and setup classes
 480 sub _load_classes {
 481     my $self = shift;
 482
 483     my $schema       = $self->schema;
 484     my $schema_class = $self->schema_class;
 485     my $constraint   = $self->constraint;
 486     my $exclude      = $self->exclude;
 487     my @tables       = sort $self->_tables_list;
 488
 489     warn "No tables found in database, nothing to load" if !@tables;
 490
 491     if(@tables) {
 492         @tables = grep { /$constraint/ } @tables if $constraint;
 493         @tables = grep { ! /$exclude/ } @tables if $exclude;
 494
 495         warn "All tables excluded by constraint/exclude, nothing to load"
 496             if !@tables;
 497     }
 498
 499     $self->{_tables} = \@tables;
 500
 501     foreach my $table (@tables) {
 502         my $table_moniker = $self->_table2moniker($table);
 503         my $table_class = $schema_class . q{::} . $table_moniker;
 504
 505         my $table_normalized = lc $table;
 506         $self->classes->{$table} = $table_class;
 507         $self->classes->{$table_normalized} = $table_class;
 508         $self->monikers->{$table} = $table_moniker;
 509         $self->monikers->{$table_normalized} = $table_moniker;
 510
 511         no warnings 'redefine';
 512         local *Class::C3::reinitialize = sub { };
 513         use warnings;
 514
 515         { no strict 'refs'; @{"${table_class}::ISA"} = qw/DBIx::Class/ }
 516
 517         $self->_use   ($table_class, @{$self->additional_classes});
 518         $self->_inject($table_class, @{$self->additional_base_classes});
 519
 520         $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, qw/PK::Auto Core/);
 521
 522         $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
 523             if @{$self->resultset_components};
 524         $self->_inject($table_class, @{$self->left_base_classes});
 525     }
 526
 527     Class::C3::reinitialize;
 528
 529     foreach my $table (@tables) {
 530         my $table_class = $self->classes->{$table};
 531         my $table_moniker = $self->monikers->{$table};
 532
 533         $self->_dbic_stmt($table_class,'table',$table);
 534
 535         my $cols = $self->_table_columns($table);
 536         my $col_info;
 537         eval { $col_info = $self->_columns_info_for($table) };
 538         if($@) {
 539             $self->_dbic_stmt($table_class,'add_columns',@$cols);
 540         }
 541         else {
 542             my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
 543             $self->_dbic_stmt(
 544                 $table_class,
 545                 'add_columns',
 546                 map { $_, ($col_info_lc{$_}||{}) } @$cols
 547             );
 548         }
 549
 550         my $pks = $self->_table_pk_info($table) || [];
 551         @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
 552               : carp("$table has no primary key");
 553
 554         my $uniqs = $self->_table_uniq_info($table) || [];
 555         $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
 556
 557         $schema_class->register_class($table_moniker, $table_class);
 558         $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class;
 559     }
 560 }
 561
 562 =head2 tables
 563
 564 Returns a sorted list of loaded tables, using the original database table
 565 names.
 566
 567 =cut
 568
 569 sub tables {
 570     my $self = shift;
 571
 572     return @{$self->_tables};
 573 }
 574
 575 # Make a moniker from a table
 576 sub _table2moniker {
 577     my ( $self, $table ) = @_;
 578
 579     my $moniker;
 580
 581     if( ref $self->moniker_map eq 'HASH' ) {
 582         $moniker = $self->moniker_map->{$table};
 583     }
 584     elsif( ref $self->moniker_map eq 'CODE' ) {
 585         $moniker = $self->moniker_map->($table);
 586     }
 587
 588     $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table;
 589
 590     return $moniker;
 591 }
 592
 593 sub _load_relationships {
 594     my $self = shift;
 595
 596     # Construct the fk_info RelBuilder wants to see, by
 597     # translating table names to monikers in the _fk_info output
 598     my %fk_info;
 599     foreach my $table ($self->tables) {
 600         my $tbl_fk_info = $self->_table_fk_info($table);
 601         foreach my $fkdef (@$tbl_fk_info) {
 602             $fkdef->{remote_source} =
 603                 $self->monikers->{delete $fkdef->{remote_table}};
 604         }
 605         my $moniker = $self->monikers->{$table};
 606         $fk_info{$moniker} = $tbl_fk_info;
 607     }
 608
 609     my $relbuilder = DBIx::Class::Schema::Loader::RelBuilder->new(
 610         $self->schema_class, \%fk_info, $self->inflect_plural,
 611         $self->inflect_singular
 612     );
 613
 614     my $rel_stmts = $relbuilder->generate_code;
 615     foreach my $src_class (sort keys %$rel_stmts) {
 616         my $src_stmts = $rel_stmts->{$src_class};
 617         foreach my $stmt (@$src_stmts) {
 618             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
 619         }
 620     }
 621 }
 622
 623 # Overload these in driver class:
 624
 625 # Returns an arrayref of column names
 626 sub _table_columns { croak "ABSTRACT METHOD" }
 627
 628 # Returns arrayref of pk col names
 629 sub _table_pk_info { croak "ABSTRACT METHOD" }
 630
 631 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
 632 sub _table_uniq_info { croak "ABSTRACT METHOD" }
 633
 634 # Returns an arrayref of foreign key constraints, each
 635 #   being a hashref with 3 keys:
 636 #   local_columns (arrayref), remote_columns (arrayref), remote_table
 637 sub _table_fk_info { croak "ABSTRACT METHOD" }
 638
 639 # Returns an array of lower case table names
 640 sub _tables_list { croak "ABSTRACT METHOD" }
 641
 642 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
 643 sub _dbic_stmt {
 644     my $self = shift;
 645     my $class = shift;
 646     my $method = shift;
 647
 648     if(!$self->debug && !$self->dump_directory) {
 649         $class->$method(@_);
 650         return;
 651     }
 652
 653     my $args = dump(@_);
 654     $args = '(' . $args . ')' if @_ < 2;
 655     my $stmt = $method . $args . q{;};
 656
 657     warn qq|$class\->$stmt\n| if $self->debug;
 658     $class->$method(@_);
 659     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
 660 }
 661
 662 # Store a raw source line for a class (for dumping purposes)
 663 sub _raw_stmt {
 664     my ($self, $class, $stmt) = @_;
 665     push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory;
 666 }
 667
 668 # Like above, but separately for the externally loaded stuff
 669 sub _ext_stmt {
 670     my ($self, $class, $stmt) = @_;
 671     push(@{$self->{_ext_storage}->{$class}}, $stmt) if $self->dump_directory;
 672 }
 673
 674 =head2 monikers
 675
 676 Returns a hashref of loaded table to moniker mappings.  There will
 677 be two entries for each table, the original name and the "normalized"
 678 name, in the case that the two are different (such as databases
 679 that like uppercase table names, or preserve your original mixed-case
 680 definitions, or what-have-you).
 681
 682 =head2 classes
 683
 684 Returns a hashref of table to class mappings.  In some cases it will
 685 contain multiple entries per table for the original and normalized table
 686 names, as above in L</monikers>.
 687
 688 =head1 SEE ALSO
 689
 690 L<DBIx::Class::Schema::Loader>
 691
 692 =cut
 693
 694 1;