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