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     foreach my $meth (qw/class source resultset/) {
 604       *{"${target}::${meth}"} =
 605         sub { shift->schema->$meth(@_) };
 606     }
 607   }
 608   return $schema;
 609 }
 610
 611 =head2 setup_connection_class
 612
 613 =over 4
 614
 615 =item Arguments: $target, @info
 616
 617 =back
 618
 619 Sets up a database connection class to inject between the schema and the
 620 subclasses that the schema creates.
 621
 622 =cut
 623
 624 sub setup_connection_class {
 625   my ($class, $target, @info) = @_;
 626   $class->inject_base($target => 'DBIx::Class::DB');
 627   #$target->load_components('DB');
 628   $target->connection(@info);
 629 }
 630
 631 =head2 storage_type
 632
 633 =over 4
 634
 635 =item Arguments: $storage_type
 636
 637 =item Return Value: $storage_type
 638
 639 =back
 640
 641 Set the storage class that will be instantiated when L</connect> is called.
 642 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
 643 assumed by L</connect>.  Defaults to C<::DBI>,
 644 which is L<DBIx::Class::Storage::DBI>.
 645
 646 You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
 647 in cases where the appropriate subclass is not autodetected, such as when
 648 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
 649 C<::DBI::Sybase::MSSQL>.
 650
 651 =head2 connection
 652
 653 =over 4
 654
 655 =item Arguments: @args
 656
 657 =item Return Value: $new_schema
 658
 659 =back
 660
 661 Instantiates a new Storage object of type
 662 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 663 $storage->connect_info. Sets the connection in-place on the schema.
 664
 665 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
 666 or L<DBIx::Class::Storage> in general.
 667
 668 =cut
 669
 670 sub connection {
 671   my ($self, @info) = @_;
 672   return $self if !@info && $self->storage;
 673   my $storage_class = $self->storage_type;
 674   $storage_class = 'DBIx::Class::Storage'.$storage_class
 675     if $storage_class =~ m/^::/;
 676   eval "require ${storage_class};";
 677   $self->throw_exception(
 678     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 679   ) if $@;
 680   my $storage = $storage_class->new($self);
 681   $storage->connect_info(\@info);
 682   $self->storage($storage);
 683   return $self;
 684 }
 685
 686 =head2 connect
 687
 688 =over 4
 689
 690 =item Arguments: @info
 691
 692 =item Return Value: $new_schema
 693
 694 =back
 695
 696 This is a convenience method. It is equivalent to calling
 697 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 698 information.
 699
 700 =cut
 701
 702 sub connect { shift->clone->connection(@_) }
 703
 704 =head2 txn_do
 705
 706 =over 4
 707
 708 =item Arguments: C<$coderef>, @coderef_args?
 709
 710 =item Return Value: The return value of $coderef
 711
 712 =back
 713
 714 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 715 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 716 See L<DBIx::Class::Storage/"txn_do"> for more information.
 717
 718 This interface is preferred over using the individual methods L</txn_begin>,
 719 L</txn_commit>, and L</txn_rollback> below.
 720
 721 =cut
 722
 723 sub txn_do {
 724   my $self = shift;
 725
 726   $self->storage or $self->throw_exception
 727     ('txn_do called on $schema without storage');
 728
 729   $self->storage->txn_do(@_);
 730 }
 731
 732 =head2 txn_begin
 733
 734 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 735 calling $schema->storage->txn_begin. See
 736 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 737
 738 =cut
 739
 740 sub txn_begin {
 741   my $self = shift;
 742
 743   $self->storage or $self->throw_exception
 744     ('txn_begin called on $schema without storage');
 745
 746   $self->storage->txn_begin;
 747 }
 748
 749 =head2 txn_commit
 750
 751 Commits the current transaction. Equivalent to calling
 752 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 753 for more information.
 754
 755 =cut
 756
 757 sub txn_commit {
 758   my $self = shift;
 759
 760   $self->storage or $self->throw_exception
 761     ('txn_commit called on $schema without storage');
 762
 763   $self->storage->txn_commit;
 764 }
 765
 766 =head2 txn_rollback
 767
 768 Rolls back the current transaction. Equivalent to calling
 769 $schema->storage->txn_rollback. See
 770 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 771
 772 =cut
 773
 774 sub txn_rollback {
 775   my $self = shift;
 776
 777   $self->storage or $self->throw_exception
 778     ('txn_rollback called on $schema without storage');
 779
 780   $self->storage->txn_rollback;
 781 }
 782
 783 =head2 clone
 784
 785 =over 4
 786
 787 =item Return Value: $new_schema
 788
 789 =back
 790
 791 Clones the schema and its associated result_source objects and returns the
 792 copy.
 793
 794 =cut
 795
 796 sub clone {
 797   my ($self) = @_;
 798   my $clone = { (ref $self ? %$self : ()) };
 799   bless $clone, (ref $self || $self);
 800
 801   foreach my $moniker ($self->sources) {
 802     my $source = $self->source($moniker);
 803     my $new = $source->new($source);
 804     $clone->register_source($moniker => $new);
 805   }
 806   $clone->storage->set_schema($clone) if $clone->storage;
 807   return $clone;
 808 }
 809
 810 =head2 populate
 811
 812 =over 4
 813
 814 =item Arguments: $source_name, \@data;
 815
 816 =back
 817
 818 Pass this method a resultsource name, and an arrayref of
 819 arrayrefs. The arrayrefs should contain a list of column names,
 820 followed by one or many sets of matching data for the given columns.
 821
 822 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 823 to insert the data, as this is a fast method. However, insert_bulk currently
 824 assumes that your datasets all contain the same type of values, using scalar
 825 references in a column in one row, and not in another will probably not work.
 826
 827 Otherwise, each set of data is inserted into the database using
 828 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 829 objects is returned.
 830
 831 i.e.,
 832
 833   $schema->populate('Artist', [
 834     [ qw/artistid name/ ],
 835     [ 1, 'Popular Band' ],
 836     [ 2, 'Indie Band' ],
 837     ...
 838   ]);
 839
 840 Since wantarray context is basically the same as looping over $rs->create(...)
 841 you won't see any performance benefits and in this case the method is more for
 842 convenience. Void context sends the column information directly to storage
 843 using <DBI>s bulk insert method. So the performance will be much better for
 844 storages that support this method.
 845
 846 Because of this difference in the way void context inserts rows into your
 847 database you need to note how this will effect any loaded components that
 848 override or augment insert.  For example if you are using a component such
 849 as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
 850 wantarray context if you want the PKs automatically created.
 851
 852 =cut
 853
 854 sub populate {
 855   my ($self, $name, $data) = @_;
 856   my $rs = $self->resultset($name);
 857   my @names = @{shift(@$data)};
 858   if(defined wantarray) {
 859     my @created;
 860     foreach my $item (@$data) {
 861       my %create;
 862       @create{@names} = @$item;
 863       push(@created, $rs->create(\%create));
 864     }
 865     return @created;
 866   }
 867   my @results_to_create;
 868   foreach my $datum (@$data) {
 869     my %result_to_create;
 870     foreach my $index (0..$#names) {
 871       $result_to_create{$names[$index]} = $$datum[$index];
 872     }
 873     push @results_to_create, \%result_to_create;
 874   }
 875   $rs->populate(\@results_to_create);
 876 }
 877
 878 =head2 exception_action
 879
 880 =over 4
 881
 882 =item Arguments: $code_reference
 883
 884 =back
 885
 886 If C<exception_action> is set for this class/object, L</throw_exception>
 887 will prefer to call this code reference with the exception as an argument,
 888 rather than its normal C<croak> or C<confess> action.
 889
 890 Your subroutine should probably just wrap the error in the exception
 891 object/class of your choosing and rethrow.  If, against all sage advice,
 892 you'd like your C<exception_action> to suppress a particular exception
 893 completely, simply have it return true.
 894
 895 Example:
 896
 897    package My::Schema;
 898    use base qw/DBIx::Class::Schema/;
 899    use My::ExceptionClass;
 900    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
 901    __PACKAGE__->load_classes;
 902
 903    # or:
 904    my $schema_obj = My::Schema->connect( .... );
 905    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
 906
 907    # suppress all exceptions, like a moron:
 908    $schema_obj->exception_action(sub { 1 });
 909
 910 =head2 stacktrace
 911
 912 =over 4
 913
 914 =item Arguments: boolean
 915
 916 =back
 917
 918 Whether L</throw_exception> should include stack trace information.
 919 Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
 920 is true.
 921
 922 =head2 throw_exception
 923
 924 =over 4
 925
 926 =item Arguments: $message
 927
 928 =back
 929
 930 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 931 user's perspective.  See L</exception_action> for details on overriding
 932 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
 933 default behavior will provide a detailed stack trace.
 934
 935 =cut
 936
 937 sub throw_exception {
 938   my $self = shift;
 939
 940   DBIx::Class::Exception->throw($_[0], $self->stacktrace)
 941     if !$self->exception_action || !$self->exception_action->(@_);
 942 }
 943
 944 =head2 deploy
 945
 946 =over 4
 947
 948 =item Arguments: $sqlt_args, $dir
 949
 950 =back
 951
 952 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 953
 954 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 955 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 956 produced include a DROP TABLE statement for each table created.
 957
 958 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
 959 ref or an array ref, containing a list of source to deploy. If present, then
 960 only the sources listed will get deployed.
 961
 962 =cut
 963
 964 sub deploy {
 965   my ($self, $sqltargs, $dir) = @_;
 966   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 967   $self->storage->deploy($self, undef, $sqltargs, $dir);
 968 }
 969
 970 =head2 create_ddl_dir (EXPERIMENTAL)
 971
 972 =over 4
 973
 974 =item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
 975
 976 =back
 977
 978 Creates an SQL file based on the Schema, for each of the specified
 979 database types, in the given directory. Given a previous version number,
 980 this will also create a file containing the ALTER TABLE statements to
 981 transform the previous schema into the current one. Note that these
 982 statements may contain DROP TABLE or DROP COLUMN statements that can
 983 potentially destroy data.
 984
 985 The file names are created using the C<ddl_filename> method below, please
 986 override this method in your schema if you would like a different file
 987 name format. For the ALTER file, the same format is used, replacing
 988 $version in the name with "$preversion-$version".
 989
 990 If no arguments are passed, then the following default values are used:
 991
 992 =over 4
 993
 994 =item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
 995
 996 =item version    - $schema->VERSION
 997
 998 =item directory  - './'
 999
