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