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