1000 =item preversion - <none>
1001
1002 =back
1003
1004 Note that this feature is currently EXPERIMENTAL and may not work correctly
1005 across all databases, or fully handle complex relationships.
1006
1007 WARNING: Please check all SQL files created, before applying them.
1008
1009 =cut
1010
1011 sub create_ddl_dir {
1012   my $self = shift;
1013
1014   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1015   $self->storage->create_ddl_dir($self, @_);
1016 }
1017
1018 =head2 ddl_filename (EXPERIMENTAL)
1019
1020 =over 4
1021
1022 =item Arguments: $directory, $database-type, $version, $preversion
1023
1024 =back
1025
1026   my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
1027
1028 This method is called by C<create_ddl_dir> to compose a file name out of
1029 the supplied directory, database type and version number. The default file
1030 name format is: C<$dir$schema-$version-$type.sql>.
1031
1032 You may override this method in your schema if you wish to use a different
1033 format.
1034
1035 =cut
1036
1037 sub ddl_filename {
1038     my ($self, $type, $dir, $version, $pversion) = @_;
1039
1040     my $filename = ref($self);
1041     $filename =~ s/::/-/g;
1042     $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1043     $filename =~ s/$version/$pversion-$version/ if($pversion);
1044
1045     return $filename;
1046 }
1047
1048 1;
1049
1050 =head1 AUTHORS
1051
1052 Matt S. Trout <mst@shadowcatsystems.co.uk>
1053
1054 =head1 LICENSE
1055
1056 You may distribute this code under the same terms as Perl itself.
1057
1058 =cut