lib/DBIx/Class/ResultSource.pm

   1 package DBIx::Class::ResultSource;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::ResultSet;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use Storable;
   9
  10 use base qw/DBIx::Class/;
  11 __PACKAGE__->load_components(qw/AccessorGroup/);
  12
  13 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
  14   _columns _primaries _unique_constraints name resultset_attributes
  15   schema from _relationships/);
  16
  17 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
  18   result_class/);
  19
  20 =head1 NAME
  21
  22 DBIx::Class::ResultSource - Result source object
  23
  24 =head1 SYNOPSIS
  25
  26 =head1 DESCRIPTION
  27
  28 A ResultSource is a component of a schema from which results can be directly
  29 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
  30
  31 =head1 METHODS
  32
  33 =cut
  34
  35 sub new {
  36   my ($class, $attrs) = @_;
  37   $class = ref $class if ref $class;
  38   my $new = bless({ %{$attrs || {}}, _resultset => undef }, $class);
  39   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  40   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
  41   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  42   $new->{_columns} = { %{$new->{_columns}||{}} };
  43   $new->{_relationships} = { %{$new->{_relationships}||{}} };
  44   $new->{name} ||= "!!NAME NOT SET!!";
  45   $new->{_columns_info_loaded} ||= 0;
  46   return $new;
  47 }
  48
  49 =pod
  50
  51 =head2 add_columns
  52
  53   $table->add_columns(qw/col1 col2 col3/);
  54
  55   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  56
  57 Adds columns to the result source. If supplied key => hashref pairs, uses
  58 the hashref as the column_info for that column. Repeated calls of this
  59 method will add more columns, not replace them.
  60
  61 The contents of the column_info are not set in stone. The following
  62 keys are currently recognised/used by DBIx::Class:
  63
  64 =over 4
  65
  66 =item accessor
  67
  68 Use this to set the name of the accessor for this column. If unset,
  69 the name of the column will be used.
  70
  71 =item data_type
  72
  73 This contains the column type. It is automatically filled by the
  74 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
  75 L<DBIx::Class::Schema::Loader> module. If you do not enter a
  76 data_type, DBIx::Class will attempt to retrieve it from the
  77 database for you, using L<DBI>'s column_info method. The values of this
  78 key are typically upper-cased.
  79
  80 Currently there is no standard set of values for the data_type. Use
  81 whatever your database supports.
  82
  83 =item size
  84
  85 The length of your column, if it is a column type that can have a size
  86 restriction. This is currently not used by DBIx::Class.
  87
  88 =item is_nullable
  89
  90 Set this to a true value for a columns that is allowed to contain
  91 NULL values. This is currently not used by DBIx::Class.
  92
  93 =item is_auto_increment
  94
  95 Set this to a true value for a column whose value is somehow
  96 automatically set. This is used to determine which columns to empty
  97 when cloning objects using C<copy>.
  98
  99 =item is_foreign_key
 100
 101 Set this to a true value for a column that contains a key from a
 102 foreign table. This is currently not used by DBIx::Class.
 103
 104 =item default_value
 105
 106 Set this to the default value which will be inserted into a column
 107 by the database. Can contain either a value or a function. This is
 108 currently not used by DBIx::Class.
 109
 110 =item sequence
 111
 112 Set this on a primary key column to the name of the sequence used to
 113 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
 114 will attempt to retrieve the name of the sequence from the database
 115 automatically.
 116
 117 =back
 118
 119 =head2 add_column
 120
 121   $table->add_column('col' => \%info?);
 122
 123 Convenience alias to add_columns.
 124
 125 =cut
 126
 127 sub add_columns {
 128   my ($self, @cols) = @_;
 129   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
 130
 131   my @added;
 132   my $columns = $self->_columns;
 133   while (my $col = shift @cols) {
 134     # If next entry is { ... } use that for the column info, if not
 135     # use an empty hashref
 136     my $column_info = ref $cols[0] ? shift(@cols) : {};
 137     push(@added, $col) unless exists $columns->{$col};
 138     $columns->{$col} = $column_info;
 139   }
 140   push @{ $self->_ordered_columns }, @added;
 141   return $self;
 142 }
 143
 144 *add_column = \&add_columns;
 145
 146 =head2 has_column
 147
 148   if ($obj->has_column($col)) { ... }
 149
 150 Returns true if the source has a column of this name, false otherwise.
 151
 152 =cut
 153
 154 sub has_column {
 155   my ($self, $column) = @_;
 156   return exists $self->_columns->{$column};
 157 }
 158
 159 =head2 column_info
 160
 161   my $info = $obj->column_info($col);
 162
 163 Returns the column metadata hashref for a column. See the description
 164 of add_column for information on the contents of the hashref.
 165
 166 =cut
 167
 168 sub column_info {
 169   my ($self, $column) = @_;
 170   $self->throw_exception("No such column $column")
 171     unless exists $self->_columns->{$column};
 172   #warn $self->{_columns_info_loaded}, "\n";
 173   if ( ! $self->_columns->{$column}{data_type}
 174        and ! $self->{_columns_info_loaded}
 175        and $self->schema and $self->storage )
 176   {
 177     $self->{_columns_info_loaded}++;
 178     my $info;
 179     # eval for the case of storage without table
 180     eval { $info = $self->storage->columns_info_for($self->from) };
 181     unless ($@) {
 182       foreach my $col ( keys %{$self->_columns} ) {
 183         foreach my $i ( keys %{$info->{$col}} ) {
 184             $self->_columns->{$col}{$i} = $info->{$col}{$i};
 185         }
 186       }
 187     }
 188   }
 189   return $self->_columns->{$column};
 190 }
 191
 192 =head2 columns
 193
 194   my @column_names = $obj->columns;
 195
 196 Returns all column names in the order they were declared to add_columns.
 197
 198 =cut
 199
 200 sub columns {
 201   my $self = shift;
 202   $self->throw_exception(
 203     "columns() is a read-only accessor, did you mean add_columns()?"
 204   ) if (@_ > 1);
 205   return @{$self->{_ordered_columns}||[]};
 206 }
 207
 208 =head2 set_primary_key
 209
 210 =over 4
 211
 212 =item Arguments: @cols
 213
 214 =back
 215
 216 Defines one or more columns as primary key for this source. Should be
 217 called after C<add_columns>.
 218
 219 Additionally, defines a unique constraint named C<primary>.
 220
 221 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 222 retrieve automatically created values from the database.
 223
 224 =cut
 225
 226 sub set_primary_key {
 227   my ($self, @cols) = @_;
 228   # check if primary key columns are valid columns
 229   foreach my $col (@cols) {
 230     $self->throw_exception("No such column $col on table " . $self->name)
 231       unless $self->has_column($col);
 232   }
 233   $self->_primaries(\@cols);
 234
 235   $self->add_unique_constraint(primary => \@cols);
 236 }
 237
 238 =head2 primary_columns
 239
 240 Read-only accessor which returns the list of primary keys.
 241
 242 =cut
 243
 244 sub primary_columns {
 245   return @{shift->_primaries||[]};
 246 }
 247
 248 =head2 add_unique_constraint
 249
 250 Declare a unique constraint on this source. Call once for each unique
 251 constraint. Unique constraints are used when you call C<find> on a
 252 L<DBIx::Class::ResultSet>. Only columns in the constraint are searched,
 253 for example:
 254
 255   # For UNIQUE (column1, column2)
 256   __PACKAGE__->add_unique_constraint(
 257     constraint_name => [ qw/column1 column2/ ],
 258   );
 259
 260 =cut
 261
 262 sub add_unique_constraint {
 263   my ($self, $name, $cols) = @_;
 264
 265   foreach my $col (@$cols) {
 266     $self->throw_exception("No such column $col on table " . $self->name)
 267       unless $self->has_column($col);
 268   }
 269
 270   my %unique_constraints = $self->unique_constraints;
 271   $unique_constraints{$name} = $cols;
 272   $self->_unique_constraints(\%unique_constraints);
 273 }
 274
 275 =head2 unique_constraints
 276
 277 Read-only accessor which returns the list of unique constraints on this source.
 278
 279 =cut
 280
 281 sub unique_constraints {
 282   return %{shift->_unique_constraints||{}};
 283 }
 284
 285 =head2 from
 286
 287 Returns an expression of the source to be supplied to storage to specify
 288 retrieval from this source. In the case of a database, the required FROM
 289 clause contents.
 290
 291 =cut
 292
 293 =head2 storage
 294
 295 Returns the storage handle for the current schema.
 296
 297 See also: L<DBIx::Class::Storage>
 298
 299 =cut
 300
 301 sub storage { shift->schema->storage; }
 302
 303 =head2 add_relationship
 304
 305   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 306
 307 The relationship name can be arbitrary, but must be unique for each
 308 relationship attached to this result source. 'related_source' should
 309 be the name with which the related result source was registered with
 310 the current schema. For example:
 311
 312   $schema->source('Book')->add_relationship('reviews', 'Review', {
 313     'foreign.book_id' => 'self.id',
 314   });
 315
 316 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 317 representation of the join between the tables. For example, if you're
 318 creating a rel from Author to Book,
 319
 320   { 'foreign.author_id' => 'self.id' }
 321
 322 will result in the JOIN clause
 323
 324   author me JOIN book foreign ON foreign.author_id = me.id
 325
 326 You can specify as many foreign => self mappings as necessary.
 327
 328 Valid attributes are as follows:
 329
 330 =over 4
 331
 332 =item join_type
 333
 334 Explicitly specifies the type of join to use in the relationship. Any
 335 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 336 the SQL command immediately before C<JOIN>.
 337
 338 =item proxy
 339
 340 An arrayref containing a list of accessors in the foreign class to proxy in
 341 the main class. If, for example, you do the following:
 342
 343   CD->might_have(liner_notes => 'LinerNotes', undef, {
 344     proxy => [ qw/notes/ ],
 345   });
 346
 347 Then, assuming LinerNotes has an accessor named notes, you can do:
 348
 349   my $cd = CD->find(1);
 350   # set notes -- LinerNotes object is created if it doesn't exist
 351   $cd->notes('Notes go here');
 352
 353 =item accessor
 354
 355 Specifies the type of accessor that should be created for the
 356 relationship. Valid values are C<single> (for when there is only a single
 357 related object), C<multi> (when there can be many), and C<filter> (for
 358 when there is a single related object, but you also want the relationship
 359 accessor to double as a column accessor). For C<multi> accessors, an
 360 add_to_* method is also created, which calls C<create_related> for the
 361 relationship.
 362
 363 =back
 364
 365 =cut
 366
 367 sub add_relationship {
 368   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 369   $self->throw_exception("Can't create relationship without join condition")
 370     unless $cond;
 371   $attrs ||= {};
 372
 373   my %rels = %{ $self->_relationships };
 374   $rels{$rel} = { class => $f_source_name,
 375                   source => $f_source_name,
 376                   cond  => $cond,
 377                   attrs => $attrs };
 378   $self->_relationships(\%rels);
 379
 380   return $self;
 381
 382   # XXX disabled. doesn't work properly currently. skip in tests.
 383
 384   my $f_source = $self->schema->source($f_source_name);
 385   unless ($f_source) {
 386     eval "require $f_source_name;";
 387     if ($@) {
 388       die $@ unless $@ =~ /Can't locate/;
 389     }
 390     $f_source = $f_source_name->result_source;
 391     #my $s_class = ref($self->schema);
 392     #$f_source_name =~ m/^${s_class}::(.*)$/;
 393     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 394     #$f_source = $self->schema->source($f_source_name);
 395   }
 396   return unless $f_source; # Can't test rel without f_source
 397
 398   eval { $self->resolve_join($rel, 'me') };
 399
 400   if ($@) { # If the resolve failed, back out and re-throw the error
 401     delete $rels{$rel}; #
 402     $self->_relationships(\%rels);
 403     $self->throw_exception("Error creating relationship $rel: $@");
 404   }
 405   1;
 406 }
 407
 408 =head2 relationships
 409
 410 Returns all relationship names for this source.
 411
 412 =cut
 413
 414 sub relationships {
 415   return keys %{shift->_relationships};
 416 }
 417
 418 =head2 relationship_info
 419
 420 =over 4
 421
 422 =item Arguments: $relname
 423
 424 =back
 425
 426 Returns a hash of relationship information for the specified relationship
 427 name.
 428
 429 =cut
 430
 431 sub relationship_info {
 432   my ($self, $rel) = @_;
 433   return $self->_relationships->{$rel};
 434 }
 435
 436 =head2 has_relationship
 437
 438 =over 4
 439
 440 =item Arguments: $rel
 441
 442 =back
 443
 444 Returns true if the source has a relationship of this name, false otherwise.
 445
 446 =cut
 447
 448 sub has_relationship {
 449   my ($self, $rel) = @_;
 450   return exists $self->_relationships->{$rel};
 451 }
 452
 453 =head2 resolve_join
 454
 455 =over 4
 456
 457 =item Arguments: $relation
 458
 459 =back
 460
 461 Returns the join structure required for the related result source.
 462
 463 =cut
 464
 465 sub resolve_join {
 466   my ($self, $join, $alias, $seen) = @_;
 467   $seen ||= {};
 468   if (ref $join eq 'ARRAY') {
 469     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 470   } elsif (ref $join eq 'HASH') {
 471     return
 472       map {
 473         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 474         ($self->resolve_join($_, $alias, $seen),
 475           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 476       } keys %$join;
 477   } elsif (ref $join) {
 478     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 479   } else {
 480     my $count = ++$seen->{$join};
 481     #use Data::Dumper; warn Dumper($seen);
 482     my $as = ($count > 1 ? "${join}_${count}" : $join);
 483     my $rel_info = $self->relationship_info($join);
 484     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 485     my $type = $rel_info->{attrs}{join_type} || '';
 486     return [ { $as => $self->related_source($join)->from,
 487                -join_type => $type },
 488              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 489   }
 490 }
 491
 492 =head2 resolve_condition
 493
 494 =over 4
 495
 496 =item Arguments: $cond, $as, $alias|$object
 497
 498 =back
 499
 500 Resolves the passed condition to a concrete query fragment. If given an alias,
 501 returns a join condition; if given an object, inverts that object to produce
 502 a related conditional from that object.
 503
 504 =cut
 505
 506 sub resolve_condition {
 507   my ($self, $cond, $as, $for) = @_;
 508   #warn %$cond;
 509   if (ref $cond eq 'HASH') {
 510     my %ret;
 511     foreach my $k (keys %{$cond}) {
 512       my $v = $cond->{$k};
 513       # XXX should probably check these are valid columns
 514       $k =~ s/^foreign\.// ||
 515         $self->throw_exception("Invalid rel cond key ${k}");
 516       $v =~ s/^self\.// ||
 517         $self->throw_exception("Invalid rel cond val ${v}");
 518       if (ref $for) { # Object
 519         #warn "$self $k $for $v";
 520         $ret{$k} = $for->get_column($v);
 521         #warn %ret;
 522       } elsif (!defined $for) { # undef, i.e. "no object"
 523         $ret{$k} = undef;
 524       } elsif (ref $as) { # reverse object
 525         $ret{$v} = $as->get_column($k);
 526       } elsif (!defined $as) { # undef, i.e. "no reverse object"
 527         $ret{$v} = undef;
 528       } else {
 529         $ret{"${as}.${k}"} = "${for}.${v}";
 530       }
 531     }
 532     return \%ret;
 533   } elsif (ref $cond eq 'ARRAY') {
 534     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 535   } else {
 536    die("Can't handle this yet :(");
 537   }
 538 }
 539
 540 =head2 resolve_prefetch
 541
 542 =over 4
 543
 544 =item Arguments: hashref/arrayref/scalar
 545
 546 =back
 547
 548 Accepts one or more relationships for the current source and returns an
 549 array of column names for each of those relationships. Column names are
 550 prefixed relative to the current source, in accordance with where they appear
 551 in the supplied relationships. Examples:
 552
 553   my $source = $schema->resultset('Tag')->source;
 554   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 555
 556   # @columns =
 557   #(
 558   #  'cd.cdid',
 559   #  'cd.artist',
 560   #  'cd.title',
 561   #  'cd.year',
 562   #  'cd.artist.artistid',
 563   #  'cd.artist.name'
 564   #)
 565
 566   @columns = $source->resolve_prefetch( qw[/ cd /] );
 567
 568   # @columns =
 569   #(
 570   #   'cd.cdid',
 571   #   'cd.artist',
 572   #   'cd.title',
 573   #   'cd.year'
 574   #)
 575
 576   $source = $schema->resultset('CD')->source;
 577   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 578
 579   # @columns =
 580   #(
 581   #  'artist.artistid',
 582   #  'artist.name',
 583   #  'producer.producerid',
 584   #  'producer.name'
 585   #)
 586
 587 =cut
 588
 589 sub resolve_prefetch {
 590   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 591   $seen ||= {};
 592   #$alias ||= $self->name;
 593   #warn $alias, Dumper $pre;
 594   if( ref $pre eq 'ARRAY' ) {
 595     return
 596       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 597         @$pre;
 598   }
 599   elsif( ref $pre eq 'HASH' ) {
 600     my @ret =
 601     map {
 602       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 603       $self->related_source($_)->resolve_prefetch(
 604                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 605     } keys %$pre;
 606     #die Dumper \@ret;
 607     return @ret;
 608   }
 609   elsif( ref $pre ) {
 610     $self->throw_exception(
 611       "don't know how to resolve prefetch reftype ".ref($pre));
 612   }
 613   else {
 614     my $count = ++$seen->{$pre};
 615     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 616     my $rel_info = $self->relationship_info( $pre );
 617     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 618       unless $rel_info;
 619     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 620     my $rel_source = $self->related_source($pre);
 621
 622     if (exists $rel_info->{attrs}{accessor}
 623          && $rel_info->{attrs}{accessor} eq 'multi') {
 624       $self->throw_exception(
 625         "Can't prefetch has_many ${pre} (join cond too complex)")
 626         unless ref($rel_info->{cond}) eq 'HASH';
 627       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 628                     keys %{$rel_info->{cond}};
 629       $collapse->{"${as_prefix}${pre}"} = \@key;
 630       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 631                    ? @{$rel_info->{attrs}{order_by}}
 632                    : (defined $rel_info->{attrs}{order_by}
 633                        ? ($rel_info->{attrs}{order_by})
 634                        : ()));
 635       push(@$order, map { "${as}.$_" } (@key, @ord));
 636     }
 637
 638     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 639       $rel_source->columns;
 640     #warn $alias, Dumper (\@ret);
 641     #return @ret;
 642   }
 643 }
 644
 645 =head2 related_source
 646
 647 =over 4
 648
 649 =item Arguments: $relname
 650
 651 =back
 652
 653 Returns the result source object for the given relationship.
 654
 655 =cut
 656
 657 sub related_source {
 658   my ($self, $rel) = @_;
 659   if( !$self->has_relationship( $rel ) ) {
 660     $self->throw_exception("No such relationship '$rel'");
 661   }
 662   return $self->schema->source($self->relationship_info($rel)->{source});
 663 }
 664
 665 =head2 related_class
 666
 667 =over 4
 668
 669 =item Arguments: $relname
 670
 671 =back
 672
 673 Returns the class name for objects in the given relationship.
 674
 675 =cut
 676
 677 sub related_class {
 678   my ($self, $rel) = @_;
 679   if( !$self->has_relationship( $rel ) ) {
 680     $self->throw_exception("No such relationship '$rel'");
 681   }
 682   return $self->schema->class($self->relationship_info($rel)->{source});
 683 }
 684
 685 =head2 resultset
 686
 687 Returns a resultset for the given source. This will initially be created
 688 on demand by calling
 689
 690   $self->resultset_class->new($self, $self->resultset_attributes)
 691
 692 but is cached from then on unless resultset_class changes.
 693
 694 =head2 resultset_class
 695
 696 Set the class of the resultset, this is useful if you want to create your
 697 own resultset methods. Create your own class derived from
 698 L<DBIx::Class::ResultSet>, and set it here.
 699
 700 =head2 resultset_attributes
 701
 702 Specify here any attributes you wish to pass to your specialised resultset.
 703
 704 =cut
 705
 706 sub resultset {
 707   my $self = shift;
 708   $self->throw_exception(
 709     'resultset does not take any arguments. If you want another resultset, '.
 710     'call it on the schema instead.'
 711   ) if scalar @_;
 712
 713   # disabled until we can figure out a way to do it without consistency issues
 714   #
 715   #return $self->{_resultset}
 716   #  if ref $self->{_resultset} eq $self->resultset_class;
 717   #return $self->{_resultset} =
 718
 719   return $self->resultset_class->new(
 720     $self, $self->{resultset_attributes}
 721   );
 722 }
 723
 724 =head2 throw_exception
 725
 726 See L<DBIx::Class::Schema/"throw_exception">.
 727
 728 =cut
 729
 730 sub throw_exception {
 731   my $self = shift;
 732   if (defined $self->schema) {
 733     $self->schema->throw_exception(@_);
 734   } else {
 735     croak(@_);
 736   }
 737 }
 738
 739 =head1 AUTHORS
 740
 741 Matt S. Trout <mst@shadowcatsystems.co.uk>
 742
 743 =head1 LICENSE
 744
 745 You may distribute this code under the same terms as Perl itself.
 746
 747 =cut
 748