lib/DBIx/Class/Schema.pm

   1 package DBIx::Class::Schema;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::Exception;
   7 use DBIx::Class::Carp;
   8 use Try::Tiny;
   9 use Scalar::Util 'weaken';
  10 use Sub::Name 'subname';
  11 use B 'svref_2object';
  12 use DBIx::Class::GlobalDestruction;
  13 use namespace::clean;
  14
  15 use base qw/DBIx::Class/;
  16
  17 __PACKAGE__->mk_classdata('class_mappings' => {});
  18 __PACKAGE__->mk_classdata('source_registrations' => {});
  19 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  20 __PACKAGE__->mk_classdata('storage');
  21 __PACKAGE__->mk_classdata('exception_action');
  22 __PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0);
  23 __PACKAGE__->mk_classdata('default_resultset_attributes' => {});
  24
  25 =head1 NAME
  26
  27 DBIx::Class::Schema - composable schemas
  28
  29 =head1 SYNOPSIS
  30
  31   package Library::Schema;
  32   use base qw/DBIx::Class::Schema/;
  33
  34   # load all Result classes in Library/Schema/Result/
  35   __PACKAGE__->load_namespaces();
  36
  37   package Library::Schema::Result::CD;
  38   use base qw/DBIx::Class::Core/;
  39
  40   __PACKAGE__->load_components(qw/InflateColumn::DateTime/); # for example
  41   __PACKAGE__->table('cd');
  42
  43   # Elsewhere in your code:
  44   my $schema1 = Library::Schema->connect(
  45     $dsn,
  46     $user,
  47     $password,
  48     { AutoCommit => 1 },
  49   );
  50
  51   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  52
  53   # fetch objects using Library::Schema::Result::DVD
  54   my $resultset = $schema1->resultset('DVD')->search( ... );
  55   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  56
  57 =head1 DESCRIPTION
  58
  59 Creates database classes based on a schema. This is the recommended way to
  60 use L<DBIx::Class> and allows you to use more than one concurrent connection
  61 with your classes.
  62
  63 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  64 carefully, as DBIx::Class does things a little differently. Note in
  65 particular which module inherits off which.
  66
  67 =head1 SETUP METHODS
  68
  69 =head2 load_namespaces
  70
  71 =over 4
  72
  73 =item Arguments: %options?
  74
  75 =back
  76
  77   __PACKAGE__->load_namespaces();
  78
  79   __PACKAGE__->load_namespaces(
  80      result_namespace => 'Res',
  81      resultset_namespace => 'RSet',
  82      default_resultset_class => '+MyDB::Othernamespace::RSet',
  83   );
  84
  85 With no arguments, this method uses L<Module::Find> to load all of the
  86 Result and ResultSet classes under the namespace of the schema from
  87 which it is called.  For example, C<My::Schema> will by default find
  88 and load Result classes named C<My::Schema::Result::*> and ResultSet
  89 classes named C<My::Schema::ResultSet::*>.
  90
  91 ResultSet classes are associated with Result class of the same name.
  92 For example, C<My::Schema::Result::CD> will get the ResultSet class
  93 C<My::Schema::ResultSet::CD> if it is present.
  94
  95 Both Result and ResultSet namespaces are configurable via the
  96 C<result_namespace> and C<resultset_namespace> options.
  97
  98 Another option, C<default_resultset_class> specifies a custom default
  99 ResultSet class for Result classes with no corresponding ResultSet.
 100
 101 All of the namespace and classname options are by default relative to
 102 the schema classname.  To specify a fully-qualified name, prefix it
 103 with a literal C<+>.  For example, C<+Other::NameSpace::Result>.
 104
 105 =head3 Warnings
 106
 107 You will be warned if ResultSet classes are discovered for which there
 108 are no matching Result classes like this:
 109
 110   load_namespaces found ResultSet class $classname with no corresponding Result class
 111
 112 If a Result class is found to already have a ResultSet class set using
 113 L</resultset_class> to some other class, you will be warned like this:
 114
 115   We found ResultSet class '$rs_class' for '$result', but it seems
 116   that you had already set '$result' to use '$rs_set' instead
 117
 118 =head3 Examples
 119
 120   # load My::Schema::Result::CD, My::Schema::Result::Artist,
 121   #    My::Schema::ResultSet::CD, etc...
 122   My::Schema->load_namespaces;
 123
 124   # Override everything to use ugly names.
 125   # In this example, if there is a My::Schema::Res::Foo, but no matching
 126   #   My::Schema::RSets::Foo, then Foo will have its
 127   #   resultset_class set to My::Schema::RSetBase
 128   My::Schema->load_namespaces(
 129     result_namespace => 'Res',
 130     resultset_namespace => 'RSets',
 131     default_resultset_class => 'RSetBase',
 132   );
 133
 134   # Put things in other namespaces
 135   My::Schema->load_namespaces(
 136     result_namespace => '+Some::Place::Results',
 137     resultset_namespace => '+Another::Place::RSets',
 138   );
 139
 140 To search multiple namespaces for either Result or ResultSet classes,
 141 use an arrayref of namespaces for that option.  In the case that the
 142 same result (or resultset) class exists in multiple namespaces, later
 143 entries in the list of namespaces will override earlier ones.
 144
 145   My::Schema->load_namespaces(
 146     # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
 147     result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
 148     resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
 149   );
 150
 151 =cut
 152
 153 # Pre-pends our classname to the given relative classname or
 154 #   class namespace, unless there is a '+' prefix, which will
 155 #   be stripped.
 156 sub _expand_relative_name {
 157   my ($class, $name) = @_;
 158   return if !$name;
 159   $name = $class . '::' . $name if ! ($name =~ s/^\+//);
 160   return $name;
 161 }
 162
 163 # Finds all modules in the supplied namespace, or if omitted in the
 164 # namespace of $class. Untaints all findings as they can be assumed
 165 # to be safe
 166 sub _findallmod {
 167   my $proto = shift;
 168   my $ns = shift || ref $proto || $proto;
 169
 170   require Module::Find;
 171   my @mods = Module::Find::findallmod($ns);
 172
 173   # try to untaint module names. mods where this fails
 174   # are left alone so we don't have to change the old behavior
 175   no locale; # localized \w doesn't untaint expression
 176   return map { $_ =~ m/^( (?:\w+::)* \w+ )$/x ? $1 : $_ } @mods;
 177 }
 178
 179 # returns a hash of $shortname => $fullname for every package
 180 # found in the given namespaces ($shortname is with the $fullname's
 181 # namespace stripped off)
 182 sub _map_namespaces {
 183   my ($class, @namespaces) = @_;
 184
 185   my @results_hash;
 186   foreach my $namespace (@namespaces) {
 187     push(
 188       @results_hash,
 189       map { (substr($_, length "${namespace}::"), $_) }
 190       $class->_findallmod($namespace)
 191     );
 192   }
 193
 194   @results_hash;
 195 }
 196
 197 # returns the result_source_instance for the passed class/object,
 198 # or dies with an informative message (used by load_namespaces)
 199 sub _ns_get_rsrc_instance {
 200   my $me = shift;
 201   my $rs_class = ref ($_[0]) || $_[0];
 202
 203   return try {
 204     $rs_class->result_source_instance
 205   } catch {
 206     $me->throw_exception (
 207       "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_"
 208     );
 209   };
 210 }
 211
 212 sub load_namespaces {
 213   my ($class, %args) = @_;
 214
 215   my $result_namespace = delete $args{result_namespace} || 'Result';
 216   my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
 217   my $default_resultset_class = delete $args{default_resultset_class};
 218
 219   $class->throw_exception('load_namespaces: unknown option(s): '
 220     . join(q{,}, map { qq{'$_'} } keys %args))
 221       if scalar keys %args;
 222
 223   $default_resultset_class
 224     = $class->_expand_relative_name($default_resultset_class);
 225
 226   for my $arg ($result_namespace, $resultset_namespace) {
 227     $arg = [ $arg ] if !ref($arg) && $arg;
 228
 229     $class->throw_exception('load_namespaces: namespace arguments must be '
 230       . 'a simple string or an arrayref')
 231         if ref($arg) ne 'ARRAY';
 232
 233     $_ = $class->_expand_relative_name($_) for (@$arg);
 234   }
 235
 236   my %results = $class->_map_namespaces(@$result_namespace);
 237   my %resultsets = $class->_map_namespaces(@$resultset_namespace);
 238
 239   my @to_register;
 240   {
 241     no warnings qw/redefine/;
 242     local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
 243     use warnings qw/redefine/;
 244
 245     # ensure classes are loaded and attached in inheritance order
 246     for my $res (values %results) {
 247       $class->ensure_class_loaded($res);
 248     }
 249     my %inh_idx;
 250     my @subclass_last = sort {
 251
 252       ($inh_idx{$a} ||=
 253         scalar @{mro::get_linear_isa( $results{$a} )}
 254       )
 255
 256           <=>
 257
 258       ($inh_idx{$b} ||=
 259         scalar @{mro::get_linear_isa( $results{$b} )}
 260       )
 261
 262     } keys(%results);
 263
 264     foreach my $result (@subclass_last) {
 265       my $result_class = $results{$result};
 266
 267       my $rs_class = delete $resultsets{$result};
 268       my $rs_set = $class->_ns_get_rsrc_instance ($result_class)->resultset_class;
 269
 270       if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
 271         if($rs_class && $rs_class ne $rs_set) {
 272           carp "We found ResultSet class '$rs_class' for '$result', but it seems "
 273              . "that you had already set '$result' to use '$rs_set' instead";
 274         }
 275       }
 276       elsif($rs_class ||= $default_resultset_class) {
 277         $class->ensure_class_loaded($rs_class);
 278         if(!$rs_class->isa("DBIx::Class::ResultSet")) {
 279             carp "load_namespaces found ResultSet class $rs_class that does not subclass DBIx::Class::ResultSet";
 280         }
 281
 282         $class->_ns_get_rsrc_instance ($result_class)->resultset_class($rs_class);
 283       }
 284
 285       my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $result;
 286
 287       push(@to_register, [ $source_name, $result_class ]);
 288     }
 289   }
 290
 291   foreach (sort keys %resultsets) {
 292     carp "load_namespaces found ResultSet class $_ with no "
 293       . 'corresponding Result class';
 294   }
 295
 296   Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
 297
 298   $class->register_class(@$_) for (@to_register);
 299
 300   return;
 301 }
 302
 303 =head2 load_classes
 304
 305 =over 4
 306
 307 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 308
 309 =back
 310
 311 L</load_classes> is an alternative method to L</load_namespaces>, both of
 312 which serve similar purposes, each with different advantages and disadvantages.
 313 In the general case you should use L</load_namespaces>, unless you need to
 314 be able to specify that only specific classes are loaded at runtime.
 315
 316 With no arguments, this method uses L<Module::Find> to find all classes under
 317 the schema's namespace. Otherwise, this method loads the classes you specify
 318 (using L<use>), and registers them (using L</"register_class">).
 319
 320 It is possible to comment out classes with a leading C<#>, but note that perl
 321 will think it's a mistake (trying to use a comment in a qw list), so you'll
 322 need to add C<no warnings 'qw';> before your load_classes call.
 323
 324 If any classes found do not appear to be Result class files, you will
 325 get the following warning:
 326
 327    Failed to load $comp_class. Can't find source_name method. Is
 328    $comp_class really a full DBIC result class? Fix it, move it elsewhere,
 329    or make your load_classes call more specific.
 330
 331 Example:
 332
 333   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 334                               # etc. (anything under the My::Schema namespace)
 335
 336   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 337   # not Other::Namespace::LinerNotes nor My::Schema::Track
 338   My::Schema->load_classes(qw/ CD Artist #Track /, {
 339     Other::Namespace => [qw/ Producer #LinerNotes /],
 340   });
 341
 342 =cut
 343
 344 sub load_classes {
 345   my ($class, @params) = @_;
 346
 347   my %comps_for;
 348
 349   if (@params) {
 350     foreach my $param (@params) {
 351       if (ref $param eq 'ARRAY') {
 352         # filter out commented entries
 353         my @modules = grep { $_ !~ /^#/ } @$param;
 354
 355         push (@{$comps_for{$class}}, @modules);
 356       }
 357       elsif (ref $param eq 'HASH') {
 358         # more than one namespace possible
 359         for my $comp ( keys %$param ) {
 360           # filter out commented entries
 361           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 362
 363           push (@{$comps_for{$comp}}, @modules);
 364         }
 365       }
 366       else {
 367         # filter out commented entries
 368         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 369       }
 370     }
 371   } else {
 372     my @comp = map { substr $_, length "${class}::"  }
 373                  $class->_findallmod;
 374     $comps_for{$class} = \@comp;
 375   }
 376
 377   my @to_register;
 378   {
 379     no warnings qw/redefine/;
 380     local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
 381     use warnings qw/redefine/;
 382
 383     foreach my $prefix (keys %comps_for) {
 384       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 385         my $comp_class = "${prefix}::${comp}";
 386         $class->ensure_class_loaded($comp_class);
 387
 388         my $snsub = $comp_class->can('source_name');
 389         if(! $snsub ) {
 390           carp "Failed to load $comp_class. Can't find source_name method. Is $comp_class really a full DBIC result class? Fix it, move it elsewhere, or make your load_classes call more specific.";
 391           next;
 392         }
 393         $comp = $snsub->($comp_class) || $comp;
 394
 395         push(@to_register, [ $comp, $comp_class ]);
 396       }
 397     }
 398   }
 399   Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
 400
 401   foreach my $to (@to_register) {
 402     $class->register_class(@$to);
 403   }
 404 }
 405
 406 =head2 storage_type
 407
 408 =over 4
 409
 410 =item Arguments: $storage_type|{$storage_type, \%args}
 411
 412 =item Return value: $storage_type|{$storage_type, \%args}
 413
 414 =item Default value: DBIx::Class::Storage::DBI
 415
 416 =back
 417
 418 Set the storage class that will be instantiated when L</connect> is called.
 419 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 420 assumed by L</connect>.
 421
 422 You want to use this to set subclasses of L<DBIx::Class::Storage::DBI>
 423 in cases where the appropriate subclass is not autodetected.
 424
 425 If your storage type requires instantiation arguments, those are
 426 defined as a second argument in the form of a hashref and the entire
 427 value needs to be wrapped into an arrayref or a hashref.  We support
 428 both types of refs here in order to play nice with your
 429 Config::[class] or your choice. See
 430 L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
 431
 432 =head2 exception_action
 433
 434 =over 4
 435
 436 =item Arguments: $code_reference
 437
 438 =item Return value: $code_reference
 439
 440 =item Default value: None
 441
 442 =back
 443
 444 When L</throw_exception> is invoked and L</exception_action> is set to a code
 445 reference, this reference will be called instead of
 446 L<DBIx::Class::Exception/throw>, with the exception message passed as the only
 447 argument.
 448
 449 Your custom throw code B<must> rethrow the exception, as L</throw_exception> is
 450 an integral part of DBIC's internal execution control flow.
 451
 452 Example:
 453
 454    package My::Schema;
 455    use base qw/DBIx::Class::Schema/;
 456    use My::ExceptionClass;
 457    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 458    __PACKAGE__->load_classes;
 459
 460    # or:
 461    my $schema_obj = My::Schema->connect( .... );
 462    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 463
 464 =head2 stacktrace
 465
 466 =over 4
 467
 468 =item Arguments: boolean
 469
 470 =back
 471
 472 Whether L</throw_exception> should include stack trace information.
 473 Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
 474 is true.
 475
 476 =head2 sqlt_deploy_hook
 477
 478 =over
 479
 480 =item Arguments: $sqlt_schema
 481
 482 =back
 483
 484 An optional sub which you can declare in your own Schema class that will get
 485 passed the L<SQL::Translator::Schema> object when you deploy the schema via
 486 L</create_ddl_dir> or L</deploy>.
 487
 488 For an example of what you can do with this, see
 489 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
 490
 491 Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
 492 is called before L</deploy>. Therefore the hook can be used only to manipulate
 493 the L<SQL::Translator::Schema> object before it is turned into SQL fed to the
 494 database. If you want to execute post-deploy statements which can not be generated
 495 by L<SQL::Translator>, the currently suggested method is to overload L</deploy>
 496 and use L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
 497
 498 =head1 METHODS
 499
 500 =head2 connect
 501
 502 =over 4
 503
 504 =item Arguments: @connectinfo
 505
 506 =item Return Value: $new_schema
 507
 508 =back
 509
 510 Creates and returns a new Schema object. The connection info set on it
 511 is used to create a new instance of the storage backend and set it on
 512 the Schema object.
 513
 514 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific
 515 syntax on the C<@connectinfo> argument, or L<DBIx::Class::Storage> in
 516 general.
 517
 518 Note that C<connect_info> expects an arrayref of arguments, but
 519 C<connect> does not. C<connect> wraps its arguments in an arrayref
 520 before passing them to C<connect_info>.
 521
 522 =head3 Overloading
 523
 524 C<connect> is a convenience method. It is equivalent to calling
 525 $schema->clone->connection(@connectinfo). To write your own overloaded
 526 version, overload L</connection> instead.
 527
 528 =cut
 529
 530 sub connect { shift->clone->connection(@_) }
 531
 532 =head2 resultset
 533
 534 =over 4
 535
 536 =item Arguments: $source_name
 537
 538 =item Return Value: $resultset
 539
 540 =back
 541
 542   my $rs = $schema->resultset('DVD');
 543
 544 Returns the L<DBIx::Class::ResultSet> object for the registered source
 545 name.
 546
 547 =cut
 548
 549 sub resultset {
 550   my ($self, $moniker) = @_;
 551   $self->throw_exception('resultset() expects a source name')
 552     unless defined $moniker;
 553   return $self->source($moniker)->resultset;
 554 }
 555
 556 =head2 sources
 557
 558 =over 4
 559
 560 =item Return Value: @source_names
 561
 562 =back
 563
 564   my @source_names = $schema->sources;
 565
 566 Lists names of all the sources registered on this Schema object.
 567
 568 =cut
 569
 570 sub sources { return keys %{shift->source_registrations}; }
 571
 572 =head2 source
 573
 574 =over 4
 575
 576 =item Arguments: $source_name
 577
 578 =item Return Value: $result_source
 579
 580 =back
 581
 582   my $source = $schema->source('Book');
 583
 584 Returns the L<DBIx::Class::ResultSource> object for the registered
 585 source name.
 586
 587 =cut
 588
 589 sub source {
 590   my $self = shift;
 591
 592   $self->throw_exception("source() expects a source name")
 593     unless @_;
 594
 595   my $moniker = shift;
 596
 597   my $sreg = $self->source_registrations;
 598   return $sreg->{$moniker} if exists $sreg->{$moniker};
 599
 600   # if we got here, they probably passed a full class name
 601   my $mapped = $self->class_mappings->{$moniker};
 602   $self->throw_exception("Can't find source for ${moniker}")
 603     unless $mapped && exists $sreg->{$mapped};
 604   return $sreg->{$mapped};
 605 }
 606
 607 =head2 class
 608
 609 =over 4
 610
 611 =item Arguments: $source_name
 612
 613 =item Return Value: $classname
 614
 615 =back
 616
 617   my $class = $schema->class('CD');
 618
 619 Retrieves the Result class name for the given source name.
 620
 621 =cut
 622
 623 sub class {
 624   my ($self, $moniker) = @_;
 625   return $self->source($moniker)->result_class;
 626 }
 627
 628 =head2 txn_do
 629
 630 =over 4
 631
 632 =item Arguments: C<$coderef>, @coderef_args?
 633
 634 =item Return Value: The return value of $coderef
 635
 636 =back
 637
 638 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 639 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 640 See L<DBIx::Class::Storage/"txn_do"> for more information.
 641
 642 This interface is preferred over using the individual methods L</txn_begin>,
 643 L</txn_commit>, and L</txn_rollback> below.
 644
 645 WARNING: If you are connected with C<< AutoCommit => 0 >> the transaction is
 646 considered nested, and you will still need to call L</txn_commit> to write your
 647 changes when appropriate. You will also want to connect with C<< auto_savepoint =>
 648 1 >> to get partial rollback to work, if the storage driver for your database
 649 supports it.
 650
 651 Connecting with C<< AutoCommit => 1 >> is recommended.
 652
 653 =cut
 654
 655 sub txn_do {
 656   my $self = shift;
 657
 658   $self->storage or $self->throw_exception
 659     ('txn_do called on $schema without storage');
 660
 661   $self->storage->txn_do(@_);
 662 }
 663
 664 =head2 txn_scope_guard
 665
 666 Runs C<txn_scope_guard> on the schema's storage. See
 667 L<DBIx::Class::Storage/txn_scope_guard>.
 668
 669 =cut
 670
 671 sub txn_scope_guard {
 672   my $self = shift;
 673
 674   $self->storage or $self->throw_exception
 675     ('txn_scope_guard called on $schema without storage');
 676
 677   $self->storage->txn_scope_guard(@_);
 678 }
 679
 680 =head2 txn_begin
 681
 682 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 683 calling $schema->storage->txn_begin. See
 684 L<DBIx::Class::Storage/"txn_begin"> for more information.
 685
 686 =cut
 687
 688 sub txn_begin {
 689   my $self = shift;
 690
 691   $self->storage or $self->throw_exception
 692     ('txn_begin called on $schema without storage');
 693
 694   $self->storage->txn_begin;
 695 }
 696
 697 =head2 txn_commit
 698
 699 Commits the current transaction. Equivalent to calling
 700 $schema->storage->txn_commit. See L<DBIx::Class::Storage/"txn_commit">
 701 for more information.
 702
 703 =cut
 704
 705 sub txn_commit {
 706   my $self = shift;
 707
 708   $self->storage or $self->throw_exception
 709     ('txn_commit called on $schema without storage');
 710
 711   $self->storage->txn_commit;
 712 }
 713
 714 =head2 txn_rollback
 715
 716 Rolls back the current transaction. Equivalent to calling
 717 $schema->storage->txn_rollback. See
 718 L<DBIx::Class::Storage/"txn_rollback"> for more information.
 719
 720 =cut
 721
 722 sub txn_rollback {
 723   my $self = shift;
 724
 725   $self->storage or $self->throw_exception
 726     ('txn_rollback called on $schema without storage');
 727
 728   $self->storage->txn_rollback;
 729 }
 730
 731 =head2 storage
 732
 733   my $storage = $schema->storage;
 734
 735 Returns the L<DBIx::Class::Storage> object for this Schema. Grab this
 736 if you want to turn on SQL statement debugging at runtime, or set the
 737 quote character. For the default storage, the documentation can be
 738 found in L<DBIx::Class::Storage::DBI>.
 739
 740 =head2 populate
 741
 742 =over 4
 743
 744 =item Arguments: $source_name, \@data;
 745
 746 =item Return value: \@$objects | nothing
 747
 748 =back
 749
 750 Pass this method a resultsource name, and an arrayref of
 751 arrayrefs. The arrayrefs should contain a list of column names,
 752 followed by one or many sets of matching data for the given columns.
 753
 754 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 755 to insert the data, as this is a fast method. However, insert_bulk currently
 756 assumes that your datasets all contain the same type of values, using scalar
 757 references in a column in one row, and not in another will probably not work.
 758
 759 Otherwise, each set of data is inserted into the database using
 760 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 761 objects is returned.
 762
 763 e.g.
 764
 765   $schema->populate('Artist', [
 766     [ qw/artistid name/ ],
 767     [ 1, 'Popular Band' ],
 768     [ 2, 'Indie Band' ],
 769     ...
 770   ]);
 771
 772 Since wantarray context is basically the same as looping over $rs->create(...)
 773 you won't see any performance benefits and in this case the method is more for
 774 convenience. Void context sends the column information directly to storage
 775 using <DBI>s bulk insert method. So the performance will be much better for
 776 storages that support this method.
 777
 778 Because of this difference in the way void context inserts rows into your
 779 database you need to note how this will effect any loaded components that
 780 override or augment insert.  For example if you are using a component such
 781 as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
 782 wantarray context if you want the PKs automatically created.
 783
 784 =cut
 785
 786 sub populate {
 787   my ($self, $name, $data) = @_;
 788   if(my $rs = $self->resultset($name)) {
 789     if(defined wantarray) {
 790         return $rs->populate($data);
 791     } else {
 792         $rs->populate($data);
 793     }
 794   } else {
 795       $self->throw_exception("$name is not a resultset");
 796   }
 797 }
 798
 799 =head2 connection
 800
 801 =over 4
 802
 803 =item Arguments: @args
 804
 805 =item Return Value: $new_schema
 806
 807 =back
 808
 809 Similar to L</connect> except sets the storage object and connection
 810 data in-place on the Schema class. You should probably be calling
 811 L</connect> to get a proper Schema object instead.
 812
 813 =head3 Overloading
 814
 815 Overload C<connection> to change the behaviour of C<connect>.
 816
 817 =cut
 818
 819 sub connection {
 820   my ($self, @info) = @_;
 821   return $self if !@info && $self->storage;
 822
 823   my ($storage_class, $args) = ref $self->storage_type ?
 824     ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
 825
 826   $storage_class = 'DBIx::Class::Storage'.$storage_class
 827     if $storage_class =~ m/^::/;
 828   try {
 829     $self->ensure_class_loaded ($storage_class);
 830   }
 831   catch {
 832     $self->throw_exception(
 833       "Unable to load storage class ${storage_class}: $_"
 834     );
 835   };
 836   my $storage = $storage_class->new($self=>$args);
 837   $storage->connect_info(\@info);
 838   $self->storage($storage);
 839   return $self;
 840 }
 841
 842 sub _normalize_storage_type {
 843   my ($self, $storage_type) = @_;
 844   if(ref $storage_type eq 'ARRAY') {
 845     return @$storage_type;
 846   } elsif(ref $storage_type eq 'HASH') {
 847     return %$storage_type;
 848   } else {
 849     $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
 850   }
 851 }
 852
 853 =head2 compose_namespace
 854
 855 =over 4
 856
 857 =item Arguments: $target_namespace, $additional_base_class?
 858
 859 =item Retur Value: $new_schema
 860
 861 =back
 862
 863 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 864 class in the target namespace (e.g. $target_namespace::CD,
 865 $target_namespace::Artist) that inherits from the corresponding classes
 866 attached to the current schema.
 867
 868 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 869 new $schema object. If C<$additional_base_class> is given, the new composed
 870 classes will inherit from first the corresponding class from the current
 871 schema then the base class.
 872
 873 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 874
 875   $schema->compose_namespace('My::DB', 'Base::Class');
 876   print join (', ', @My::DB::CD::ISA) . "\n";
 877   print join (', ', @My::DB::Artist::ISA) ."\n";
 878
 879 will produce the output
 880
 881   My::Schema::CD, Base::Class
 882   My::Schema::Artist, Base::Class
 883
 884 =cut
 885
 886 # this might be oversimplified
 887 # sub compose_namespace {
 888 #   my ($self, $target, $base) = @_;
 889
 890 #   my $schema = $self->clone;
 891 #   foreach my $moniker ($schema->sources) {
 892 #     my $source = $schema->source($moniker);
 893 #     my $target_class = "${target}::${moniker}";
 894 #     $self->inject_base(
 895 #       $target_class => $source->result_class, ($base ? $base : ())
 896 #     );
 897 #     $source->result_class($target_class);
 898 #     $target_class->result_source_instance($source)
 899 #       if $target_class->can('result_source_instance');
 900 #     $schema->register_source($moniker, $source);
 901 #   }
 902 #   return $schema;
 903 # }
 904
 905 sub compose_namespace {
 906   my ($self, $target, $base) = @_;
 907
 908   my $schema = $self->clone;
 909
 910   $schema->source_registrations({});
 911
 912   # the original class-mappings must remain - otherwise
 913   # reverse_relationship_info will not work
 914   #$schema->class_mappings({});
 915
 916   {
 917     no warnings qw/redefine/;
 918     local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
 919     use warnings qw/redefine/;
 920
 921     no strict qw/refs/;
 922     foreach my $moniker ($self->sources) {
 923       my $orig_source = $self->source($moniker);
 924
 925       my $target_class = "${target}::${moniker}";
 926       $self->inject_base($target_class, $orig_source->result_class, ($base || ()) );
 927
 928       # register_source examines result_class, and then returns us a clone
 929       my $new_source = $schema->register_source($moniker, bless
 930         { %$orig_source, result_class => $target_class },
 931         ref $orig_source,
 932       );
 933
 934       if ($target_class->can('result_source_instance')) {
 935         # give the class a schema-less source copy
 936         $target_class->result_source_instance( bless
 937           { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} },
 938           ref $new_source,
 939         );
 940       }
 941     }
 942
 943     foreach my $meth (qw/class source resultset/) {
 944       no warnings 'redefine';
 945       *{"${target}::${meth}"} = subname "${target}::${meth}" =>
 946         sub { shift->schema->$meth(@_) };
 947     }
 948   }
 949
 950   Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
 951
 952   return $schema;
 953 }
 954
 955 sub setup_connection_class {
 956   my ($class, $target, @info) = @_;
 957   $class->inject_base($target => 'DBIx::Class::DB');
 958   #$target->load_components('DB');
 959   $target->connection(@info);
 960 }
 961
 962 =head2 svp_begin
 963
 964 Creates a new savepoint (does nothing outside a transaction).
 965 Equivalent to calling $schema->storage->svp_begin.  See
 966 L<DBIx::Class::Storage/"svp_begin"> for more information.
 967
 968 =cut
 969
 970 sub svp_begin {
 971   my ($self, $name) = @_;
 972
 973   $self->storage or $self->throw_exception
 974     ('svp_begin called on $schema without storage');
 975
 976   $self->storage->svp_begin($name);
 977 }
 978
 979 =head2 svp_release
 980
 981 Releases a savepoint (does nothing outside a transaction).
 982 Equivalent to calling $schema->storage->svp_release.  See
 983 L<DBIx::Class::Storage/"svp_release"> for more information.
 984
 985 =cut
 986
 987 sub svp_release {
 988   my ($self, $name) = @_;
 989
 990   $self->storage or $self->throw_exception
 991     ('svp_release called on $schema without storage');
 992
 993   $self->storage->svp_release($name);
 994 }
 995
 996 =head2 svp_rollback
 997
 998 Rollback to a savepoint (does nothing outside a transaction).
 999 Equivalent to calling $schema->storage->svp_rollback.  See
