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