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