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::Schema::Loader/;
   8 use UNIVERSAL::require;
   9 use DBIx::Class::Schema::Loader::RelBuilder;
  10 use Data::Dump qw/ dump /;
  11 use POSIX qw//;
  12 require DBIx::Class;
  13
  14 __PACKAGE__->mk_ro_accessors(qw/
  15                                 schema
  16                                 schema_class
  17
  18                                 exclude
  19                                 constraint
  20                                 additional_classes
  21                                 additional_base_classes
  22                                 left_base_classes
  23                                 components
  24                                 resultset_components
  25                                 relationships
  26                                 moniker_map
  27                                 inflect_singular
  28                                 inflect_plural
  29                                 debug
  30                                 dump_directory
  31
  32                                 legacy_default_inflections
  33
  34                                 db_schema
  35                                 _tables
  36                                 classes
  37                                 monikers
  38                              /);
  39
  40 =head1 NAME
  41
  42 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  43
  44 =head1 SYNOPSIS
  45
  46 See L<DBIx::Class::Schema::Loader>
  47
  48 =head1 DESCRIPTION
  49
  50 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  51 classes, and implements the common functionality between them.
  52
  53 =head1 CONSTRUCTOR OPTIONS
  54
  55 These constructor options are the base options for
  56 L<DBIx::Class::Schema::Loader/loader_opts>.  Available constructor options are:
  57
  58 =head2 relationships
  59
  60 Try to automatically detect/setup has_a and has_many relationships.
  61
  62 =head2 debug
  63
  64 If set to true, each constructive L<DBIx::Class> statement the loader
  65 decides to execute will be C<warn>-ed before execution.
  66
  67 =head2 constraint
  68
  69 Only load tables matching regex.  Best specified as a qr// regex.
  70
  71 =head2 exclude
  72
  73 Exclude tables matching regex.  Best specified as a qr// regex.
  74
  75 =head2 moniker_map
  76
  77 Overrides the default table name to moniker translation.  Can be either
  78 a hashref of table keys and moniker values, or a coderef for a translator
  79 function taking a single scalar table name argument and returning
  80 a scalar moniker.  If the hash entry does not exist, or the function
  81 returns a false value, the code falls back to default behavior
  82 for that table name.
  83
  84 The default behavior is: C<join '', map ucfirst, split /[\W_]+/, lc $table>,
  85 which is to say: lowercase everything, split up the table name into chunks
  86 anywhere a non-alpha-numeric character occurs, change the case of first letter
  87 of each chunk to upper case, and put the chunks back together.  Examples:
  88
  89     Table Name  | Moniker Name
  90     ---------------------------
  91     luser       | Luser
  92     luser_group | LuserGroup
  93     luser-opts  | LuserOpts
  94
  95 =head2 inflect_plural
  96
  97 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
  98 if hash key does not exist or coderef returns false), but acts as a map
  99 for pluralizing relationship names.  The default behavior is to utilize
 100 L<Lingua::EN::Inflect::Number/to_PL>.
 101
 102 =head2 inflect_singular
 103
 104 As L</inflect_plural> above, but for singularizing relationship names.
 105 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 106
 107 =head2 additional_base_classes
 108
 109 List of additional base classes all of your table classes will use.
 110
 111 =head2 left_base_classes
 112
 113 List of additional base classes all of your table classes will use
 114 that need to be leftmost.
 115
 116 =head2 additional_classes
 117
 118 List of additional classes which all of your table classes will use.
 119
 120 =head2 components
 121
 122 List of additional components to be loaded into all of your table
 123 classes.  A good example would be C<ResultSetManager>.
 124
 125 =head2 resultset_components
 126
 127 List of additional ResultSet components to be loaded into your table
 128 classes.  A good example would be C<AlwaysRS>.  Component
 129 C<ResultSetManager> will be automatically added to the above
 130 C<components> list if this option is set.
 131
 132 =head2 legacy_default_inflections
 133
 134 Setting this option changes the default fallback for L</inflect_plural> to
 135 utilize L<Lingua::EN::Inflect/PL>, and L</inflect_singular> to a no-op.
 136 Those choices produce substandard results, but might be necessary to support
 137 your existing code if you started developing on a version prior to 0.03 and
 138 don't wish to go around updating all your relationship names to the new
 139 defaults.
 140
 141 =head2 dump_directory
 142
 143 This option is designed to be a tool to help you transition from this
 144 loader to a manually-defined schema when you decide it's time to do so.
 145
 146 The value of this option is a perl libdir pathname.  Within
 147 that directory this module will create a baseline manual
 148 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 149 in memory.
 150
 151 The created schema class will have the same classname as the one on
 152 which you are setting this option (and the ResultSource classes will be
 153 based on this name as well).  Therefore it is wise to note that if you
 154 point the C<dump_directory> option of a schema class at the live libdir
 155 where that class is currently located, it will overwrite itself with a
 156 manual version of itself.  This might be a really good or bad thing
 157 depending on your situation and perspective.
 158
 159 Normally you wouldn't hard-code this setting in your schema class, as it
 160 is meant for one-time manual usage.
 161
 162 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 163 recommended way to access this functionality.
 164
 165 =head1 DEPRECATED CONSTRUCTOR OPTIONS
 166
 167 =head2 inflect_map
 168
 169 Equivalent to L</inflect_plural>.
 170
 171 =head2 inflect
 172
 173 Equivalent to L</inflect_plural>.
 174
 175 =head2 connect_info, dsn, user, password, options
 176
 177 You connect these schemas the same way you would any L<DBIx::Class::Schema>,
 178 which is by calling either C<connect> or C<connection> on a schema class
 179 or object.  These options are only supported via the deprecated
 180 C<load_from_connection> interface, which will be removed in the future.
 181
 182 =head1 METHODS
 183
 184 None of these methods are intended for direct invocation by regular
 185 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
 186 can also be found via standard L<DBIx::Class::Schema> methods somehow.
 187
 188 =cut
 189
 190 # ensure that a peice of object data is a valid arrayref, creating
 191 # an empty one or encapsulating whatever's there.
 192 sub _ensure_arrayref {
 193     my $self = shift;
 194
 195     foreach (@_) {
 196         $self->{$_} ||= [];
 197         $self->{$_} = [ $self->{$_} ]
 198             unless ref $self->{$_} eq 'ARRAY';
 199     }
 200 }
 201
 202 =head2 new
 203
 204 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 205 by L<DBIx::Class::Schema::Loader>.
 206
 207 =cut
 208
 209 sub new {
 210     my ( $class, %args ) = @_;
 211
 212     my $self = { %args };
 213
 214     bless $self => $class;
 215
 216     $self->{db_schema}  ||= '';
 217     $self->_ensure_arrayref(qw/additional_classes
 218                                additional_base_classes
 219                                left_base_classes
 220                                components
 221                                resultset_components
 222                               /);
 223
 224     push(@{$self->{components}}, 'ResultSetManager')
 225         if @{$self->{resultset_components}};
 226
 227     $self->{monikers} = {};
 228     $self->{classes} = {};
 229
 230     # Support deprecated arguments
 231     for(qw/inflect_map inflect/) {
 232         warn "Argument $_ is deprecated in favor of 'inflect_plural'"
 233             if $self->{$_};
 234     }
 235     $self->{inflect_plural} ||= $self->{inflect_map} || $self->{inflect};
 236
 237     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 238     $self->{schema} ||= $self->{schema_class};
 239
 240     $self;
 241 }
 242
 243 sub _load_external {
 244     my $self = shift;
 245
 246     foreach my $table_class (values %{$self->classes}) {
 247         $table_class->require;
 248         if($@ && $@ !~ /^Can't locate /) {
 249             croak "Failed to load external class definition"
 250                   . " for '$table_class': $@";
 251         }
 252         next if $@; # "Can't locate" error
 253
 254         # If we make it to here, we loaded an external definition
 255         warn qq/# Loaded external class definition for '$table_class'\n/
 256             if $self->debug;
 257
 258         if($self->dump_directory) {
 259             my $class_path = $table_class;
 260             $class_path =~ s{::}{/}g;
 261             $class_path .= '.pm';
 262             my $filename = $INC{$class_path};
 263             croak 'Failed to locate actual external module file for '
 264                   . "'$table_class'"
 265                       if !$filename;
 266             open(my $fh, '<', $filename)
 267                 or croak "Failed to open $filename for reading: $!";
 268             $self->_raw_stmt($table_class,
 269                 q|# These lines loaded from user-supplied external file: |
 270             );
 271             while(<$fh>) {
 272                 chomp;
 273                 $self->_raw_stmt($table_class, $_);
 274             }
 275             $self->_raw_stmt($table_class,
 276                 q|# End of lines loaded from user-supplied external file |
 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->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;
 316     my $dir = $self->dump_directory;
 317     foreach (@name_parts) {
 318         $dir .= q{/} . $_;
 319         if(! -d $dir) {
 320             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 321         }
 322     }
 323 }
 324
 325 sub _dump_to_dir {
 326     my ($self) = @_;
 327
 328     my $target_dir = $self->dump_directory;
 329     my $schema_class = $self->schema_class;
 330
 331     croak "Must specify target directory for dumping!" if ! $target_dir;
 332
 333     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n";
 334
 335     if(! -d $target_dir) {
 336         mkdir($target_dir) or croak "mkdir('$target_dir') failed: $!";
 337     }
 338
 339     my $verstr = $DBIx::Class::Schema::Loader::VERSION;
 340     my $datestr = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime);
 341     my $tagline = qq|# Created by DBIx::Class::Schema::Loader v$verstr @ $datestr|;
 342
 343     $self->_ensure_dump_subdirs($schema_class);
 344
 345     my $schema_fn = $self->_get_dump_filename($schema_class);
 346     open(my $schema_fh, '>', $schema_fn)
 347         or croak "Cannot open $schema_fn for writing: $!";
 348     print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|;
 349     print $schema_fh qq|use strict;\nuse warnings;\n\n|;
 350     print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|;
 351     print $schema_fh qq|__PACKAGE__->load_classes;\n|;
 352     print $schema_fh qq|\n1;\n\n|;
 353     close($schema_fh)
 354         or croak "Cannot close $schema_fn: $!";
 355
 356     foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
 357         $self->_ensure_dump_subdirs($src_class);
 358         my $src_fn = $self->_get_dump_filename($src_class);
 359         open(my $src_fh, '>', $src_fn)
 360             or croak "Cannot open $src_fn for writing: $!";
 361         print $src_fh qq|package $src_class;\n\n$tagline\n\n|;
 362         print $src_fh qq|use strict;\nuse warnings;\n\n|;
 363         print $src_fh qq|use base 'DBIx::Class';\n\n|;
 364         print $src_fh qq|$_\n|
 365             for @{$self->{_dump_storage}->{$src_class}};
 366         print $src_fh qq|\n1;\n\n|;
 367         close($src_fh)
 368             or croak "Cannot close $src_fn: $!";
 369     }
 370
 371     warn "Schema dump completed.\n";
 372 }
 373
 374 sub _use {
 375     my $self = shift;
 376     my $target = shift;
 377
 378     foreach (@_) {
 379         $_->require or croak ($_ . "->require: $@");
 380         $self->_raw_stmt($target, "use $_;");
 381         warn "$target: use $_" if $self->debug;
 382         eval "package $target; use $_;";
 383         croak "use $_: $@" if $@;
 384     }
 385 }
 386
 387 sub _inject {
 388     my $self = shift;
 389     my $target = shift;
 390     my $schema_class = $self->schema_class;
 391
 392     my $blist = join(q{ }, @_);
 393     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
 394     warn "$target: use base qw/ $blist /" if $self->debug && @_;
 395     foreach (@_) {
 396         $_->require or croak ($_ . "->require: $@");
 397         $schema_class->inject_base($target, $_);
 398     }
 399 }
 400
 401 # Load and setup classes
 402 sub _load_classes {
 403     my $self = shift;
 404
 405     my $schema       = $self->schema;
 406     my $schema_class = $self->schema_class;
 407     my $constraint   = $self->constraint;
 408     my $exclude      = $self->exclude;
 409     my @tables       = sort $self->_tables_list;
 410
 411     warn "No tables found in database, nothing to load" if !@tables;
 412
 413     if(@tables) {
 414         @tables = grep { /$constraint/ } @tables if $constraint;
 415         @tables = grep { ! /$exclude/ } @tables if $exclude;
 416
 417         warn "All tables excluded by constraint/exclude, nothing to load"
 418             if !@tables;
 419     }
 420
 421     $self->{_tables} = \@tables;
 422
 423     foreach my $table (@tables) {
 424         my $table_moniker = $self->_table2moniker($table);
 425         my $table_class = $schema_class . q{::} . $table_moniker;
 426
 427         my $table_normalized = lc $table;
 428         $self->classes->{$table} = $table_class;
 429         $self->classes->{$table_normalized} = $table_class;
 430         $self->monikers->{$table} = $table_moniker;
 431         $self->monikers->{$table_normalized} = $table_moniker;
 432
 433         no warnings 'redefine';
 434         local *Class::C3::reinitialize = sub { };
 435         use warnings;
 436
 437         { no strict 'refs'; @{"${table_class}::ISA"} = qw/DBIx::Class/ }
 438
 439         $self->_use   ($table_class, @{$self->additional_classes});
 440         $self->_inject($table_class, @{$self->additional_base_classes});
 441
 442         $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, qw/PK::Auto Core/);
 443
 444         $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
 445             if @{$self->resultset_components};
 446         $self->_inject($table_class, @{$self->left_base_classes});
 447     }
 448
 449     Class::C3::reinitialize;
 450
 451     foreach my $table (@tables) {
 452         my $table_class = $self->classes->{$table};
 453         my $table_moniker = $self->monikers->{$table};
 454
 455         $self->_dbic_stmt($table_class,'table',$table);
 456
 457         my $cols = $self->_table_columns($table);
 458         my $col_info;
 459         eval { $col_info = $schema->storage->columns_info_for($table) };
 460         if($@) {
 461             $self->_dbic_stmt($table_class,'add_columns',@$cols);
 462         }
 463         else {
 464             my %cols_hash;
 465             foreach my $col (@$cols) {
 466                 $cols_hash{$col} = \%{($col_info->{$col})};
 467             }
 468             $self->_dbic_stmt($table_class,'add_columns',%cols_hash);
 469         }
 470
 471         my $pks = $self->_table_pk_info($table) || [];
 472         @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
 473               : carp("$table has no primary key");
 474
 475         my $uniqs = $self->_table_uniq_info($table) || [];
 476         $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
 477
 478         $schema_class->register_class($table_moniker, $table_class);
 479         $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class;
 480     }
 481 }
 482
 483 =head2 tables
 484
 485 Returns a sorted list of loaded tables, using the original database table
 486 names.
 487
 488 =cut
 489
 490 sub tables {
 491     my $self = shift;
 492
 493     return @{$self->_tables};
 494 }
 495
 496 # Make a moniker from a table
 497 sub _table2moniker {
 498     my ( $self, $table ) = @_;
 499
 500     my $moniker;
 501
 502     if( ref $self->moniker_map eq 'HASH' ) {
 503         $moniker = $self->moniker_map->{$table};
 504     }
 505     elsif( ref $self->moniker_map eq 'CODE' ) {
 506         $moniker = $self->moniker_map->($table);
 507     }
 508
 509     $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table;
 510
 511     return $moniker;
 512 }
 513
 514 sub _load_relationships {
 515     my $self = shift;
 516
 517     # Construct the fk_info RelBuilder wants to see, by
 518     # translating table names to monikers in the _fk_info output
 519     my %fk_info;
 520     foreach my $table ($self->tables) {
 521         my $tbl_fk_info = $self->_table_fk_info($table);
 522         foreach my $fkdef (@$tbl_fk_info) {
 523             $fkdef->{remote_source} =
 524                 $self->monikers->{delete $fkdef->{remote_table}};
 525         }
 526         my $moniker = $self->monikers->{$table};
 527         $fk_info{$moniker} = $tbl_fk_info;
 528     }
 529
 530     my $relbuilder = DBIx::Class::Schema::Loader::RelBuilder->new(
 531         $self->schema_class, \%fk_info, $self->inflect_plural,
 532         $self->inflect_singular
 533     );
 534
 535     my $rel_stmts = $relbuilder->generate_code;
 536     foreach my $src_class (sort keys %$rel_stmts) {
 537         my $src_stmts = $rel_stmts->{$src_class};
 538         foreach my $stmt (@$src_stmts) {
 539             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
 540         }
 541     }
 542 }
 543
 544 # Overload these in driver class:
 545
 546 # Returns an arrayref of column names
 547 sub _table_columns { croak "ABSTRACT METHOD" }
 548
 549 # Returns arrayref of pk col names
 550 sub _table_pk_info { croak "ABSTRACT METHOD" }
 551
 552 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
 553 sub _table_uniq_info { croak "ABSTRACT METHOD" }
 554
 555 # Returns an arrayref of foreign key constraints, each
 556 #   being a hashref with 3 keys:
 557 #   local_columns (arrayref), remote_columns (arrayref), remote_table
 558 sub _table_fk_info { croak "ABSTRACT METHOD" }
 559
 560 # Returns an array of lower case table names
 561 sub _tables_list { croak "ABSTRACT METHOD" }
 562
 563 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
 564 sub _dbic_stmt {
 565     my $self = shift;
 566     my $class = shift;
 567     my $method = shift;
 568
 569     if(!$self->debug && !$self->dump_directory) {
 570         $class->$method(@_);
 571         return;
 572     }
 573
 574     my $args = dump(@_);
 575     $args = '(' . $args . ')' if @_ < 2;
 576     my $stmt = $method . $args . q{;};
 577
 578     warn qq|$class\->$stmt\n| if $self->debug;
 579     $class->$method(@_);
 580     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
 581 }
 582
 583 # Store a raw source line for a class (for dumping purposes)
 584 sub _raw_stmt {
 585     my ($self, $class, $stmt) = @_;
 586     push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory;
 587 }
 588
 589 =head2 monikers
 590
 591 Returns a hashref of loaded table to moniker mappings.  There will
 592 be two entries for each table, the original name and the "normalized"
 593 name, in the case that the two are different (such as databases
 594 that like uppercase table names, or preserve your original mixed-case
 595 definitions, or what-have-you).
 596
 597 =head2 classes
 598
 599 Returns a hashref of table to class mappings.  In some cases it will
 600 contain multiple entries per table for the original and normalized table
 601 names, as above in L</monikers>.
 602
 603 =head1 SEE ALSO
 604
 605 L<DBIx::Class::Schema::Loader>
 606
 607 =cut
 608
 609 1;