lib/DBIx/Class/Schema.pm

   1 package DBIx::Class::Schema;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp::Clan qw/^DBIx::Class/;
   7
   8 use base qw/DBIx::Class/;
   9
  10 __PACKAGE__->mk_classdata('class_mappings' => {});
  11 __PACKAGE__->mk_classdata('source_registrations' => {});
  12 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  13 __PACKAGE__->mk_classdata('storage');
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Schema - composable schemas
  18
  19 =head1 SYNOPSIS
  20
  21   package Library::Schema;
  22   use base qw/DBIx::Class::Schema/;
  23
  24   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  25   __PACKAGE__->load_classes(qw/CD Book DVD/);
  26
  27   package Library::Schema::CD;
  28   use base qw/DBIx::Class/;
  29   __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
  30   __PACKAGE__->table('cd');
  31
  32   # Elsewhere in your code:
  33   my $schema1 = Library::Schema->connect(
  34     $dsn,
  35     $user,
  36     $password,
  37     { AutoCommit => 0 },
  38   );
  39
  40   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  41
  42   # fetch objects using Library::Schema::DVD
  43   my $resultset = $schema1->resultset('DVD')->search( ... );
  44   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  45
  46 =head1 DESCRIPTION
  47
  48 Creates database classes based on a schema. This is the recommended way to
  49 use L<DBIx::Class> and allows you to use more than one concurrent connection
  50 with your classes.
  51
  52 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  53 carefully as DBIx::Class does things a little differently. Note in
  54 particular which module inherits off which.
  55
  56 =head1 METHODS
  57
  58 =head2 register_class
  59
  60 =over 4
  61
  62 =item Arguments: ($moniker, $component_class)
  63
  64 =back
  65
  66 Registers a class which isa L<DBIx::Class::ResultSourceProxy>. Equivalent to
  67 calling
  68
  69   $schema->register_source($moniker, $component_class->result_source_instance);
  70
  71 =cut
  72
  73 sub register_class {
  74   my ($self, $moniker, $to_register) = @_;
  75   $self->register_source($moniker => $to_register->result_source_instance);
  76 }
  77
  78 =head2 register_source
  79
  80 =over 4
  81
  82 =item Arguments: ($moniker, $result_source)
  83
  84 =back
  85
  86 Registers the L<DBIx::Class::ResultSource> in the schema with the given
  87 moniker.
  88
  89 =cut
  90
  91 sub register_source {
  92   my ($self, $moniker, $source) = @_;
  93   my %reg = %{$self->source_registrations};
  94   $reg{$moniker} = $source;
  95   $self->source_registrations(\%reg);
  96   $source->schema($self);
  97   if ($source->result_class) {
  98     my %map = %{$self->class_mappings};
  99     $map{$source->result_class} = $moniker;
 100     $self->class_mappings(\%map);
 101   }
 102 }
 103
 104 =head2 class
 105
 106 =over 4
 107
 108 =item Arguments: ($moniker)
 109
 110 =item Returns: $classname
 111
 112 =back
 113
 114 Retrieves the result class name for the given moniker.
 115
 116 e.g.,
 117
 118   my $class = $schema->class('CD');
 119
 120 =cut
 121
 122 sub class {
 123   my ($self, $moniker) = @_;
 124   return $self->source($moniker)->result_class;
 125 }
 126
 127 =head2 source
 128
 129 =over 4
 130
 131 =item Arguments: ($moniker)
 132
 133 =item Returns: $result_source
 134
 135 =back
 136
 137   my $source = $schema->source('Book');
 138
 139 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
 140
 141 =cut
 142
 143 sub source {
 144   my ($self, $moniker) = @_;
 145   my $sreg = $self->source_registrations;
 146   return $sreg->{$moniker} if exists $sreg->{$moniker};
 147
 148   # if we got here, they probably passed a full class name
 149   my $mapped = $self->class_mappings->{$moniker};
 150   $self->throw_exception("Can't find source for ${moniker}")
 151     unless $mapped && exists $sreg->{$mapped};
 152   return $sreg->{$mapped};
 153 }
 154
 155 =head2 sources
 156
 157 =over 4
 158
 159 =item Returns: @source_monikers
 160
 161 =back
 162
 163 Returns the source monikers of all source registrations on this schema.
 164
 165 e.g.,
 166
 167   my @source_monikers = $schema->sources;
 168
 169 =cut
 170
 171 sub sources { return keys %{shift->source_registrations}; }
 172
 173 =head2 resultset
 174
 175 =over 4
 176
 177 =item Arguments: ($moniker)
 178
 179 =item Returns: $result_set
 180
 181 =back
 182
 183   my $rs = $schema->resultset('DVD');
 184
 185 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
 186
 187 =cut
 188
 189 sub resultset {
 190   my ($self, $moniker) = @_;
 191   return $self->source($moniker)->resultset;
 192 }
 193
 194 =head2 load_classes
 195
 196 =over 4
 197
 198 =item Arguments: @classes?, { $namespace => [ @classes ] }+
 199
 200 =back
 201
 202 With no arguments, this method uses L<Module::Find> to find all classes under
 203 the schema's namespace. Otherwise, this method loads the classes you specify
 204 (using L<use>), and registers them (using L</"register_class">).
 205
 206 It is possible to comment out classes with a leading '#', but note that perl
 207 will think it's a mistake (trying to use a comment in a qw list) so you'll
 208 need to add "no warnings 'qw';" before your load_classes call.
 209
 210 e.g.,
 211
 212   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
 213                               # etc. (anything under the My::Schema namespace)
 214
 215   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
 216   # not Other::Namespace::LinerNotes nor My::Schema::Track
 217   My::Schema->load_classes(qw/ CD Artist #Track /, {
 218     Other::Namespace => [qw/ Producer #LinerNotes /],
 219   });
 220
 221 =cut
 222
 223 sub load_classes {
 224   my ($class, @params) = @_;
 225
 226   my %comps_for;
 227
 228   if (@params) {
 229     foreach my $param (@params) {
 230       if (ref $param eq 'ARRAY') {
 231         # filter out commented entries
 232         my @modules = grep { $_ !~ /^#/ } @$param;
 233
 234         push (@{$comps_for{$class}}, @modules);
 235       }
 236       elsif (ref $param eq 'HASH') {
 237         # more than one namespace possible
 238         for my $comp ( keys %$param ) {
 239           # filter out commented entries
 240           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
 241
 242           push (@{$comps_for{$comp}}, @modules);
 243         }
 244       }
 245       else {
 246         # filter out commented entries
 247         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
 248       }
 249     }
 250   } else {
 251     eval "require Module::Find;";
 252     $class->throw_exception(
 253       "No arguments to load_classes and couldn't load Module::Find ($@)"
 254     ) if $@;
 255     my @comp = map { substr $_, length "${class}::"  }
 256                  Module::Find::findallmod($class);
 257     $comps_for{$class} = \@comp;
 258   }
 259
 260   my @to_register;
 261   {
 262     no warnings qw/redefine/;
 263     local *Class::C3::reinitialize = sub { };
 264     foreach my $prefix (keys %comps_for) {
 265       foreach my $comp (@{$comps_for{$prefix}||[]}) {
 266         my $comp_class = "${prefix}::${comp}";
 267         eval "use $comp_class"; # If it fails, assume the user fixed it
 268         if ($@) {
 269           $comp_class =~ s/::/\//g;
 270           die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/;
 271           warn $@ if $@;
 272         }
 273         push(@to_register, [ $comp, $comp_class ]);
 274       }
 275     }
 276   }
 277   Class::C3->reinitialize;
 278
 279   foreach my $to (@to_register) {
 280     $class->register_class(@$to);
 281     #  if $class->can('result_source_instance');
 282   }
 283 }
 284
 285 =head2 compose_connection
 286
 287 =over 4
 288
 289 =item Arguments: ($target_namespace, @db_info)
 290
 291 =item Returns: $new_schema
 292
 293 =back
 294
 295 Calls L<DBIx::Class::schema/"compose_namespace"> to the target namespace,
 296 calls L<DBIx::Class::Schema/connection>(@db_info) on the new schema, then
 297 injects the L<DBix::Class::ResultSetProxy> component and a resultset_instance
 298 classdata entry on all the new classes in order to support
 299 $target_namespaces::$class->search(...) method calls.
 300
 301 This is primarily useful when you have a specific need for class method access
 302 to a connection. In normal usage it is preferred to call
 303 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 304 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 305 more information.
 306
 307 =cut
 308
 309 sub compose_connection {
 310   my ($self, $target, @info) = @_;
 311   my $base = 'DBIx::Class::ResultSetProxy';
 312   eval "require ${base};";
 313   $self->throw_exception
 314     ("No arguments to load_classes and couldn't load ${base} ($@)")
 315       if $@;
 316
 317   if ($self eq $target) {
 318     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 319     foreach my $moniker ($self->sources) {
 320       my $source = $self->source($moniker);
 321       my $class = $source->result_class;
 322       $self->inject_base($class, $base);
 323       $class->mk_classdata(resultset_instance => $source->resultset);
 324       $class->mk_classdata(class_resolver => $self);
 325     }
 326     $self->connection(@info);
 327     return $self;
 328   }
 329
 330   my $schema = $self->compose_namespace($target, $base);
 331   {
 332     no strict 'refs';
 333     *{"${target}::schema"} = sub { $schema };
 334   }
 335
 336   $schema->connection(@info);
 337   foreach my $moniker ($schema->sources) {
 338     my $source = $schema->source($moniker);
 339     my $class = $source->result_class;
 340     #warn "$moniker $class $source ".$source->storage;
 341     $class->mk_classdata(result_source_instance => $source);
 342     $class->mk_classdata(resultset_instance => $source->resultset);
 343     $class->mk_classdata(class_resolver => $schema);
 344   }
 345   return $schema;
 346 }
 347
 348 =head2 compose_namespace
 349
 350 =over 4
 351
 352 =item Arguments: $target_namespace, $additional_base_class?
 353
 354 =item Returns: $new_schema
 355
 356 =back
 357
 358 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 359 class in the target namespace (e.g. $target_namespace::CD,
 360 $target_namespace::Artist) that inherits from the corresponding classes
 361 attached to the current schema.
 362
 363 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 364 new $schema object. If C<$additional_base_class> is given, the new composed
 365 classes will inherit from first the corresponding classe from the current
 366 schema then the base class.
 367
 368 e.g. (for a schema with My::Schema::CD and My::Schema::Artist classes),
 369
 370   $schema->compose_namespace('My::DB', 'Base::Class');
 371   print join (', ', @My::DB::CD::ISA) . "\n";
 372   print join (', ', @My::DB::Artist::ISA) ."\n";
 373
 374 Will produce the output
 375
 376   My::Schema::CD, Base::Class
 377   My::Schema::Artist, Base::Class
 378
 379 =cut
 380
 381 sub compose_namespace {
 382   my ($self, $target, $base) = @_;
 383   my %reg = %{ $self->source_registrations };
 384   my %target;
 385   my %map;
 386   my $schema = $self->clone;
 387   {
 388     no warnings qw/redefine/;
 389     local *Class::C3::reinitialize = sub { };
 390     foreach my $moniker ($schema->sources) {
 391       my $source = $schema->source($moniker);
 392       my $target_class = "${target}::${moniker}";
 393       $self->inject_base(
 394         $target_class => $source->result_class, ($base ? $base : ())
 395       );
 396       $source->result_class($target_class);
 397     }
 398   }
 399   Class::C3->reinitialize();
 400   {
 401     no strict 'refs';
 402     foreach my $meth (qw/class source resultset/) {
 403       *{"${target}::${meth}"} =
 404         sub { shift->schema->$meth(@_) };
 405     }
 406   }
 407   return $schema;
 408 }
 409
 410 =head2 setup_connection_class
 411
 412 =over 4
 413
 414 =item Arguments: ($target, @info)
 415
 416 =back
 417
 418 Sets up a database connection class to inject between the schema and the
 419 subclasses that the schema creates.
 420
 421 =cut
 422
 423 sub setup_connection_class {
 424   my ($class, $target, @info) = @_;
 425   $class->inject_base($target => 'DBIx::Class::DB');
 426   #$target->load_components('DB');
 427   $target->connection(@info);
 428 }
 429
 430 =head2 connection
 431
 432 =over 4
 433
 434 =item Arguments: (@args)
 435
 436 =item Returns: $new_schema
 437
 438 =back
 439
 440 Instantiates a new Storage object of type
 441 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 442 $storage->connect_info. Sets the connection in-place on the schema. See
 443 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
 444
 445 =cut
 446
 447 sub connection {
 448   my ($self, @info) = @_;
 449   return $self if !@info && $self->storage;
 450   my $storage_class = $self->storage_type;
 451   $storage_class = 'DBIx::Class::Storage'.$storage_class
 452     if $storage_class =~ m/^::/;
 453   eval "require ${storage_class};";
 454   $self->throw_exception(
 455     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 456   ) if $@;
 457   my $storage = $storage_class->new;
 458   $storage->connect_info(\@info);
 459   $self->storage($storage);
 460   return $self;
 461 }
 462
 463 =head2 connect
 464
 465 =over 4
 466
 467 =item Arguments: (@info)
 468
 469 =item Returns: $new_schema
 470
 471 =back
 472
 473 This is a convenience method. It is equivalent to calling
 474 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 475 information.
 476
 477 =cut
 478
 479 sub connect { shift->clone->connection(@_) }
 480
 481 =head2 txn_begin
 482
 483 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 484 calling $schema->storage->txn_begin. See
 485 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 486
 487 =cut
 488
 489 sub txn_begin { shift->storage->txn_begin }
 490
 491 =head2 txn_commit
 492
 493 Commits the current transaction. Equivalent to calling
 494 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 495 for more information.
 496
 497 =cut
 498
 499 sub txn_commit { shift->storage->txn_commit }
 500
 501 =head2 txn_rollback
 502
 503 Rolls back the current transaction. Equivalent to calling
 504 $schema->storage->txn_rollback. See
 505 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 506
 507 =cut
 508
 509 sub txn_rollback { shift->storage->txn_rollback }
 510
 511 =head2 txn_do
 512
 513 =over 4
 514
 515 =item Arguments: (C<$coderef>, @coderef_args?)
 516
 517 =item Returns: The return value of $coderef
 518
 519 =back
 520
 521 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 522 returning its result (if any). If an exception is caught, a rollback is issued
 523 and the exception is rethrown. If the rollback fails, (i.e. throws an
 524 exception) an exception is thrown that includes a "Rollback failed" message.
 525
 526 For example,
 527
 528   my $author_rs = $schema->resultset('Author')->find(1);
 529
 530   my $coderef = sub {
 531     my ($author, @titles) = @_;
 532
 533     # If any one of these fails, the entire transaction fails
 534     $author->create_related('books', {
 535       title => $_
 536     }) foreach (@titles);
 537
 538     return $author->books;
 539   };
 540
 541   my $rs;
 542   eval {
 543     $rs = $schema->txn_do($coderef, $author_rs, qw/Night Day It/);
 544   };
 545
 546   if ($@) {
 547     my $error = $@;
 548     if ($error =~ /Rollback failed/) {
 549       die "something terrible has happened!";
 550     } else {
 551       deal_with_failed_transaction();
 552     }
 553   }
 554
 555 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 556 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
 557 the Schema's storage, and txn_do() can be called in void, scalar and list
 558 context and it will behave as expected.
 559
 560 =cut
 561
 562 sub txn_do {
 563   my ($self, $coderef, @args) = @_;
 564
 565   ref $self or $self->throw_exception
 566     ('Cannot execute txn_do as a class method');
 567   ref $coderef eq 'CODE' or $self->throw_exception
 568     ('$coderef must be a CODE reference');
 569
 570   my (@return_values, $return_value);
 571
 572   $self->txn_begin; # If this throws an exception, no rollback is needed
 573
 574   my $wantarray = wantarray; # Need to save this since the context
 575                              # inside the eval{} block is independent
 576                              # of the context that called txn_do()
 577   eval {
 578
 579     # Need to differentiate between scalar/list context to allow for
 580     # returning a list in scalar context to get the size of the list
 581     if ($wantarray) {
 582       # list context
 583       @return_values = $coderef->(@args);
 584     } elsif (defined $wantarray) {
 585       # scalar context
 586       $return_value = $coderef->(@args);
 587     } else {
 588       # void context
 589       $coderef->(@args);
 590     }
 591     $self->txn_commit;
 592   };
 593
 594   if ($@) {
 595     my $error = $@;
 596
 597     eval {
 598       $self->txn_rollback;
 599     };
 600
 601     if ($@) {
 602       my $rollback_error = $@;
 603       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 604       $self->throw_exception($error)  # propagate nested rollback
 605         if $rollback_error =~ /$exception_class/;
 606
 607       $self->throw_exception(
 608         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 609       );
 610     } else {
 611       $self->throw_exception($error); # txn failed but rollback succeeded
 612     }
 613   }
 614
 615   return $wantarray ? @return_values : $return_value;
 616 }
 617
 618 =head2 clone
 619
 620 =over 4
 621
 622 =item Returns: $new_schema
 623
 624 =back
 625
 626 Clones the schema and its associated result_source objects and returns the
 627 copy.
 628
 629 =cut
 630
 631 sub clone {
 632   my ($self) = @_;
 633   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 634   foreach my $moniker ($self->sources) {
 635     my $source = $self->source($moniker);
 636     my $new = $source->new($source);
 637     $clone->register_source($moniker => $new);
 638   }
 639   return $clone;
 640 }
 641
 642 =head2 populate
 643
 644 =over 4
 645
 646 =item Arguments: ($moniker, \@data);
 647
 648 =back
 649
 650 Populates the source registered with the given moniker with the supplied data.
 651 @data should be a list of listrefs -- the first containing column names, the
 652 second matching values.
 653
 654 i.e.,
 655
 656   $schema->populate('Artist', [
 657     [ qw/artistid name/ ],
 658     [ 1, 'Popular Band' ],
 659     [ 2, 'Indie Band' ],
 660     ...
 661   ]);
 662
 663 =cut
 664
 665 sub populate {
 666   my ($self, $name, $data) = @_;
 667   my $rs = $self->resultset($name);
 668   my @names = @{shift(@$data)};
 669   my @created;
 670   foreach my $item (@$data) {
 671     my %create;
 672     @create{@names} = @$item;
 673     push(@created, $rs->create(\%create));
 674   }
 675   return @created;
 676 }
 677
 678 =head2 throw_exception
 679
 680 =over 4
 681
 682 =item Arguments: ($message)
 683
 684 =back
 685
 686 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 687 user's perspective.
 688
 689 =cut
 690
 691 sub throw_exception {
 692   my ($self) = shift;
 693   croak @_;
 694 }
 695
 696 =head2 deploy (EXPERIMENTAL)
 697
 698 =over 4
 699
 700 =item Arguments: ($sqlt_args)
 701
 702 =back
 703
 704 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 705
 706 Note that this feature is currently EXPERIMENTAL and may not work correctly
 707 across all databases, or fully handle complex relationships.
 708
 709 =cut
 710
 711 sub deploy {
 712   my ($self, $sqltargs) = @_;
 713   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 714   $self->storage->deploy($self, undef, $sqltargs);
 715 }
 716
 717 1;
 718
 719 =head1 AUTHORS
 720
 721 Matt S. Trout <mst@shadowcatsystems.co.uk>
 722
 723 =head1 LICENSE
 724
 725 You may distribute this code under the same terms as Perl itself.
 726
 727 =cut
 728