lib/DBIx/Class/Schema.pm

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