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