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 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 = File::Spec->rel2abs($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 = File::Spec->rel2abs($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; # we don't care about the very last element,
 343                      # which is a filename
 344
 345     my $dir = $self->dump_directory;
 346     foreach (@name_parts) {
 347         $dir = File::Spec->catdir($dir,$_);
 348         if(! -d $dir) {
 349             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 350         }
 351     }
 352 }
 353
 354 sub _dump_to_dir {
 355     my ($self) = @_;
 356
 357     my $target_dir = $self->dump_directory;
 358
 359     my $schema_class = $self->schema_class;
 360
 361     croak "Must specify target directory for dumping!" if ! $target_dir;
 362
 363     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n";
 364
 365     if(! -d $target_dir) {
 366         mkdir($target_dir) or croak "mkdir('$target_dir') failed: $!";
 367     }
 368
 369     my $verstr = $DBIx::Class::Schema::Loader::VERSION;
 370     my $datestr = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime);
 371     my $tagline = qq|# Created by DBIx::Class::Schema::Loader v$verstr @ $datestr|;
 372
 373     $self->_ensure_dump_subdirs($schema_class);
 374
 375     my $schema_fn = $self->_get_dump_filename($schema_class);
 376     if (-f $schema_fn && !$self->dump_overwrite) {
 377         warn "$schema_fn exists, will not overwrite\n";
 378     }
 379     else {
 380         open(my $schema_fh, '>', $schema_fn)
 381             or croak "Cannot open $schema_fn for writing: $!";
 382         print $schema_fh qq|package $schema_class;\n\n$tagline\n\n|;
 383         print $schema_fh qq|use strict;\nuse warnings;\n\n|;
 384         print $schema_fh qq|use base 'DBIx::Class::Schema';\n\n|;
 385         print $schema_fh qq|__PACKAGE__->load_classes;\n|;
 386         print $schema_fh qq|\n1;\n\n|;
 387         close($schema_fh)
 388             or croak "Cannot close $schema_fn: $!";
 389     }
 390
 391     foreach my $src_class (sort keys %{$self->{_dump_storage}}) {
 392         $self->_ensure_dump_subdirs($src_class);
 393         my $src_fn = $self->_get_dump_filename($src_class);
 394         if (-f $src_fn && !$self->dump_overwrite) {
 395             warn "$src_fn exists, will not overwrite\n";
 396             next;
 397         }
 398         open(my $src_fh, '>', $src_fn)
 399             or croak "Cannot open $src_fn for writing: $!";
 400         print $src_fh qq|package $src_class;\n\n$tagline\n\n|;
 401         print $src_fh qq|use strict;\nuse warnings;\n\n|;
 402         print $src_fh qq|use base 'DBIx::Class';\n\n|;
 403         print $src_fh qq|$_\n|
 404             for @{$self->{_dump_storage}->{$src_class}};
 405         print $src_fh qq|\n1;\n\n|;
 406         close($src_fh)
 407             or croak "Cannot close $src_fn: $!";
 408     }
 409
 410     warn "Schema dump completed.\n";
 411 }
 412
 413 sub _use {
 414     my $self = shift;
 415     my $target = shift;
 416     my $evalstr;
 417
 418     foreach (@_) {
 419         warn "$target: use $_;" if $self->debug;
 420         $self->_raw_stmt($target, "use $_;");
 421         $_->require or croak ($_ . "->require: $@");
 422         $evalstr .= "package $target; use $_;";
 423     }
 424     eval $evalstr if $evalstr;
 425     croak $@ if $@;
 426 }
 427
 428 sub _inject {
 429     my $self = shift;
 430     my $target = shift;
 431     my $schema_class = $self->schema_class;
 432
 433     my $blist = join(q{ }, @_);
 434     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
 435     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
 436     foreach (@_) {
 437         $_->require or croak ($_ . "->require: $@");
 438         $schema_class->inject_base($target, $_);
 439     }
 440 }
 441
 442 # Load and setup classes
 443 sub _load_classes {
 444     my $self = shift;
 445
 446     my $schema       = $self->schema;
 447     my $schema_class = $self->schema_class;
 448     my $constraint   = $self->constraint;
 449     my $exclude      = $self->exclude;
 450     my @tables       = sort $self->_tables_list;
 451
 452     warn "No tables found in database, nothing to load" if !@tables;
 453
 454     if(@tables) {
 455         @tables = grep { /$constraint/ } @tables if $constraint;
 456         @tables = grep { ! /$exclude/ } @tables if $exclude;
 457
 458         warn "All tables excluded by constraint/exclude, nothing to load"
 459             if !@tables;
 460     }
 461
 462     $self->{_tables} = \@tables;
 463
 464     foreach my $table (@tables) {
 465         my $table_moniker = $self->_table2moniker($table);
 466         my $table_class = $schema_class . q{::} . $table_moniker;
 467
 468         my $table_normalized = lc $table;
 469         $self->classes->{$table} = $table_class;
 470         $self->classes->{$table_normalized} = $table_class;
 471         $self->monikers->{$table} = $table_moniker;
 472         $self->monikers->{$table_normalized} = $table_moniker;
 473
 474         no warnings 'redefine';
 475         local *Class::C3::reinitialize = sub { };
 476         use warnings;
 477
 478         { no strict 'refs'; @{"${table_class}::ISA"} = qw/DBIx::Class/ }
 479
 480         $self->_use   ($table_class, @{$self->additional_classes});
 481         $self->_inject($table_class, @{$self->additional_base_classes});
 482
 483         $self->_dbic_stmt($table_class, 'load_components', @{$self->components}, qw/PK::Auto Core/);
 484
 485         $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
 486             if @{$self->resultset_components};
 487         $self->_inject($table_class, @{$self->left_base_classes});
 488     }
 489
 490     Class::C3::reinitialize;
 491
 492     foreach my $table (@tables) {
 493         my $table_class = $self->classes->{$table};
 494         my $table_moniker = $self->monikers->{$table};
 495
 496         $self->_dbic_stmt($table_class,'table',$table);
 497
 498         my $cols = $self->_table_columns($table);
 499         my $col_info;
 500         eval { $col_info = $schema->storage->columns_info_for($table) };
 501         if($@) {
 502             $self->_dbic_stmt($table_class,'add_columns',@$cols);
 503         }
 504         else {
 505             my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
 506             $self->_dbic_stmt(
 507                 $table_class,
 508                 'add_columns',
 509                 map { $_, ($col_info_lc{$_}||{}) } @$cols
 510             );
 511         }
 512
 513         my $pks = $self->_table_pk_info($table) || [];
 514         @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
 515               : carp("$table has no primary key");
 516
 517         my $uniqs = $self->_table_uniq_info($table) || [];
 518         $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
 519
 520         $schema_class->register_class($table_moniker, $table_class);
 521         $schema->register_class($table_moniker, $table_class) if $schema ne $schema_class;
 522     }
 523 }
 524
 525 =head2 tables
 526
 527 Returns a sorted list of loaded tables, using the original database table
 528 names.
 529
 530 =cut
 531
 532 sub tables {
 533     my $self = shift;
 534
 535     return @{$self->_tables};
 536 }
 537
 538 # Make a moniker from a table
 539 sub _table2moniker {
 540     my ( $self, $table ) = @_;
 541
 542     my $moniker;
 543
 544     if( ref $self->moniker_map eq 'HASH' ) {
 545         $moniker = $self->moniker_map->{$table};
 546     }
 547     elsif( ref $self->moniker_map eq 'CODE' ) {
 548         $moniker = $self->moniker_map->($table);
 549     }
 550
 551     $moniker ||= join '', map ucfirst, split /[\W_]+/, lc $table;
 552
 553     return $moniker;
 554 }
 555
 556 sub _load_relationships {
 557     my $self = shift;
 558
 559     # Construct the fk_info RelBuilder wants to see, by
 560     # translating table names to monikers in the _fk_info output
 561     my %fk_info;
 562     foreach my $table ($self->tables) {
 563         my $tbl_fk_info = $self->_table_fk_info($table);
 564         foreach my $fkdef (@$tbl_fk_info) {
 565             $fkdef->{remote_source} =
 566                 $self->monikers->{delete $fkdef->{remote_table}};
 567         }
 568         my $moniker = $self->monikers->{$table};
 569         $fk_info{$moniker} = $tbl_fk_info;
 570     }
 571
 572     my $relbuilder = DBIx::Class::Schema::Loader::RelBuilder->new(
 573         $self->schema_class, \%fk_info, $self->inflect_plural,
 574         $self->inflect_singular
 575     );
 576
 577     my $rel_stmts = $relbuilder->generate_code;
 578     foreach my $src_class (sort keys %$rel_stmts) {
 579         my $src_stmts = $rel_stmts->{$src_class};
 580         foreach my $stmt (@$src_stmts) {
 581             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
 582         }
 583     }
 584 }
 585
 586 # Overload these in driver class:
 587
 588 # Returns an arrayref of column names
 589 sub _table_columns { croak "ABSTRACT METHOD" }
 590
 591 # Returns arrayref of pk col names
 592 sub _table_pk_info { croak "ABSTRACT METHOD" }
 593
 594 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
 595 sub _table_uniq_info { croak "ABSTRACT METHOD" }
 596
 597 # Returns an arrayref of foreign key constraints, each
 598 #   being a hashref with 3 keys:
 599 #   local_columns (arrayref), remote_columns (arrayref), remote_table
 600 sub _table_fk_info { croak "ABSTRACT METHOD" }
 601
 602 # Returns an array of lower case table names
 603 sub _tables_list { croak "ABSTRACT METHOD" }
 604
 605 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
 606 sub _dbic_stmt {
 607     my $self = shift;
 608     my $class = shift;
 609     my $method = shift;
 610
 611     if(!$self->debug && !$self->dump_directory) {
 612         $class->$method(@_);
 613         return;
 614     }
 615
 616     my $args = dump(@_);
 617     $args = '(' . $args . ')' if @_ < 2;
 618     my $stmt = $method . $args . q{;};
 619
 620     warn qq|$class\->$stmt\n| if $self->debug;
 621     $class->$method(@_);
 622     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
 623 }
 624
 625 # Store a raw source line for a class (for dumping purposes)
 626 sub _raw_stmt {
 627     my ($self, $class, $stmt) = @_;
 628     push(@{$self->{_dump_storage}->{$class}}, $stmt) if $self->dump_directory;
 629 }
 630
 631 =head2 monikers
 632
 633 Returns a hashref of loaded table to moniker mappings.  There will
 634 be two entries for each table, the original name and the "normalized"
 635 name, in the case that the two are different (such as databases
 636 that like uppercase table names, or preserve your original mixed-case
 637 definitions, or what-have-you).
 638
 639 =head2 classes
 640
 641 Returns a hashref of table to class mappings.  In some cases it will
 642 contain multiple entries per table for the original and normalized table
 643 names, as above in L</monikers>.
 644
 645 =head1 SEE ALSO
 646
 647 L<DBIx::Class::Schema::Loader>
 648
 649 =cut
 650
 651 1;