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 (DEPRECATED)
 451
 452 =over 4
 453
 454 =item Arguments: $target_namespace, @db_info
 455
 456 =item Return Value: $new_schema
 457
 458 =back
 459
 460 DEPRECATED. You probably wanted compose_namespace.
 461
 462 Actually, you probably just wanted to call connect.
 463
 464 =for hidden due to deprecation
 465
 466 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 467 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 468 then injects the L<DBix::Class::ResultSetProxy> component and a
 469 resultset_instance classdata entry on all the new classes, in order to support
 470 $target_namespaces::$class->search(...) method calls.
 471
 472 This is primarily useful when you have a specific need for class method access
 473 to a connection. In normal usage it is preferred to call
 474 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 475 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 476 more information.
 477
 478 =cut
 479
 480 {
 481   my $warn;
 482
 483   sub compose_connection {
 484     my ($self, $target, @info) = @_;
 485
 486     warn "compose_connection deprecated as of 0.08000" unless $warn++;
 487
 488     my $base = 'DBIx::Class::ResultSetProxy';
 489     eval "require ${base};";
 490     $self->throw_exception
 491       ("No arguments to load_classes and couldn't load ${base} ($@)")
 492         if $@;
 493
 494     if ($self eq $target) {
 495       # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 496       foreach my $moniker ($self->sources) {
 497         my $source = $self->source($moniker);
 498         my $class = $source->result_class;
 499         $self->inject_base($class, $base);
 500         $class->mk_classdata(resultset_instance => $source->resultset);
 501         $class->mk_classdata(class_resolver => $self);
 502       }
 503       $self->connection(@info);
 504       return $self;
 505     }
 506
 507     my $schema = $self->compose_namespace($target, $base);
 508     {
 509       no strict 'refs';
 510       *{"${target}::schema"} = sub { $schema };
 511     }
 512
 513     $schema->connection(@info);
 514     foreach my $moniker ($schema->sources) {
 515       my $source = $schema->source($moniker);
 516       my $class = $source->result_class;
 517       #warn "$moniker $class $source ".$source->storage;
 518       $class->mk_classdata(result_source_instance => $source);
 519       $class->mk_classdata(resultset_instance => $source->resultset);
 520       $class->mk_classdata(class_resolver => $schema);
 521     }
 522     return $schema;
 523   }
 524 }
 525
 526 =head2 compose_namespace
 527
 528 =over 4
 529
 530 =item Arguments: $target_namespace, $additional_base_class?
 531
 532 =item Return Value: $new_schema
 533
 534 =back
 535
 536 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 537 class in the target namespace (e.g. $target_namespace::CD,
 538 $target_namespace::Artist) that inherits from the corresponding classes
 539 attached to the current schema.
 540
 541 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 542 new $schema object. If C<$additional_base_class> is given, the new composed
 543 classes will inherit from first the corresponding classe from the current
 544 schema then the base class.
 545
 546 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 547
 548   $schema->compose_namespace('My::DB', 'Base::Class');
 549   print join (', ', @My::DB::CD::ISA) . "\n";
 550   print join (', ', @My::DB::Artist::ISA) ."\n";
 551
 552 will produce the output
 553
 554   My::Schema::CD, Base::Class
 555   My::Schema::Artist, Base::Class
 556
 557 =cut
 558
 559 sub compose_namespace {
 560   my ($self, $target, $base) = @_;
 561   my %reg = %{ $self->source_registrations };
 562   my %target;
 563   my %map;
 564   my $schema = $self->clone;
 565   {
 566     no warnings qw/redefine/;
 567     local *Class::C3::reinitialize = sub { };
 568     foreach my $moniker ($schema->sources) {
 569       my $source = $schema->source($moniker);
 570       my $target_class = "${target}::${moniker}";
 571       $self->inject_base(
 572         $target_class => $source->result_class, ($base ? $base : ())
 573       );
 574       $source->result_class($target_class);
 575       $target_class->result_source_instance($source)
 576         if $target_class->can('result_source_instance');
 577     }
 578   }
 579   Class::C3->reinitialize();
 580   {
 581     no strict 'refs';
 582     foreach my $meth (qw/class source resultset/) {
 583       *{"${target}::${meth}"} =
 584         sub { shift->schema->$meth(@_) };
 585     }
 586   }
 587   return $schema;
 588 }
 589
 590 =head2 setup_connection_class
 591
 592 =over 4
 593
 594 =item Arguments: $target, @info
 595
 596 =back
 597
 598 Sets up a database connection class to inject between the schema and the
 599 subclasses that the schema creates.
 600
 601 =cut
 602
 603 sub setup_connection_class {
 604   my ($class, $target, @info) = @_;
 605   $class->inject_base($target => 'DBIx::Class::DB');
 606   #$target->load_components('DB');
 607   $target->connection(@info);
 608 }
 609
 610 =head2 storage_type
 611
 612 =over 4
 613
 614 =item Arguments: $storage_type
 615
 616 =item Return Value: $storage_type
 617
 618 =back
 619
 620 Set the storage class that will be instantiated when L</connect> is called.
 621 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 622 assumed by L</connect>.  Defaults to C<::DBI>,
 623 which is L<DBIx::Class::Storage::DBI>.
 624
 625 You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
 626 in cases where the appropriate subclass is not autodetected, such as when
 627 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
 628 C<::DBI::Sybase::MSSQL>.
 629
 630 =head2 connection
 631
 632 =over 4
 633
 634 =item Arguments: @args
 635
 636 =item Return Value: $new_schema
 637
 638 =back
 639
 640 Instantiates a new Storage object of type
 641 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 642 $storage->connect_info. Sets the connection in-place on the schema.
 643
 644 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
 645 or L<DBIx::Class::Storage> in general.
 646
 647 =cut
 648
 649 sub connection {
 650   my ($self, @info) = @_;
 651   return $self if !@info && $self->storage;
 652   my $storage_class = $self->storage_type;
 653   $storage_class = 'DBIx::Class::Storage'.$storage_class
 654     if $storage_class =~ m/^::/;
 655   eval "require ${storage_class};";
 656   $self->throw_exception(
 657     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 658   ) if $@;
 659   my $storage = $storage_class->new($self);
 660   $storage->connect_info(\@info);
 661   $self->storage($storage);
 662   return $self;
 663 }
 664
 665 =head2 connect
 666
 667 =over 4
 668
 669 =item Arguments: @info
 670
 671 =item Return Value: $new_schema
 672
 673 =back
 674
 675 This is a convenience method. It is equivalent to calling
 676 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 677 information.
 678
 679 =cut
 680
 681 sub connect { shift->clone->connection(@_) }
 682
 683 =head2 txn_do
 684
 685 =over 4
 686
 687 =item Arguments: C<$coderef>, @coderef_args?
 688
 689 =item Return Value: The return value of $coderef
 690
 691 =back
 692
 693 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 694 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 695 See L<DBIx::Class::Storage/"txn_do"> for more information.
 696
 697 This interface is preferred over using the individual methods L</txn_begin>,
 698 L</txn_commit>, and L</txn_rollback> below.
 699
 700 =cut
 701
 702 sub txn_do {
 703   my $self = shift;
 704
 705   $self->storage or $self->throw_exception
 706     ('txn_do called on $schema without storage');
 707
 708   $self->storage->txn_do(@_);
 709 }
 710
 711 =head2 txn_begin
 712
 713 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 714 calling $schema->storage->txn_begin. See
 715 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 716
 717 =cut
 718
 719 sub txn_begin {
 720   my $self = shift;
 721
 722   $self->storage or $self->throw_exception
 723     ('txn_begin called on $schema without storage');
 724
 725   $self->storage->txn_begin;
 726 }
 727
 728 =head2 txn_commit
 729
 730 Commits the current transaction. Equivalent to calling
 731 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 732 for more information.
 733
 734 =cut
 735
 736 sub txn_commit {
 737   my $self = shift;
 738
 739   $self->storage or $self->throw_exception
 740     ('txn_commit called on $schema without storage');
 741
 742   $self->storage->txn_commit;
 743 }
 744
 745 =head2 txn_rollback
 746
 747 Rolls back the current transaction. Equivalent to calling
 748 $schema->storage->txn_rollback. See
 749 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 750
 751 =cut
 752
 753 sub txn_rollback {
 754   my $self = shift;
 755
 756   $self->storage or $self->throw_exception
 757     ('txn_rollback called on $schema without storage');
 758
 759   $self->storage->txn_rollback;
 760 }
 761
 762 =head2 clone
 763
 764 =over 4
 765
 766 =item Return Value: $new_schema
 767
 768 =back
 769
 770 Clones the schema and its associated result_source objects and returns the
 771 copy.
 772
 773 =cut
 774
 775 sub clone {
 776   my ($self) = @_;
 777   my $clone = { (ref $self ? %$self : ()) };
 778   bless $clone, (ref $self || $self);
 779
 780   foreach my $moniker ($self->sources) {
 781     my $source = $self->source($moniker);
 782     my $new = $source->new($source);
 783     $clone->register_source($moniker => $new);
 784   }
 785   $clone->storage->set_schema($clone) if $clone->storage;
 786   return $clone;
 787 }
 788
 789 =head2 populate
 790
 791 =over 4
 792
 793 =item Arguments: $source_name, \@data;
 794
 795 =back
 796
 797 Pass this method a resultsource name, and an arrayref of
 798 arrayrefs. The arrayrefs should contain a list of column names,
 799 followed by one or many sets of matching data for the given columns.
 800
 801 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 802 to insert the data, as this is a fast method. However, insert_bulk currently
 803 assumes that your datasets all contain the same type of values, using scalar
 804 references in a column in one row, and not in another will probably not work.
 805
 806 Otherwise, each set of data is inserted into the database using
 807 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 808 objects is returned.
 809
 810 i.e.,
 811
 812   $schema->populate('Artist', [
 813     [ qw/artistid name/ ],
 814     [ 1, 'Popular Band' ],
 815     [ 2, 'Indie Band' ],
 816     ...
 817   ]);
 818
 819 =cut
 820
 821 sub populate {
 822   my ($self, $name, $data) = @_;
 823   my $rs = $self->resultset($name);
 824   my @names = @{shift(@$data)};
 825   if(defined wantarray) {
 826     my @created;
 827     foreach my $item (@$data) {
 828       my %create;
 829       @create{@names} = @$item;
 830       push(@created, $rs->create(\%create));
 831     }
 832     return @created;
 833   }
 834   $self->storage->insert_bulk($self->source($name)->from, \@names, $data);
 835 }
 836
 837 =head2 exception_action
 838
 839 =over 4
 840
 841 =item Arguments: $code_reference
 842
 843 =back
 844
 845 If C<exception_action> is set for this class/object, L</throw_exception>
 846 will prefer to call this code reference with the exception as an argument,
 847 rather than its normal <croak> action.
 848
 849 Your subroutine should probably just wrap the error in the exception
 850 object/class of your choosing and rethrow.  If, against all sage advice,
 851 you'd like your C<exception_action> to suppress a particular exception
 852 completely, simply have it return true.
 853
 854 Example:
 855
 856    package My::Schema;
 857    use base qw/DBIx::Class::Schema/;
 858    use My::ExceptionClass;
 859    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 860    __PACKAGE__->load_classes;
 861
 862    # or:
 863    my $schema_obj = My::Schema->connect( .... );
 864    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 865
 866    # suppress all exceptions, like a moron:
 867    $schema_obj->exception_action(sub { 1 });
 868
 869 =head2 throw_exception
 870
 871 =over 4
 872
 873 =item Arguments: $message
 874
 875 =back
 876
 877 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 878 user's perspective.  See L</exception_action> for details on overriding
 879 this method's behavior.
 880
 881 =cut
 882
 883 sub throw_exception {
 884   my $self = shift;
 885   croak @_ if !$self->exception_action || !$self->exception_action->(@_);
 886 }
 887
 888 =head2 deploy (EXPERIMENTAL)
 889
 890 =over 4
 891
 892 =item Arguments: $sqlt_args, $dir
 893
 894 =back
 895
 896 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 897
 898 Note that this feature is currently EXPERIMENTAL and may not work correctly
 899 across all databases, or fully handle complex relationships.
 900
 901 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 902 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 903 produced include a DROP TABLE statement for each table created.
 904
 905 =cut
 906
 907 sub deploy {
 908   my ($self, $sqltargs, $dir) = @_;
 909   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 910   $self->storage->deploy($self, undef, $sqltargs, $dir);
 911 }
 912
 913 =head2 create_ddl_dir (EXPERIMENTAL)
 914
 915 =over 4
 916
 917 =item Arguments: \@databases, $version, $directory, $sqlt_args
 918
 919 =back
 920
 921 Creates an SQL file based on the Schema, for each of the specified
 922 database types, in the given directory.
 923
 924 Note that this feature is currently EXPERIMENTAL and may not work correctly
 925 across all databases, or fully handle complex relationships.
 926
 927 =cut
 928
 929 sub create_ddl_dir {
 930   my $self = shift;
 931
 932   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 933   $self->storage->create_ddl_dir($self, @_);
 934 }
 935
 936 =head2 ddl_filename (EXPERIMENTAL)
 937
 938   my $filename = $table->ddl_filename($type, $dir, $version)
 939
 940 Creates a filename for a SQL file based on the table class name.  Not
 941 intended for direct end user use.
 942
 943 =cut
 944
 945 sub ddl_filename {
 946     my ($self, $type, $dir, $version) = @_;
 947
 948     my $filename = ref($self);
 949     $filename =~ s/::/-/;
 950     $filename = "$dir$filename-$version-$type.sql";
 951
 952     return $filename;
 953 }
 954
 955 1;
 956
 957 =head1 AUTHORS
 958
 959 Matt S. Trout <mst@shadowcatsystems.co.uk>
 960
 961 =head1 LICENSE
 962
 963 You may distribute this code under the same terms as Perl itself.
 964
 965 =cut