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 remove_columns
 209
 210   $table->remove_columns(qw/col1 col2 col3/);
 211
 212 Removes columns from the result source.
 213
 214 =head2 remove_column
 215
 216   $table->remove_column('col');
 217
 218 Convenience alias to remove_columns.
 219
 220 =cut
 221
 222 sub remove_columns {
 223   my ($self, @cols) = @_;
 224
 225   return unless $self->_ordered_columns;
 226
 227   my $columns = $self->_columns;
 228   my @remaining;
 229
 230   foreach my $col (@{$self->_ordered_columns}) {
 231     push @remaining, $col unless grep(/$col/, @cols);
 232   }
 233
 234   foreach (@cols) {
 235     undef $columns->{$_};
 236   };
 237
 238   $self->_ordered_columns(\@remaining);
 239 }
 240
 241 *remove_column = \&remove_columns;
 242
 243 =head2 set_primary_key
 244
 245 =over 4
 246
 247 =item Arguments: @cols
 248
 249 =back
 250
 251 Defines one or more columns as primary key for this source. Should be
 252 called after C<add_columns>.
 253
 254 Additionally, defines a unique constraint named C<primary>.
 255
 256 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 257 retrieve automatically created values from the database.
 258
 259 =cut
 260
 261 sub set_primary_key {
 262   my ($self, @cols) = @_;
 263   # check if primary key columns are valid columns
 264   foreach my $col (@cols) {
 265     $self->throw_exception("No such column $col on table " . $self->name)
 266       unless $self->has_column($col);
 267   }
 268   $self->_primaries(\@cols);
 269
 270   $self->add_unique_constraint(primary => \@cols);
 271 }
 272
 273 =head2 primary_columns
 274
 275 Read-only accessor which returns the list of primary keys.
 276
 277 =cut
 278
 279 sub primary_columns {
 280   return @{shift->_primaries||[]};
 281 }
 282
 283 =head2 add_unique_constraint
 284
 285 Declare a unique constraint on this source. Call once for each unique
 286 constraint. Unique constraints are used when you call C<find> on a
 287 L<DBIx::Class::ResultSet>. Only columns in the constraint are searched,
 288 for example:
 289
 290   # For UNIQUE (column1, column2)
 291   __PACKAGE__->add_unique_constraint(
 292     constraint_name => [ qw/column1 column2/ ],
 293   );
 294
 295 =cut
 296
 297 sub add_unique_constraint {
 298   my ($self, $name, $cols) = @_;
 299
 300   foreach my $col (@$cols) {
 301     $self->throw_exception("No such column $col on table " . $self->name)
 302       unless $self->has_column($col);
 303   }
 304
 305   my %unique_constraints = $self->unique_constraints;
 306   $unique_constraints{$name} = $cols;
 307   $self->_unique_constraints(\%unique_constraints);
 308 }
 309
 310 =head2 unique_constraints
 311
 312 Read-only accessor which returns the list of unique constraints on this source.
 313
 314 =cut
 315
 316 sub unique_constraints {
 317   return %{shift->_unique_constraints||{}};
 318 }
 319
 320 =head2 from
 321
 322 Returns an expression of the source to be supplied to storage to specify
 323 retrieval from this source. In the case of a database, the required FROM
 324 clause contents.
 325
 326 =cut
 327
 328 =head2 storage
 329
 330 Returns the storage handle for the current schema.
 331
 332 See also: L<DBIx::Class::Storage>
 333
 334 =cut
 335
 336 sub storage { shift->schema->storage; }
 337
 338 =head2 add_relationship
 339
 340   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 341
 342 The relationship name can be arbitrary, but must be unique for each
 343 relationship attached to this result source. 'related_source' should
 344 be the name with which the related result source was registered with
 345 the current schema. For example:
 346
 347   $schema->source('Book')->add_relationship('reviews', 'Review', {
 348     'foreign.book_id' => 'self.id',
 349   });
 350
 351 The condition C<$cond> needs to be an L<SQL::Abstract>-style
 352 representation of the join between the tables. For example, if you're
 353 creating a rel from Author to Book,
 354
 355   { 'foreign.author_id' => 'self.id' }
 356
 357 will result in the JOIN clause
 358
 359   author me JOIN book foreign ON foreign.author_id = me.id
 360
 361 You can specify as many foreign => self mappings as necessary.
 362
 363 Valid attributes are as follows:
 364
 365 =over 4
 366
 367 =item join_type
 368
 369 Explicitly specifies the type of join to use in the relationship. Any
 370 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 371 the SQL command immediately before C<JOIN>.
 372
 373 =item proxy
 374
 375 An arrayref containing a list of accessors in the foreign class to proxy in
 376 the main class. If, for example, you do the following:
 377
 378   CD->might_have(liner_notes => 'LinerNotes', undef, {
 379     proxy => [ qw/notes/ ],
 380   });
 381
 382 Then, assuming LinerNotes has an accessor named notes, you can do:
 383
 384   my $cd = CD->find(1);
 385   # set notes -- LinerNotes object is created if it doesn't exist
 386   $cd->notes('Notes go here');
 387
 388 =item accessor
 389
 390 Specifies the type of accessor that should be created for the
 391 relationship. Valid values are C<single> (for when there is only a single
 392 related object), C<multi> (when there can be many), and C<filter> (for
 393 when there is a single related object, but you also want the relationship
 394 accessor to double as a column accessor). For C<multi> accessors, an
 395 add_to_* method is also created, which calls C<create_related> for the
 396 relationship.
 397
 398 =back
 399
 400 =cut
 401
 402 sub add_relationship {
 403   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 404   $self->throw_exception("Can't create relationship without join condition")
 405     unless $cond;
 406   $attrs ||= {};
 407
 408   my %rels = %{ $self->_relationships };
 409   $rels{$rel} = { class => $f_source_name,
 410                   source => $f_source_name,
 411                   cond  => $cond,
 412                   attrs => $attrs };
 413   $self->_relationships(\%rels);
 414
 415   return $self;
 416
 417   # XXX disabled. doesn't work properly currently. skip in tests.
 418
 419   my $f_source = $self->schema->source($f_source_name);
 420   unless ($f_source) {
 421     eval "require $f_source_name;";
 422     if ($@) {
 423       die $@ unless $@ =~ /Can't locate/;
 424     }
 425     $f_source = $f_source_name->result_source;
 426     #my $s_class = ref($self->schema);
 427     #$f_source_name =~ m/^${s_class}::(.*)$/;
 428     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 429     #$f_source = $self->schema->source($f_source_name);
 430   }
 431   return unless $f_source; # Can't test rel without f_source
 432
 433   eval { $self->resolve_join($rel, 'me') };
 434
 435   if ($@) { # If the resolve failed, back out and re-throw the error
 436     delete $rels{$rel}; #
 437     $self->_relationships(\%rels);
 438     $self->throw_exception("Error creating relationship $rel: $@");
 439   }
 440   1;
 441 }
 442
 443 =head2 relationships
 444
 445 Returns all relationship names for this source.
 446
 447 =cut
 448
 449 sub relationships {
 450   return keys %{shift->_relationships};
 451 }
 452
 453 =head2 relationship_info
 454
 455 =over 4
 456
 457 =item Arguments: $relname
 458
 459 =back
 460
 461 Returns a hash of relationship information for the specified relationship
 462 name.
 463
 464 =cut
 465
 466 sub relationship_info {
 467   my ($self, $rel) = @_;
 468   return $self->_relationships->{$rel};
 469 }
 470
 471 =head2 has_relationship
 472
 473 =over 4
 474
 475 =item Arguments: $rel
 476
 477 =back
 478
 479 Returns true if the source has a relationship of this name, false otherwise.
 480
 481 =cut
 482
 483 sub has_relationship {
 484   my ($self, $rel) = @_;
 485   return exists $self->_relationships->{$rel};
 486 }
 487
 488 =head2 resolve_join
 489
 490 =over 4
 491
 492 =item Arguments: $relation
 493
 494 =back
 495
 496 Returns the join structure required for the related result source.
 497
 498 =cut
 499
 500 sub resolve_join {
 501   my ($self, $join, $alias, $seen) = @_;
 502   $seen ||= {};
 503   if (ref $join eq 'ARRAY') {
 504     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 505   } elsif (ref $join eq 'HASH') {
 506     return
 507       map {
 508         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 509         ($self->resolve_join($_, $alias, $seen),
 510           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 511       } keys %$join;
 512   } elsif (ref $join) {
 513     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 514   } else {
 515     my $count = ++$seen->{$join};
 516     #use Data::Dumper; warn Dumper($seen);
 517     my $as = ($count > 1 ? "${join}_${count}" : $join);
 518     my $rel_info = $self->relationship_info($join);
 519     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 520     my $type = $rel_info->{attrs}{join_type} || '';
 521     return [ { $as => $self->related_source($join)->from,
 522                -join_type => $type },
 523              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 524   }
 525 }
 526
 527 =head2 resolve_condition
 528
 529 =over 4
 530
 531 =item Arguments: $cond, $as, $alias|$object
 532
 533 =back
 534
 535 Resolves the passed condition to a concrete query fragment. If given an alias,
 536 returns a join condition; if given an object, inverts that object to produce
 537 a related conditional from that object.
 538
 539 =cut
 540
 541 sub resolve_condition {
 542   my ($self, $cond, $as, $for) = @_;
 543   #warn %$cond;
 544   if (ref $cond eq 'HASH') {
 545     my %ret;
 546     while (my ($k, $v) = each %{$cond}) {
 547       # XXX should probably check these are valid columns
 548       $k =~ s/^foreign\.// ||
 549         $self->throw_exception("Invalid rel cond key ${k}");
 550       $v =~ s/^self\.// ||
 551         $self->throw_exception("Invalid rel cond val ${v}");
 552       if (ref $for) { # Object
 553         #warn "$self $k $for $v";
 554         $ret{$k} = $for->get_column($v);
 555         #warn %ret;
 556       } elsif (ref $as) { # reverse object
 557         $ret{$v} = $as->get_column($k);
 558       } else {
 559         $ret{"${as}.${k}"} = "${for}.${v}";
 560       }
 561     }
 562     return \%ret;
 563   } elsif (ref $cond eq 'ARRAY') {
 564     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 565   } else {
 566    die("Can't handle this yet :(");
 567   }
 568 }
 569
 570 =head2 resolve_prefetch
 571
 572 =over 4
 573
 574 =item Arguments: hashref/arrayref/scalar
 575
 576 =back
 577
 578 Accepts one or more relationships for the current source and returns an
 579 array of column names for each of those relationships. Column names are
 580 prefixed relative to the current source, in accordance with where they appear
 581 in the supplied relationships. Examples:
 582
 583   my $source = $schema->resultset('Tag')->source;
 584   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 585
 586   # @columns =
 587   #(
 588   #  'cd.cdid',
 589   #  'cd.artist',
 590   #  'cd.title',
 591   #  'cd.year',
 592   #  'cd.artist.artistid',
 593   #  'cd.artist.name'
 594   #)
 595
 596   @columns = $source->resolve_prefetch( qw[/ cd /] );
 597
 598   # @columns =
 599   #(
 600   #   'cd.cdid',
 601   #   'cd.artist',
 602   #   'cd.title',
 603   #   'cd.year'
 604   #)
 605
 606   $source = $schema->resultset('CD')->source;
 607   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 608
 609   # @columns =
 610   #(
 611   #  'artist.artistid',
 612   #  'artist.name',
 613   #  'producer.producerid',
 614   #  'producer.name'
 615   #)
 616
 617 =cut
 618
 619 sub resolve_prefetch {
 620   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 621   $seen ||= {};
 622   #$alias ||= $self->name;
 623   #warn $alias, Dumper $pre;
 624   if( ref $pre eq 'ARRAY' ) {
 625     return
 626       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 627         @$pre;
 628   }
 629   elsif( ref $pre eq 'HASH' ) {
 630     my @ret =
 631     map {
 632       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 633       $self->related_source($_)->resolve_prefetch(
 634                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 635     } keys %$pre;
 636     #die Dumper \@ret;
 637     return @ret;
 638   }
 639   elsif( ref $pre ) {
 640     $self->throw_exception(
 641       "don't know how to resolve prefetch reftype ".ref($pre));
 642   }
 643   else {
 644     my $count = ++$seen->{$pre};
 645     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 646     my $rel_info = $self->relationship_info( $pre );
 647     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 648       unless $rel_info;
 649     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 650     my $rel_source = $self->related_source($pre);
 651
 652     if (exists $rel_info->{attrs}{accessor}
 653          && $rel_info->{attrs}{accessor} eq 'multi') {
 654       $self->throw_exception(
 655         "Can't prefetch has_many ${pre} (join cond too complex)")
 656         unless ref($rel_info->{cond}) eq 'HASH';
 657       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 658                     keys %{$rel_info->{cond}};
 659       $collapse->{"${as_prefix}${pre}"} = \@key;
 660       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 661                    ? @{$rel_info->{attrs}{order_by}}
 662                    : (defined $rel_info->{attrs}{order_by}
 663                        ? ($rel_info->{attrs}{order_by})
 664                        : ()));
 665       push(@$order, map { "${as}.$_" } (@key, @ord));
 666     }
 667
 668     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 669       $rel_source->columns;
 670     #warn $alias, Dumper (\@ret);
 671     #return @ret;
 672   }
 673 }
 674
 675 =head2 related_source
 676
 677 =over 4
 678
 679 =item Arguments: $relname
 680
 681 =back
 682
 683 Returns the result source object for the given relationship.
 684
 685 =cut
 686
 687 sub related_source {
 688   my ($self, $rel) = @_;
 689   if( !$self->has_relationship( $rel ) ) {
 690     $self->throw_exception("No such relationship '$rel'");
 691   }
 692   return $self->schema->source($self->relationship_info($rel)->{source});
 693 }
 694
 695 =head2 related_class
 696
 697 =over 4
 698
 699 =item Arguments: $relname
 700
 701 =back
 702
 703 Returns the class name for objects in the given relationship.
 704
 705 =cut
 706
 707 sub related_class {
 708   my ($self, $rel) = @_;
 709   if( !$self->has_relationship( $rel ) ) {
 710     $self->throw_exception("No such relationship '$rel'");
 711   }
 712   return $self->schema->class($self->relationship_info($rel)->{source});
 713 }
 714
 715 =head2 resultset
 716
 717 Returns a resultset for the given source. This will initially be created
 718 on demand by calling
 719
 720   $self->resultset_class->new($self, $self->resultset_attributes)
 721
 722 but is cached from then on unless resultset_class changes.
 723
 724 =head2 resultset_class
 725
 726 Set the class of the resultset, this is useful if you want to create your
 727 own resultset methods. Create your own class derived from
 728 L<DBIx::Class::ResultSet>, and set it here.
 729
 730 =head2 resultset_attributes
 731
 732 Specify here any attributes you wish to pass to your specialised resultset.
 733
 734 =cut
 735
 736 sub resultset {
 737   my $self = shift;
 738   $self->throw_exception(
 739     'resultset does not take any arguments. If you want another resultset, '.
 740     'call it on the schema instead.'
 741   ) if scalar @_;
 742   return $self->{_resultset}
 743     if ref $self->{_resultset} eq $self->resultset_class;
 744   return $self->{_resultset} = $self->resultset_class->new(
 745     $self, $self->{resultset_attributes}
 746   );
 747 }
 748
 749 =head2 throw_exception
 750
 751 See L<DBIx::Class::Schema/"throw_exception">.
 752
 753 =cut
 754
 755 sub throw_exception {
 756   my $self = shift;
 757   if (defined $self->schema) {
 758     $self->schema->throw_exception(@_);
 759   } else {
 760     croak(@_);
 761   }
 762 }
 763
 764 =head1 AUTHORS
 765
 766 Matt S. Trout <mst@shadowcatsystems.co.uk>
 767
 768 =head1 LICENSE
 769
 770 You may distribute this code under the same terms as Perl itself.
 771
 772 =cut
 773