lib/DBIx/Class/Schema.pm

   1 package DBIx::Class::Schema;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp::Clan qw/^DBIx::Class/;
   7 use Scalar::Util qw/weaken/;
   8
   9 use base qw/DBIx::Class/;
  10
  11 __PACKAGE__->mk_classdata('class_mappings' => {});
  12 __PACKAGE__->mk_classdata('source_registrations' => {});
  13 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  14 __PACKAGE__->mk_classdata('storage');
  15
  16 =head1 NAME
  17
  18 DBIx::Class::Schema - composable schemas
  19
  20 =head1 SYNOPSIS
  21
  22   package Library::Schema;
  23   use base qw/DBIx::Class::Schema/;
  24
  25   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  26   __PACKAGE__->load_classes(qw/CD Book DVD/);
  27
  28   package Library::Schema::CD;
  29   use base qw/DBIx::Class/;
  30   __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
  31   __PACKAGE__->table('cd');
  32
  33   # Elsewhere in your code:
  34   my $schema1 = Library::Schema->connect(
  35     $dsn,
  36     $user,
  37     $password,
  38     { AutoCommit => 0 },
  39   );
  40
  41   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  42
  43   # fetch objects using Library::Schema::DVD
  44   my $resultset = $schema1->resultset('DVD')->search( ... );
  45   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  46
  47 =head1 DESCRIPTION
  48
  49 Creates database classes based on a schema. This is the recommended way to
  50 use L<DBIx::Class> and allows you to use more than one concurrent connection
  51 with your classes.
  52
  53 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  54 carefully, as DBIx::Class does things a little differently. Note in
  55 particular which module inherits off which.
  56
  57 =head1 METHODS
  58
  59 =head2 register_class
  60
  61 =over 4
  62
  63 =item Arguments: $moniker, $component_class
  64
  65 =back
  66
  67 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
  68 calling:
  69
  70   $schema->register_source($moniker, $component_class->result_source_instance);
  71
  72 =cut
  73
  74 sub register_class {
  75   my ($self, $moniker, $to_register) = @_;
  76   $self->register_source($moniker => $to_register->result_source_instance);
  77 }
  78
  79 =head2 register_source
  80
  81 =over 4
  82
  83 =item Arguments: $moniker, $result_source
  84
  85 =back
  86
  87 Registers the L<DBIx::Class::ResultSource> in the schema with the given
  88 moniker.
  89
  90 =cut
  91
  92 sub register_source {
  93   my ($self, $moniker, $source) = @_;
  94   my %reg = %{$self->source_registrations};
  95   $reg{$moniker} = $source;
  96   $self->source_registrations(\%reg);
  97   $source->schema($self);
  98   weaken($source->{schema}) if ref($self);
  99   if ($source->result_class) {
 100     my %map = %{$self->class_mappings};
 101     $map{$source->result_class} = $moniker;
 102     $self->class_mappings(\%map);
 103   }
 104 }
 105
 106 =head2 class
 107
 108 =over 4
 109
 110 =item Arguments: $moniker
 111
 112 =item Return Value: $classname
 113
 114 =back
 115
 116 Retrieves the result class name for the given moniker. For example:
 117
 118   my $class = $schema->class('CD');
 119
 120 =cut
 121
 122 sub class {
 123   my ($self, $moniker) = @_;
 124   return $self->source($moniker)->result_class;
 125 }
 126
 127 =head2 source
 128
 129 =over 4
 130
 131 =item Arguments: $moniker
 132
 133 =item Return Value: $result_source
 134
 135 =back
 136
 137   my $source = $schema->source('Book');
 138
 139 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
 140
 141 =cut
 142
 143 sub source {
 144   my ($self, $moniker) = @_;
 145   my $sreg = $self->source_registrations;
 146   return $sreg->{$moniker} if exists $sreg->{$moniker};
 147
 148   # if we got here, they probably passed a full class name
 149   my $mapped = $self->class_mappings->{$moniker};
 150   $self->throw_exception("Can't find source for ${moniker}")
 151     unless $mapped && exists $sreg->{$mapped};
 152   return $sreg->{$mapped};
 153 }
 154
 155 =head2 sources
 156
 157 =over 4
 158
 159 =item Return Value: @source_monikers
 160
 161 =back
 162
 163 Returns the source monikers of all source registrations on this schema.
 164 For example:
 165
 166   my @source_monikers = $schema->sources;
 167
 168 =cut
 169
 170 sub sources { return keys %{shift->source_registrations}; }
 171
 172 =head2 resultset
 173
 174 =over 4
 175
 176 =item Arguments: $moniker
 177
 178 =item Return Value: $result_set
 179
 180 =back
 181
 182   my $rs = $schema->resultset('DVD');
 183
 184 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
 185
 186 =cut
 187
 188 sub resultset {
 189   my ($self, $moniker) = @_;
 190   return $self->source($moniker)->resultset;
 191 }
 192
 193 =head2 load_classes
 194
 195 =over 4
 196
 197 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 198
 199 =back
 200
 201 With no arguments, this method uses L<Module::Find> to find all classes under
 202 the schema's namespace. Otherwise, this method loads the classes you specify
 203 (using L<use>), and registers them (using L</"register_class">).
 204
 205 It is possible to comment out classes with a leading C<#>, but note that perl
 206 will think it's a mistake (trying to use a comment in a qw list), so you'll
 207 need to add C<no warnings 'qw';> before your load_classes call.
 208
 209 Example:
 210
 211   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 212                               # etc. (anything under the My::Schema namespace)
 213
 214   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 215   # not Other::Namespace::LinerNotes nor My::Schema::Track
 216   My::Schema->load_classes(qw/ CD Artist #Track /, {
 217     Other::Namespace => [qw/ Producer #LinerNotes /],
 218   });
 219
 220 =cut
 221
 222 sub load_classes {
 223   my ($class, @params) = @_;
 224
 225   my %comps_for;
 226
 227   if (@params) {
 228     foreach my $param (@params) {
 229       if (ref $param eq 'ARRAY') {
 230         # filter out commented entries
 231         my @modules = grep { $_ !~ /^#/ } @$param;
 232
 233         push (@{$comps_for{$class}}, @modules);
 234       }
 235       elsif (ref $param eq 'HASH') {
 236         # more than one namespace possible
 237         for my $comp ( keys %$param ) {
 238           # filter out commented entries
 239           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 240
 241           push (@{$comps_for{$comp}}, @modules);
 242         }
 243       }
 244       else {
 245         # filter out commented entries
 246         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 247       }
 248     }
 249   } else {
 250     eval "require Module::Find;";
 251     $class->throw_exception(
 252       "No arguments to load_classes and couldn't load Module::Find ($@)"
 253     ) if $@;
 254     my @comp = map { substr $_, length "${class}::"  }
 255                  Module::Find::findallmod($class);
 256     $comps_for{$class} = \@comp;
 257   }
 258
 259   my @to_register;
 260   {
 261     no warnings qw/redefine/;
 262     local *Class::C3::reinitialize = sub { };
 263     foreach my $prefix (keys %comps_for) {
 264       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 265         my $comp_class = "${prefix}::${comp}";
 266         $class->ensure_class_loaded($comp_class);
 267         $comp_class->source_name($comp) unless $comp_class->source_name;
 268
 269         push(@to_register, [ $comp_class->source_name, $comp_class ]);
 270       }
 271     }
 272   }
 273   Class::C3->reinitialize;
 274
 275   foreach my $to (@to_register) {
 276     $class->register_class(@$to);
 277     #  if $class->can('result_source_instance');
 278   }
 279 }
 280
 281 =head2 load_namespaces
 282
 283 =over 4
 284
 285 =item Arguments: %options?
 286
 287 =back
 288
 289 This is an alternative to L</load_classes> above which assumes an alternative
 290 layout for automatic class loading.  It assumes that all ResultSource classes
 291 to be loaded are underneath a sub- namespace of the schema called
 292 "ResultSource", and any corresponding ResultSet classes to be underneath a
 293 sub-namespace of the schema called "ResultSet".
 294
 295 You can change the namespaces checked for ResultSources and ResultSets via
 296 the C<resultsource_namespace> and C<resultset_namespace> options, respectively.
 297
 298 Any source which does not have an explicitly-defined corresponding ResultSet
 299 will have one created in the appropriate namespace for it, based on
 300 L<DBIx::Class::ResultSet>.  If you wish to change this default ResultSet
 301 base class, you can do so via the C<default_resultset_base> option.  (Your
 302 custom default should, of course, be based on L<DBIx::Class::ResultSet>
 303 itself).
 304
 305 This method requires L<Module::Find> to be installed on the system.
 306
 307 Example:
 308
 309   My::Schema->load_namespaces;
 310   # loads My::Schema::ResultSource::CD, My::Schema::ResultSource::Artist,
 311   #    My::Schema::ResultSet::CD, etc...
 312
 313   My::Schema->load_namespaces(
 314     resultsource_namespace => 'My::Schema::RSources',
 315     resultset_namespace => 'My::Schema::RSets',
 316     default_resultset_base => 'My::Schema::RSetBase',
 317   );
 318   # loads My::Schema::RSources::CD, My::Schema::RSources::Artist,
 319   #    My::Schema::RSets::CD, and if no such class exists on disk,
 320   #    creates My::Schema::RSets::Artist in memory based on the
 321   #    class My::Schema::RSetBase
 322
 323 =cut
 324
 325 sub load_namespaces {
 326   my ($class, %args) = @_;
 327
 328   my $resultsource_namespace = $args{resultsource_namespace}
 329                                || ($class . '::ResultSource');
 330   my $resultset_namespace = $args{resultset_namespace}
 331                             || ($class . '::ResultSet');
 332   my $default_resultset_base = $args{default_resultset_base}
 333                                || 'DBIx::Class::ResultSet';
 334
 335   eval "require Module::Find";
 336   $class->throw_exception("Couldn't load Module::Find ($@)") if $@;
 337
 338   my %sources = map { (substr($_, length "${resultsource_namespace}::"), $_) }
 339       Module::Find::findallmod($resultsource_namespace);
 340
 341   my %resultsets = map { (substr($_, length "${resultset_namespace}::"), $_) }
 342       Module::Find::findallmod($resultset_namespace);
 343
 344   my @to_register;
 345   {
 346     no warnings qw/redefine/;
 347     no strict qw/refs/;
 348     local *Class::C3::reinitialize = sub { };
 349     foreach my $source (keys %sources) {
 350       my $source_class = $sources{$source};
 351       $class->ensure_class_loaded($source_class);
 352       $source_class->source_name($source) unless $source_class->source_name;
 353       if(!$source_class->resultset_class
 354          || $source_class->resultset_class eq 'DBIx::Class::ResultSet') {
 355         if(my $rs_class = delete $resultsets{$source}) {
 356           $class->ensure_class_loaded($rs_class);
 357           $source_class->resultset_class($rs_class);
 358         }
 359         else {
 360           my $rs_class = "$resultset_namespace\::$source";
 361           @{"$rs_class\::ISA"} = ($default_resultset_base);
 362           $source_class->resultset_class($rs_class);
 363         }
 364       }
 365
 366       push(@to_register, [ $source_class->source_name, $source_class ]);
 367     }
 368   }
 369
 370   foreach (keys %resultsets) {
 371     warn "load_namespaces found ResultSet $_ with no "
 372       . 'corresponding ResultSource';
 373   }
 374
 375   Class::C3->reinitialize;
 376
 377   foreach my $to (@to_register) {
 378     $class->register_class(@$to);
 379     #  if $class->can('result_source_instance');
 380   }
 381 }
 382
 383 =head2 compose_connection
 384
 385 =over 4
 386
 387 =item Arguments: $target_namespace, @db_info
 388
 389 =item Return Value: $new_schema
 390
 391 =back
 392
 393 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 394 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 395 then injects the L<DBix::Class::ResultSetProxy> component and a
 396 resultset_instance classdata entry on all the new classes, in order to support
 397 $target_namespaces::$class->search(...) method calls.
 398
 399 This is primarily useful when you have a specific need for class method access
 400 to a connection. In normal usage it is preferred to call
 401 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 402 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 403 more information.
 404
 405 =cut
 406
 407 sub compose_connection {
 408   my ($self, $target, @info) = @_;
 409   my $base = 'DBIx::Class::ResultSetProxy';
 410   eval "require ${base};";
 411   $self->throw_exception
 412     ("No arguments to load_classes and couldn't load ${base} ($@)")
 413       if $@;
 414
 415   if ($self eq $target) {
 416     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 417     foreach my $moniker ($self->sources) {
 418       my $source = $self->source($moniker);
 419       my $class = $source->result_class;
 420       $self->inject_base($class, $base);
 421       $class->mk_classdata(resultset_instance => $source->resultset);
 422       $class->mk_classdata(class_resolver => $self);
 423     }
 424     $self->connection(@info);
 425     return $self;
 426   }
 427
 428   my $schema = $self->compose_namespace($target, $base);
 429   {
 430     no strict 'refs';
 431     *{"${target}::schema"} = sub { $schema };
 432   }
 433
 434   $schema->connection(@info);
 435   foreach my $moniker ($schema->sources) {
 436     my $source = $schema->source($moniker);
 437     my $class = $source->result_class;
 438     #warn "$moniker $class $source ".$source->storage;
 439     $class->mk_classdata(result_source_instance => $source);
 440     $class->mk_classdata(resultset_instance => $source->resultset);
 441     $class->mk_classdata(class_resolver => $schema);
 442   }
 443   return $schema;
 444 }
 445
 446 =head2 compose_namespace
 447
 448 =over 4
 449
 450 =item Arguments: $target_namespace, $additional_base_class?
 451
 452 =item Return Value: $new_schema
 453
 454 =back
 455
 456 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 457 class in the target namespace (e.g. $target_namespace::CD,
 458 $target_namespace::Artist) that inherits from the corresponding classes
 459 attached to the current schema.
 460
 461 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 462 new $schema object. If C<$additional_base_class> is given, the new composed
 463 classes will inherit from first the corresponding classe from the current
 464 schema then the base class.
 465
 466 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 467
 468   $schema->compose_namespace('My::DB', 'Base::Class');
 469   print join (', ', @My::DB::CD::ISA) . "\n";
 470   print join (', ', @My::DB::Artist::ISA) ."\n";
 471
 472 will produce the output
 473
 474   My::Schema::CD, Base::Class
 475   My::Schema::Artist, Base::Class
 476
 477 =cut
 478
 479 sub compose_namespace {
 480   my ($self, $target, $base) = @_;
 481   my %reg = %{ $self->source_registrations };
 482   my %target;
 483   my %map;
 484   my $schema = $self->clone;
 485   {
 486     no warnings qw/redefine/;
 487     local *Class::C3::reinitialize = sub { };
 488     foreach my $moniker ($schema->sources) {
 489       my $source = $schema->source($moniker);
 490       my $target_class = "${target}::${moniker}";
 491       $self->inject_base(
 492         $target_class => $source->result_class, ($base ? $base : ())
 493       );
 494       $source->result_class($target_class);
 495       $target_class->result_source_instance($source)
 496         if $target_class->can('result_source_instance');
 497     }
 498   }
 499   Class::C3->reinitialize();
 500   {
 501     no strict 'refs';
 502     foreach my $meth (qw/class source resultset/) {
 503       *{"${target}::${meth}"} =
 504         sub { shift->schema->$meth(@_) };
 505     }
 506   }
 507   return $schema;
 508 }
 509
 510 =head2 setup_connection_class
 511
 512 =over 4
 513
 514 =item Arguments: $target, @info
 515
 516 =back
 517
 518 Sets up a database connection class to inject between the schema and the
 519 subclasses that the schema creates.
 520
 521 =cut
 522
 523 sub setup_connection_class {
 524   my ($class, $target, @info) = @_;
 525   $class->inject_base($target => 'DBIx::Class::DB');
 526   #$target->load_components('DB');
 527   $target->connection(@info);
 528 }
 529
 530 =head2 connection
 531
 532 =over 4
 533
 534 =item Arguments: @args
 535
 536 =item Return Value: $new_schema
 537
 538 =back
 539
 540 Instantiates a new Storage object of type
 541 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 542 $storage->connect_info. Sets the connection in-place on the schema. See
 543 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
 544
 545 =cut
 546
 547 sub connection {
 548   my ($self, @info) = @_;
 549   return $self if !@info && $self->storage;
 550   my $storage_class = $self->storage_type;
 551   $storage_class = 'DBIx::Class::Storage'.$storage_class
 552     if $storage_class =~ m/^::/;
 553   eval "require ${storage_class};";
 554   $self->throw_exception(
 555     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 556   ) if $@;
 557   my $storage = $storage_class->new;
 558   $storage->connect_info(\@info);
 559   $self->storage($storage);
 560   return $self;
 561 }
 562
 563 =head2 connect
 564
 565 =over 4
 566
 567 =item Arguments: @info
 568
 569 =item Return Value: $new_schema
 570
 571 =back
 572
 573 This is a convenience method. It is equivalent to calling
 574 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 575 information.
 576
 577 =cut
 578
 579 sub connect { shift->clone->connection(@_) }
 580
 581 =head2 txn_begin
 582
 583 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 584 calling $schema->storage->txn_begin. See
 585 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 586
 587 =cut
 588
 589 sub txn_begin { shift->storage->txn_begin }
 590
 591 =head2 txn_commit
 592
 593 Commits the current transaction. Equivalent to calling
 594 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 595 for more information.
 596
 597 =cut
 598
 599 sub txn_commit { shift->storage->txn_commit }
 600
 601 =head2 txn_rollback
 602
 603 Rolls back the current transaction. Equivalent to calling
 604 $schema->storage->txn_rollback. See
 605 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 606
 607 =cut
 608
 609 sub txn_rollback { shift->storage->txn_rollback }
 610
 611 =head2 txn_do
 612
 613 =over 4
 614
 615 =item Arguments: C<$coderef>, @coderef_args?
 616
 617 =item Return Value: The return value of $coderef
 618
 619 =back
 620
 621 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 622 returning its result (if any). If an exception is caught, a rollback is issued
 623 and the exception is rethrown. If the rollback fails, (i.e. throws an
 624 exception) an exception is thrown that includes a "Rollback failed" message.
 625
 626 For example,
 627
 628   my $author_rs = $schema->resultset('Author')->find(1);
 629   my @titles = qw/Night Day It/;
 630
 631   my $coderef = sub {
 632     # If any one of these fails, the entire transaction fails
 633     $author_rs->create_related('books', {
 634       title => $_
 635     }) foreach (@titles);
 636
 637     return $author->books;
 638   };
 639
 640   my $rs;
 641   eval {
 642     $rs = $schema->txn_do($coderef);
 643   };
 644
 645   if ($@) {                                  # Transaction failed
 646     die "something terrible has happened!"   #
 647       if ($@ =~ /Rollback failed/);          # Rollback failed
 648
 649     deal_with_failed_transaction();
 650   }
 651
 652 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 653 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
 654 the Schema's storage, and txn_do() can be called in void, scalar and list
 655 context and it will behave as expected.
 656
 657 =cut
 658
 659 sub txn_do {
 660   my ($self, $coderef, @args) = @_;
 661
 662   $self->storage or $self->throw_exception
 663     ('txn_do called on $schema without storage');
 664   ref $coderef eq 'CODE' or $self->throw_exception
 665     ('$coderef must be a CODE reference');
 666
 667   my (@return_values, $return_value);
 668
 669   $self->txn_begin; # If this throws an exception, no rollback is needed
 670
 671   my $wantarray = wantarray; # Need to save this since the context
 672                              # inside the eval{} block is independent
 673                              # of the context that called txn_do()
 674   eval {
 675
 676     # Need to differentiate between scalar/list context to allow for
 677     # returning a list in scalar context to get the size of the list
 678     if ($wantarray) {
 679       # list context
 680       @return_values = $coderef->(@args);
 681     } elsif (defined $wantarray) {
 682       # scalar context
 683       $return_value = $coderef->(@args);
 684     } else {
 685       # void context
 686       $coderef->(@args);
 687     }
 688     $self->txn_commit;
 689   };
 690
 691   if ($@) {
 692     my $error = $@;
 693
 694     eval {
 695       $self->txn_rollback;
 696     };
 697
 698     if ($@) {
 699       my $rollback_error = $@;
 700       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 701       $self->throw_exception($error)  # propagate nested rollback
 702         if $rollback_error =~ /$exception_class/;
 703
 704       $self->throw_exception(
 705         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 706       );
 707     } else {
 708       $self->throw_exception($error); # txn failed but rollback succeeded
 709     }
 710   }
 711
 712   return $wantarray ? @return_values : $return_value;
 713 }
 714
 715 =head2 clone
 716
 717 =over 4
 718
 719 =item Return Value: $new_schema
 720
 721 =back
 722
 723 Clones the schema and its associated result_source objects and returns the
 724 copy.
 725
 726 =cut
 727
 728 sub clone {
 729   my ($self) = @_;
 730   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 731   foreach my $moniker ($self->sources) {
 732     my $source = $self->source($moniker);
 733     my $new = $source->new($source);
 734     $clone->register_source($moniker => $new);
 735   }
 736   return $clone;
 737 }
 738
 739 =head2 populate
 740
 741 =over 4
 742
 743 =item Arguments: $moniker, \@data;
 744
 745 =back
 746
 747 Populates the source registered with the given moniker with the supplied data.
 748 @data should be a list of listrefs -- the first containing column names, the
 749 second matching values.
 750
 751 i.e.,
 752
 753   $schema->populate('Artist', [
 754     [ qw/artistid name/ ],
 755     [ 1, 'Popular Band' ],
 756     [ 2, 'Indie Band' ],
 757     ...
 758   ]);
 759
 760 =cut
 761
 762 sub populate {
 763   my ($self, $name, $data) = @_;
 764   my $rs = $self->resultset($name);
 765   my @names = @{shift(@$data)};
 766   my @created;
 767   foreach my $item (@$data) {
 768     my %create;
 769     @create{@names} = @$item;
 770     push(@created, $rs->create(\%create));
 771   }
 772   return @created;
 773 }
 774
 775 =head2 throw_exception
 776
 777 =over 4
 778
 779 =item Arguments: $message
 780
 781 =back
 782
 783 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 784 user's perspective.
 785
 786 =cut
 787
 788 sub throw_exception {
 789   my ($self) = shift;
 790   croak @_;
 791 }
 792
 793 =head2 deploy (EXPERIMENTAL)
 794
 795 =over 4
 796
 797 =item Arguments: $sqlt_args
 798
 799 =back
 800
 801 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 802
 803 Note that this feature is currently EXPERIMENTAL and may not work correctly
 804 across all databases, or fully handle complex relationships.
 805
 806 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 807 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 808 produced include a DROP TABLE statement for each table created.
 809
 810 =cut
 811
 812 sub deploy {
 813   my ($self, $sqltargs) = @_;
 814   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 815   $self->storage->deploy($self, undef, $sqltargs);
 816 }
 817
 818 =head2 create_ddl_dir (EXPERIMENTAL)
 819
 820 =over 4
 821
 822 =item Arguments: \@databases, $version, $directory, $sqlt_args
 823
 824 =back
 825
 826 Creates an SQL file based on the Schema, for each of the specified
 827 database types, in the given directory.
 828
 829 Note that this feature is currently EXPERIMENTAL and may not work correctly
 830 across all databases, or fully handle complex relationships.
 831
 832 =cut
 833
 834 sub create_ddl_dir
 835 {
 836   my $self = shift;
 837
 838   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 839   $self->storage->create_ddl_dir($self, @_);
 840 }
 841
 842 =head2 ddl_filename (EXPERIMENTAL)
 843
 844   my $filename = $table->ddl_filename($type, $dir, $version)
 845
 846 Creates a filename for a SQL file based on the table class name.  Not
 847 intended for direct end user use.
 848
 849 =cut
 850
 851 sub ddl_filename
 852 {
 853     my ($self, $type, $dir, $version) = @_;
 854
 855     my $filename = ref($self);
 856     $filename =~ s/::/-/;
 857     $filename = "$dir$filename-$version-$type.sql";
 858
 859     return $filename;
 860 }
 861
 862 1;
 863
 864 =head1 AUTHORS
 865
 866 Matt S. Trout <mst@shadowcatsystems.co.uk>
 867
 868 =head1 LICENSE
 869
 870 You may distribute this code under the same terms as Perl itself.
 871
 872 =cut
 873