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