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