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 storage
 175
 176   my $storage = $schema->storage;
 177
 178 Returns the L<DBIx::Class::Storage> object for this Schema.
 179
 180 =head2 resultset
 181
 182 =over 4
 183
 184 =item Arguments: $moniker
 185
 186 =item Return Value: $result_set
 187
 188 =back
 189
 190   my $rs = $schema->resultset('DVD');
 191
 192 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
 193
 194 =cut
 195
 196 sub resultset {
 197   my ($self, $moniker) = @_;
 198   return $self->source($moniker)->resultset;
 199 }
 200
 201 =head2 load_classes
 202
 203 =over 4
 204
 205 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 206
 207 =back
 208
 209 With no arguments, this method uses L<Module::Find> to find all classes under
 210 the schema's namespace. Otherwise, this method loads the classes you specify
 211 (using L<use>), and registers them (using L</"register_class">).
 212
 213 It is possible to comment out classes with a leading C<#>, but note that perl
 214 will think it's a mistake (trying to use a comment in a qw list), so you'll
 215 need to add C<no warnings 'qw';> before your load_classes call.
 216
 217 Example:
 218
 219   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 220                               # etc. (anything under the My::Schema namespace)
 221
 222   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 223   # not Other::Namespace::LinerNotes nor My::Schema::Track
 224   My::Schema->load_classes(qw/ CD Artist #Track /, {
 225     Other::Namespace => [qw/ Producer #LinerNotes /],
 226   });
 227
 228 =cut
 229
 230 sub load_classes {
 231   my ($class, @params) = @_;
 232
 233   my %comps_for;
 234
 235   if (@params) {
 236     foreach my $param (@params) {
 237       if (ref $param eq 'ARRAY') {
 238         # filter out commented entries
 239         my @modules = grep { $_ !~ /^#/ } @$param;
 240
 241         push (@{$comps_for{$class}}, @modules);
 242       }
 243       elsif (ref $param eq 'HASH') {
 244         # more than one namespace possible
 245         for my $comp ( keys %$param ) {
 246           # filter out commented entries
 247           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 248
 249           push (@{$comps_for{$comp}}, @modules);
 250         }
 251       }
 252       else {
 253         # filter out commented entries
 254         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 255       }
 256     }
 257   } else {
 258     my @comp = map { substr $_, length "${class}::"  }
 259                  Module::Find::findallmod($class);
 260     $comps_for{$class} = \@comp;
 261   }
 262
 263   my @to_register;
 264   {
 265     no warnings qw/redefine/;
 266     local *Class::C3::reinitialize = sub { };
 267     foreach my $prefix (keys %comps_for) {
 268       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 269         my $comp_class = "${prefix}::${comp}";
 270         { # try to untaint module name. mods where this fails
 271           # are left alone so we don't have to change the old behavior
 272           no locale; # localized \w doesn't untaint expression
 273           if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
 274             $comp_class = $1;
 275           }
 276         }
 277         $class->ensure_class_loaded($comp_class);
 278         $comp_class->source_name($comp) unless $comp_class->source_name;
 279
 280         push(@to_register, [ $comp_class->source_name, $comp_class ]);
 281       }
 282     }
 283   }
 284   Class::C3->reinitialize;
 285
 286   foreach my $to (@to_register) {
 287     $class->register_class(@$to);
 288     #  if $class->can('result_source_instance');
 289   }
 290 }
 291
 292 =head2 load_namespaces
 293
 294 =over 4
 295
 296 =item Arguments: %options?
 297
 298 =back
 299
 300 This is an alternative to L</load_classes> above which assumes an alternative
 301 layout for automatic class loading.  It assumes that all result
 302 classes are underneath a sub-namespace of the schema called C<Result>, any
 303 corresponding ResultSet classes are underneath a sub-namespace of the schema
 304 called C<ResultSet>.
 305
 306 Both of the sub-namespaces are configurable if you don't like the defaults,
 307 via the options C<result_namespace> and C<resultset_namespace>.
 308
 309 If (and only if) you specify the option C<default_resultset_class>, any found
 310 Result classes for which we do not find a corresponding
 311 ResultSet class will have their C<resultset_class> set to
 312 C<default_resultset_class>.
 313
 314 C<load_namespaces> takes care of calling C<resultset_class> for you where
 315 neccessary if you didn't do it for yourself.
 316
 317 All of the namespace and classname options to this method are relative to
 318 the schema classname by default.  To specify a fully-qualified name, prefix
 319 it with a literal C<+>.
 320
 321 Examples:
 322
 323   # load My::Schema::Result::CD, My::Schema::Result::Artist,
 324   #    My::Schema::ResultSet::CD, etc...
 325   My::Schema->load_namespaces;
 326
 327   # Override everything to use ugly names.
 328   # In this example, if there is a My::Schema::Res::Foo, but no matching
 329   #   My::Schema::RSets::Foo, then Foo will have its
 330   #   resultset_class set to My::Schema::RSetBase
 331   My::Schema->load_namespaces(
 332     result_namespace => 'Res',
 333     resultset_namespace => 'RSets',
 334     default_resultset_class => 'RSetBase',
 335   );
 336
 337   # Put things in other namespaces
 338   My::Schema->load_namespaces(
 339     result_namespace => '+Some::Place::Results',
 340     resultset_namespace => '+Another::Place::RSets',
 341   );
 342
 343 If you'd like to use multiple namespaces of each type, simply use an arrayref
 344 of namespaces for that option.  In the case that the same result
 345 (or resultset) class exists in multiple namespaces, the latter entries in
 346 your list of namespaces will override earlier ones.
 347
 348   My::Schema->load_namespaces(
 349     # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
 350     result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
 351     resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
 352   );
 353
 354 =cut
 355
 356 # Pre-pends our classname to the given relative classname or
 357 #   class namespace, unless there is a '+' prefix, which will
 358 #   be stripped.
 359 sub _expand_relative_name {
 360   my ($class, $name) = @_;
 361   return if !$name;
 362   $name = $class . '::' . $name if ! ($name =~ s/^\+//);
 363   return $name;
 364 }
 365
 366 # returns a hash of $shortname => $fullname for every package
 367 #  found in the given namespaces ($shortname is with the $fullname's
 368 #  namespace stripped off)
 369 sub _map_namespaces {
 370   my ($class, @namespaces) = @_;
 371
 372   my @results_hash;
 373   foreach my $namespace (@namespaces) {
 374     push(
 375       @results_hash,
 376       map { (substr($_, length "${namespace}::"), $_) }
 377       Module::Find::findallmod($namespace)
 378     );
 379   }
 380
 381   @results_hash;
 382 }
 383
 384 sub load_namespaces {
 385   my ($class, %args) = @_;
 386
 387   my $result_namespace = delete $args{result_namespace} || 'Result';
 388   my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
 389   my $default_resultset_class = delete $args{default_resultset_class};
 390
 391   $class->throw_exception('load_namespaces: unknown option(s): '
 392     . join(q{,}, map { qq{'$_'} } keys %args))
 393       if scalar keys %args;
 394
 395   $default_resultset_class
 396     = $class->_expand_relative_name($default_resultset_class);
 397
 398   for my $arg ($result_namespace, $resultset_namespace) {
 399     $arg = [ $arg ] if !ref($arg) && $arg;
 400
 401     $class->throw_exception('load_namespaces: namespace arguments must be '
 402       . 'a simple string or an arrayref')
 403         if ref($arg) ne 'ARRAY';
 404
 405     $_ = $class->_expand_relative_name($_) for (@$arg);
 406   }
 407
 408   my %results = $class->_map_namespaces(@$result_namespace);
 409   my %resultsets = $class->_map_namespaces(@$resultset_namespace);
 410
 411   my @to_register;
 412   {
 413     no warnings 'redefine';
 414     local *Class::C3::reinitialize = sub { };
 415     use warnings 'redefine';
 416
 417     foreach my $result (keys %results) {
 418       my $result_class = $results{$result};
 419       $class->ensure_class_loaded($result_class);
 420       $result_class->source_name($result) unless $result_class->source_name;
 421
 422       my $rs_class = delete $resultsets{$result};
 423       my $rs_set = $result_class->resultset_class;
 424       if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
 425         if($rs_class && $rs_class ne $rs_set) {
 426           warn "We found ResultSet class '$rs_class' for '$result', but it seems "
 427              . "that you had already set '$result' to use '$rs_set' instead";
 428         }
 429       }
 430       elsif($rs_class ||= $default_resultset_class) {
 431         $class->ensure_class_loaded($rs_class);
 432         $result_class->resultset_class($rs_class);
 433       }
 434
 435       push(@to_register, [ $result_class->source_name, $result_class ]);
 436     }
 437   }
 438
 439   foreach (sort keys %resultsets) {
 440     warn "load_namespaces found ResultSet class $_ with no "
 441       . 'corresponding Result class';
 442   }
 443
 444   Class::C3->reinitialize;
 445   $class->register_class(@$_) for (@to_register);
 446
 447   return;
 448 }
 449
 450 =head2 compose_connection
 451
 452 =over 4
 453
 454 =item Arguments: $target_namespace, @db_info
 455
 456 =item Return Value: $new_schema
 457
 458 =back
 459
 460 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 461 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 462 then injects the L<DBix::Class::ResultSetProxy> component and a
 463 resultset_instance classdata entry on all the new classes, in order to support
 464 $target_namespaces::$class->search(...) method calls.
 465
 466 This is primarily useful when you have a specific need for class method access
 467 to a connection. In normal usage it is preferred to call
 468 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 469 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 470 more information.
 471
 472 =cut
 473
 474 sub compose_connection {
 475   my ($self, $target, @info) = @_;
 476   my $base = 'DBIx::Class::ResultSetProxy';
 477   eval "require ${base};";
 478   $self->throw_exception
 479     ("No arguments to load_classes and couldn't load ${base} ($@)")
 480       if $@;
 481
 482   if ($self eq $target) {
 483     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 484     foreach my $moniker ($self->sources) {
 485       my $source = $self->source($moniker);
 486       my $class = $source->result_class;
 487       $self->inject_base($class, $base);
 488       $class->mk_classdata(resultset_instance => $source->resultset);
 489       $class->mk_classdata(class_resolver => $self);
 490     }
 491     $self->connection(@info);
 492     return $self;
 493   }
 494
 495   my $schema = $self->compose_namespace($target, $base);
 496   {
 497     no strict 'refs';
 498     *{"${target}::schema"} = sub { $schema };
 499   }
 500
 501   $schema->connection(@info);
 502   foreach my $moniker ($schema->sources) {
 503     my $source = $schema->source($moniker);
 504     my $class = $source->result_class;
 505     #warn "$moniker $class $source ".$source->storage;
 506     $class->mk_classdata(result_source_instance => $source);
 507     $class->mk_classdata(resultset_instance => $source->resultset);
 508     $class->mk_classdata(class_resolver => $schema);
 509   }
 510   return $schema;
 511 }
 512
 513 =head2 compose_namespace
 514
 515 =over 4
 516
 517 =item Arguments: $target_namespace, $additional_base_class?
 518
 519 =item Return Value: $new_schema
 520
 521 =back
 522
 523 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 524 class in the target namespace (e.g. $target_namespace::CD,
 525 $target_namespace::Artist) that inherits from the corresponding classes
 526 attached to the current schema.
 527
 528 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 529 new $schema object. If C<$additional_base_class> is given, the new composed
 530 classes will inherit from first the corresponding classe from the current
 531 schema then the base class.
 532
 533 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 534
 535   $schema->compose_namespace('My::DB', 'Base::Class');
 536   print join (', ', @My::DB::CD::ISA) . "\n";
 537   print join (', ', @My::DB::Artist::ISA) ."\n";
 538
 539 will produce the output
 540
 541   My::Schema::CD, Base::Class
 542   My::Schema::Artist, Base::Class
 543
 544 =cut
 545
 546 sub compose_namespace {
 547   my ($self, $target, $base) = @_;
 548   my %reg = %{ $self->source_registrations };
 549   my %target;
 550   my %map;
 551   my $schema = $self->clone;
 552   {
 553     no warnings qw/redefine/;
 554     local *Class::C3::reinitialize = sub { };
 555     foreach my $moniker ($schema->sources) {
 556       my $source = $schema->source($moniker);
 557       my $target_class = "${target}::${moniker}";
 558       $self->inject_base(
 559         $target_class => $source->result_class, ($base ? $base : ())
 560       );
 561       $source->result_class($target_class);
 562       $target_class->result_source_instance($source)
 563         if $target_class->can('result_source_instance');
 564     }
 565   }
 566   Class::C3->reinitialize();
 567   {
 568     no strict 'refs';
 569     foreach my $meth (qw/class source resultset/) {
 570       *{"${target}::${meth}"} =
 571         sub { shift->schema->$meth(@_) };
 572     }
 573   }
 574   return $schema;
 575 }
 576
 577 =head2 setup_connection_class
 578
 579 =over 4
 580
 581 =item Arguments: $target, @info
 582
 583 =back
 584
 585 Sets up a database connection class to inject between the schema and the
 586 subclasses that the schema creates.
 587
 588 =cut
 589
 590 sub setup_connection_class {
 591   my ($class, $target, @info) = @_;
 592   $class->inject_base($target => 'DBIx::Class::DB');
 593   #$target->load_components('DB');
 594   $target->connection(@info);
 595 }
 596
 597 =head2 storage_type
 598
 599 =over 4
 600
 601 =item Arguments: $storage_type
 602
 603 =item Return Value: $storage_type
 604
 605 =back
 606
 607 Set the storage class that will be instantiated when L</connect> is called.
 608 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 609 assumed by L</connect>.  Defaults to C<::DBI>,
 610 which is L<DBIx::Class::Storage::DBI>.
 611
 612 You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
 613 in cases where the appropriate subclass is not autodetected, such as when
 614 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
 615 C<::DBI::Sybase::MSSQL>.
 616
 617 =head2 connection
 618
 619 =over 4
 620
 621 =item Arguments: @args
 622
 623 =item Return Value: $new_schema
 624
 625 =back
 626
 627 Instantiates a new Storage object of type
 628 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 629 $storage->connect_info. Sets the connection in-place on the schema.
 630
 631 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
 632 or L<DBIx::Class::Storage> in general.
 633
 634 =cut
 635
 636 sub connection {
 637   my ($self, @info) = @_;
 638   return $self if !@info && $self->storage;
 639   my $storage_class = $self->storage_type;
 640   $storage_class = 'DBIx::Class::Storage'.$storage_class
 641     if $storage_class =~ m/^::/;
 642   eval "require ${storage_class};";
 643   $self->throw_exception(
 644     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 645   ) if $@;
 646   my $storage = $storage_class->new($self);
 647   $storage->connect_info(\@info);
 648   $self->storage($storage);
 649   return $self;
 650 }
 651
 652 =head2 connect
 653
 654 =over 4
 655
 656 =item Arguments: @info
 657
 658 =item Return Value: $new_schema
 659
 660 =back
 661
 662 This is a convenience method. It is equivalent to calling
 663 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 664 information.
 665
 666 =cut
 667
 668 sub connect { shift->clone->connection(@_) }
 669
 670 =head2 txn_do
 671
 672 =over 4
 673
 674 =item Arguments: C<$coderef>, @coderef_args?
 675
 676 =item Return Value: The return value of $coderef
 677
 678 =back
 679
 680 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 681 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 682 See L<DBIx::Class::Storage/"txn_do"> for more information.
 683
 684 This interface is preferred over using the individual methods L</txn_begin>,
 685 L</txn_commit>, and L</txn_rollback> below.
 686
 687 =cut
 688
 689 sub txn_do {
 690   my $self = shift;
 691
 692   $self->storage or $self->throw_exception
 693     ('txn_do called on $schema without storage');
 694
 695   $self->storage->txn_do(@_);
 696 }
 697
 698 =head2 txn_begin
 699
 700 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 701 calling $schema->storage->txn_begin. See
 702 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 703
 704 =cut
 705
 706 sub txn_begin {
 707   my $self = shift;
 708
 709   $self->storage or $self->throw_exception
 710     ('txn_begin called on $schema without storage');
 711
 712   $self->storage->txn_begin;
 713 }
 714
 715 =head2 txn_commit
 716
 717 Commits the current transaction. Equivalent to calling
 718 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 719 for more information.
 720
 721 =cut
 722
 723 sub txn_commit {
 724   my $self = shift;
 725
 726   $self->storage or $self->throw_exception
 727     ('txn_commit called on $schema without storage');
 728
 729   $self->storage->txn_commit;
 730 }
 731
 732 =head2 txn_rollback
 733
 734 Rolls back the current transaction. Equivalent to calling
 735 $schema->storage->txn_rollback. See
 736 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 737
 738 =cut
 739
 740 sub txn_rollback {
 741   my $self = shift;
 742
 743   $self->storage or $self->throw_exception
 744     ('txn_rollback called on $schema without storage');
 745
 746   $self->storage->txn_rollback;
 747 }
 748
 749 =head2 clone
 750
 751 =over 4
 752
 753 =item Return Value: $new_schema
 754
 755 =back
 756
 757 Clones the schema and its associated result_source objects and returns the
 758 copy.
 759
 760 =cut
 761
 762 sub clone {
 763   my ($self) = @_;
 764   my $clone = { (ref $self ? %$self : ()) };
 765   bless $clone, (ref $self || $self);
 766
 767   foreach my $moniker ($self->sources) {
 768     my $source = $self->source($moniker);
 769     my $new = $source->new($source);
 770     $clone->register_source($moniker => $new);
 771   }
 772   $clone->storage->set_schema($clone) if $clone->storage;
 773   return $clone;
 774 }
 775
 776 =head2 populate
 777
 778 =over 4
 779
 780 =item Arguments: $source_name, \@data;
 781
 782 =back
 783
 784 Pass this method a resultsource name, and an arrayref of
 785 arrayrefs. The arrayrefs should contain a list of column names,
 786 followed by one or many sets of matching data for the given columns.
 787
 788 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 789 to insert the data, as this is a fast method. However, insert_bulk currently
 790 assumes that your datasets all contain the same type of values, using scalar
 791 references in a column in one row, and not in another will probably not work.
 792
 793 Otherwise, each set of data is inserted into the database using
 794 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 795 objects is returned.
 796
 797 i.e.,
 798
 799   $schema->populate('Artist', [
 800     [ qw/artistid name/ ],
 801     [ 1, 'Popular Band' ],
 802     [ 2, 'Indie Band' ],
 803     ...
 804   ]);
 805
 806 =cut
 807
 808 sub populate {
 809   my ($self, $name, $data) = @_;
 810   my $rs = $self->resultset($name);
 811   my @names = @{shift(@$data)};
 812   if(defined wantarray) {
 813     my @created;
 814     foreach my $item (@$data) {
 815       my %create;
 816       @create{@names} = @$item;
 817       push(@created, $rs->create(\%create));
 818     }
 819     return @created;
 820   }
 821   $self->storage->insert_bulk($self->source($name)->from, \@names, $data);
 822 }
 823
 824 =head2 exception_action
 825
 826 =over 4
 827
 828 =item Arguments: $code_reference
 829
 830 =back
 831
 832 If C<exception_action> is set for this class/object, L</throw_exception>
 833 will prefer to call this code reference with the exception as an argument,
 834 rather than its normal <croak> action.
 835
 836 Your subroutine should probably just wrap the error in the exception
 837 object/class of your choosing and rethrow.  If, against all sage advice,
 838 you'd like your C<exception_action> to suppress a particular exception
 839 completely, simply have it return true.
 840
 841 Example:
 842
 843    package My::Schema;
 844    use base qw/DBIx::Class::Schema/;
 845    use My::ExceptionClass;
 846    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 847    __PACKAGE__->load_classes;
 848
 849    # or:
 850    my $schema_obj = My::Schema->connect( .... );
 851    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 852
 853    # suppress all exceptions, like a moron:
 854    $schema_obj->exception_action(sub { 1 });
 855
 856 =head2 throw_exception
 857
 858 =over 4
 859
 860 =item Arguments: $message
 861
 862 =back
 863
 864 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 865 user's perspective.  See L</exception_action> for details on overriding
 866 this method's behavior.
 867
 868 =cut
 869
 870 sub throw_exception {
 871   my $self = shift;
 872   croak @_ if !$self->exception_action || !$self->exception_action->(@_);
 873 }
 874
 875 =head2 deploy (EXPERIMENTAL)
 876
 877 =over 4
 878
 879 =item Arguments: $sqlt_args, $dir
 880
 881 =back
 882
 883 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 884
 885 Note that this feature is currently EXPERIMENTAL and may not work correctly
 886 across all databases, or fully handle complex relationships.
 887
 888 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 889 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 890 produced include a DROP TABLE statement for each table created.
 891
 892 =cut
 893
 894 sub deploy {
 895   my ($self, $sqltargs, $dir) = @_;
 896   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 897   $self->storage->deploy($self, undef, $sqltargs, $dir);
 898 }
 899
 900 =head2 create_ddl_dir (EXPERIMENTAL)
 901
 902 =over 4
 903
 904 =item Arguments: \@databases, $version, $directory, $sqlt_args
 905
 906 =back
 907
 908 Creates an SQL file based on the Schema, for each of the specified
 909 database types, in the given directory.
 910
 911 Note that this feature is currently EXPERIMENTAL and may not work correctly
 912 across all databases, or fully handle complex relationships.
 913
 914 =cut
 915
 916 sub create_ddl_dir {
 917   my $self = shift;
 918
 919   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 920   $self->storage->create_ddl_dir($self, @_);
 921 }
 922
 923 =head2 ddl_filename (EXPERIMENTAL)
 924
 925   my $filename = $table->ddl_filename($type, $dir, $version)
 926
 927 Creates a filename for a SQL file based on the table class name.  Not
 928 intended for direct end user use.
 929
 930 =cut
 931
 932 sub ddl_filename {
 933     my ($self, $type, $dir, $version) = @_;
 934
 935     my $filename = ref($self);
 936     $filename =~ s/::/-/;
 937     $filename = "$dir$filename-$version-$type.sql";
 938
 939     return $filename;
 940 }
 941
 942 1;
 943
 944 =head1 AUTHORS
 945
 946 Matt S. Trout <mst@shadowcatsystems.co.uk>
 947
 948 =head1 LICENSE
 949
 950 You may distribute this code under the same terms as Perl itself.
 951
 952 =cut