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