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