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