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