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