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 use File::Spec;
   9
  10 use base qw/DBIx::Class/;
  11
  12 __PACKAGE__->mk_classdata('class_mappings' => {});
  13 __PACKAGE__->mk_classdata('source_registrations' => {});
  14 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
  15 __PACKAGE__->mk_classdata('storage');
  16
  17 =head1 NAME
  18
  19 DBIx::Class::Schema - composable schemas
  20
  21 =head1 SYNOPSIS
  22
  23   package Library::Schema;
  24   use base qw/DBIx::Class::Schema/;
  25
  26   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  27   __PACKAGE__->load_classes(qw/CD Book DVD/);
  28
  29   package Library::Schema::CD;
  30   use base qw/DBIx::Class/;
  31   __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
  32   __PACKAGE__->table('cd');
  33
  34   # Elsewhere in your code:
  35   my $schema1 = Library::Schema->connect(
  36     $dsn,
  37     $user,
  38     $password,
  39     { AutoCommit => 0 },
  40   );
  41
  42   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
  43
  44   # fetch objects using Library::Schema::DVD
  45   my $resultset = $schema1->resultset('DVD')->search( ... );
  46   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
  47
  48 =head1 DESCRIPTION
  49
  50 Creates database classes based on a schema. This is the recommended way to
  51 use L<DBIx::Class> and allows you to use more than one concurrent connection
  52 with your classes.
  53
  54 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
  55 carefully, as DBIx::Class does things a little differently. Note in
  56 particular which module inherits off which.
  57
  58 =head1 METHODS
  59
  60 =head2 register_class
  61
  62 =over 4
  63
  64 =item Arguments: $moniker, $component_class
  65
  66 =back
  67
  68 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
  69 calling:
  70
  71   $schema->register_source($moniker, $component_class->result_source_instance);
  72
  73 =cut
  74
  75 sub register_class {
  76   my ($self, $moniker, $to_register) = @_;
  77   $self->register_source($moniker => $to_register->result_source_instance);
  78 }
  79
  80 =head2 register_source
  81
  82 =over 4
  83
  84 =item Arguments: $moniker, $result_source
  85
  86 =back
  87
  88 Registers the L<DBIx::Class::ResultSource> in the schema with the given
  89 moniker.
  90
  91 =cut
  92
  93 sub register_source {
  94   my ($self, $moniker, $source) = @_;
  95   my %reg = %{$self->source_registrations};
  96   $reg{$moniker} = $source;
  97   $self->source_registrations(\%reg);
  98   $source->schema($self);
  99   weaken($source->{schema}) if ref($self);
 100   if ($source->result_class) {
 101     my %map = %{$self->class_mappings};
 102     $map{$source->result_class} = $moniker;
 103     $self->class_mappings(\%map);
 104   }
 105 }
 106
 107 =head2 class
 108
 109 =over 4
 110
 111 =item Arguments: $moniker
 112
 113 =item Return Value: $classname
 114
 115 =back
 116
 117 Retrieves the result class name for the given moniker. For example:
 118
 119   my $class = $schema->class('CD');
 120
 121 =cut
 122
 123 sub class {
 124   my ($self, $moniker) = @_;
 125   return $self->source($moniker)->result_class;
 126 }
 127
 128 =head2 source
 129
 130 =over 4
 131
 132 =item Arguments: $moniker
 133
 134 =item Return Value: $result_source
 135
 136 =back
 137
 138   my $source = $schema->source('Book');
 139
 140 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
 141
 142 =cut
 143
 144 sub source {
 145   my ($self, $moniker) = @_;
 146   my $sreg = $self->source_registrations;
 147   return $sreg->{$moniker} if exists $sreg->{$moniker};
 148
 149   # if we got here, they probably passed a full class name
 150   my $mapped = $self->class_mappings->{$moniker};
 151   $self->throw_exception("Can't find source for ${moniker}")
 152     unless $mapped && exists $sreg->{$mapped};
 153   return $sreg->{$mapped};
 154 }
 155
 156 =head2 sources
 157
 158 =over 4
 159
 160 =item Return Value: @source_monikers
 161
 162 =back
 163
 164 Returns the source monikers of all source registrations on this schema.
 165 For example:
 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 Return Value: $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 C<#>, 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 C<no warnings 'qw';> before your load_classes call.
 209
 210 Example:
 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
 274         $comp_class->source_name($comp) unless $comp_class->source_name;
 275
 276         push(@to_register, [ $comp_class->source_name, $comp_class ]);
 277       }
 278     }
 279   }
 280   Class::C3->reinitialize;
 281
 282   foreach my $to (@to_register) {
 283     $class->register_class(@$to);
 284     #  if $class->can('result_source_instance');
 285   }
 286 }
 287
 288 =head2 compose_connection
 289
 290 =over 4
 291
 292 =item Arguments: $target_namespace, @db_info
 293
 294 =item Return Value: $new_schema
 295
 296 =back
 297
 298 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 299 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 300 then injects the L<DBix::Class::ResultSetProxy> component and a
 301 resultset_instance classdata entry on all the new classes, in order to support
 302 $target_namespaces::$class->search(...) method calls.
 303
 304 This is primarily useful when you have a specific need for class method access
 305 to a connection. In normal usage it is preferred to call
 306 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 307 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 308 more information.
 309
 310 =cut
 311
 312 sub compose_connection {
 313   my ($self, $target, @info) = @_;
 314   my $base = 'DBIx::Class::ResultSetProxy';
 315   eval "require ${base};";
 316   $self->throw_exception
 317     ("No arguments to load_classes and couldn't load ${base} ($@)")
 318       if $@;
 319
 320   if ($self eq $target) {
 321     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
 322     foreach my $moniker ($self->sources) {
 323       my $source = $self->source($moniker);
 324       my $class = $source->result_class;
 325       $self->inject_base($class, $base);
 326       $class->mk_classdata(resultset_instance => $source->resultset);
 327       $class->mk_classdata(class_resolver => $self);
 328     }
 329     $self->connection(@info);
 330     return $self;
 331   }
 332
 333   my $schema = $self->compose_namespace($target, $base);
 334   {
 335     no strict 'refs';
 336     *{"${target}::schema"} = sub { $schema };
 337   }
 338
 339   $schema->connection(@info);
 340   foreach my $moniker ($schema->sources) {
 341     my $source = $schema->source($moniker);
 342     my $class = $source->result_class;
 343     #warn "$moniker $class $source ".$source->storage;
 344     $class->mk_classdata(result_source_instance => $source);
 345     $class->mk_classdata(resultset_instance => $source->resultset);
 346     $class->mk_classdata(class_resolver => $schema);
 347   }
 348   return $schema;
 349 }
 350
 351 =head2 compose_namespace
 352
 353 =over 4
 354
 355 =item Arguments: $target_namespace, $additional_base_class?
 356
 357 =item Return Value: $new_schema
 358
 359 =back
 360
 361 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
 362 class in the target namespace (e.g. $target_namespace::CD,
 363 $target_namespace::Artist) that inherits from the corresponding classes
 364 attached to the current schema.
 365
 366 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 367 new $schema object. If C<$additional_base_class> is given, the new composed
 368 classes will inherit from first the corresponding classe from the current
 369 schema then the base class.
 370
 371 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
 372
 373   $schema->compose_namespace('My::DB', 'Base::Class');
 374   print join (', ', @My::DB::CD::ISA) . "\n";
 375   print join (', ', @My::DB::Artist::ISA) ."\n";
 376
 377 will produce the output
 378
 379   My::Schema::CD, Base::Class
 380   My::Schema::Artist, Base::Class
 381
 382 =cut
 383
 384 sub compose_namespace {
 385   my ($self, $target, $base) = @_;
 386   my %reg = %{ $self->source_registrations };
 387   my %target;
 388   my %map;
 389   my $schema = $self->clone;
 390   {
 391     no warnings qw/redefine/;
 392     local *Class::C3::reinitialize = sub { };
 393     foreach my $moniker ($schema->sources) {
 394       my $source = $schema->source($moniker);
 395       my $target_class = "${target}::${moniker}";
 396       $self->inject_base(
 397         $target_class => $source->result_class, ($base ? $base : ())
 398       );
 399       $source->result_class($target_class);
 400     }
 401   }
 402   Class::C3->reinitialize();
 403   {
 404     no strict 'refs';
 405     foreach my $meth (qw/class source resultset/) {
 406       *{"${target}::${meth}"} =
 407         sub { shift->schema->$meth(@_) };
 408     }
 409   }
 410   return $schema;
 411 }
 412
 413 =head2 setup_connection_class
 414
 415 =over 4
 416
 417 =item Arguments: $target, @info
 418
 419 =back
 420
 421 Sets up a database connection class to inject between the schema and the
 422 subclasses that the schema creates.
 423
 424 =cut
 425
 426 sub setup_connection_class {
 427   my ($class, $target, @info) = @_;
 428   $class->inject_base($target => 'DBIx::Class::DB');
 429   #$target->load_components('DB');
 430   $target->connection(@info);
 431 }
 432
 433 =head2 connection
 434
 435 =over 4
 436
 437 =item Arguments: @args
 438
 439 =item Return Value: $new_schema
 440
 441 =back
 442
 443 Instantiates a new Storage object of type
 444 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
 445 $storage->connect_info. Sets the connection in-place on the schema. See
 446 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
 447
 448 =cut
 449
 450 sub connection {
 451   my ($self, @info) = @_;
 452   return $self if !@info && $self->storage;
 453   my $storage_class = $self->storage_type;
 454   $storage_class = 'DBIx::Class::Storage'.$storage_class
 455     if $storage_class =~ m/^::/;
 456   eval "require ${storage_class};";
 457   $self->throw_exception(
 458     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
 459   ) if $@;
 460   my $storage = $storage_class->new;
 461   $storage->connect_info(\@info);
 462   $self->storage($storage);
 463   $self->on_connect() if($self->can('on_connect'));
 464   return $self;
 465 }
 466
 467 =head2 connect
 468
 469 =over 4
 470
 471 =item Arguments: @info
 472
 473 =item Return Value: $new_schema
 474
 475 =back
 476
 477 This is a convenience method. It is equivalent to calling
 478 $schema->clone->connection(@info). See L</connection> and L</clone> for more
 479 information.
 480
 481 =cut
 482
 483 sub connect { shift->clone->connection(@_) }
 484
 485 =head2 txn_begin
 486
 487 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
 488 calling $schema->storage->txn_begin. See
 489 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
 490
 491 =cut
 492
 493 sub txn_begin { shift->storage->txn_begin }
 494
 495 =head2 txn_commit
 496
 497 Commits the current transaction. Equivalent to calling
 498 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
 499 for more information.
 500
 501 =cut
 502
 503 sub txn_commit { shift->storage->txn_commit }
 504
 505 =head2 txn_rollback
 506
 507 Rolls back the current transaction. Equivalent to calling
 508 $schema->storage->txn_rollback. See
 509 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
 510
 511 =cut
 512
 513 sub txn_rollback { shift->storage->txn_rollback }
 514
 515 =head2 txn_do
 516
 517 =over 4
 518
 519 =item Arguments: C<$coderef>, @coderef_args?
 520
 521 =item Return Value: The return value of $coderef
 522
 523 =back
 524
 525 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
 526 returning its result (if any). If an exception is caught, a rollback is issued
 527 and the exception is rethrown. If the rollback fails, (i.e. throws an
 528 exception) an exception is thrown that includes a "Rollback failed" message.
 529
 530 For example,
 531
 532   my $author_rs = $schema->resultset('Author')->find(1);
 533
 534   my $coderef = sub {
 535     my ($author, @titles) = @_;
 536
 537     # If any one of these fails, the entire transaction fails
 538     $author->create_related('books', {
 539       title => $_
 540     }) foreach (@titles);
 541
 542     return $author->books;
 543   };
 544
 545   my $rs;
 546   eval {
 547     $rs = $schema->txn_do($coderef, $author_rs, qw/Night Day It/);
 548   };
 549
 550   if ($@) {
 551     my $error = $@;
 552     if ($error =~ /Rollback failed/) {
 553       die "something terrible has happened!";
 554     } else {
 555       deal_with_failed_transaction();
 556     }
 557   }
 558
 559 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
 560 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
 561 the Schema's storage, and txn_do() can be called in void, scalar and list
 562 context and it will behave as expected.
 563
 564 =cut
 565
 566 sub txn_do {
 567   my ($self, $coderef, @args) = @_;
 568
 569   ref $self or $self->throw_exception
 570     ('Cannot execute txn_do as a class method');
 571   ref $coderef eq 'CODE' or $self->throw_exception
 572     ('$coderef must be a CODE reference');
 573
 574   my (@return_values, $return_value);
 575
 576   $self->txn_begin; # If this throws an exception, no rollback is needed
 577
 578   my $wantarray = wantarray; # Need to save this since the context
 579                              # inside the eval{} block is independent
 580                              # of the context that called txn_do()
 581   eval {
 582
 583     # Need to differentiate between scalar/list context to allow for
 584     # returning a list in scalar context to get the size of the list
 585     if ($wantarray) {
 586       # list context
 587       @return_values = $coderef->(@args);
 588     } elsif (defined $wantarray) {
 589       # scalar context
 590       $return_value = $coderef->(@args);
 591     } else {
 592       # void context
 593       $coderef->(@args);
 594     }
 595     $self->txn_commit;
 596   };
 597
 598   if ($@) {
 599     my $error = $@;
 600
 601     eval {
 602       $self->txn_rollback;
 603     };
 604
 605     if ($@) {
 606       my $rollback_error = $@;
 607       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
 608       $self->throw_exception($error)  # propagate nested rollback
 609         if $rollback_error =~ /$exception_class/;
 610
 611       $self->throw_exception(
 612         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
 613       );
 614     } else {
 615       $self->throw_exception($error); # txn failed but rollback succeeded
 616     }
 617   }
 618
 619   return $wantarray ? @return_values : $return_value;
 620 }
 621
 622 =head2 clone
 623
 624 =over 4
 625
 626 =item Return Value: $new_schema
 627
 628 =back
 629
 630 Clones the schema and its associated result_source objects and returns the
 631 copy.
 632
 633 =cut
 634
 635 sub clone {
 636   my ($self) = @_;
 637   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
 638   foreach my $moniker ($self->sources) {
 639     my $source = $self->source($moniker);
 640     my $new = $source->new($source);
 641     $clone->register_source($moniker => $new);
 642   }
 643   return $clone;
 644 }
 645
 646 =head2 populate
 647
 648 =over 4
 649
 650 =item Arguments: $moniker, \@data;
 651
 652 =back
 653
 654 Populates the source registered with the given moniker with the supplied data.
 655 @data should be a list of listrefs -- the first containing column names, the
 656 second matching values.
 657
 658 i.e.,
 659
 660   $schema->populate('Artist', [
 661     [ qw/artistid name/ ],
 662     [ 1, 'Popular Band' ],
 663     [ 2, 'Indie Band' ],
 664     ...
 665   ]);
 666
 667 =cut
 668
 669 sub populate {
 670   my ($self, $name, $data) = @_;
 671   my $rs = $self->resultset($name);
 672   my @names = @{shift(@$data)};
 673   my @created;
 674   foreach my $item (@$data) {
 675     my %create;
 676     @create{@names} = @$item;
 677     push(@created, $rs->create(\%create));
 678   }
 679   return @created;
 680 }
 681
 682 =head2 throw_exception
 683
 684 =over 4
 685
 686 =item Arguments: $message
 687
 688 =back
 689
 690 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 691 user's perspective.
 692
 693 =cut
 694
 695 sub throw_exception {
 696   my ($self) = shift;
 697   croak @_;
 698 }
 699
 700 =head2 deploy (EXPERIMENTAL)
 701
 702 =over 4
 703
 704 =item Arguments: $sqlt_args
 705
 706 =back
 707
 708 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 709
 710 Note that this feature is currently EXPERIMENTAL and may not work correctly
 711 across all databases, or fully handle complex relationships.
 712
 713 =cut
 714
 715 sub deploy {
 716   my ($self, $sqltargs) = @_;
 717   $self->throw_exception("Can't deploy without storage") unless $self->storage;
 718   $self->storage->deploy($self, undef, $sqltargs);
 719 }
 720
 721 =head2 create_ddl_dir (EXPERIMENTAL)
 722
 723 =over 4
 724
 725 =item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
 726
 727 =back
 728
 729 Creates an SQL file based on the Schema, for each of the specified
 730 database types, in the given directory. Given a previous version number,
 731 this will also create a file containing the ALTER TABLE statements to
 732 transform the previous schema into the current one. Note that these
 733 statements may contain DROP TABLE or DROP COLUMN statements that can
 734 potentially destroy data.
 735
 736 The file names are created using the C<ddl_filename> method below, please
 737 override thus method in your schema if you would like a different file
 738 name format. For the ALTER file, the same format is used, replacing
 739 $version in the name with "$preversion-$version".
 740
 741 If no arguments are passed, then the following default values are used:
 742
 743 =over 4
 744
 745 =item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
 746
 747 =item version    - $schema->VERSION
 748
 749 =item directory  - './'
 750
 751 =item preversion - <none>
 752
 753 =back
 754 Note that this feature is currently EXPERIMENTAL and may not work correctly
 755 across all databases, or fully handle complex relationships.
 756
 757 WARNING: Please check all SQL files created, before applying them.
 758
 759 =cut
 760
 761 sub create_ddl_dir
 762 {
 763   my $self = shift;
 764
 765   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
 766   $self->storage->create_ddl_dir($self, @_);
 767 }
 768
 769 =head2 ddl_filename
 770
 771 =over 4
 772
 773 =item Arguments: $directory, $database-type, $version
 774
 775 =back
 776
 777 This method is called by C<create_ddl_dir> to compose a file name out of
 778 the supplied directory, database type and version number. The default file
 779 name format is: "$filename-$version-$type.sql".
 780
 781 You may override this method in your schema if you wish to use a different
 782 format.
 783
 784 =cut
 785
 786 sub ddl_filename
 787 {
 788     my ($self, $dir, $type, $version) = @_;
 789
 790     my $filename = ref($self);
 791     $filename =~ s/^.*:://;
 792     $filename = File::Spec->catpath($dir, "$filename-$version-$type.sql");
 793
 794     return $filename;
 795 }
 796
 797 1;
 798
 799 =head1 AUTHORS
 800
 801 Matt S. Trout <mst@shadowcatsystems.co.uk>
 802
 803 =head1 LICENSE
 804
 805 You may distribute this code under the same terms as Perl itself.
 806
 807 =cut
 808