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 Note that C<connect_info> expects an arrayref of arguments, but
 463 C<connect> does not. C<connect> wraps it's arguments in an arrayref
 464 before passing them to C<connect_info>.
 465
 466 =cut
 467
 468 sub connect { shift->clone->connection(@_) }
 469
 470 =head2 resultset
 471
 472 =over 4
 473
 474 =item Arguments: $source_name
 475
 476 =item Return Value: $resultset
 477
 478 =back
 479
 480   my $rs = $schema->resultset('DVD');
 481
 482 Returns the L<DBIx::Class::ResultSet> object for the registered source
 483 name.
 484
 485 =cut
 486
 487 sub resultset {
 488   my ($self, $moniker) = @_;
 489   return $self->source($moniker)->resultset;
 490 }
 491
 492 =head2 sources
 493
 494 =over 4
 495
 496 =item Return Value: @source_names
 497
 498 =back
 499
 500   my @source_names = $schema->sources;
 501
 502 Lists names of all the sources registered on this Schema object.
 503
 504 =cut
 505
 506 sub sources { return keys %{shift->source_registrations}; }
 507
 508 =head2 source
 509
 510 =over 4
 511
 512 =item Arguments: $source_name
 513
 514 =item Return Value: $result_source
 515
 516 =back
 517
 518   my $source = $schema->source('Book');
 519
 520 Returns the L<DBIx::Class::ResultSource> object for the registered
 521 source name.
 522
 523 =cut
 524
 525 sub source {
 526   my ($self, $moniker) = @_;
 527   my $sreg = $self->source_registrations;
 528   return $sreg->{$moniker} if exists $sreg->{$moniker};
 529
 530   # if we got here, they probably passed a full class name
 531   my $mapped = $self->class_mappings->{$moniker};
 532   $self->throw_exception("Can't find source for ${moniker}")
 533     unless $mapped && exists $sreg->{$mapped};
 534   return $sreg->{$mapped};
 535 }
 536
 537 =head2 class
 538
 539 =over 4
 540
 541 =item Arguments: $source_name
 542
 543 =item Return Value: $classname
 544
 545 =back
 546
 547   my $class = $schema->class('CD');
 548
 549 Retrieves the Result class name for the given source name.
 550
 551 =cut
 552
 553 sub class {
 554   my ($self, $moniker) = @_;
 555   return $self->source($moniker)->result_class;
 556 }
 557
 558 =head2 txn_do
 559
 560 =over 4
 561
 562 =item Arguments: C<$coderef>, @coderef_args?
 563
 564 =item Return Value: The return value of $coderef
 565
 566 =back
 567
 568 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 569 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
 570 See L<DBIx::Class::Storage/"txn_do"> for more information.
 571
 572 This interface is preferred over using the individual methods L</txn_begin>,
 573 L</txn_commit>, and L</txn_rollback> below.
 574
 575 =cut
 576
 577 sub txn_do {
 578   my $self = shift;
 579
 580   $self->storage or $self->throw_exception
 581     ('txn_do called on $schema without storage');
 582
 583   $self->storage->txn_do(@_);
 584 }
 585
 586 =head2 txn_scope_guard (EXPERIMENTAL)
 587
 588 Runs C<txn_scope_guard> on the schema's storage. See
 589 L<DBIx::Class::Storage/txn_scope_guard>.
 590
 591 =cut
 592
 593 sub txn_scope_guard {
 594   my $self = shift;
 595
 596   $self->storage or $self->throw_exception
 597     ('txn_scope_guard called on $schema without storage');
 598
 599   $self->storage->txn_scope_guard(@_);
 600 }
 601
 602 =head2 txn_begin
 603
 604 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 605 calling $schema->storage->txn_begin. See
 606 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 607
 608 =cut
 609
 610 sub txn_begin {
 611   my $self = shift;
 612
 613   $self->storage or $self->throw_exception
 614     ('txn_begin called on $schema without storage');
 615
 616   $self->storage->txn_begin;
 617 }
 618
 619 =head2 txn_commit
 620
 621 Commits the current transaction. Equivalent to calling
 622 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 623 for more information.
 624
 625 =cut
 626
 627 sub txn_commit {
 628   my $self = shift;
 629
 630   $self->storage or $self->throw_exception
 631     ('txn_commit called on $schema without storage');
 632
 633   $self->storage->txn_commit;
 634 }
 635
 636 =head2 txn_rollback
 637
 638 Rolls back the current transaction. Equivalent to calling
 639 $schema->storage->txn_rollback. See
 640 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 641
 642 =cut
 643
 644 sub txn_rollback {
 645   my $self = shift;
 646
 647   $self->storage or $self->throw_exception
 648     ('txn_rollback called on $schema without storage');
 649
 650   $self->storage->txn_rollback;
 651 }
 652
 653 =head2 storage
 654
 655   my $storage = $schema->storage;
 656
 657 Returns the L<DBIx::Class::Storage> object for this Schema. Grab this
 658 if you want to turn on SQL statement debugging at runtime, or set the
 659 quote character. For the default storage, the documentation can be
 660 found in L<DBIx::Class::Storage::DBI>.
 661
 662 =head2 populate
 663
 664 =over 4
 665
 666 =item Arguments: $source_name, \@data;
 667
 668 =item Return value: \@$objects | nothing
 669
 670 =back
 671
 672 Pass this method a resultsource name, and an arrayref of
 673 arrayrefs. The arrayrefs should contain a list of column names,
 674 followed by one or many sets of matching data for the given columns.
 675
 676 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 677 to insert the data, as this is a fast method. However, insert_bulk currently
 678 assumes that your datasets all contain the same type of values, using scalar
 679 references in a column in one row, and not in another will probably not work.
 680
 681 Otherwise, each set of data is inserted into the database using
 682 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 683 objects is returned.
 684
 685 i.e.,
 686
 687   $schema->populate('Artist', [
 688     [ qw/artistid name/ ],
 689     [ 1, 'Popular Band' ],
 690     [ 2, 'Indie Band' ],
 691     ...
 692   ]);
 693
 694 Since wantarray context is basically the same as looping over $rs->create(...)
 695 you won't see any performance benefits and in this case the method is more for
 696 convenience. Void context sends the column information directly to storage
 697 using <DBI>s bulk insert method. So the performance will be much better for
 698 storages that support this method.
 699
 700 Because of this difference in the way void context inserts rows into your
 701 database you need to note how this will effect any loaded components that
 702 override or augment insert.  For example if you are using a component such
 703 as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
 704 wantarray context if you want the PKs automatically created.
 705
 706 =cut
 707
 708 sub populate {
 709   my ($self, $name, $data) = @_;
 710   my $rs = $self->resultset($name);
 711   my @names = @{shift(@$data)};
 712   if(defined wantarray) {
 713     my @created;
 714     foreach my $item (@$data) {
 715       my %create;
 716       @create{@names} = @$item;
 717       push(@created, $rs->create(\%create));
 718     }
 719     return @created;
 720   }
 721   my @results_to_create;
 722   foreach my $datum (@$data) {
 723     my %result_to_create;
 724     foreach my $index (0..$#names) {
 725       $result_to_create{$names[$index]} = $$datum[$index];
 726     }
 727     push @results_to_create, \%result_to_create;
 728   }
 729   $rs->populate(\@results_to_create);
 730 }
 731
 732 =head2 connection
 733
 734 =over 4
 735
 736 =item Arguments: @args
 737
 738 =item Return Value: $new_schema
 739
 740 =back
 741
 742 Similar to L</connect> except sets the storage object and connection
 743 data in-place on the Schema class. You should probably be calling
 744 L</connect> to get a proper Schema object instead.
 745
 746
 747 =cut
 748
 749 sub connection {
 750   my ($self, @info) = @_;
 751   return $self if !@info && $self->storage;
 752
 753   my ($storage_class, $args) = ref $self->storage_type ?
 754     ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
 755
 756   $storage_class = 'DBIx::Class::Storage'.$storage_class
 757     if $storage_class =~ m/^::/;
 758   eval "require ${storage_class};";
 759   $self->throw_exception(
 760     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 761   ) if $@;
 762   my $storage = $storage_class->new($self=>$args);
 763   $storage->connect_info(\@info);
 764   $self->storage($storage);
 765   return $self;
 766 }
 767
 768 sub _normalize_storage_type {
 769   my ($self, $storage_type) = @_;
 770   if(ref $storage_type eq 'ARRAY') {
 771     return @$storage_type;
 772   } elsif(ref $storage_type eq 'HASH') {
 773     return %$storage_type;
 774   } else {
 775     $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
 776   }
 777 }
 778
 779 =head2 compose_namespace
 780
 781 =over 4
 782
 783 =item Arguments: $target_namespace, $additional_base_class?
 784
 785 =item Retur Value: $new_schema
 786
 787 =back
 788
 789 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 790 class in the target namespace (e.g. $target_namespace::CD,
 791 $target_namespace::Artist) that inherits from the corresponding classes
 792 attached to the current schema.
 793
 794 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 795 new $schema object. If C<$additional_base_class> is given, the new composed
 796 classes will inherit from first the corresponding classe from the current
 797 schema then the base class.
 798
 799 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 800
 801   $schema->compose_namespace('My::DB', 'Base::Class');
 802   print join (', ', @My::DB::CD::ISA) . "\n";
 803   print join (', ', @My::DB::Artist::ISA) ."\n";
 804
 805 will produce the output
 806
 807   My::Schema::CD, Base::Class
 808   My::Schema::Artist, Base::Class
 809
 810 =cut
 811
 812 # this might be oversimplified
 813 # sub compose_namespace {
 814 #   my ($self, $target, $base) = @_;
 815
 816 #   my $schema = $self->clone;
 817 #   foreach my $moniker ($schema->sources) {
 818 #     my $source = $schema->source($moniker);
 819 #     my $target_class = "${target}::${moniker}";
 820 #     $self->inject_base(
 821 #       $target_class => $source->result_class, ($base ? $base : ())
 822 #     );
 823 #     $source->result_class($target_class);
 824 #     $target_class->result_source_instance($source)
 825 #       if $target_class->can('result_source_instance');
 826 #     $schema->register_source($moniker, $source);
 827 #   }
 828 #   return $schema;
 829 # }
 830
 831 sub compose_namespace {
 832   my ($self, $target, $base) = @_;
 833   my $schema = $self->clone;
 834   {
 835     no warnings qw/redefine/;
 836 #    local *Class::C3::reinitialize = sub { };
 837     foreach my $moniker ($schema->sources) {
 838       my $source = $schema->source($moniker);
 839       my $target_class = "${target}::${moniker}";
 840       $self->inject_base(
 841         $target_class => $source->result_class, ($base ? $base : ())
 842       );
 843       $source->result_class($target_class);
 844       $target_class->result_source_instance($source)
 845         if $target_class->can('result_source_instance');
 846      $schema->register_source($moniker, $source);
 847     }
 848   }
 849 #  Class::C3->reinitialize();
 850   {
 851     no strict 'refs';
 852     no warnings 'redefine';
 853     foreach my $meth (qw/class source resultset/) {
 854       *{"${target}::${meth}"} =
 855         sub { shift->schema->$meth(@_) };
 856     }
 857   }
 858   return $schema;
 859 }
 860
 861 sub setup_connection_class {
 862   my ($class, $target, @info) = @_;
 863   $class->inject_base($target => 'DBIx::Class::DB');
 864   #$target->load_components('DB');
 865   $target->connection(@info);
 866 }
 867
 868 =head2 svp_begin
 869
 870 Creates a new savepoint (does nothing outside a transaction).
 871 Equivalent to calling $schema->storage->svp_begin.  See
 872 L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
 873
 874 =cut
 875
 876 sub svp_begin {
 877   my ($self, $name) = @_;
 878
 879   $self->storage or $self->throw_exception
 880     ('svp_begin called on $schema without storage');
 881
 882   $self->storage->svp_begin($name);
 883 }
 884
 885 =head2 svp_release
 886
 887 Releases a savepoint (does nothing outside a transaction).
 888 Equivalent to calling $schema->storage->svp_release.  See
 889 L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
 890
 891 =cut
 892
 893 sub svp_release {
 894   my ($self, $name) = @_;
 895
 896   $self->storage or $self->throw_exception
 897     ('svp_release called on $schema without storage');
 898
 899   $self->storage->svp_release($name);
 900 }
 901
 902 =head2 svp_rollback
 903
 904 Rollback to a savepoint (does nothing outside a transaction).
 905 Equivalent to calling $schema->storage->svp_rollback.  See
 906 L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
 907
 908 =cut
 909
 910 sub svp_rollback {
 911   my ($self, $name) = @_;
 912
 913   $self->storage or $self->throw_exception
 914     ('svp_rollback called on $schema without storage');
 915
 916   $self->storage->svp_rollback($name);
 917 }
 918
 919 =head2 clone
 920
 921 =over 4
 922
 923 =item Return Value: $new_schema
 924
 925 =back
 926
 927 Clones the schema and its associated result_source objects and returns the
 928 copy.
 929
 930 =cut
 931
 932 sub clone {
 933   my ($self) = @_;
 934   my $clone = { (ref $self ? %$self : ()) };
 935   bless $clone, (ref $self || $self);
 936
 937   $clone->class_mappings({ %{$clone->class_mappings} });
 938   $clone->source_registrations({ %{$clone->source_registrations} });
 939   foreach my $moniker ($self->sources) {
 940     my $source = $self->source($moniker);
 941     my $new = $source->new($source);
 942     # we use extra here as we want to leave the class_mappings as they are
 943     # but overwrite the source_registrations entry with the new source
 944     $clone->register_extra_source($moniker => $new);
 945   }
 946   $clone->storage->set_schema($clone) if $clone->storage;
 947   return $clone;
 948 }
 949
 950 =head2 throw_exception
 951
 952 =over 4
 953
 954 =item Arguments: $message
 955
 956 =back
 957
 958 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 959 user's perspective.  See L</exception_action> for details on overriding
 960 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
 961 default behavior will provide a detailed stack trace.
 962
 963 =cut
 964
 965 sub throw_exception {
 966   my $self = shift;
 967
 968   DBIx::Class::Exception->throw($_[0], $self->stacktrace)
 969     if !$self->exception_action || !$self->exception_action->(@_);
 970 }
 971
 972 =head2 deploy
 973
 974 =over 4
 975
 976 =item Arguments: $sqlt_args, $dir
 977
 978 =back
 979
 980 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 981
 982 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 983 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 984 produced include a DROP TABLE statement for each table created.
 985
 986 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
 987 ref or an array ref, containing a list of source to deploy. If present, then
 988 only the sources listed will get deployed. Furthermore, you can use the
 989 C<add_fk_index> parser parameter to prevent the parser from creating an index for each
 990 FK.
 991
 992 =cut
 993
 994 sub deploy {
 995   my ($self, $sqltargs, $dir) = @_;
 996   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 997   $self->storage->deploy($self, undef, $sqltargs, $dir);
 998 }
 999
