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