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