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