lib/DBIx/Class/Schema.pm

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