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