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