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