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