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