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