lib/DBIx/Class/Schema.pm

   1 package DBIx::Class::Schema;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp::Clan qw/^DBIx::Class/;
   7 use Scalar::Util qw/weaken/;
   8 require Module::Find;
   9
  10 use base qw/DBIx::Class/;
  11
  12 __PACKAGE__->mk_classdata('class_mappings' => {});
  13 __PACKAGE__->mk_classdata('source_registrations' => {});
  14 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  15 __PACKAGE__->mk_classdata('storage');
  16 __PACKAGE__->mk_classdata('exception_action');
  17
  18 =head1 NAME
  19
  20 DBIx::Class::Schema - composable schemas
  21
  22 =head1 SYNOPSIS
  23
  24   package Library::Schema;
  25   use base qw/DBIx::Class::Schema/;
  26
  27   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  28   __PACKAGE__->load_classes(qw/CD Book DVD/);
  29
  30   package Library::Schema::CD;
  31   use base qw/DBIx::Class/;
  32   __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
  33   __PACKAGE__->table('cd');
  34
  35   # Elsewhere in your code:
  36   my $schema1 = Library::Schema->connect(
  37     $dsn,
  38     $user,
  39     $password,
  40     { AutoCommit => 0 },
  41   );
  42
  43   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  44
  45   # fetch objects using Library::Schema::DVD
  46   my $resultset = $schema1->resultset('DVD')->search( ... );
  47   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  48
  49 =head1 DESCRIPTION
  50
  51 Creates database classes based on a schema. This is the recommended way to
  52 use L<DBIx::Class> and allows you to use more than one concurrent connection
  53 with your classes.
  54
  55 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  56 carefully, as DBIx::Class does things a little differently. Note in
  57 particular which module inherits off which.
  58
  59 =head1 METHODS
  60
  61 =head2 register_class
  62
  63 =over 4
  64
  65 =item Arguments: $moniker, $component_class
  66
  67 =back
  68
  69 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
  70 calling:
  71
  72   $schema->register_source($moniker, $component_class->result_source_instance);
  73
  74 =cut
  75
  76 sub register_class {
  77   my ($self, $moniker, $to_register) = @_;
  78   $self->register_source($moniker => $to_register->result_source_instance);
  79 }
  80
  81 =head2 register_source
  82
  83 =over 4
  84
  85 =item Arguments: $moniker, $result_source
  86
  87 =back
  88
  89 Registers the L<DBIx::Class::ResultSource> in the schema with the given
  90 moniker.
  91
  92 =cut
  93
  94 sub register_source {
  95   my ($self, $moniker, $source) = @_;
  96   my %reg = %{$self->source_registrations};
  97   $reg{$moniker} = $source;
  98   $self->source_registrations(\%reg);
  99   $source->schema($self);
 100   weaken($source->{schema}) if ref($self);
 101   if ($source->result_class) {
 102     my %map = %{$self->class_mappings};
 103     $map{$source->result_class} = $moniker;
 104     $self->class_mappings(\%map);
 105   }
 106 }
 107
 108 =head2 class
 109
 110 =over 4
 111
 112 =item Arguments: $moniker
 113
 114 =item Return Value: $classname
 115
 116 =back
 117
 118 Retrieves the result class name for the given moniker. For example:
 119
 120   my $class = $schema->class('CD');
 121
 122 =cut
 123
 124 sub class {
 125   my ($self, $moniker) = @_;
 126   return $self->source($moniker)->result_class;
 127 }
 128
 129 =head2 source
 130
 131 =over 4
 132
 133 =item Arguments: $moniker
 134
 135 =item Return Value: $result_source
 136
 137 =back
 138
 139   my $source = $schema->source('Book');
 140
 141 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
 142
 143 =cut
 144
 145 sub source {
 146   my ($self, $moniker) = @_;
 147   my $sreg = $self->source_registrations;
 148   return $sreg->{$moniker} if exists $sreg->{$moniker};
 149
 150   # if we got here, they probably passed a full class name
 151   my $mapped = $self->class_mappings->{$moniker};
 152   $self->throw_exception("Can't find source for ${moniker}")
 153     unless $mapped && exists $sreg->{$mapped};
 154   return $sreg->{$mapped};
 155 }
 156
 157 =head2 sources
 158
 159 =over 4
 160
 161 =item Return Value: @source_monikers
 162
 163 =back
 164
 165 Returns the source monikers of all source registrations on this schema.
 166 For example:
 167
 168   my @source_monikers = $schema->sources;
 169
 170 =cut
 171
 172 sub sources { return keys %{shift->source_registrations}; }
 173
 174 =head2 resultset
 175
 176 =over 4
 177
 178 =item Arguments: $moniker
 179
 180 =item Return Value: $result_set
 181
 182 =back
 183
 184   my $rs = $schema->resultset('DVD');
 185
 186 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
 187
 188 =cut
 189
 190 sub resultset {
 191   my ($self, $moniker) = @_;
 192   return $self->source($moniker)->resultset;
 193 }
 194
 195 =head2 load_classes
 196
 197 =over 4
 198
 199 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 200
 201 =back
 202
 203 With no arguments, this method uses L<Module::Find> to find all classes under
 204 the schema's namespace. Otherwise, this method loads the classes you specify
 205 (using L<use>), and registers them (using L</"register_class">).
 206
 207 It is possible to comment out classes with a leading C<#>, but note that perl
 208 will think it's a mistake (trying to use a comment in a qw list), so you'll
 209 need to add C<no warnings 'qw';> before your load_classes call.
 210
 211 Example:
 212
 213   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 214                               # etc. (anything under the My::Schema namespace)
 215
 216   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 217   # not Other::Namespace::LinerNotes nor My::Schema::Track
 218   My::Schema->load_classes(qw/ CD Artist #Track /, {
 219     Other::Namespace => [qw/ Producer #LinerNotes /],
 220   });
 221
 222 =cut
 223
 224 sub load_classes {
 225   my ($class, @params) = @_;
 226
 227   my %comps_for;
 228
 229   if (@params) {
 230     foreach my $param (@params) {
 231       if (ref $param eq 'ARRAY') {
 232         # filter out commented entries
 233         my @modules = grep { $_ !~ /^#/ } @$param;
 234
 235         push (@{$comps_for{$class}}, @modules);
 236       }
 237       elsif (ref $param eq 'HASH') {
 238         # more than one namespace possible
 239         for my $comp ( keys %$param ) {
 240           # filter out commented entries
 241           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 242
 243           push (@{$comps_for{$comp}}, @modules);
 244         }
 245       }
 246       else {
 247         # filter out commented entries
 248         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 249       }
 250     }
 251   } else {
 252     my @comp = map { substr $_, length "${class}::"  }
 253                  Module::Find::findallmod($class);
 254     $comps_for{$class} = \@comp;
 255   }
 256
 257   my @to_register;
 258   {
 259     no warnings qw/redefine/;
 260     local *Class::C3::reinitialize = sub { };
 261     foreach my $prefix (keys %comps_for) {
 262       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 263         my $comp_class = "${prefix}::${comp}";
 264         $class->ensure_class_loaded($comp_class);
 265         $comp_class->source_name($comp) unless $comp_class->source_name;
 266
 267         push(@to_register, [ $comp_class->source_name, $comp_class ]);
 268       }
 269     }
 270   }
 271   Class::C3->reinitialize;
 272
 273   foreach my $to (@to_register) {
 274     $class->register_class(@$to);
 275     #  if $class->can('result_source_instance');
 276   }
 277 }
 278
 279 =head2 load_namespaces
 280
 281 =over 4
 282
 283 =item Arguments: %options?
 284
 285 =back
 286
 287 This is an alternative to L</load_classes> above which assumes an alternative
 288 layout for automatic class loading.  It assumes that all ResultSource classes
 289 to be loaded are underneath a sub-namespace of the schema called
 290 "ResultSource", any corresponding ResultSet classes to be underneath a
 291 sub-namespace of the schema called "ResultSet", and any corresponing
 292 Result classes to be underneath a sub-namespace of the schema called "Result".
 293
 294 All of those sub-namespaces are configurable if you don't like the defaults,
 295 via the options C<resultsource_namespace>, C<resultset_namespace>, and
 296 C<result_namespace>, respectively.
 297
 298 If (and only if) you specify the option C<default_resultset_base>, any found
 299 ResultSource classes that have no manually-created corresponding ResultSet
 300 class will have one created for them in memory in the C<resultset_namespace>,
 301 based on C<default_resultset_base>.
 302
 303 All of the namespace and classname options to this method are relative to
 304 the schema classname by default.  To specify a fully-qualified name, prefix
 305 it with a literal C<+>.
 306
 307 Example:
 308
 309   # load My::Schema::ResultSource::CD, My::Schema::ResultSource::Artist,
 310   #    My::Schema::ResultSet::CD, etc...
 311   My::Schema->load_namespaces;
 312
 313   # Override everything...
 314   My::Schema->load_namespaces(
 315     resultsource_namespace => 'RSources',
 316     resultset_namespace => 'RSets',
 317     result_namespace => 'Results',
 318     default_resultset_base => 'RSetBase',
 319   );
 320   # ... and if there is a My::Schema::RSources::Foo, but no matching
 321   #   My::Schema::RSets::Foo, then My::Schema::RSets::Foo will be created
 322   #   for you in memory, based on My::Schema::RSetBase
 323
 324   # Put things in other namespaces
 325   My::Schema->load_namespaces(
 326     resultsource_namespace => '+Some::Place::RSources',
 327     resultset_namespace => '+Another::Place::RSets',
 328     result_namespace => '+Crazy::Stuff::Results',
 329     default_resultset_base => '+You::Never::Know::RSetBase',
 330   );
 331
 332
 333 =cut
 334
 335 sub load_namespaces {
 336   my ($class, %args) = @_;
 337
 338   my $resultsource_namespace = $args{resultsource_namespace} || 'ResultSource';
 339   my $resultset_namespace    = $args{resultset_namespace}    || 'ResultSet';
 340   my $result_namespace       = $args{result_namespace}       || 'Result';
 341   my $default_resultset_base = $args{default_resultset_base};
 342
 343   foreach ($resultsource_namespace, $resultset_namespace,
 344            $result_namespace,       $default_resultset_base) {
 345     next if !$_;
 346     $_ = $class . '::' . $_ if !s/^\+//;
 347   }
 348
 349   my %sources = map { (substr($_, length "${resultsource_namespace}::"), $_) }
 350       Module::Find::findallmod($resultsource_namespace);
 351
 352   my %resultsets = map { (substr($_, length "${resultset_namespace}::"), $_) }
 353       Module::Find::findallmod($resultset_namespace);
 354
 355   my %results = map { (substr($_, length "${result_namespace}::"), $_) }
 356       Module::Find::findallmod($result_namespace);
 357
 358   my @to_register;
 359   {
 360     no warnings qw/redefine/;
 361     local *Class::C3::reinitialize = sub { };
 362     use warnings qw/redefine/;
 363
 364     foreach my $source (keys %sources) {
 365       my $source_class = $sources{$source};
 366       $class->ensure_class_loaded($source_class);
 367       $source_class->source_name($source) unless $source_class->source_name;
 368
 369       my $rs_class = delete $resultsets{$source};
 370       my $rs_set = $source_class->resultset_class;
 371       if(!$rs_set || $rs_set eq 'DBIx::Class::ResultSet') {
 372         if($rs_class) {
 373           $class->ensure_class_loaded($rs_class);
 374           $source_class->resultset_class($rs_class);
 375         }
 376         elsif($default_resultset_base) {
 377           $class->ensure_class_loaded($default_resultset_base);
 378           $rs_class = "$resultset_namespace\::$source";
 379           { no strict qw/refs/; @{"$rs_class\::ISA"} = ($default_resultset_base); }
 380           $source_class->resultset_class($rs_class);
 381         }
 382       }
 383       elsif($rs_set && $rs_class) {
 384         warn "We found ResultSet class '$rs_class' for '$source', but it seems "
 385            . "that you had already set '$source' to use '$rs_set' instead";
 386       }
 387
 388       my $r_class = delete $results{$source};
 389       if($r_class) {
 390         my $r_set = $source_class->result_class;
 391         if(!$r_set || $r_set eq $sources{$source}) {
 392           $class->ensure_class_loaded($r_class);
 393           $source_class->result_class($r_class);
 394         }
 395         else {
 396           warn "We found Result class '$r_class' for '$source', but it seems "
 397              . "that you had already set '$source' to use '$r_set' instead";
 398         }
 399       }
 400
 401       push(@to_register, [ $source_class->source_name, $source_class ]);
 402     }
 403   }
 404
 405   foreach (sort keys %resultsets) {
 406     warn "load_namespaces found ResultSet class $_ with no "
 407       . 'corresponding ResultSource';
 408   }
 409
 410   foreach (sort keys %results) {
 411     warn "load_namespaces found Result class $_ with no "
 412       . 'corresponding ResultSource';
 413   }
 414
 415   Class::C3->reinitialize;
 416   $class->register_class(@$_) for (@to_register);
 417
 418   return;
 419 }
 420
 421 =head2 compose_connection
 422
 423 =over 4
 424
 425 =item Arguments: $target_namespace, @db_info
 426
 427 =item Return Value: $new_schema
 428
 429 =back
 430
 431 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 432 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 433 then injects the L<DBix::Class::ResultSetProxy> component and a
 434 resultset_instance classdata entry on all the new classes, in order to support
 435 $target_namespaces::$class->search(...) method calls.
 436
 437 This is primarily useful when you have a specific need for class method access
 438 to a connection. In normal usage it is preferred to call
 439 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 440 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 441 more information.
 442
 443 =cut
 444
 445 sub compose_connection {
 446   my ($self, $target, @info) = @_;
 447   my $base = 'DBIx::Class::ResultSetProxy';
 448   eval "require ${base};";
 449   $self->throw_exception
 450     ("No arguments to load_classes and couldn't load ${base} ($@)")
 451       if $@;
 452
 453   if ($self eq $target) {
 454     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 455     foreach my $moniker ($self->sources) {
 456       my $source = $self->source($moniker);
 457       my $class = $source->result_class;
 458       $self->inject_base($class, $base);
 459       $class->mk_classdata(resultset_instance => $source->resultset);
 460       $class->mk_classdata(class_resolver => $self);
 461     }
 462     $self->connection(@info);
 463     return $self;
 464   }
 465
 466   my $schema = $self->compose_namespace($target, $base);
 467   {
 468     no strict 'refs';
 469     *{"${target}::schema"} = sub { $schema };
 470   }
 471
 472   $schema->connection(@info);
 473   foreach my $moniker ($schema->sources) {
 474     my $source = $schema->source($moniker);
 475     my $class = $source->result_class;
 476     #warn "$moniker $class $source ".$source->storage;
 477     $class->mk_classdata(result_source_instance => $source);
 478     $class->mk_classdata(resultset_instance => $source->resultset);
 479     $class->mk_classdata(class_resolver => $schema);
 480   }
 481   return $schema;
 482 }
 483
 484 =head2 compose_namespace
 485
 486 =over 4
 487
 488 =item Arguments: $target_namespace, $additional_base_class?
 489
 490 =item Return Value: $new_schema
 491
 492 =back
 493
 494 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 495 class in the target namespace (e.g. $target_namespace::CD,
 496 $target_namespace::Artist) that inherits from the corresponding classes
 497 attached to the current schema.
 498
 499 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 500 new $schema object. If C<$additional_base_class> is given, the new composed
 501 classes will inherit from first the corresponding classe from the current
 502 schema then the base class.
 503
 504 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 505
 506   $schema->compose_namespace('My::DB', 'Base::Class');
 507   print join (', ', @My::DB::CD::ISA) . "\n";
 508   print join (', ', @My::DB::Artist::ISA) ."\n";
 509
 510 will produce the output
 511
 512   My::Schema::CD, Base::Class
 513   My::Schema::Artist, Base::Class
 514
 515 =cut
 516
 517 sub compose_namespace {
 518   my ($self, $target, $base) = @_;
 519   my %reg = %{ $self->source_registrations };
 520   my %target;
 521   my %map;
 522   my $schema = $self->clone;
 523   {
 524     no warnings qw/redefine/;
 525     local *Class::C3::reinitialize = sub { };
 526     foreach my $moniker ($schema->sources) {
 527       my $source = $schema->source($moniker);
 528       my $target_class = "${target}::${moniker}";
 529       $self->inject_base(
 530         $target_class => $source->result_class, ($base ? $base : ())
 531       );
 532       $source->result_class($target_class);
 533       $target_class->result_source_instance($source)
 534         if $target_class->can('result_source_instance');
 535     }
 536   }
 537   Class::C3->reinitialize();
 538   {
 539     no strict 'refs';
 540     foreach my $meth (qw/class source resultset/) {
 541       *{"${target}::${meth}"} =
 542         sub { shift->schema->$meth(@_) };
 543     }
 544   }
 545   return $schema;
 546 }
 547
 548 =head2 setup_connection_class
 549
 550 =over 4
 551
 552 =item Arguments: $target, @info
 553
 554 =back
 555
 556 Sets up a database connection class to inject between the schema and the
 557 subclasses that the schema creates.
 558
 559 =cut
 560
 561 sub setup_connection_class {
 562   my ($class, $target, @info) = @_;
 563   $class->inject_base($target => 'DBIx::Class::DB');
 564   #$target->load_components('DB');
 565   $target->connection(@info);
 566 }
 567
 568 =head2 connection
 569
 570 =over 4
 571
 572 =item Arguments: @args
 573
 574 =item Return Value: $new_schema
 575
 576 =back
 577
 578 Instantiates a new Storage object of type
 579 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 580 $storage->connect_info. Sets the connection in-place on the schema. See
 581 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
 582
 583 =cut
 584
 585 sub connection {
 586   my ($self, @info) = @_;
 587   return $self if !@info && $self->storage;
 588   my $storage_class = $self->storage_type;
 589   $storage_class = 'DBIx::Class::Storage'.$storage_class
 590     if $storage_class =~ m/^::/;
 591   eval "require ${storage_class};";
 592   $self->throw_exception(
 593     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 594   ) if $@;
 595   my $storage = $storage_class->new($self);
 596   $storage->connect_info(\@info);
 597   $self->storage($storage);
 598   return $self;
 599 }
 600
 601 =head2 connect
 602
 603 =over 4
 604
 605 =item Arguments: @info
 606
 607 =item Return Value: $new_schema
 608
 609 =back
 610
 611 This is a convenience method. It is equivalent to calling
 612 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 613 information.
 614
 615 =cut
 616
 617 sub connect { shift->clone->connection(@_) }
 618
 619 =head2 txn_begin
 620
 621 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 622 calling $schema->storage->txn_begin. See
 623 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 624
 625 =cut
 626
 627 sub txn_begin { shift->storage->txn_begin }
 628
 629 =head2 txn_commit
 630
 631 Commits the current transaction. Equivalent to calling
 632 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 633 for more information.
 634
 635 =cut
 636
 637 sub txn_commit { shift->storage->txn_commit }
 638
 639 =head2 txn_rollback
 640
 641 Rolls back the current transaction. Equivalent to calling
 642 $schema->storage->txn_rollback. See
 643 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 644
 645 =cut
 646
 647 sub txn_rollback { shift->storage->txn_rollback }
 648
 649 =head2 txn_do
 650
 651 =over 4
 652
 653 =item Arguments: C<$coderef>, @coderef_args?
 654
 655 =item Return Value: The return value of $coderef
 656
 657 =back
 658
 659 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 660 returning its result (if any). If an exception is caught, a rollback is issued
 661 and the exception is rethrown. If the rollback fails, (i.e. throws an
 662 exception) an exception is thrown that includes a "Rollback failed" message.
 663
 664 For example,
 665
 666   my $author_rs = $schema->resultset('Author')->find(1);
 667   my @titles = qw/Night Day It/;
 668
 669   my $coderef = sub {
 670     # If any one of these fails, the entire transaction fails
 671     $author_rs->create_related('books', {
 672       title => $_
 673     }) foreach (@titles);
 674
 675     return $author->books;
 676   };
 677
 678   my $rs;
 679   eval {
 680     $rs = $schema->txn_do($coderef);
 681   };
 682
 683   if ($@) {                                  # Transaction failed
 684     die "something terrible has happened!"   #
 685       if ($@ =~ /Rollback failed/);          # Rollback failed
 686
 687     deal_with_failed_transaction();
 688   }
 689
 690 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 691 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
 692 the Schema's storage, and txn_do() can be called in void, scalar and list
 693 context and it will behave as expected.
 694
 695 =cut
 696
 697 sub txn_do {
 698   my ($self, $coderef, @args) = @_;
 699
 700   $self->storage or $self->throw_exception
 701     ('txn_do called on $schema without storage');
 702   ref $coderef eq 'CODE' or $self->throw_exception
 703     ('$coderef must be a CODE reference');
 704
 705   my (@return_values, $return_value);
 706
 707   $self->txn_begin; # If this throws an exception, no rollback is needed
 708
 709   my $wantarray = wantarray; # Need to save this since the context
 710                              # inside the eval{} block is independent
 711                              # of the context that called txn_do()
 712   eval {
 713
 714     # Need to differentiate between scalar/list context to allow for
 715     # returning a list in scalar context to get the size of the list
 716     if ($wantarray) {
 717       # list context
 718       @return_values = $coderef->(@args);
 719     } elsif (defined $wantarray) {
 720       # scalar context
 721       $return_value = $coderef->(@args);
 722     } else {
 723       # void context
 724       $coderef->(@args);
 725     }
 726     $self->txn_commit;
 727   };
 728
 729   if ($@) {
 730     my $error = $@;
 731
 732     eval {
 733       $self->txn_rollback;
 734     };
 735
 736     if ($@) {
 737       my $rollback_error = $@;
 738       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 739       $self->throw_exception($error)  # propagate nested rollback
 740         if $rollback_error =~ /$exception_class/;
 741
 742       $self->throw_exception(
 743         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 744       );
 745     } else {
 746       $self->throw_exception($error); # txn failed but rollback succeeded
 747     }
 748   }
 749
 750   return $wantarray ? @return_values : $return_value;
 751 }
 752
 753 =head2 clone
 754
 755 =over 4
 756
 757 =item Return Value: $new_schema
 758
 759 =back
 760
 761 Clones the schema and its associated result_source objects and returns the
 762 copy.
 763
 764 =cut
 765
 766 sub clone {
 767   my ($self) = @_;
 768   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 769   foreach my $moniker ($self->sources) {
 770     my $source = $self->source($moniker);
 771     my $new = $source->new($source);
 772     $clone->register_source($moniker => $new);
 773   }
 774   $clone->storage->set_schema($clone) if $clone->storage;
 775   return $clone;
 776 }
 777
 778 =head2 populate
 779
 780 =over 4
 781
 782 =item Arguments: $moniker, \@data;
 783
 784 =back
 785
 786 Populates the source registered with the given moniker with the supplied data.
 787 @data should be a list of listrefs -- the first containing column names, the
 788 second matching values.
 789
 790 i.e.,
 791
 792   $schema->populate('Artist', [
 793     [ qw/artistid name/ ],
 794     [ 1, 'Popular Band' ],
 795     [ 2, 'Indie Band' ],
 796     ...
 797   ]);
 798
 799 =cut
 800
 801 sub populate {
 802   my ($self, $name, $data) = @_;
 803   my $rs = $self->resultset($name);
 804   my @names = @{shift(@$data)};
 805   my @created;
 806   foreach my $item (@$data) {
 807     my %create;
 808     @create{@names} = @$item;
 809     push(@created, $rs->create(\%create));
 810   }
 811   return @created;
 812 }
 813
 814 =head2 exception_action
 815
 816 =over 4
 817
 818 =item Arguments: $code_reference
 819
 820 =back
 821
 822 If C<exception_action> is set for this class/object, L</throw_exception>
 823 will prefer to call this code reference with the exception as an argument,
 824 rather than its normal <croak> action.
 825
 826 Your subroutine should probably just wrap the error in the exception
 827 object/class of your choosing and rethrow.  If, against all sage advice,
 828 you'd like your C<exception_action> to suppress a particular exception
 829 completely, simply have it return true.
 830
 831 Example:
 832
 833    package My::Schema;
 834    use base qw/DBIx::Class::Schema/;
 835    use My::ExceptionClass;
 836    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 837    __PACKAGE__->load_classes;
 838
 839    # or:
 840    my $schema_obj = My::Schema->connect( .... );
 841    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 842
 843    # suppress all exceptions, like a moron:
 844    $schema_obj->exception_action(sub { 1 });
 845
 846 =head2 throw_exception
 847
 848 =over 4
 849
 850 =item Arguments: $message
 851
 852 =back
 853
 854 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 855 user's perspective.  See L</exception_action> for details on overriding
 856 this method's behavior.
 857
 858 =cut
 859
 860 sub throw_exception {
 861   my $self = shift;
 862   croak @_ if !$self->exception_action || !$self->exception_action->(@_);
 863 }
 864
 865 =head2 deploy (EXPERIMENTAL)
 866
 867 =over 4
 868
 869 =item Arguments: $sqlt_args
 870
 871 =back
 872
 873 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 874
 875 Note that this feature is currently EXPERIMENTAL and may not work correctly
 876 across all databases, or fully handle complex relationships.
 877
 878 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 879 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 880 produced include a DROP TABLE statement for each table created.
 881
 882 =cut
 883
 884 sub deploy {
 885   my ($self, $sqltargs) = @_;
 886   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 887   $self->storage->deploy($self, undef, $sqltargs);
 888 }
 889
 890 =head2 create_ddl_dir (EXPERIMENTAL)
 891
 892 =over 4
 893
 894 =item Arguments: \@databases, $version, $directory, $sqlt_args
 895
 896 =back
 897
 898 Creates an SQL file based on the Schema, for each of the specified
 899 database types, in the given directory.
 900
 901 Note that this feature is currently EXPERIMENTAL and may not work correctly
 902 across all databases, or fully handle complex relationships.
 903
 904 =cut
 905
 906 sub create_ddl_dir
 907 {
 908   my $self = shift;
 909
 910   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 911   $self->storage->create_ddl_dir($self, @_);
 912 }
 913
 914 =head2 ddl_filename (EXPERIMENTAL)
 915
 916   my $filename = $table->ddl_filename($type, $dir, $version)
 917
 918 Creates a filename for a SQL file based on the table class name.  Not
 919 intended for direct end user use.
 920
 921 =cut
 922
 923 sub ddl_filename
 924 {
 925     my ($self, $type, $dir, $version) = @_;
 926
 927     my $filename = ref($self);
 928     $filename =~ s/::/-/;
 929     $filename = "$dir$filename-$version-$type.sql";
 930
 931     return $filename;
 932 }
 933
 934 1;
 935
 936 =head1 AUTHORS
 937
 938 Matt S. Trout <mst@shadowcatsystems.co.uk>
 939
 940 =head1 LICENSE
 941
 942 You may distribute this code under the same terms as Perl itself.
 943
 944 =cut
 945