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