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         eval "use $comp_class"; # If it fails, assume the user fixed it
 267         if ($@) {
 268           $comp_class =~ s/::/\//g;
 269           die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/;
 270           warn $@ if $@;
 271         }
 272
 273         $comp_class->source_name($comp) unless $comp_class->source_name;
 274
 275         push(@to_register, [ $comp_class->source_name, $comp_class ]);
 276       }
 277     }
 278   }
 279   Class::C3->reinitialize;
 280
 281   foreach my $to (@to_register) {
 282     $class->register_class(@$to);
 283     #  if $class->can('result_source_instance');
 284   }
 285 }
 286
 287 =head2 compose_connection
 288
 289 =over 4
 290
 291 =item Arguments: $target_namespace, @db_info
 292
 293 =item Return Value: $new_schema
 294
 295 =back
 296
 297 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 298 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 299 then injects the L<DBix::Class::ResultSetProxy> component and a
 300 resultset_instance classdata entry on all the new classes, in order to support
 301 $target_namespaces::$class->search(...) method calls.
 302
 303 This is primarily useful when you have a specific need for class method access
 304 to a connection. In normal usage it is preferred to call
 305 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 306 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 307 more information.
 308
 309 =cut
 310
 311 sub compose_connection {
 312   my ($self, $target, @info) = @_;
 313   my $base = 'DBIx::Class::ResultSetProxy';
 314   eval "require ${base};";
 315   $self->throw_exception
 316     ("No arguments to load_classes and couldn't load ${base} ($@)")
 317       if $@;
 318
 319   if ($self eq $target) {
 320     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 321     foreach my $moniker ($self->sources) {
 322       my $source = $self->source($moniker);
 323       my $class = $source->result_class;
 324       $self->inject_base($class, $base);
 325       $class->mk_classdata(resultset_instance => $source->resultset);
 326       $class->mk_classdata(class_resolver => $self);
 327     }
 328     $self->connection(@info);
 329     return $self;
 330   }
 331
 332   my $schema = $self->compose_namespace($target, $base);
 333   {
 334     no strict 'refs';
 335     *{"${target}::schema"} = sub { $schema };
 336   }
 337
 338   $schema->connection(@info);
 339   foreach my $moniker ($schema->sources) {
 340     my $source = $schema->source($moniker);
 341     my $class = $source->result_class;
 342     #warn "$moniker $class $source ".$source->storage;
 343     $class->mk_classdata(result_source_instance => $source);
 344     $class->mk_classdata(resultset_instance => $source->resultset);
 345     $class->mk_classdata(class_resolver => $schema);
 346   }
 347   return $schema;
 348 }
 349
 350 =head2 compose_namespace
 351
 352 =over 4
 353
 354 =item Arguments: $target_namespace, $additional_base_class?
 355
 356 =item Return Value: $new_schema
 357
 358 =back
 359
 360 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 361 class in the target namespace (e.g. $target_namespace::CD,
 362 $target_namespace::Artist) that inherits from the corresponding classes
 363 attached to the current schema.
 364
 365 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 366 new $schema object. If C<$additional_base_class> is given, the new composed
 367 classes will inherit from first the corresponding classe from the current
 368 schema then the base class.
 369
 370 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 371
 372   $schema->compose_namespace('My::DB', 'Base::Class');
 373   print join (', ', @My::DB::CD::ISA) . "\n";
 374   print join (', ', @My::DB::Artist::ISA) ."\n";
 375
 376 will produce the output
 377
 378   My::Schema::CD, Base::Class
 379   My::Schema::Artist, Base::Class
 380
 381 =cut
 382
 383 sub compose_namespace {
 384   my ($self, $target, $base) = @_;
 385   my %reg = %{ $self->source_registrations };
 386   my %target;
 387   my %map;
 388   my $schema = $self->clone;
 389   {
 390     no warnings qw/redefine/;
 391     local *Class::C3::reinitialize = sub { };
 392     foreach my $moniker ($schema->sources) {
 393       my $source = $schema->source($moniker);
 394       my $target_class = "${target}::${moniker}";
 395       $self->inject_base(
 396         $target_class => $source->result_class, ($base ? $base : ())
 397       );
 398       $source->result_class($target_class);
 399     }
 400   }
 401   Class::C3->reinitialize();
 402   {
 403     no strict 'refs';
 404     foreach my $meth (qw/class source resultset/) {
 405       *{"${target}::${meth}"} =
 406         sub { shift->schema->$meth(@_) };
 407     }
 408   }
 409   return $schema;
 410 }
 411
 412 =head2 setup_connection_class
 413
 414 =over 4
 415
 416 =item Arguments: $target, @info
 417
 418 =back
 419
 420 Sets up a database connection class to inject between the schema and the
 421 subclasses that the schema creates.
 422
 423 =cut
 424
 425 sub setup_connection_class {
 426   my ($class, $target, @info) = @_;
 427   $class->inject_base($target => 'DBIx::Class::DB');
 428   #$target->load_components('DB');
 429   $target->connection(@info);
 430 }
 431
 432 =head2 connection
 433
 434 =over 4
 435
 436 =item Arguments: @args
 437
 438 =item Return Value: $new_schema
 439
 440 =back
 441
 442 Instantiates a new Storage object of type
 443 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 444 $storage->connect_info. Sets the connection in-place on the schema. See
 445 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
 446
 447 =cut
 448
 449 sub connection {
 450   my ($self, @info) = @_;
 451   return $self if !@info && $self->storage;
 452   my $storage_class = $self->storage_type;
 453   $storage_class = 'DBIx::Class::Storage'.$storage_class
 454     if $storage_class =~ m/^::/;
 455   eval "require ${storage_class};";
 456   $self->throw_exception(
 457     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 458   ) if $@;
 459   my $storage = $storage_class->new;
 460   $storage->connect_info(\@info);
 461   $self->storage($storage);
 462   return $self;
 463 }
 464
 465 =head2 connect
 466
 467 =over 4
 468
 469 =item Arguments: @info
 470
 471 =item Return Value: $new_schema
 472
 473 =back
 474
 475 This is a convenience method. It is equivalent to calling
 476 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 477 information.
 478
 479 =cut
 480
 481 sub connect { shift->clone->connection(@_) }
 482
 483 =head2 txn_begin
 484
 485 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 486 calling $schema->storage->txn_begin. See
 487 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 488
 489 =cut
 490
 491 sub txn_begin { shift->storage->txn_begin }
 492
 493 =head2 txn_commit
 494
 495 Commits the current transaction. Equivalent to calling
 496 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 497 for more information.
 498
 499 =cut
 500
 501 sub txn_commit { shift->storage->txn_commit }
 502
 503 =head2 txn_rollback
 504
 505 Rolls back the current transaction. Equivalent to calling
 506 $schema->storage->txn_rollback. See
 507 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 508
 509 =cut
 510
 511 sub txn_rollback { shift->storage->txn_rollback }
 512
 513 =head2 txn_do
 514
 515 =over 4
 516
 517 =item Arguments: C<$coderef>, @coderef_args?
 518
 519 =item Return Value: The return value of $coderef
 520
 521 =back
 522
 523 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 524 returning its result (if any). If an exception is caught, a rollback is issued
 525 and the exception is rethrown. If the rollback fails, (i.e. throws an
 526 exception) an exception is thrown that includes a "Rollback failed" message.
 527
 528 For example,
 529
 530   my $author_rs = $schema->resultset('Author')->find(1);
 531
 532   my $coderef = sub {
 533     my ($author, @titles) = @_;
 534
 535     # If any one of these fails, the entire transaction fails
 536     $author->create_related('books', {
 537       title => $_
 538     }) foreach (@titles);
 539
 540     return $author->books;
 541   };
 542
 543   my $rs;
 544   eval {
 545     $rs = $schema->txn_do($coderef, $author_rs, qw/Night Day It/);
 546   };
 547
 548   if ($@) {
 549     my $error = $@;
 550     if ($error =~ /Rollback failed/) {
 551       die "something terrible has happened!";
 552     } else {
 553       deal_with_failed_transaction();
 554     }
 555   }
 556
 557 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 558 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
 559 the Schema's storage, and txn_do() can be called in void, scalar and list
 560 context and it will behave as expected.
 561
 562 =cut
 563
 564 sub txn_do {
 565   my ($self, $coderef, @args) = @_;
 566
 567   ref $self or $self->throw_exception
 568     ('Cannot execute txn_do as a class method');
 569   ref $coderef eq 'CODE' or $self->throw_exception
 570     ('$coderef must be a CODE reference');
 571
 572   my (@return_values, $return_value);
 573
 574   $self->txn_begin; # If this throws an exception, no rollback is needed
 575
 576   my $wantarray = wantarray; # Need to save this since the context
 577                              # inside the eval{} block is independent
 578                              # of the context that called txn_do()
 579   eval {
 580
 581     # Need to differentiate between scalar/list context to allow for
 582     # returning a list in scalar context to get the size of the list
 583     if ($wantarray) {
 584       # list context
 585       @return_values = $coderef->(@args);
 586     } elsif (defined $wantarray) {
 587       # scalar context
 588       $return_value = $coderef->(@args);
 589     } else {
 590       # void context
 591       $coderef->(@args);
 592     }
 593     $self->txn_commit;
 594   };
 595
 596   if ($@) {
 597     my $error = $@;
 598
 599     eval {
 600       $self->txn_rollback;
 601     };
 602
 603     if ($@) {
 604       my $rollback_error = $@;
 605       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 606       $self->throw_exception($error)  # propagate nested rollback
 607         if $rollback_error =~ /$exception_class/;
 608
 609       $self->throw_exception(
 610         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 611       );
 612     } else {
 613       $self->throw_exception($error); # txn failed but rollback succeeded
 614     }
 615   }
 616
 617   return $wantarray ? @return_values : $return_value;
 618 }
 619
 620 =head2 clone
 621
 622 =over 4
 623
 624 =item Return Value: $new_schema
 625
 626 =back
 627
 628 Clones the schema and its associated result_source objects and returns the
 629 copy.
 630
 631 =cut
 632
 633 sub clone {
 634   my ($self) = @_;
 635   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 636   foreach my $moniker ($self->sources) {
 637     my $source = $self->source($moniker);
 638     my $new = $source->new($source);
 639     $clone->register_source($moniker => $new);
 640   }
 641   return $clone;
 642 }
 643
 644 =head2 populate
 645
 646 =over 4
 647
 648 =item Arguments: $moniker, \@data;
 649
 650 =back
 651
 652 Populates the source registered with the given moniker with the supplied data.
 653 @data should be a list of listrefs -- the first containing column names, the
 654 second matching values.
 655
 656 i.e.,
 657
 658   $schema->populate('Artist', [
 659     [ qw/artistid name/ ],
 660     [ 1, 'Popular Band' ],
 661     [ 2, 'Indie Band' ],
 662     ...
 663   ]);
 664
 665 =cut
 666
 667 sub populate {
 668   my ($self, $name, $data) = @_;
 669   my $rs = $self->resultset($name);
 670   my @names = @{shift(@$data)};
 671   my @created;
 672   foreach my $item (@$data) {
 673     my %create;
 674     @create{@names} = @$item;
 675     push(@created, $rs->create(\%create));
 676   }
 677   return @created;
 678 }
 679
 680 =head2 throw_exception
 681
 682 =over 4
 683
 684 =item Arguments: $message
 685
 686 =back
 687
 688 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 689 user's perspective.
 690
 691 =cut
 692
 693 sub throw_exception {
 694   my ($self) = shift;
 695   croak @_;
 696 }
 697
 698 =head2 deploy (EXPERIMENTAL)
 699
 700 =over 4
 701
 702 =item Arguments: $sqlt_args
 703
 704 =back
 705
 706 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 707
 708 Note that this feature is currently EXPERIMENTAL and may not work correctly
 709 across all databases, or fully handle complex relationships.
 710
 711 =cut
 712
 713 sub deploy {
 714   my ($self, $sqltargs) = @_;
 715   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 716   $self->storage->deploy($self, undef, $sqltargs);
 717 }
 718
 719 =head2 create_ddl_dir (EXPERIMENTAL)
 720
 721 =over 4
 722
 723 =item Arguments: \@databases, $version, $directory, $sqlt_args
 724
 725 =back
 726
 727 Creates an SQL file based on the Schema, for each of the specified
 728 database types, in the given directory.
 729
 730 Note that this feature is currently EXPERIMENTAL and may not work correctly
 731 across all databases, or fully handle complex relationships.
 732
 733 =cut
 734
 735 sub create_ddl_dir
 736 {
 737   my $self = shift;
 738
 739   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 740   $self->storage->create_ddl_dir($self, @_);
 741 }
 742
 743 sub ddl_filename
 744 {
 745     my ($self, $type, $dir, $version) = @_;
 746
 747     my $filename = ref($self);
 748     $filename =~ s/^.*:://;
 749     $filename = "$dir$filename-$version-$type.sql";
 750
 751     return $filename;
 752 }
 753
 754 1;
 755
 756 =head1 AUTHORS
 757
 758 Matt S. Trout <mst@shadowcatsystems.co.uk>
 759
 760 =head1 LICENSE
 761
 762 You may distribute this code under the same terms as Perl itself.
 763
 764 =cut
 765