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