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