1000 =head2 deployment_statements
1001
1002 =over 4
1003
1004 =item Arguments: $rdbms_type, $sqlt_args, $dir
1005
1006 =item Return value: $listofstatements
1007
1008 =back
1009
1010 A convenient shortcut to storage->deployment_statements(). Returns the
1011 SQL statements used by L</deploy> and
1012 L<DBIx::Class::Schema::Storage/deploy>. C<$rdbms_type> provides the
1013 (optional) SQLT (not DBI) database driver name for which the SQL
1014 statements are produced.  If not supplied, the type is determined by
1015 interrogating the current connection.  The other two arguments are
1016 identical to those of L</deploy>.
1017
1018 =cut
1019
1020 sub deployment_statements {
1021   my $self = shift;
1022
1023   $self->throw_exception("Can't generate deployment statements without a storage")
1024     if not $self->storage;
1025
1026   $self->storage->deployment_statements($self, @_);
1027 }
1028
1029 =head2 create_ddl_dir (EXPERIMENTAL)
1030
1031 =over 4
1032
1033 =item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
1034
1035 =back
1036
1037 Creates an SQL file based on the Schema, for each of the specified
1038 database types, in the given directory. Given a previous version number,
1039 this will also create a file containing the ALTER TABLE statements to
1040 transform the previous schema into the current one. Note that these
1041 statements may contain DROP TABLE or DROP COLUMN statements that can
1042 potentially destroy data.
1043
1044 The file names are created using the C<ddl_filename> method below, please
1045 override this method in your schema if you would like a different file
1046 name format. For the ALTER file, the same format is used, replacing
1047 $version in the name with "$preversion-$version".
1048
1049 See L<DBIx::Class::Schema/deploy> for details of $sqlt_args.
1050
1051 If no arguments are passed, then the following default values are used:
1052
1053 =over 4
1054
1055 =item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
1056
1057 =item version    - $schema->VERSION
1058
1059 =item directory  - './'
1060
1061 =item preversion - <none>
1062
1063 =back
1064
1065 Note that this feature is currently EXPERIMENTAL and may not work correctly
1066 across all databases, or fully handle complex relationships.
1067
1068 WARNING: Please check all SQL files created, before applying them.
1069
1070 =cut
1071
1072 sub create_ddl_dir {
1073   my $self = shift;
1074
1075   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1076   $self->storage->create_ddl_dir($self, @_);
1077 }
1078
1079 =head2 ddl_filename
1080
1081 =over 4
1082
1083 =item Arguments: $database-type, $version, $directory, $preversion
1084
1085 =item Return value: $normalised_filename
1086
1087 =back
1088
1089   my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
1090
1091 This method is called by C<create_ddl_dir> to compose a file name out of
1092 the supplied directory, database type and version number. The default file
1093 name format is: C<$dir$schema-$version-$type.sql>.
1094
1095 You may override this method in your schema if you wish to use a different
1096 format.
1097
1098 =cut
1099
1100 sub ddl_filename {
1101   my ($self, $type, $version, $dir, $preversion) = @_;
1102
1103   my $filename = ref($self);
1104   $filename =~ s/::/-/g;
1105   $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1106   $filename =~ s/$version/$preversion-$version/ if($preversion);
1107
1108   return $filename;
1109 }
1110
1111 =head2 thaw
1112
1113 Provided as the recommended way of thawing schema objects. You can call
1114 C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1115 reference to any schema, so are rather useless
1116
1117 =cut
1118
1119 sub thaw {
1120   my ($self, $obj) = @_;
1121   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1122   return Storable::thaw($obj);
1123 }
1124
1125 =head2 freeze
1126
1127 This doesn't actualy do anything more than call L<Storable/freeze>, it is just
1128 provided here for symetry.
1129
1130 =cut
1131
1132 sub freeze {
1133   return Storable::freeze($_[1]);
1134 }
1135
1136 =head2 dclone
1137
1138 Recommeneded way of dcloning objects. This is needed to properly maintain
1139 references to the schema object (which itself is B<not> cloned.)
1140
1141 =cut
1142
1143 sub dclone {
1144   my ($self, $obj) = @_;
1145   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1146   return Storable::dclone($obj);
1147 }
1148
1149 =head2 schema_version
1150
1151 Returns the current schema class' $VERSION in a normalised way.
1152
1153 =cut
1154
1155 sub schema_version {
1156   my ($self) = @_;
1157   my $class = ref($self)||$self;
1158
1159   # does -not- use $schema->VERSION
1160   # since that varies in results depending on if version.pm is installed, and if
1161   # so the perl or XS versions. If you want this to change, bug the version.pm
1162   # author to make vpp and vxs behave the same.
1163
1164   my $version;
1165   {
1166     no strict 'refs';
1167     $version = ${"${class}::VERSION"};
1168   }
1169   return $version;
1170 }
1171
1172
1173 =head2 register_class
1174
1175 =over 4
1176
1177 =item Arguments: $moniker, $component_class
1178
1179 =back
1180
1181 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.
1182
1183 You will only need this method if you have your Result classes in
1184 files which are not named after the packages (or all in the same
1185 file). You may also need it to register classes at runtime.
1186
1187 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
1188 calling:
1189
1190   $schema->register_source($moniker, $component_class->result_source_instance);
1191
1192 =cut
1193
1194 sub register_class {
1195   my ($self, $moniker, $to_register) = @_;
1196   $self->register_source($moniker => $to_register->result_source_instance);
1197 }
1198
1199 =head2 register_source
1200
1201 =over 4
1202
1203 =item Arguments: $moniker, $result_source
1204
1205 =back
1206
1207 This method is called by L</register_class>.
1208
1209 Registers the L<DBIx::Class::ResultSource> in the schema with the given
1210 moniker.
1211
1212 =cut
1213
1214 sub register_source {
1215   my $self = shift;
1216
1217   $self->_register_source(@_);
1218 }
1219
1220 =head2 register_extra_source
1221
1222 =over 4
1223
1224 =item Arguments: $moniker, $result_source
1225
1226 =back
1227
1228 As L</register_source> but should be used if the result class already
1229 has a source and you want to register an extra one.
1230
1231 =cut
1232
1233 sub register_extra_source {
1234   my $self = shift;
1235
1236   $self->_register_source(@_, { extra => 1 });
1237 }
1238
1239 sub _register_source {
1240   my ($self, $moniker, $source, $params) = @_;
1241
1242   %$source = %{ $source->new( { %$source, source_name => $moniker }) };
1243
1244   my %reg = %{$self->source_registrations};
1245   $reg{$moniker} = $source;
1246   $self->source_registrations(\%reg);
1247
1248   $source->schema($self);
1249   weaken($source->{schema}) if ref($self);
1250   return if ($params->{extra});
1251
1252   if ($source->result_class) {
1253     my %map = %{$self->class_mappings};
1254     if (exists $map{$source->result_class}) {
1255       warn $source->result_class . ' already has a source, use register_extra_source for additional sources';
1256     }
1257     $map{$source->result_class} = $moniker;
1258     $self->class_mappings(\%map);
1259   }
1260 }
1261
1262 sub _unregister_source {
1263     my ($self, $moniker) = @_;
1264     my %reg = %{$self->source_registrations};
1265
1266     my $source = delete $reg{$moniker};
1267     $self->source_registrations(\%reg);
1268     if ($source->result_class) {
1269         my %map = %{$self->class_mappings};
1270         delete $map{$source->result_class};
1271         $self->class_mappings(\%map);
1272     }
1273 }
1274
1275
1276 =head2 compose_connection (DEPRECATED)
1277
1278 =over 4
1279
1280 =item Arguments: $target_namespace, @db_info
1281
1282 =item Return Value: $new_schema
1283
1284 =back
1285
1286 DEPRECATED. You probably wanted compose_namespace.
1287
1288 Actually, you probably just wanted to call connect.
1289
1290 =begin hidden
1291
1292 (hidden due to deprecation)
1293
1294 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
1295 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
1296 then injects the L<DBix::Class::ResultSetProxy> component and a
1297 resultset_instance classdata entry on all the new classes, in order to support
1298 $target_namespaces::$class->search(...) method calls.
1299
1300 This is primarily useful when you have a specific need for class method access
1301 to a connection. In normal usage it is preferred to call
1302 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
1303 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
1304 more information.
1305
1306 =end hidden
1307
1308 =cut
1309
1310 {
1311   my $warn;
1312
1313   sub compose_connection {
1314     my ($self, $target, @info) = @_;
1315
1316     warn "compose_connection deprecated as of 0.08000"
1317       unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
1318
1319     my $base = 'DBIx::Class::ResultSetProxy';
1320     eval "require ${base};";
1321     $self->throw_exception
1322       ("No arguments to load_classes and couldn't load ${base} ($@)")
1323         if $@;
1324
1325     if ($self eq $target) {
1326       # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
1327       foreach my $moniker ($self->sources) {
1328         my $source = $self->source($moniker);
1329         my $class = $source->result_class;
1330         $self->inject_base($class, $base);
1331         $class->mk_classdata(resultset_instance => $source->resultset);
1332         $class->mk_classdata(class_resolver => $self);
1333       }
1334       $self->connection(@info);
1335       return $self;
1336     }
1337
1338     my $schema = $self->compose_namespace($target, $base);
1339     {
1340       no strict 'refs';
1341       my $name = join '::', $target, 'schema';
1342       *$name = Sub::Name::subname $name, sub { $schema };
1343     }
1344
1345     $schema->connection(@info);
1346     foreach my $moniker ($schema->sources) {
1347       my $source = $schema->source($moniker);
1348       my $class = $source->result_class;
1349       #warn "$moniker $class $source ".$source->storage;
1350       $class->mk_classdata(result_source_instance => $source);
1351       $class->mk_classdata(resultset_instance => $source->resultset);
1352       $class->mk_classdata(class_resolver => $schema);
1353     }
1354     return $schema;
1355   }
1356 }
1357
1358 1;
1359
1360 =head1 AUTHORS
1361
1362 Matt S. Trout <mst@shadowcatsystems.co.uk>
1363
1364 =head1 LICENSE
1365
1366 You may distribute this code under the same terms as Perl itself.
1367
1368 =cut