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