lib/DBIx/Class/Schema.pm

   1 package DBIx::Class::Schema;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base 'DBIx::Class';
   7
   8 use DBIx::Class::Carp;
   9 use Scalar::Util qw( weaken blessed refaddr );
  10 use DBIx::Class::_Util qw(
  11   refdesc refcount quote_sub scope_guard
  12   is_exception dbic_internal_try dbic_internal_catch
  13   fail_on_internal_call emit_loud_diag
  14 );
  15 use Devel::GlobalDestruction;
  16 use namespace::clean;
  17
  18 __PACKAGE__->mk_group_accessors( inherited => qw( storage exception_action ) );
  19 __PACKAGE__->mk_classaccessor('storage_type' => '::DBI');
  20 __PACKAGE__->mk_classaccessor('stacktrace' => $ENV{DBIC_TRACE} || 0);
  21 __PACKAGE__->mk_classaccessor('default_resultset_attributes' => {});
  22
  23 # These two should have been private from the start but too late now
  24 # Undocumented on purpose, hopefully it won't ever be necessary to
  25 # screw with them
  26 __PACKAGE__->mk_classaccessor('class_mappings' => {});
  27 __PACKAGE__->mk_classaccessor('source_registrations' => {});
  28
  29 __PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' );
  30 __PACKAGE__->schema_sanity_checker(
  31   'DBIx::Class::Schema::SanityChecker'
  32 );
  33
  34 =head1 NAME
  35
  36 DBIx::Class::Schema - composable schemas
  37
  38 =head1 SYNOPSIS
  39
  40   package Library::Schema;
  41   use base qw/DBIx::Class::Schema/;
  42
  43   # load all Result classes in Library/Schema/Result/
  44   __PACKAGE__->load_namespaces();
  45
  46   package Library::Schema::Result::CD;
  47   use base qw/DBIx::Class::Core/;
  48
  49   __PACKAGE__->load_components(qw/InflateColumn::DateTime/); # for example
  50   __PACKAGE__->table('cd');
  51
  52   # Elsewhere in your code:
  53   my $schema1 = Library::Schema->connect(
  54     $dsn,
  55     $user,
  56     $password,
  57     { AutoCommit => 1 },
  58   );
  59
  60   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  61
  62   # fetch objects using Library::Schema::Result::DVD
  63   my $resultset = $schema1->resultset('DVD')->search( ... );
  64   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  65
  66 =head1 DESCRIPTION
  67
  68 Creates database classes based on a schema. This is the recommended way to
  69 use L<DBIx::Class> and allows you to use more than one concurrent connection
  70 with your classes.
  71
  72 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  73 carefully, as DBIx::Class does things a little differently. Note in
  74 particular which module inherits off which.
  75
  76 =head1 SETUP METHODS
  77
  78 =head2 load_namespaces
  79
  80 =over 4
  81
  82 =item Arguments: %options?
  83
  84 =back
  85
  86   package MyApp::Schema;
  87   __PACKAGE__->load_namespaces();
  88
  89   __PACKAGE__->load_namespaces(
  90      result_namespace => 'Res',
  91      resultset_namespace => 'RSet',
  92      default_resultset_class => '+MyApp::Othernamespace::RSet',
  93   );
  94
  95 With no arguments, this method uses L<Module::Find> to load all of the
  96 Result and ResultSet classes under the namespace of the schema from
  97 which it is called.  For example, C<My::Schema> will by default find
  98 and load Result classes named C<My::Schema::Result::*> and ResultSet
  99 classes named C<My::Schema::ResultSet::*>.
 100
 101 ResultSet classes are associated with Result class of the same name.
 102 For example, C<My::Schema::Result::CD> will get the ResultSet class
 103 C<My::Schema::ResultSet::CD> if it is present.
 104
 105 Both Result and ResultSet namespaces are configurable via the
 106 C<result_namespace> and C<resultset_namespace> options.
 107
 108 Another option, C<default_resultset_class> specifies a custom default
 109 ResultSet class for Result classes with no corresponding ResultSet.
 110
 111 All of the namespace and classname options are by default relative to
 112 the schema classname.  To specify a fully-qualified name, prefix it
 113 with a literal C<+>.  For example, C<+Other::NameSpace::Result>.
 114
 115 =head3 Warnings
 116
 117 You will be warned if ResultSet classes are discovered for which there
 118 are no matching Result classes like this:
 119
 120   load_namespaces found ResultSet class $classname with no corresponding Result class
 121
 122 If a ResultSource instance is found to already have a ResultSet class set
 123 using L<resultset_class|DBIx::Class::ResultSource/resultset_class> to some
 124 other class, you will be warned like this:
 125
 126   We found ResultSet class '$rs_class' for '$result_class', but it seems
 127   that you had already set '$result_class' to use '$rs_set' instead
 128
 129 =head3 Examples
 130
 131   # load My::Schema::Result::CD, My::Schema::Result::Artist,
 132   #    My::Schema::ResultSet::CD, etc...
 133   My::Schema->load_namespaces;
 134
 135   # Override everything to use ugly names.
 136   # In this example, if there is a My::Schema::Res::Foo, but no matching
 137   #   My::Schema::RSets::Foo, then Foo will have its
 138   #   resultset_class set to My::Schema::RSetBase
 139   My::Schema->load_namespaces(
 140     result_namespace => 'Res',
 141     resultset_namespace => 'RSets',
 142     default_resultset_class => 'RSetBase',
 143   );
 144
 145   # Put things in other namespaces
 146   My::Schema->load_namespaces(
 147     result_namespace => '+Some::Place::Results',
 148     resultset_namespace => '+Another::Place::RSets',
 149   );
 150
 151 To search multiple namespaces for either Result or ResultSet classes,
 152 use an arrayref of namespaces for that option.  In the case that the
 153 same result (or resultset) class exists in multiple namespaces, later
 154 entries in the list of namespaces will override earlier ones.
 155
 156   My::Schema->load_namespaces(
 157     # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
 158     result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
 159     resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
 160   );
 161
 162 =cut
 163
 164 # Pre-pends our classname to the given relative classname or
 165 #   class namespace, unless there is a '+' prefix, which will
 166 #   be stripped.
 167 sub _expand_relative_name {
 168   my ($class, $name) = @_;
 169   $name =~ s/^\+// or $name = "${class}::${name}";
 170   return $name;
 171 }
 172
 173 # Finds all modules in the supplied namespace, or if omitted in the
 174 # namespace of $class. Untaints all findings as they can be assumed
 175 # to be safe
 176 sub _findallmod {
 177   require Module::Find;
 178   return map
 179     { $_ =~ /(.+)/ }   # untaint result
 180     Module::Find::findallmod( $_[1] || ref $_[0] || $_[0] )
 181   ;
 182 }
 183
 184 # returns a hash of $shortname => $fullname for every package
 185 # found in the given namespaces ($shortname is with the $fullname's
 186 # namespace stripped off)
 187 sub _map_namespaces {
 188   my ($me, $namespaces) = @_;
 189
 190   my %res;
 191   for my $ns (@$namespaces) {
 192     $res{ substr($_, length "${ns}::") } = $_
 193       for $me->_findallmod($ns);
 194   }
 195
 196   \%res;
 197 }
 198
 199 # returns the result_source_instance for the passed class/object,
 200 # or dies with an informative message (used by load_namespaces)
 201 sub _ns_get_rsrc_instance {
 202   my $me = shift;
 203   my $rs_class = ref ($_[0]) || $_[0];
 204
 205   return dbic_internal_try {
 206     $rs_class->result_source
 207   } dbic_internal_catch {
 208     $me->throw_exception (
 209       "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_"
 210     );
 211   };
 212 }
 213
 214 sub load_namespaces {
 215   my ($class, %args) = @_;
 216
 217   my $result_namespace = delete $args{result_namespace} || 'Result';
 218   my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
 219
 220   my $default_resultset_class = delete $args{default_resultset_class};
 221
 222   $default_resultset_class = $class->_expand_relative_name($default_resultset_class)
 223     if $default_resultset_class;
 224
 225   $class->throw_exception('load_namespaces: unknown option(s): '
 226     . join(q{,}, map { qq{'$_'} } keys %args))
 227       if scalar keys %args;
 228
 229   for my $arg ($result_namespace, $resultset_namespace) {
 230     $arg = [ $arg ] if ( $arg and ! ref $arg );
 231
 232     $class->throw_exception('load_namespaces: namespace arguments must be '
 233       . 'a simple string or an arrayref')
 234         if ref($arg) ne 'ARRAY';
 235
 236     $_ = $class->_expand_relative_name($_) for (@$arg);
 237   }
 238
 239   my $results_by_source_name = $class->_map_namespaces($result_namespace);
 240   my $resultsets_by_source_name = $class->_map_namespaces($resultset_namespace);
 241
 242   my @to_register;
 243   {
 244     # ensure classes are loaded and attached in inheritance order
 245     for my $result_class (values %$results_by_source_name) {
 246       $class->ensure_class_loaded($result_class);
 247     }
 248     my %inh_idx;
 249     my @source_names_by_subclass_last = sort {
 250
 251       ($inh_idx{$a} ||=
 252         scalar @{mro::get_linear_isa( $results_by_source_name->{$a} )}
 253       )
 254
 255           <=>
 256
 257       ($inh_idx{$b} ||=
 258         scalar @{mro::get_linear_isa( $results_by_source_name->{$b} )}
 259       )
 260
 261     } keys(%$results_by_source_name);
 262
 263     foreach my $source_name (@source_names_by_subclass_last) {
 264       my $result_class = $results_by_source_name->{$source_name};
 265
 266       my $preset_resultset_class = $class->_ns_get_rsrc_instance ($result_class)->resultset_class;
 267       my $found_resultset_class = delete $resultsets_by_source_name->{$source_name};
 268
 269       if($preset_resultset_class && $preset_resultset_class ne 'DBIx::Class::ResultSet') {
 270         if($found_resultset_class && $found_resultset_class ne $preset_resultset_class) {
 271           carp "We found ResultSet class '$found_resultset_class' matching '$results_by_source_name->{$source_name}', but it seems "
 272              . "that you had already set the '$results_by_source_name->{$source_name}' resultet to '$preset_resultset_class' instead";
 273         }
 274       }
 275       # elsif - there may be *no* default_resultset_class, in which case we fallback to
 276       # DBIx::Class::Resultset and there is nothing to check
 277       elsif($found_resultset_class ||= $default_resultset_class) {
 278         $class->ensure_class_loaded($found_resultset_class);
 279         if(!$found_resultset_class->isa("DBIx::Class::ResultSet")) {
 280             carp "load_namespaces found ResultSet class '$found_resultset_class' that does not subclass DBIx::Class::ResultSet";
 281         }
 282
 283         $class->_ns_get_rsrc_instance ($result_class)->resultset_class($found_resultset_class);
 284       }
 285
 286       my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $source_name;
 287
 288       push(@to_register, [ $source_name, $result_class ]);
 289     }
 290   }
 291
 292   foreach (sort keys %$resultsets_by_source_name) {
 293     carp "load_namespaces found ResultSet class '$resultsets_by_source_name->{$_}' "
 294         .'with no corresponding Result class';
 295   }
 296
 297   $class->register_class(@$_) for (@to_register);
 298
 299   return;
 300 }
 301
 302 =head2 load_classes
 303
 304 =over 4
 305
 306 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 307
 308 =back
 309
 310 L</load_classes> is an alternative method to L</load_namespaces>, both of
 311 which serve similar purposes, each with different advantages and disadvantages.
 312 In the general case you should use L</load_namespaces>, unless you need to
 313 be able to specify that only specific classes are loaded at runtime.
 314
 315 With no arguments, this method uses L<Module::Find> to find all classes under
 316 the schema's namespace. Otherwise, this method loads the classes you specify
 317 (using L<use>), and registers them (using L</"register_class">).
 318
 319 It is possible to comment out classes with a leading C<#>, but note that perl
 320 will think it's a mistake (trying to use a comment in a qw list), so you'll
 321 need to add C<no warnings 'qw';> before your load_classes call.
 322
 323 If any classes found do not appear to be Result class files, you will
 324 get the following warning:
 325
 326    Failed to load $comp_class. Can't find source_name method. Is
 327    $comp_class really a full DBIC result class? Fix it, move it elsewhere,
 328    or make your load_classes call more specific.
 329
 330 Example:
 331
 332   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 333                               # etc. (anything under the My::Schema namespace)
 334
 335   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 336   # not Other::Namespace::LinerNotes nor My::Schema::Track
 337   My::Schema->load_classes(qw/ CD Artist #Track /, {
 338     Other::Namespace => [qw/ Producer #LinerNotes /],
 339   });
 340
 341 =cut
 342
 343 sub load_classes {
 344   my ($class, @params) = @_;
 345
 346   my %comps_for;
 347
 348   if (@params) {
 349     foreach my $param (@params) {
 350       if (ref $param eq 'ARRAY') {
 351         # filter out commented entries
 352         my @modules = grep { $_ !~ /^#/ } @$param;
 353
 354         push (@{$comps_for{$class}}, @modules);
 355       }
 356       elsif (ref $param eq 'HASH') {
 357         # more than one namespace possible
 358         for my $comp ( keys %$param ) {
 359           # filter out commented entries
 360           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 361
 362           push (@{$comps_for{$comp}}, @modules);
 363         }
 364       }
 365       else {
 366         # filter out commented entries
 367         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 368       }
 369     }
 370   } else {
 371     my @comp = map { substr $_, length "${class}::"  }
 372                  $class->_findallmod($class);
 373     $comps_for{$class} = \@comp;
 374   }
 375
 376   my @to_register;
 377   {
 378     foreach my $prefix (keys %comps_for) {
 379       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 380         my $comp_class = "${prefix}::${comp}";
 381         $class->ensure_class_loaded($comp_class);
 382
 383         my $snsub = $comp_class->can('source_name');
 384         if(! $snsub ) {
 385           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.";
 386           next;
 387         }
 388         $comp = $snsub->($comp_class) || $comp;
 389
 390         push(@to_register, [ $comp, $comp_class ]);
 391       }
 392     }
 393   }
 394
 395   foreach my $to (@to_register) {
 396     $class->register_class(@$to);
 397   }
 398 }
 399
 400 =head2 storage_type
 401
 402 =over 4
 403
 404 =item Arguments: $storage_type|{$storage_type, \%args}
 405
 406 =item Return Value: $storage_type|{$storage_type, \%args}
 407
 408 =item Default value: DBIx::Class::Storage::DBI
 409
 410 =back
 411
 412 Set the storage class that will be instantiated when L</connect> is called.
 413 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 414 assumed by L</connect>.
 415
 416 You want to use this to set subclasses of L<DBIx::Class::Storage::DBI>
 417 in cases where the appropriate subclass is not autodetected.
 418
 419 If your storage type requires instantiation arguments, those are
 420 defined as a second argument in the form of a hashref and the entire
 421 value needs to be wrapped into an arrayref or a hashref.  We support
 422 both types of refs here in order to play nice with your
 423 Config::[class] or your choice. See
 424 L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
 425
 426 =head2 default_resultset_attributes
 427
 428 =over 4
 429
 430 =item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
 431
 432 =item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES>
 433
 434 =item Default value: None
 435
 436 =back
 437
 438 Like L<DBIx::Class::ResultSource/resultset_attributes> stores a collection
 439 of resultset attributes, to be used as defaults for B<every> ResultSet
 440 instance schema-wide. The same list of CAVEATS and WARNINGS applies, with
 441 the extra downside of these defaults being practically inescapable: you will
 442 B<not> be able to derive a ResultSet instance with these attributes unset.
 443
 444 Example:
 445
 446    package My::Schema;
 447    use base qw/DBIx::Class::Schema/;
 448    __PACKAGE__->default_resultset_attributes( { software_limit => 1 } );
 449
 450 =head2 schema_sanity_checker
 451
 452 =over 4
 453
 454 =item Arguments: L<perform_schema_sanity_checks()|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> provider
 455
 456 =item Return Value: L<perform_schema_sanity_checks()|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> provider
 457
 458 =item Default value: L<DBIx::Class::Schema::SanityChecker>
 459
 460 =back
 461
 462 On every call to L</connection> if the value of this attribute evaluates to
 463 true, DBIC will invoke
 464 C<< L<$schema_sanity_checker|/schema_sanity_checker>->L<perform_schema_sanity_checks|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks>($schema) >>
 465 before returning. The return value of this invocation is ignored.
 466
 467 B<YOU ARE STRONGLY URGED> to
 468 L<learn more about the reason|DBIx::Class::Schema::SanityChecker/WHY> this
 469 feature was introduced. Blindly disabling the checker on existing projects
 470 B<may result in data corruption> after upgrade to C<< DBIC >= v0.082900 >>.
 471
 472 Example:
 473
 474    package My::Schema;
 475    use base qw/DBIx::Class::Schema/;
 476    __PACKAGE__->schema_sanity_checker('My::Schema::SanityChecker');
 477
 478    # or to disable all checks:
 479    __PACKAGE__->schema_sanity_checker('');
 480
 481 Note: setting the value to C<undef> B<will not> have the desired effect,
 482 due to an implementation detail of L<Class::Accessor::Grouped> inherited
 483 accessors. In order to disable any and all checks you must set this
 484 attribute to an empty string as shown in the second example above.
 485
 486 =head2 exception_action
 487
 488 =over 4
 489
 490 =item Arguments: $code_reference
 491
 492 =item Return Value: $code_reference
 493
 494 =item Default value: None
 495
 496 =back
 497
 498 When L</throw_exception> is invoked and L</exception_action> is set to a code
 499 reference, this reference will be called instead of
 500 L<DBIx::Class::Exception/throw>, with the exception message passed as the only
 501 argument.
 502
 503 Your custom throw code B<must> rethrow the exception, as L</throw_exception> is
 504 an integral part of DBIC's internal execution control flow.
 505
 506 Example:
 507
 508    package My::Schema;
 509    use base qw/DBIx::Class::Schema/;
 510    use My::ExceptionClass;
 511    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 512    __PACKAGE__->load_classes;
 513
 514    # or:
 515    my $schema_obj = My::Schema->connect( .... );
 516    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 517
 518 =head2 stacktrace
 519
 520 =over 4
 521
 522 =item Arguments: boolean
 523
 524 =back
 525
 526 Whether L</throw_exception> should include stack trace information.
 527 Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
 528 is true.
 529
 530 =head2 sqlt_deploy_hook
 531
 532 =over
 533
 534 =item Arguments: $sqlt_schema
 535
 536 =back
 537
 538 An optional sub which you can declare in your own Schema class that will get
 539 passed the L<SQL::Translator::Schema> object when you deploy the schema via
 540 L</create_ddl_dir> or L</deploy>.
 541
 542 For an example of what you can do with this, see
 543 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
 544
 545 Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
 546 is called before L</deploy>. Therefore the hook can be used only to manipulate
 547 the L<SQL::Translator::Schema> object before it is turned into SQL fed to the
 548 database. If you want to execute post-deploy statements which can not be generated
 549 by L<SQL::Translator>, the currently suggested method is to overload L</deploy>
 550 and use L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
 551
 552 =head1 METHODS
 553
 554 =head2 connect
 555
 556 =over 4
 557
 558 =item Arguments: @connectinfo
 559
 560 =item Return Value: $new_schema
 561
 562 =back
 563
 564 Creates and returns a new Schema object. The connection info set on it
 565 is used to create a new instance of the storage backend and set it on
 566 the Schema object.
 567
 568 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific
 569 syntax on the C<@connectinfo> argument, or L<DBIx::Class::Storage> in
 570 general.
 571
 572 Note that C<connect_info> expects an arrayref of arguments, but
 573 C<connect> does not. C<connect> wraps its arguments in an arrayref
 574 before passing them to C<connect_info>.
 575
 576 =head3 Overloading
 577
 578 C<connect> is a convenience method. It is equivalent to calling
 579 $schema->clone->connection(@connectinfo). To write your own overloaded
 580 version, overload L</connection> instead.
 581
 582 =cut
 583
 584 sub connect :DBIC_method_is_indirect_sugar {
 585   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
 586   shift->clone->connection(@_);
 587 }
 588
 589 =head2 resultset
 590
 591 =over 4
 592
 593 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name>
 594
 595 =item Return Value: L<$resultset|DBIx::Class::ResultSet>
 596
 597 =back
 598
 599   my $rs = $schema->resultset('DVD');
 600
 601 Returns the L<DBIx::Class::ResultSet> object for the registered source
 602 name.
 603
 604 =cut
 605
 606 sub resultset {
 607   my ($self, $source_name) = @_;
 608   $self->throw_exception('resultset() expects a source name')
 609     unless defined $source_name;
 610   return $self->source($source_name)->resultset;
 611 }
 612
 613 =head2 sources
 614
 615 =over 4
 616
 617 =item Return Value: L<@source_names|DBIx::Class::ResultSource/source_name>
 618
 619 =back
 620
 621   my @source_names = $schema->sources;
 622
 623 Lists names of all the sources registered on this Schema object.
 624
 625 =cut
 626
 627 sub sources { keys %{shift->source_registrations} }
 628
 629 =head2 source
 630
 631 =over 4
 632
 633 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name>
 634
 635 =item Return Value: L<$result_source|DBIx::Class::ResultSource>
 636
 637 =back
 638
 639   my $source = $schema->source('Book');
 640
 641 Returns the L<DBIx::Class::ResultSource> object for the registered
 642 source name.
 643
 644 =cut
 645
 646 sub source {
 647   my ($self, $source_name) = @_;
 648
 649   $self->throw_exception("source() expects a source name")
 650     unless $source_name;
 651
 652   my $source_registrations;
 653
 654   my $rsrc =
 655     ( $source_registrations = $self->source_registrations )->{$source_name}
 656       ||
 657     # if we got here, they probably passed a full class name
 658     $source_registrations->{ $self->class_mappings->{$source_name} || '' }
 659       ||
 660     $self->throw_exception( "Can't find source for ${source_name}" )
 661   ;
 662
 663   # DO NOT REMOVE:
 664   # We need to prevent alterations of pre-existing $@ due to where this call
 665   # sits in the overall stack ( *unless* of course there is an actual error
 666   # to report ). set_mro does alter $@ (and yes - it *can* throw an exception)
 667   # We do not use local because set_mro *can* throw an actual exception
 668   # We do not use a try/catch either, as on one hand it would slow things
 669   # down for no reason (we would always rethrow), but also because adding *any*
 670   # try/catch block below will segfault various threading tests on older perls
 671   # ( which in itself is a FIXME but ENOTIMETODIG )
 672   my $old_dollarat = $@;
 673
 674   no strict 'refs';
 675   mro::set_mro($_, 'c3') for
 676     grep
 677       {
 678         # some pseudo-sources do not have a result/resultset yet
 679         defined $_
 680           and
 681         (
 682           (
 683             ${"${_}::__INITIAL_MRO_UPON_DBIC_LOAD__"}
 684               ||= mro::get_mro($_)
 685           )
 686             ne
 687           'c3'
 688         )
 689       }
 690       map
 691         { length ref $_ ? ref $_ : $_ }
 692         ( $rsrc, $rsrc->result_class, $rsrc->resultset_class )
 693   ;
 694
 695   # DO NOT REMOVE - see comment above
 696   $@ = $old_dollarat;
 697
 698   $rsrc;
 699 }
 700
 701 =head2 class
 702
 703 =over 4
 704
 705 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name>
 706
 707 =item Return Value: $classname
 708
 709 =back
 710
 711   my $class = $schema->class('CD');
 712
 713 Retrieves the Result class name for the given source name.
 714
 715 =cut
 716
 717 sub class {
 718   return shift->source(shift)->result_class;
 719 }
 720
 721 =head2 txn_do
 722
 723 =over 4
 724
 725 =item Arguments: C<$coderef>, @coderef_args?
 726
 727 =item Return Value: The return value of $coderef
 728
 729 =back
 730
 731 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 732 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 733 See L<DBIx::Class::Storage/"txn_do"> for more information.
 734
 735 This interface is preferred over using the individual methods L</txn_begin>,
 736 L</txn_commit>, and L</txn_rollback> below.
 737
 738 WARNING: If you are connected with C<< AutoCommit => 0 >> the transaction is
 739 considered nested, and you will still need to call L</txn_commit> to write your
 740 changes when appropriate. You will also want to connect with C<< auto_savepoint =>
 741 1 >> to get partial rollback to work, if the storage driver for your database
 742 supports it.
 743
 744 Connecting with C<< AutoCommit => 1 >> is recommended.
 745
 746 =cut
 747
 748 sub txn_do {
 749   my $self = shift;
 750
 751   $self->storage or $self->throw_exception
 752     ('txn_do called on $schema without storage');
 753
 754   $self->storage->txn_do(@_);
 755 }
 756
 757 =head2 txn_scope_guard
 758
 759 Runs C<txn_scope_guard> on the schema's storage. See
 760 L<DBIx::Class::Storage/txn_scope_guard>.
 761
 762 =cut
 763
 764 sub txn_scope_guard {
 765   my $self = shift;
 766
 767   $self->storage or $self->throw_exception
 768     ('txn_scope_guard called on $schema without storage');
 769
 770   $self->storage->txn_scope_guard(@_);
 771 }
 772
 773 =head2 txn_begin
 774
 775 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 776 calling $schema->storage->txn_begin. See
 777 L<DBIx::Class::Storage/"txn_begin"> for more information.
 778
 779 =cut
 780
 781 sub txn_begin {
 782   my $self = shift;
 783
 784   $self->storage or $self->throw_exception
 785     ('txn_begin called on $schema without storage');
 786
 787   $self->storage->txn_begin;
 788 }
 789
 790 =head2 txn_commit
 791
 792 Commits the current transaction. Equivalent to calling
 793 $schema->storage->txn_commit. See L<DBIx::Class::Storage/"txn_commit">
 794 for more information.
 795
 796 =cut
 797
 798 sub txn_commit {
 799   my $self = shift;
 800
 801   $self->storage or $self->throw_exception
 802     ('txn_commit called on $schema without storage');
 803
 804   $self->storage->txn_commit;
 805 }
 806
 807 =head2 txn_rollback
 808
 809 Rolls back the current transaction. Equivalent to calling
 810 $schema->storage->txn_rollback. See
 811 L<DBIx::Class::Storage/"txn_rollback"> for more information.
 812
 813 =cut
 814
 815 sub txn_rollback {
 816   my $self = shift;
 817
 818   $self->storage or $self->throw_exception
 819     ('txn_rollback called on $schema without storage');
 820
 821   $self->storage->txn_rollback;
 822 }
 823
 824 =head2 storage
 825
 826   my $storage = $schema->storage;
 827
 828 Returns the L<DBIx::Class::Storage> object for this Schema. Grab this
 829 if you want to turn on SQL statement debugging at runtime, or set the
 830 quote character. For the default storage, the documentation can be
 831 found in L<DBIx::Class::Storage::DBI>.
 832
 833 =head2 populate
 834
 835 =over 4
 836
 837 =item Arguments: L<$source_name|DBIx::Class::ResultSource/source_name>, [ \@column_list, \@row_values+ ] | [ \%col_data+ ]
 838
 839 =item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context)
 840
 841 =back
 842
 843 A convenience shortcut to L<DBIx::Class::ResultSet/populate>. Equivalent to:
 844
 845  $schema->resultset($source_name)->populate([...]);
 846
 847 =over 4
 848
 849 =item NOTE
 850
 851 The context of this method call has an important effect on what is
 852 submitted to storage. In void context data is fed directly to fastpath
 853 insertion routines provided by the underlying storage (most often
 854 L<DBI/execute_for_fetch>), bypassing the L<new|DBIx::Class::Row/new> and
 855 L<insert|DBIx::Class::Row/insert> calls on the
 856 L<Result|DBIx::Class::Manual::ResultClass> class, including any
 857 augmentation of these methods provided by components. For example if you
 858 are using something like L<DBIx::Class::UUIDColumns> to create primary
 859 keys for you, you will find that your PKs are empty.  In this case you
 860 will have to explicitly force scalar or list context in order to create
 861 those values.
 862
 863 =back
 864
 865 =cut
 866
 867 sub populate :DBIC_method_is_indirect_sugar {
 868   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
 869
 870   my ($self, $name, $data) = @_;
 871   my $rs = $self->resultset($name)
 872     or $self->throw_exception("'$name' is not a resultset");
 873
 874   return $rs->populate($data);
 875 }
 876
 877 =head2 connection
 878
 879 =over 4
 880
 881 =item Arguments: @args
 882
 883 =item Return Value: $self
 884
 885 =back
 886
 887 Similar to L</connect> except sets the storage object and connection
 888 data B<in-place> on C<$self>. You should probably be calling
 889 L</connect> to get a properly L<cloned|/clone> Schema object instead.
 890
 891 If the accessor L</schema_sanity_checker> returns a true value C<$checker>,
 892 the following call will take place before return:
 893 C<< L<$checker|/schema_sanity_checker>->L<perform_schema_sanity_checks(C<$self>)|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> >>
 894
 895 =head3 Overloading
 896
 897 Overload C<connection> to change the behaviour of C<connect>.
 898
 899 =cut
 900
 901 my $default_off_stderr_blurb_emitted;
 902 sub connection {
 903   my ($self, @info) = @_;
 904   return $self if !@info && $self->storage;
 905
 906   my ($storage_class, $args) = ref $self->storage_type
 907     ? $self->_normalize_storage_type($self->storage_type)
 908     : $self->storage_type
 909   ;
 910
 911   $storage_class =~ s/^::/DBIx::Class::Storage::/;
 912
 913   dbic_internal_try {
 914     $self->ensure_class_loaded ($storage_class);
 915   }
 916   dbic_internal_catch {
 917     $self->throw_exception(
 918       "Unable to load storage class ${storage_class}: $_"
 919     );
 920   };
 921
 922   my $storage = $storage_class->new( $self => $args||{} );
 923   $storage->connect_info(\@info);
 924   $self->storage($storage);
 925
 926   if( my $checker = $self->schema_sanity_checker ) {
 927     $checker->perform_schema_sanity_checks($self);
 928   }
 929
 930   $self;
 931 }
 932
 933 sub _normalize_storage_type {
 934   my ($self, $storage_type) = @_;
 935   if(ref $storage_type eq 'ARRAY') {
 936     return @$storage_type;
 937   } elsif(ref $storage_type eq 'HASH') {
 938     return %$storage_type;
 939   } else {
 940     $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
 941   }
 942 }
 943
 944 =head2 compose_namespace
 945
 946 =over 4
 947
 948 =item Arguments: $target_namespace, $additional_base_class?
 949
 950 =item Return Value: $new_schema
 951
 952 =back
 953
 954 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 955 class in the target namespace (e.g. $target_namespace::CD,
 956 $target_namespace::Artist) that inherits from the corresponding classes
 957 attached to the current schema.
 958
 959 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 960 new $schema object. If C<$additional_base_class> is given, the new composed
 961 classes will inherit from first the corresponding class from the current
 962 schema then the base class.
 963
 964 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 965
 966   $schema->compose_namespace('My::DB', 'Base::Class');
 967   print join (', ', @My::DB::CD::ISA) . "\n";
 968   print join (', ', @My::DB::Artist::ISA) ."\n";
 969
 970 will produce the output
 971
 972   My::Schema::CD, Base::Class
 973   My::Schema::Artist, Base::Class
 974
 975 =cut
 976
 977 sub compose_namespace {
 978   my ($self, $target, $base) = @_;
 979
 980   my $schema = $self->clone;
 981
 982   $schema->source_registrations({});
 983
 984   # the original class-mappings must remain - otherwise
 985   # reverse_relationship_info will not work
 986   #$schema->class_mappings({});
 987
 988   {
 989     foreach my $source_name ($self->sources) {
 990       my $orig_source = $self->source($source_name);
 991
 992       my $target_class = "${target}::${source_name}";
 993       $self->inject_base($target_class, $orig_source->result_class, ($base || ()) );
 994
 995       $schema->register_source(
 996         $source_name,
 997         $orig_source->clone(
 998           result_class => $target_class
 999         ),
1000       );
1001     }
1002
1003     # Legacy stuff, not inserting INDIRECT assertions
1004     quote_sub "${target}::${_}" => "shift->schema->$_(\@_)"
1005       for qw(class source resultset);
1006   }
1007
1008   # needed to cover the newly installed stuff via quote_sub above
1009   Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
1010
1011   # Give each composed class yet another *schema-less* source copy
1012   # this is used for the freeze/thaw cycle
1013   #
1014   # This is not covered by any tests directly, but is indirectly exercised
1015   # in t/cdbi/sweet/08pager by re-setting the schema on an existing object
1016   # FIXME - there is likely a much cheaper way to take care of this
1017   for my $source_name ($self->sources) {
1018
1019     my $target_class = "${target}::${source_name}";
1020
1021     $target_class->result_source_instance(
1022       $self->source($source_name)->clone(
1023         result_class => $target_class,
1024         schema => ( ref $schema || $schema ),
1025       )
1026     );
1027   }
1028
1029   return $schema;
1030 }
1031
1032 # LEGACY: The intra-call to this was removed in 66d9ef6b and then
1033 # the sub was de-documented way later in 249963d4. No way to be sure
1034 # nothing on darkpan is calling it directly, so keeping as-is
1035 sub setup_connection_class {
1036   my ($class, $target, @info) = @_;
1037   $class->inject_base($target => 'DBIx::Class::DB');
1038   #$target->load_components('DB');
1039   $target->connection(@info);
1040 }
1041
1042 =head2 svp_begin
1043
1044 Creates a new savepoint (does nothing outside a transaction).
1045 Equivalent to calling $schema->storage->svp_begin.  See
1046 L<DBIx::Class::Storage/"svp_begin"> for more information.
1047
1048 =cut
1049
1050 sub svp_begin {
1051   my ($self, $name) = @_;
1052
1053   $self->storage or $self->throw_exception
1054     ('svp_begin called on $schema without storage');
1055
1056   $self->storage->svp_begin($name);
1057 }
1058
1059 =head2 svp_release
1060
1061 Releases a savepoint (does nothing outside a transaction).
1062 Equivalent to calling $schema->storage->svp_release.  See
1063 L<DBIx::Class::Storage/"svp_release"> for more information.
1064
1065 =cut
1066
1067 sub svp_release {
1068   my ($self, $name) = @_;
1069
1070   $self->storage or $self->throw_exception
1071     ('svp_release called on $schema without storage');
1072
1073   $self->storage->svp_release($name);
1074 }
1075
1076 =head2 svp_rollback
1077
1078 Rollback to a savepoint (does nothing outside a transaction).
1079 Equivalent to calling $schema->storage->svp_rollback.  See
1080 L<DBIx::Class::Storage/"svp_rollback"> for more information.
1081
1082 =cut
1083
1084 sub svp_rollback {
1085   my ($self, $name) = @_;
1086
1087   $self->storage or $self->throw_exception
1088     ('svp_rollback called on $schema without storage');
1089
1090   $self->storage->svp_rollback($name);
1091 }
1092
1093 =head2 clone
1094
1095 =over 4
1096
1097 =item Arguments: %attrs?
1098
1099 =item Return Value: $new_schema
1100
1101 =back
1102
1103 Clones the schema and its associated result_source objects and returns the
1104 copy. The resulting copy will have the same attributes as the source schema,
1105 except for those attributes explicitly overridden by the provided C<%attrs>.
1106
1107 =cut
1108
1109 sub clone {
1110   my $self = shift;
1111
1112   my $clone = {
1113       (ref $self ? %$self : ()),
1114       (@_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_),
1115   };
1116   bless $clone, (ref $self || $self);
1117
1118   $clone->$_(undef) for qw/class_mappings source_registrations storage/;
1119
1120   $clone->_copy_state_from($self);
1121
1122   return $clone;
1123 }
1124
1125 # Needed in Schema::Loader - if you refactor, please make a compatibility shim
1126 # -- Caelum
1127 sub _copy_state_from {
1128   my ($self, $from) = @_;
1129
1130   $self->class_mappings({ %{$from->class_mappings} });
1131   $self->source_registrations({ %{$from->source_registrations} });
1132
1133   # we use extra here as we want to leave the class_mappings as they are
1134   # but overwrite the source_registrations entry with the new source
1135   $self->register_extra_source( $_ => $from->source($_) )
1136     for $from->sources;
1137
1138   if ($from->storage) {
1139     $self->storage($from->storage);
1140     $self->storage->set_schema($self);
1141   }
1142 }
1143
1144 =head2 throw_exception
1145
1146 =over 4
1147
1148 =item Arguments: $message
1149
1150 =back
1151
1152 Throws an exception. Obeys the exemption rules of L<DBIx::Class::Carp> to report
1153 errors from outer-user's perspective. See L</exception_action> for details on overriding
1154 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
1155 default behavior will provide a detailed stack trace.
1156
1157 =cut
1158
1159 sub throw_exception {
1160   my ($self, @args) = @_;
1161
1162   if (
1163     ! DBIx::Class::_Util::in_internal_try()
1164       and
1165     my $act = $self->exception_action
1166   ) {
1167
1168     my $guard_disarmed;
1169
1170     my $guard = scope_guard {
1171       return if $guard_disarmed;
1172       emit_loud_diag( emit_dups => 1, msg => "
1173
1174                     !!! DBIx::Class INTERNAL PANIC !!!
1175
1176 The exception_action() handler installed on '$self'
1177 aborted the stacktrace below via a longjmp (either via Return::Multilevel or
1178 plain goto, or Scope::Upper or something equally nefarious). There currently
1179 is nothing safe DBIx::Class can do, aside from displaying this error. A future
1180 version ( 0.082900, when available ) will reduce the cases in which the
1181 handler is invoked, but this is neither a complete solution, nor can it do
1182 anything for other software that might be affected by a similar problem.
1183
1184                       !!! FIX YOUR ERROR HANDLING !!!
1185
1186 This guard was activated starting",
1187       );
1188     };
1189
1190     dbic_internal_try {
1191       # if it throws - good, we'll assign to @args in the end
1192       # if it doesn't - do different things depending on RV truthiness
1193       if( $act->(@args) ) {
1194         $args[0] = (
1195           "Invocation of the exception_action handler installed on $self did *not*"
1196         .' result in an exception. DBIx::Class is unable to function without a reliable'
1197         .' exception mechanism, ensure your exception_action does not hide exceptions'
1198         ." (original error: $args[0])"
1199         );
1200       }
1201       else {
1202         carp_unique (
1203           "The exception_action handler installed on $self returned false instead"
1204         .' of throwing an exception. This behavior has been deprecated, adjust your'
1205         .' handler to always rethrow the supplied error'
1206         );
1207       }
1208
1209       1;
1210     }
1211     dbic_internal_catch {
1212       # We call this to get the necessary warnings emitted and disregard the RV
1213       # as it's definitely an exception if we got as far as this catch{} block
1214       is_exception(
1215         $args[0] = $_
1216       );
1217     };
1218
1219     # Done guarding against https://github.com/PerlDancer/Dancer2/issues/1125
1220     $guard_disarmed = 1;
1221   }
1222
1223   DBIx::Class::Exception->throw( $args[0], $self->stacktrace );
1224 }
1225
1226 =head2 deploy
1227
1228 =over 4
1229
1230 =item Arguments: \%sqlt_args, $dir
1231
1232 =back
1233
1234 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
1235
1236 See L<SQL::Translator/METHODS> for a list of values for C<\%sqlt_args>.
1237 The most common value for this would be C<< { add_drop_table => 1 } >>
1238 to have the SQL produced include a C<DROP TABLE> statement for each table
1239 created. For quoting purposes supply C<quote_identifiers>.
1240
1241 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
1242 ref or an array ref, containing a list of source to deploy. If present, then
1243 only the sources listed will get deployed. Furthermore, you can use the
1244 C<add_fk_index> parser parameter to prevent the parser from creating an index for each
1245 FK.
1246
1247 =cut
1248
1249 sub deploy {
1250   my ($self, $sqltargs, $dir) = @_;
1251   $self->throw_exception("Can't deploy without storage") unless $self->storage;
1252   $self->storage->deploy($self, undef, $sqltargs, $dir);
1253 }
1254
1255 =head2 deployment_statements
1256
1257 =over 4
1258
1259 =item Arguments: See L<DBIx::Class::Storage::DBI/deployment_statements>
1260
1261 =item Return Value: $listofstatements
1262
1263 =back
1264
1265 A convenient shortcut to
1266 C<< $self->storage->deployment_statements($self, @args) >>.
1267 Returns the statements used by L</deploy> and
1268 L<DBIx::Class::Storage/deploy>.
1269
1270 =cut
1271
1272 sub deployment_statements {
1273   my $self = shift;
1274
1275   $self->throw_exception("Can't generate deployment statements without a storage")
1276     if not $self->storage;
1277
1278   $self->storage->deployment_statements($self, @_);
1279 }
1280
1281 =head2 create_ddl_dir
1282
1283 =over 4
1284
1285 =item Arguments: See L<DBIx::Class::Storage::DBI/create_ddl_dir>
1286
1287 =back
1288
1289 A convenient shortcut to
1290 C<< $self->storage->create_ddl_dir($self, @args) >>.
1291
1292 Creates an SQL file based on the Schema, for each of the specified
1293 database types, in the given directory.
1294
1295 =cut
1296
1297 sub create_ddl_dir {
1298   my $self = shift;
1299
1300   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1301   $self->storage->create_ddl_dir($self, @_);
1302 }
1303
1304 =head2 ddl_filename
1305
1306 =over 4
1307
1308 =item Arguments: $database-type, $version, $directory, $preversion
1309
1310 =item Return Value: $normalised_filename
1311
1312 =back
1313
1314   my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
1315
1316 This method is called by C<create_ddl_dir> to compose a file name out of
1317 the supplied directory, database type and version number. The default file
1318 name format is: C<$dir$schema-$version-$type.sql>.
1319
1320 You may override this method in your schema if you wish to use a different
1321 format.
1322
1323  WARNING
1324
1325  Prior to DBIx::Class version 0.08100 this method had a different signature:
1326
1327     my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
1328
1329  In recent versions variables $dir and $version were reversed in order to
1330  bring the signature in line with other Schema/Storage methods. If you
1331  really need to maintain backward compatibility, you can do the following
1332  in any overriding methods:
1333
1334     ($dir, $version) = ($version, $dir) if ($DBIx::Class::VERSION < 0.08100);
1335
1336 =cut
1337
1338 sub ddl_filename {
1339   my ($self, $type, $version, $dir, $preversion) = @_;
1340
1341   $version = "$preversion-$version" if $preversion;
1342
1343   my $class = blessed($self) || $self;
1344   $class =~ s/::/-/g;
1345
1346   return "$dir/$class-$version-$type.sql";
1347 }
1348
1349 =head2 thaw
1350
1351 Provided as the recommended way of thawing schema objects. You can call
1352 C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1353 reference to any schema, so are rather useless.
1354
1355 =cut
1356
1357 sub thaw {
1358   my ($self, $obj) = @_;
1359   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1360   return Storable::thaw($obj);
1361 }
1362
1363 =head2 freeze
1364
1365 This doesn't actually do anything beyond calling L<nfreeze|Storable/SYNOPSIS>,
1366 it is just provided here for symmetry.
1367
1368 =cut
1369
1370 sub freeze {
1371   return Storable::nfreeze($_[1]);
1372 }
1373
1374 =head2 dclone
1375
1376 =over 4
1377
1378 =item Arguments: $object
1379
1380 =item Return Value: dcloned $object
1381
1382 =back
1383
1384 Recommended way of dcloning L<DBIx::Class::Row> and L<DBIx::Class::ResultSet>
1385 objects so their references to the schema object
1386 (which itself is B<not> cloned) are properly maintained.
1387
1388 =cut
1389
1390 sub dclone {
1391   my ($self, $obj) = @_;
1392   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1393   return Storable::dclone($obj);
1394 }
1395
1396 =head2 schema_version
1397
1398 Returns the current schema class' $VERSION in a normalised way.
1399
1400 =cut
1401
1402 sub schema_version {
1403   my ($self) = @_;
1404   my $class = ref($self)||$self;
1405
1406   # does -not- use $schema->VERSION
1407   # since that varies in results depending on if version.pm is installed, and if
1408   # so the perl or XS versions. If you want this to change, bug the version.pm
1409   # author to make vpp and vxs behave the same.
1410
1411   my $version;
1412   {
1413     no strict 'refs';
1414     $version = ${"${class}::VERSION"};
1415   }
1416   return $version;
1417 }
1418
1419
1420 =head2 register_class
1421
1422 =over 4
1423
1424 =item Arguments: $source_name, $component_class
1425
1426 =back
1427
1428 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.
1429
1430 You will only need this method if you have your Result classes in
1431 files which are not named after the packages (or all in the same
1432 file). You may also need it to register classes at runtime.
1433
1434 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
1435 calling:
1436
1437   $schema->register_source($source_name, $component_class->result_source);
1438
1439 =cut
1440
1441 sub register_class {
1442   my ($self, $source_name, $to_register) = @_;
1443   $self->register_source($source_name => $to_register->result_source);
1444 }
1445
1446 =head2 register_source
1447
1448 =over 4
1449
1450 =item Arguments: $source_name, L<$result_source|DBIx::Class::ResultSource>
1451
1452 =back
1453
1454 This method is called by L</register_class>.
1455
1456 Registers the L<DBIx::Class::ResultSource> in the schema with the given
1457 source name.
1458
1459 =cut
1460
1461 sub register_source { shift->_register_source(@_) }
1462
1463 =head2 unregister_source
1464
1465 =over 4
1466
1467 =item Arguments: $source_name
1468
1469 =back
1470
1471 Removes the L<DBIx::Class::ResultSource> from the schema for the given source name.
1472
1473 =cut
1474
1475 sub unregister_source { shift->_unregister_source(@_) }
1476
1477 =head2 register_extra_source
1478
1479 =over 4
1480
1481 =item Arguments: $source_name, L<$result_source|DBIx::Class::ResultSource>
1482
1483 =back
1484
1485 As L</register_source> but should be used if the result class already
1486 has a source and you want to register an extra one.
1487
1488 =cut
1489
1490 sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }
1491
1492 sub _register_source {
1493   my ($self, $source_name, $supplied_rsrc, $params) = @_;
1494
1495   my $derived_rsrc = $supplied_rsrc->clone({
1496     source_name => $source_name,
1497   });
1498
1499   # Do not move into the clone-hashref above: there are things
1500   # on CPAN that do hook 'sub schema' </facepalm>
1501   # https://metacpan.org/source/LSAUNDERS/DBIx-Class-Preview-1.000003/lib/DBIx/Class/ResultSource/Table/Previewed.pm#L9-38
1502   $derived_rsrc->schema($self);
1503
1504   weaken $derived_rsrc->{schema}
1505     if length( my $schema_class = ref($self) );
1506
1507   my %reg = %{$self->source_registrations};
1508   $reg{$source_name} = $derived_rsrc;
1509   $self->source_registrations(\%reg);
1510
1511   return $derived_rsrc if $params->{extra};
1512
1513   my( $result_class, $result_class_level_rsrc );
1514   if (
1515     $result_class = $derived_rsrc->result_class
1516       and
1517     # There are known cases where $rs_class is *ONLY* an inflator, without
1518     # any hint of a rsrc (e.g. DBIx::Class::KiokuDB::EntryProxy)
1519     $result_class_level_rsrc = dbic_internal_try { $result_class->result_source_instance }
1520   ) {
1521     my %map = %{$self->class_mappings};
1522
1523     carp (
1524       "$result_class already had a registered source which was replaced by "
1525     . 'this call. Perhaps you wanted register_extra_source(), though it is '
1526     . 'more likely you did something wrong.'
1527     ) if (
1528       exists $map{$result_class}
1529         and
1530       $map{$result_class} ne $source_name
1531         and
1532       $result_class_level_rsrc != $supplied_rsrc
1533     );
1534
1535     $map{$result_class} = $source_name;
1536     $self->class_mappings(\%map);
1537
1538
1539     my $schema_class_level_rsrc;
1540     if (
1541       # we are called on a schema instance, not on the class
1542       length $schema_class
1543
1544         and
1545
1546       # the schema class also has a registration with the same name
1547       $schema_class_level_rsrc = dbic_internal_try { $schema_class->source($source_name) }
1548
1549         and
1550
1551       # what we are registering on the schema instance *IS* derived
1552       # from the class-level (top) rsrc...
1553       ( grep { $_ == $derived_rsrc } $result_class_level_rsrc->__derived_instances )
1554
1555         and
1556
1557       # ... while the schema-class-level has stale-markers
1558       keys %{ $schema_class_level_rsrc->{__metadata_divergencies} || {} }
1559     ) {
1560       my $msg =
1561         "The ResultSource instance you just registered on '$self' as "
1562       . "'$source_name' seems to have no relation to $schema_class->"
1563       . "source('$source_name') which in turn is marked stale (likely due "
1564       . "to recent $result_class->... direct class calls). This is almost "
1565       . "always a mistake: perhaps you forgot a cycle of "
1566       . "$schema_class->unregister_source( '$source_name' ) / "
1567       . "$schema_class->register_class( '$source_name' => '$result_class' )"
1568       ;
1569
1570       DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
1571         ? emit_loud_diag( msg => $msg, confess => 1 )
1572         : carp_unique($msg)
1573       ;
1574     }
1575   }
1576
1577   $derived_rsrc;
1578 }
1579
1580 my $global_phase_destroy;
1581 sub DESTROY {
1582   ### NO detected_reinvoked_destructor check
1583   ### This code very much relies on being called multuple times
1584
1585   return if $global_phase_destroy ||= in_global_destruction;
1586
1587   my $self = shift;
1588   my $srcs = $self->source_registrations;
1589
1590   for my $source_name (keys %$srcs) {
1591     # find first source that is not about to be GCed (someone other than $self
1592     # holds a reference to it) and reattach to it, weakening our own link
1593     #
1594     # during global destruction (if we have not yet bailed out) this should throw
1595     # which will serve as a signal to not try doing anything else
1596     # however beware - on older perls the exception seems randomly untrappable
1597     # due to some weird race condition during thread joining :(((
1598     if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) {
1599       local $SIG{__DIE__} if $SIG{__DIE__};
1600       local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT;
1601       eval {
1602         $srcs->{$source_name}->schema($self);
1603         weaken $srcs->{$source_name};
1604         1;
1605       } or do {
1606         $global_phase_destroy = 1;
1607       };
1608
1609       last;
1610     }
1611   }
1612
1613   # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
1614   # collected before leaving this scope. Depending on the code above, this
1615   # may very well be just a preventive measure guarding future modifications
1616   undef;
1617 }
1618
1619 sub _unregister_source {
1620     my ($self, $source_name) = @_;
1621     my %reg = %{$self->source_registrations};
1622
1623     my $source = delete $reg{$source_name};
1624     $self->source_registrations(\%reg);
1625     if ($source->result_class) {
1626         my %map = %{$self->class_mappings};
1627         delete $map{$source->result_class};
1628         $self->class_mappings(\%map);
1629     }
1630 }
1631
1632
1633 =head2 compose_connection (DEPRECATED)
1634
1635 =over 4
1636
1637 =item Arguments: $target_namespace, @db_info
1638
1639 =item Return Value: $new_schema
1640
1641 =back
1642
1643 DEPRECATED. You probably wanted compose_namespace.
1644
1645 Actually, you probably just wanted to call connect.
1646
1647 =begin hidden
1648
1649 (hidden due to deprecation)
1650
1651 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
1652 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
1653 then injects the L<DBix::Class::ResultSetProxy> component and a
1654 resultset_instance classdata entry on all the new classes, in order to support
1655 $target_namespaces::$class->search(...) method calls.
1656
1657 This is primarily useful when you have a specific need for class method access
1658 to a connection. In normal usage it is preferred to call
1659 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
1660 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
1661 more information.
1662
1663 =end hidden
1664
1665 =cut
1666
1667 sub compose_connection {
1668   my ($self, $target, @info) = @_;
1669
1670   carp_once "compose_connection deprecated as of 0.08000"
1671     unless $INC{"DBIx/Class/CDBICompat.pm"};
1672
1673   dbic_internal_try {
1674     require DBIx::Class::ResultSetProxy;
1675   }
1676   dbic_internal_catch {
1677     $self->throw_exception
1678       ("No arguments to load_classes and couldn't load DBIx::Class::ResultSetProxy ($_)")
1679   };
1680
1681   if ($self eq $target) {
1682     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
1683     foreach my $source_name ($self->sources) {
1684       my $source = $self->source($source_name);
1685       my $class = $source->result_class;
1686       $self->inject_base($class, 'DBIx::Class::ResultSetProxy');
1687       $class->mk_classaccessor(resultset_instance => $source->resultset);
1688       $class->mk_classaccessor(class_resolver => $self);
1689     }
1690     $self->connection(@info);
1691     return $self;
1692   }
1693
1694   my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy');
1695   quote_sub "${target}::schema", '$s', { '$s' => \$schema };
1696
1697   # needed to cover the newly installed stuff via quote_sub above
1698   Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
1699
1700   $schema->connection(@info);
1701   foreach my $source_name ($schema->sources) {
1702     my $source = $schema->source($source_name);
1703     my $class = $source->result_class;
1704     #warn "$source_name $class $source ".$source->storage;
1705
1706     $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] );
1707     # explicit set-call, avoid mro update lag
1708     $class->set_inherited( result_source_instance => $source );
1709
1710     $class->mk_classaccessor(resultset_instance => $source->resultset);
1711     $class->mk_classaccessor(class_resolver => $schema);
1712   }
1713   return $schema;
1714 }
1715
1716 =head1 FURTHER QUESTIONS?
1717
1718 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
1719
1720 =head1 COPYRIGHT AND LICENSE
1721
1722 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
1723 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
1724 redistribute it and/or modify it under the same terms as the
1725 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1726
1727 =cut
1728
1729 1;