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