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: None
 286
 287 =back
 288
 289 This is an alternative to L</load_classes> above which assumes an alternative
 290 layout for automatic class loading.  This variant takes no arguments.  It
 291 assumes that all ResultSource classes to be loaded are underneath a sub-
 292 namespace of the schema called "ResultSource", and any corresponding
 293 ResultSet classes to be underneath a sub-namespace of the schema called
 294 "ResultSet".
 295
 296 Any missing ResultSet definitions will be created in memory as basic
 297 inheritors of L<DBIx::Class::ResultSet>.  You don't need to explicitly
 298 specify the result_class of the sources unless you wish to override
 299 the naming convention above.
 300
 301 This method requires L<Module::Find> to be installed on the system.
 302
 303 Example:
 304
 305   My::Schema->load_namespaces;
 306   # loads My::Schema::ResultSource::CD, My::Schema::ResultSource::Artist,
 307   #    My::Schema::ResultSet::CD, etc...
 308
 309 =cut
 310
 311 sub load_namespaces {
 312   my ($class) = @_;
 313
 314   my $source_namespace = $class . '::ResultSource';
 315   my $resultset_namespace = $class . '::ResultSet';
 316
 317   eval "require Module::Find";
 318   $class->throw_exception("Couldn't load Module::Find ($@)") if $@;
 319
 320   my %sources = map { (substr($_, length "${source_namespace}::"), $_) }
 321       Module::Find::findallmod($source_namespace);
 322
 323   my %resultsets = map { (substr($_, length "${resultset_namespace}::"), $_) }
 324       Module::Find::findallmod($resultset_namespace);
 325
 326   my @to_register;
 327   {
 328     no warnings qw/redefine/;
 329     local *Class::C3::reinitialize = sub { };
 330     foreach my $source (keys %sources) {
 331       my $source_class = $sources{$source};
 332       $class->ensure_class_loaded($source_class);
 333       $source_class->source_name($source) unless $source_class->source_name;
 334       unless($source_class->resultset_class) {
 335         if(my $rs_class = delete $resultsets{$source}) {
 336           $class->ensure_class_loaded($rs_class);
 337           $source_class->resultset_class($rs_class);
 338         }
 339         else {
 340           require DBIx::Class::ResultSet;
 341           my $rs_class = "${class}::ResultSet::$source";
 342           @{"$rs_class::ISA"} = 'DBIx::Class::ResultSet';
 343           $source_class->resultset_class($rs_class);
 344         }
 345       }
 346
 347       push(@to_register, [ $source_class->source_name, $source_class ]);
 348     }
 349   }
 350
 351   foreach (keys %resultsets) {
 352     warn "load_namespaces found ResultSet $_ with no "
 353       . 'corresponding ResultSource';
 354   }
 355
 356   Class::C3->reinitialize;
 357
 358   foreach my $to (@to_register) {
 359     $class->register_class(@$to);
 360     #  if $class->can('result_source_instance');
 361   }
 362 }
 363
 364 =head2 compose_connection
 365
 366 =over 4
 367
 368 =item Arguments: $target_namespace, @db_info
 369
 370 =item Return Value: $new_schema
 371
 372 =back
 373
 374 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 375 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 376 then injects the L<DBix::Class::ResultSetProxy> component and a
 377 resultset_instance classdata entry on all the new classes, in order to support
 378 $target_namespaces::$class->search(...) method calls.
 379
 380 This is primarily useful when you have a specific need for class method access
 381 to a connection. In normal usage it is preferred to call
 382 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 383 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 384 more information.
 385
 386 =cut
 387
 388 sub compose_connection {
 389   my ($self, $target, @info) = @_;
 390   my $base = 'DBIx::Class::ResultSetProxy';
 391   eval "require ${base};";
 392   $self->throw_exception
 393     ("No arguments to load_classes and couldn't load ${base} ($@)")
 394       if $@;
 395
 396   if ($self eq $target) {
 397     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 398     foreach my $moniker ($self->sources) {
 399       my $source = $self->source($moniker);
 400       my $class = $source->result_class;
 401       $self->inject_base($class, $base);
 402       $class->mk_classdata(resultset_instance => $source->resultset);
 403       $class->mk_classdata(class_resolver => $self);
 404     }
 405     $self->connection(@info);
 406     return $self;
 407   }
 408
 409   my $schema = $self->compose_namespace($target, $base);
 410   {
 411     no strict 'refs';
 412     *{"${target}::schema"} = sub { $schema };
 413   }
 414
 415   $schema->connection(@info);
 416   foreach my $moniker ($schema->sources) {
 417     my $source = $schema->source($moniker);
 418     my $class = $source->result_class;
 419     #warn "$moniker $class $source ".$source->storage;
 420     $class->mk_classdata(result_source_instance => $source);
 421     $class->mk_classdata(resultset_instance => $source->resultset);
 422     $class->mk_classdata(class_resolver => $schema);
 423   }
 424   return $schema;
 425 }
 426
 427 =head2 compose_namespace
 428
 429 =over 4
 430
 431 =item Arguments: $target_namespace, $additional_base_class?
 432
 433 =item Return Value: $new_schema
 434
 435 =back
 436
 437 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 438 class in the target namespace (e.g. $target_namespace::CD,
 439 $target_namespace::Artist) that inherits from the corresponding classes
 440 attached to the current schema.
 441
 442 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 443 new $schema object. If C<$additional_base_class> is given, the new composed
 444 classes will inherit from first the corresponding classe from the current
 445 schema then the base class.
 446
 447 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 448
 449   $schema->compose_namespace('My::DB', 'Base::Class');
 450   print join (', ', @My::DB::CD::ISA) . "\n";
 451   print join (', ', @My::DB::Artist::ISA) ."\n";
 452
 453 will produce the output
 454
 455   My::Schema::CD, Base::Class
 456   My::Schema::Artist, Base::Class
 457
 458 =cut
 459
 460 sub compose_namespace {
 461   my ($self, $target, $base) = @_;
 462   my %reg = %{ $self->source_registrations };
 463   my %target;
 464   my %map;
 465   my $schema = $self->clone;
 466   {
 467     no warnings qw/redefine/;
 468     local *Class::C3::reinitialize = sub { };
 469     foreach my $moniker ($schema->sources) {
 470       my $source = $schema->source($moniker);
 471       my $target_class = "${target}::${moniker}";
 472       $self->inject_base(
 473         $target_class => $source->result_class, ($base ? $base : ())
 474       );
 475       $source->result_class($target_class);
 476       $target_class->result_source_instance($source)
 477         if $target_class->can('result_source_instance');
 478     }
 479   }
 480   Class::C3->reinitialize();
 481   {
 482     no strict 'refs';
 483     foreach my $meth (qw/class source resultset/) {
 484       *{"${target}::${meth}"} =
 485         sub { shift->schema->$meth(@_) };
 486     }
 487   }
 488   return $schema;
 489 }
 490
 491 =head2 setup_connection_class
 492
 493 =over 4
 494
 495 =item Arguments: $target, @info
 496
 497 =back
 498
 499 Sets up a database connection class to inject between the schema and the
 500 subclasses that the schema creates.
 501
 502 =cut
 503
 504 sub setup_connection_class {
 505   my ($class, $target, @info) = @_;
 506   $class->inject_base($target => 'DBIx::Class::DB');
 507   #$target->load_components('DB');
 508   $target->connection(@info);
 509 }
 510
 511 =head2 connection
 512
 513 =over 4
 514
 515 =item Arguments: @args
 516
 517 =item Return Value: $new_schema
 518
 519 =back
 520
 521 Instantiates a new Storage object of type
 522 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 523 $storage->connect_info. Sets the connection in-place on the schema. See
 524 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
 525
 526 =cut
 527
 528 sub connection {
 529   my ($self, @info) = @_;
 530   return $self if !@info && $self->storage;
 531   my $storage_class = $self->storage_type;
 532   $storage_class = 'DBIx::Class::Storage'.$storage_class
 533     if $storage_class =~ m/^::/;
 534   eval "require ${storage_class};";
 535   $self->throw_exception(
 536     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 537   ) if $@;
 538   my $storage = $storage_class->new;
 539   $storage->connect_info(\@info);
 540   $self->storage($storage);
 541   return $self;
 542 }
 543
 544 =head2 connect
 545
 546 =over 4
 547
 548 =item Arguments: @info
 549
 550 =item Return Value: $new_schema
 551
 552 =back
 553
 554 This is a convenience method. It is equivalent to calling
 555 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 556 information.
 557
 558 =cut
 559
 560 sub connect { shift->clone->connection(@_) }
 561
 562 =head2 txn_begin
 563
 564 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 565 calling $schema->storage->txn_begin. See
 566 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 567
 568 =cut
 569
 570 sub txn_begin { shift->storage->txn_begin }
 571
 572 =head2 txn_commit
 573
 574 Commits the current transaction. Equivalent to calling
 575 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 576 for more information.
 577
 578 =cut
 579
 580 sub txn_commit { shift->storage->txn_commit }
 581
 582 =head2 txn_rollback
 583
 584 Rolls back the current transaction. Equivalent to calling
 585 $schema->storage->txn_rollback. See
 586 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 587
 588 =cut
 589
 590 sub txn_rollback { shift->storage->txn_rollback }
 591
 592 =head2 txn_do
 593
 594 =over 4
 595
 596 =item Arguments: C<$coderef>, @coderef_args?
 597
 598 =item Return Value: The return value of $coderef
 599
 600 =back
 601
 602 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 603 returning its result (if any). If an exception is caught, a rollback is issued
 604 and the exception is rethrown. If the rollback fails, (i.e. throws an
 605 exception) an exception is thrown that includes a "Rollback failed" message.
 606
 607 For example,
 608
 609   my $author_rs = $schema->resultset('Author')->find(1);
 610   my @titles = qw/Night Day It/;
 611
 612   my $coderef = sub {
 613     # If any one of these fails, the entire transaction fails
 614     $author_rs->create_related('books', {
 615       title => $_
 616     }) foreach (@titles);
 617
 618     return $author->books;
 619   };
 620
 621   my $rs;
 622   eval {
 623     $rs = $schema->txn_do($coderef);
 624   };
 625
 626   if ($@) {                                  # Transaction failed
 627     die "something terrible has happened!"   #
 628       if ($@ =~ /Rollback failed/);          # Rollback failed
 629
 630     deal_with_failed_transaction();
 631   }
 632
 633 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 634 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
 635 the Schema's storage, and txn_do() can be called in void, scalar and list
 636 context and it will behave as expected.
 637
 638 =cut
 639
 640 sub txn_do {
 641   my ($self, $coderef, @args) = @_;
 642
 643   $self->storage or $self->throw_exception
 644     ('txn_do called on $schema without storage');
 645   ref $coderef eq 'CODE' or $self->throw_exception
 646     ('$coderef must be a CODE reference');
 647
 648   my (@return_values, $return_value);
 649
 650   $self->txn_begin; # If this throws an exception, no rollback is needed
 651
 652   my $wantarray = wantarray; # Need to save this since the context
 653                              # inside the eval{} block is independent
 654                              # of the context that called txn_do()
 655   eval {
 656
 657     # Need to differentiate between scalar/list context to allow for
 658     # returning a list in scalar context to get the size of the list
 659     if ($wantarray) {
 660       # list context
 661       @return_values = $coderef->(@args);
 662     } elsif (defined $wantarray) {
 663       # scalar context
 664       $return_value = $coderef->(@args);
 665     } else {
 666       # void context
 667       $coderef->(@args);
 668     }
 669     $self->txn_commit;
 670   };
 671
 672   if ($@) {
 673     my $error = $@;
 674
 675     eval {
 676       $self->txn_rollback;
 677     };
 678
 679     if ($@) {
 680       my $rollback_error = $@;
 681       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 682       $self->throw_exception($error)  # propagate nested rollback
 683         if $rollback_error =~ /$exception_class/;
 684
 685       $self->throw_exception(
 686         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 687       );
 688     } else {
 689       $self->throw_exception($error); # txn failed but rollback succeeded
 690     }
 691   }
 692
 693   return $wantarray ? @return_values : $return_value;
 694 }
 695
 696 =head2 clone
 697
 698 =over 4
 699
 700 =item Return Value: $new_schema
 701
 702 =back
 703
 704 Clones the schema and its associated result_source objects and returns the
 705 copy.
 706
 707 =cut
 708
 709 sub clone {
 710   my ($self) = @_;
 711   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 712   foreach my $moniker ($self->sources) {
 713     my $source = $self->source($moniker);
 714     my $new = $source->new($source);
 715     $clone->register_source($moniker => $new);
 716   }
 717   return $clone;
 718 }
 719
 720 =head2 populate
 721
 722 =over 4
 723
 724 =item Arguments: $moniker, \@data;
 725
 726 =back
 727
 728 Populates the source registered with the given moniker with the supplied data.
 729 @data should be a list of listrefs -- the first containing column names, the
 730 second matching values.
 731
 732 i.e.,
 733
 734   $schema->populate('Artist', [
 735     [ qw/artistid name/ ],
 736     [ 1, 'Popular Band' ],
 737     [ 2, 'Indie Band' ],
 738     ...
 739   ]);
 740
 741 =cut
 742
 743 sub populate {
 744   my ($self, $name, $data) = @_;
 745   my $rs = $self->resultset($name);
 746   my @names = @{shift(@$data)};
 747   my @created;
 748   foreach my $item (@$data) {
 749     my %create;
 750     @create{@names} = @$item;
 751     push(@created, $rs->create(\%create));
 752   }
 753   return @created;
 754 }
 755
 756 =head2 throw_exception
 757
 758 =over 4
 759
 760 =item Arguments: $message
 761
 762 =back
 763
 764 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 765 user's perspective.
 766
 767 =cut
 768
 769 sub throw_exception {
 770   my ($self) = shift;
 771   croak @_;
 772 }
 773
 774 =head2 deploy (EXPERIMENTAL)
 775
 776 =over 4
 777
 778 =item Arguments: $sqlt_args
 779
 780 =back
 781
 782 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 783
 784 Note that this feature is currently EXPERIMENTAL and may not work correctly
 785 across all databases, or fully handle complex relationships.
 786
 787 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 788 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 789 produced include a DROP TABLE statement for each table created.
 790
 791 =cut
 792
 793 sub deploy {
 794   my ($self, $sqltargs) = @_;
 795   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 796   $self->storage->deploy($self, undef, $sqltargs);
 797 }
 798
 799 =head2 create_ddl_dir (EXPERIMENTAL)
 800
 801 =over 4
 802
 803 =item Arguments: \@databases, $version, $directory, $sqlt_args
 804
 805 =back
 806
 807 Creates an SQL file based on the Schema, for each of the specified
 808 database types, in the given directory.
 809
 810 Note that this feature is currently EXPERIMENTAL and may not work correctly
 811 across all databases, or fully handle complex relationships.
 812
 813 =cut
 814
 815 sub create_ddl_dir
 816 {
 817   my $self = shift;
 818
 819   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 820   $self->storage->create_ddl_dir($self, @_);
 821 }
 822
 823 =head2 ddl_filename (EXPERIMENTAL)
 824
 825   my $filename = $table->ddl_filename($type, $dir, $version)
 826
 827 Creates a filename for a SQL file based on the table class name.  Not
 828 intended for direct end user use.
 829
 830 =cut
 831
 832 sub ddl_filename
 833 {
 834     my ($self, $type, $dir, $version) = @_;
 835
 836     my $filename = ref($self);
 837     $filename =~ s/::/-/;
 838     $filename = "$dir$filename-$version-$type.sql";
 839
 840     return $filename;
 841 }
 842
 843 1;
 844
 845 =head1 AUTHORS
 846
 847 Matt S. Trout <mst@shadowcatsystems.co.uk>
 848
 849 =head1 LICENSE
 850
 851 You may distribute this code under the same terms as Perl itself.
 852
 853 =cut
 854