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