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