1000 L<DBIx::Class::Storage/"svp_rollback"> for more information.
1001
1002 =cut
1003
1004 sub svp_rollback {
1005   my ($self, $name) = @_;
1006
1007   $self->storage or $self->throw_exception
1008     ('svp_rollback called on $schema without storage');
1009
1010   $self->storage->svp_rollback($name);
1011 }
1012
1013 =head2 clone
1014
1015 =over 4
1016
1017 =item Arguments: %attrs?
1018
1019 =item Return Value: $new_schema
1020
1021 =back
1022
1023 Clones the schema and its associated result_source objects and returns the
1024 copy. The resulting copy will have the same attributes as the source schema,
1025 except for those attributes explicitly overriden by the provided C<%attrs>.
1026
1027 =cut
1028
1029 sub clone {
1030   my $self = shift;
1031
1032   my $clone = {
1033       (ref $self ? %$self : ()),
1034       (@_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_),
1035   };
1036   bless $clone, (ref $self || $self);
1037
1038   $clone->class_mappings({ %{$clone->class_mappings} });
1039   $clone->source_registrations({ %{$clone->source_registrations} });
1040   foreach my $moniker ($self->sources) {
1041     my $source = $self->source($moniker);
1042     my $new = $source->new($source);
1043     # we use extra here as we want to leave the class_mappings as they are
1044     # but overwrite the source_registrations entry with the new source
1045     $clone->register_extra_source($moniker => $new);
1046   }
1047   $clone->storage->set_schema($clone) if $clone->storage;
1048
1049   return $clone;
1050 }
1051
1052 =head2 throw_exception
1053
1054 =over 4
1055
1056 =item Arguments: $message
1057
1058 =back
1059
1060 Throws an exception. Obeys the exemption rules of L<DBIx::Class::Carp> to report
1061 errors from outer-user's perspective. See L</exception_action> for details on overriding
1062 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
1063 default behavior will provide a detailed stack trace.
1064
1065 =cut
1066
1067 my $false_exception_action_warned;
1068 sub throw_exception {
1069   my $self = shift;
1070
1071   if (my $act = $self->exception_action) {
1072     if ($act->(@_)) {
1073       DBIx::Class::Exception->throw(
1074           "Invocation of the exception_action handler installed on $self did *not*"
1075         .' result in an exception. DBIx::Class is unable to function without a reliable'
1076         .' exception mechanism, ensure that exception_action does not hide exceptions'
1077         ." (original error: $_[0])"
1078       );
1079     }
1080     elsif(! $false_exception_action_warned++) {
1081       carp (
1082           "The exception_action handler installed on $self returned false instead"
1083         .' of throwing an exception. This behavior has been deprecated, adjust your'
1084         .' handler to always rethrow the supplied error.'
1085       );
1086     }
1087   }
1088
1089   DBIx::Class::Exception->throw($_[0], $self->stacktrace);
1090 }
1091
1092 =head2 deploy
1093
1094 =over 4
1095
1096 =item Arguments: \%sqlt_args, $dir
1097
1098 =back
1099
1100 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
1101
1102 See L<SQL::Translator/METHODS> for a list of values for C<\%sqlt_args>.
1103 The most common value for this would be C<< { add_drop_table => 1 } >>
1104 to have the SQL produced include a C<DROP TABLE> statement for each table
1105 created. For quoting purposes supply C<quote_table_names> and
1106 C<quote_field_names>.
1107
1108 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
1109 ref or an array ref, containing a list of source to deploy. If present, then
1110 only the sources listed will get deployed. Furthermore, you can use the
1111 C<add_fk_index> parser parameter to prevent the parser from creating an index for each
1112 FK.
1113
1114 =cut
1115
1116 sub deploy {
1117   my ($self, $sqltargs, $dir) = @_;
1118   $self->throw_exception("Can't deploy without storage") unless $self->storage;
1119   $self->storage->deploy($self, undef, $sqltargs, $dir);
1120 }
1121
1122 =head2 deployment_statements
1123
1124 =over 4
1125
1126 =item Arguments: See L<DBIx::Class::Storage::DBI/deployment_statements>
1127
1128 =item Return value: $listofstatements
1129
1130 =back
1131
1132 A convenient shortcut to
1133 C<< $self->storage->deployment_statements($self, @args) >>.
1134 Returns the SQL statements used by L</deploy> and
1135 L<DBIx::Class::Schema::Storage/deploy>.
1136
1137 =cut
1138
1139 sub deployment_statements {
1140   my $self = shift;
1141
1142   $self->throw_exception("Can't generate deployment statements without a storage")
1143     if not $self->storage;
1144
1145   $self->storage->deployment_statements($self, @_);
1146 }
1147
1148 =head2 create_ddl_dir
1149
1150 =over 4
1151
1152 =item Arguments: See L<DBIx::Class::Storage::DBI/create_ddl_dir>
1153
1154 =back
1155
1156 A convenient shortcut to
1157 C<< $self->storage->create_ddl_dir($self, @args) >>.
1158
1159 Creates an SQL file based on the Schema, for each of the specified
1160 database types, in the given directory.
1161
1162 =cut
1163
1164 sub create_ddl_dir {
1165   my $self = shift;
1166
1167   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1168   $self->storage->create_ddl_dir($self, @_);
1169 }
1170
1171 =head2 ddl_filename
1172
1173 =over 4
1174
1175 =item Arguments: $database-type, $version, $directory, $preversion
1176
1177 =item Return value: $normalised_filename
1178
1179 =back
1180
1181   my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
1182
1183 This method is called by C<create_ddl_dir> to compose a file name out of
1184 the supplied directory, database type and version number. The default file
1185 name format is: C<$dir$schema-$version-$type.sql>.
1186
1187 You may override this method in your schema if you wish to use a different
1188 format.
1189
1190  WARNING
1191
1192  Prior to DBIx::Class version 0.08100 this method had a different signature:
1193
1194     my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
1195
1196  In recent versions variables $dir and $version were reversed in order to
1197  bring the signature in line with other Schema/Storage methods. If you
1198  really need to maintain backward compatibility, you can do the following
1199  in any overriding methods:
1200
1201     ($dir, $version) = ($version, $dir) if ($DBIx::Class::VERSION < 0.08100);
1202
1203 =cut
1204
1205 sub ddl_filename {
1206   my ($self, $type, $version, $dir, $preversion) = @_;
1207
1208   require File::Spec;
1209
1210   my $filename = ref($self);
1211   $filename =~ s/::/-/g;
1212   $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1213   $filename =~ s/$version/$preversion-$version/ if($preversion);
1214
1215   return $filename;
1216 }
1217
1218 =head2 thaw
1219
1220 Provided as the recommended way of thawing schema objects. You can call
1221 C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1222 reference to any schema, so are rather useless.
1223
1224 =cut
1225
1226 sub thaw {
1227   my ($self, $obj) = @_;
1228   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1229   require Storable;
1230   return Storable::thaw($obj);
1231 }
1232
1233 =head2 freeze
1234
1235 This doesn't actually do anything more than call L<Storable/nfreeze>, it is just
1236 provided here for symmetry.
1237
1238 =cut
1239
1240 sub freeze {
1241   require Storable;
1242   return Storable::nfreeze($_[1]);
1243 }
1244
1245 =head2 dclone
1246
1247 =over 4
1248
1249 =item Arguments: $object
1250
1251 =item Return Value: dcloned $object
1252
1253 =back
1254
1255 Recommended way of dcloning L<DBIx::Class::Row> and L<DBIx::Class::ResultSet>
1256 objects so their references to the schema object
1257 (which itself is B<not> cloned) are properly maintained.
1258
1259 =cut
1260
1261 sub dclone {
1262   my ($self, $obj) = @_;
1263   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1264   require Storable;
1265   return Storable::dclone($obj);
1266 }
1267
1268 =head2 schema_version
1269
1270 Returns the current schema class' $VERSION in a normalised way.
1271
1272 =cut
1273
1274 sub schema_version {
1275   my ($self) = @_;
1276   my $class = ref($self)||$self;
1277
1278   # does -not- use $schema->VERSION
1279   # since that varies in results depending on if version.pm is installed, and if
1280   # so the perl or XS versions. If you want this to change, bug the version.pm
1281   # author to make vpp and vxs behave the same.
1282
1283   my $version;
1284   {
1285     no strict 'refs';
1286     $version = ${"${class}::VERSION"};
1287   }
1288   return $version;
1289 }
1290
1291
1292 =head2 register_class
1293
1294 =over 4
1295
1296 =item Arguments: $moniker, $component_class
1297
1298 =back
1299
1300 This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
1301
1302 You will only need this method if you have your Result classes in
1303 files which are not named after the packages (or all in the same
1304 file). You may also need it to register classes at runtime.
1305
1306 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
1307 calling:
1308
1309   $schema->register_source($moniker, $component_class->result_source_instance);
1310
1311 =cut
1312
1313 sub register_class {
1314   my ($self, $moniker, $to_register) = @_;
1315   $self->register_source($moniker => $to_register->result_source_instance);
1316 }
1317
1318 =head2 register_source
1319
1320 =over 4
1321
1322 =item Arguments: $moniker, $result_source
1323
1324 =back
1325
1326 This method is called by L</register_class>.
1327
1328 Registers the L<DBIx::Class::ResultSource> in the schema with the given
1329 moniker.
1330
1331 =cut
1332
1333 sub register_source { shift->_register_source(@_) }
1334
1335 =head2 unregister_source
1336
1337 =over 4
1338
1339 =item Arguments: $moniker
1340
1341 =back
1342
1343 Removes the L<DBIx::Class::ResultSource> from the schema for the given moniker.
1344
1345 =cut
1346
1347 sub unregister_source { shift->_unregister_source(@_) }
1348
1349 =head2 register_extra_source
1350
1351 =over 4
1352
1353 =item Arguments: $moniker, $result_source
1354
1355 =back
1356
1357 As L</register_source> but should be used if the result class already
1358 has a source and you want to register an extra one.
1359
1360 =cut
1361
1362 sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }
1363
1364 sub _register_source {
1365   my ($self, $moniker, $source, $params) = @_;
1366
1367   $source = $source->new({ %$source, source_name => $moniker });
1368
1369   $source->schema($self);
1370   weaken $source->{schema} if ref($self);
1371
1372   my %reg = %{$self->source_registrations};
1373   $reg{$moniker} = $source;
1374   $self->source_registrations(\%reg);
1375
1376   return $source if $params->{extra};
1377
1378   my $rs_class = $source->result_class;
1379   if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
1380     my %map = %{$self->class_mappings};
1381     if (
1382       exists $map{$rs_class}
1383         and
1384       $map{$rs_class} ne $moniker
1385         and
1386       $rsrc ne $_[2]  # orig_source
1387     ) {
1388       carp
1389         "$rs_class already had a registered source which was replaced by this call. "
1390       . 'Perhaps you wanted register_extra_source(), though it is more likely you did '
1391       . 'something wrong.'
1392       ;
1393     }
1394
1395     $map{$rs_class} = $moniker;
1396     $self->class_mappings(\%map);
1397   }
1398
1399   return $source;
1400 }
1401
1402 my $global_phase_destroy;
1403 sub DESTROY {
1404   return if $global_phase_destroy ||= in_global_destruction;
1405
1406   my $self = shift;
1407   my $srcs = $self->source_registrations;
1408
1409   for my $moniker (keys %$srcs) {
1410     # find first source that is not about to be GCed (someone other than $self
1411     # holds a reference to it) and reattach to it, weakening our own link
1412     #
1413     # during global destruction (if we have not yet bailed out) this should throw
1414     # which will serve as a signal to not try doing anything else
1415     # however beware - on older perls the exception seems randomly untrappable
1416     # due to some weird race condition during thread joining :(((
1417     if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) {
1418       local $@;
1419       eval {
1420         $srcs->{$moniker}->schema($self);
1421         weaken $srcs->{$moniker};
1422         1;
1423       } or do {
1424         $global_phase_destroy = 1;
1425       };
1426
1427       last;
1428     }
1429   }
1430 }
1431
1432 sub _unregister_source {
1433     my ($self, $moniker) = @_;
1434     my %reg = %{$self->source_registrations};
1435
1436     my $source = delete $reg{$moniker};
1437     $self->source_registrations(\%reg);
1438     if ($source->result_class) {
1439         my %map = %{$self->class_mappings};
1440         delete $map{$source->result_class};
1441         $self->class_mappings(\%map);
1442     }
1443 }
1444
1445
1446 =head2 compose_connection (DEPRECATED)
1447
1448 =over 4
1449
1450 =item Arguments: $target_namespace, @db_info
1451
1452 =item Return Value: $new_schema
1453
1454 =back
1455
1456 DEPRECATED. You probably wanted compose_namespace.
1457
1458 Actually, you probably just wanted to call connect.
1459
1460 =begin hidden
1461
1462 (hidden due to deprecation)
1463
1464 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
1465 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
1466 then injects the L<DBix::Class::ResultSetProxy> component and a
1467 resultset_instance classdata entry on all the new classes, in order to support
1468 $target_namespaces::$class->search(...) method calls.
1469
1470 This is primarily useful when you have a specific need for class method access
1471 to a connection. In normal usage it is preferred to call
1472 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
1473 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
1474 more information.
1475
1476 =end hidden
1477
1478 =cut
1479
1480 sub compose_connection {
1481   my ($self, $target, @info) = @_;
1482
1483   carp_once "compose_connection deprecated as of 0.08000"
1484     unless $INC{"DBIx/Class/CDBICompat.pm"};
1485
1486   my $base = 'DBIx::Class::ResultSetProxy';
1487   try {
1488     eval "require ${base};"
1489   }
1490   catch {
1491     $self->throw_exception
1492       ("No arguments to load_classes and couldn't load ${base} ($_)")
1493   };
1494
1495   if ($self eq $target) {
1496     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
1497     foreach my $moniker ($self->sources) {
1498       my $source = $self->source($moniker);
1499       my $class = $source->result_class;
1500       $self->inject_base($class, $base);
1501       $class->mk_classdata(resultset_instance => $source->resultset);
1502       $class->mk_classdata(class_resolver => $self);
1503     }
1504     $self->connection(@info);
1505     return $self;
1506   }
1507
1508   my $schema = $self->compose_namespace($target, $base);
1509   {
1510     no strict 'refs';
1511     my $name = join '::', $target, 'schema';
1512     *$name = subname $name, sub { $schema };
1513   }
1514
1515   $schema->connection(@info);
1516   foreach my $moniker ($schema->sources) {
1517     my $source = $schema->source($moniker);
1518     my $class = $source->result_class;
1519     #warn "$moniker $class $source ".$source->storage;
1520     $class->mk_classdata(result_source_instance => $source);
1521     $class->mk_classdata(resultset_instance => $source->resultset);
1522     $class->mk_classdata(class_resolver => $schema);
1523   }
1524   return $schema;
1525 }
1526
1527 1;
1528
1529 =head1 AUTHORS
1530
1531 Matt S. Trout <mst@shadowcatsystems.co.uk>
1532
1533 =head1 LICENSE
1534
1535 You may distribute this code under the same terms as Perl itself.
1536
1537 =cut