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