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
 271         $comp_class->source_name($comp) unless $comp_class->source_name;
 272
 273         push(@to_register, [ $comp_class->source_name, $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 Return Value: $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> with @db_info on the new schema,
 297 then injects the L<DBix::Class::ResultSetProxy> component and a
 298 resultset_instance 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 Return Value: $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 For example, 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 Return Value: $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 Return Value: $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 Return Value: 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 Return Value: $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 =head2 create_ddl_dir (EXPERIMENTAL)
 718
 719 =over 4
 720
 721 =item Arguments: \@databases, $version, $directory, $sqlt_args
 722
 723 =back
 724
 725 Creates an SQL file based on the Schema, for each of the specified
 726 database types, in the given directory.
 727
 728 Note that this feature is currently EXPERIMENTAL and may not work correctly
 729 across all databases, or fully handle complex relationships.
 730
 731 =cut
 732
 733 sub create_ddl_dir
 734 {
 735   my $self = shift;
 736
 737   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 738   $self->storage->create_ddl_dir($self, @_);
 739 }
 740
 741 sub ddl_filename
 742 {
 743     my ($self, $type, $dir, $version) = @_;
 744
 745     my $filename = ref($self);
 746     $filename =~ s/^.*:://;
 747     $filename = "$dir$filename-$version-$type.sql";
 748
 749     return $filename;
 750 }
 751
 752 1;
 753
 754 =head1 AUTHORS
 755
 756 Matt S. Trout <mst@shadowcatsystems.co.uk>
 757
 758 =head1 LICENSE
 759
 760 You may distribute this code under the same terms as Perl itself.
 761
 762 =cut
 763