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