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.
  59
  60 Repeated calls of this method will add more columns, not replace them.
  61
  62 The contents of the column_info are not set in stone, the following
  63 keys are currently recognised/used by DBIx::Class.
  64
  65 =over 4
  66
  67 =item accessor
  68
  69 Use this to set the name of the accessor for this column. If unset,
  70 the name of the column will be used.
  71
  72 =item data_type
  73
  74 This contains the column type, it is automatically filled by the
  75 L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
  76 L<DBIx::Class::Schema::Loader> module. If you do not enter the
  77 data_type, DBIx::Class will attempt to retrieve it from the
  78 database for you, using L<DBI>s column_info method. The values of this
  79 key are typically upper-cased.
  80
  81 Currently there is no standard set of values for the data_type, use
  82 whatever your database(s) support.
  83
  84 =item size
  85
  86 The length of your column, if it is a column type that can have a size
  87 restriction. This is currently not used by DBIx::Class.
  88
  89 =item is_nullable
  90
  91 If the column is allowed to contain NULL values, set a true value
  92 (typically 1), here. This is currently not used by DBIx::Class.
  93
  94 =item is_auto_increment
  95
  96 Set this to a true value if this is a column that is somehow
  97 automatically filled. This is used to determine which columns to empty
  98 when cloning objects using C<copy>.
  99
 100 =item is_foreign_key
 101
 102 Set this to a true value if this column represents a key from a
 103 foreign table. This is currently not used by DBIx::Class.
 104
 105 =item default_value
 106
 107 Set this to the default value which will be inserted into this column
 108 by the database. Can contain either values or functions. This is
 109 currently not used by DBIx::Class.
 110
 111 =item sequence
 112
 113 Sets the name of the sequence to use to generate values.  If not
 114 specified, L<DBIx::Class::PK::Auto> will attempt to retrieve the
 115 name of the sequence from the database 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 1 if the source has a column of this name, 0 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
 254 e.g.,
 255
 256   # For UNIQUE (column1, column2)
 257   __PACKAGE__->add_unique_constraint(
 258     constraint_name => [ qw/column1 column2/ ],
 259   );
 260
 261 =cut
 262
 263 sub add_unique_constraint {
 264   my ($self, $name, $cols) = @_;
 265
 266   foreach my $col (@$cols) {
 267     $self->throw_exception("No such column $col on table " . $self->name)
 268       unless $self->has_column($col);
 269   }
 270
 271   my %unique_constraints = $self->unique_constraints;
 272   $unique_constraints{$name} = $cols;
 273   $self->_unique_constraints(\%unique_constraints);
 274 }
 275
 276 =head2 unique_constraints
 277
 278 Read-only accessor which returns the list of unique constraints on this source.
 279
 280 =cut
 281
 282 sub unique_constraints {
 283   return %{shift->_unique_constraints||{}};
 284 }
 285
 286 =head2 from
 287
 288 Returns an expression of the source to be supplied to storage to specify
 289 retrieval from this source; in the case of a database the required FROM clause
 290 contents.
 291
 292 =cut
 293
 294 =head2 storage
 295
 296 Returns the storage handle for the current schema.
 297
 298 See also: L<DBIx::Class::Storage>
 299
 300 =cut
 301
 302 sub storage { shift->schema->storage; }
 303
 304 =head2 add_relationship
 305
 306   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 307
 308 The relationship name can be arbitrary, but must be unique for each
 309 relationship attached to this result source. 'related_source' should
 310 be the name with which the related result source was registered with
 311 the current schema. For example:
 312
 313   $schema->source('Book')->add_relationship('reviews', 'Review', {
 314     'foreign.book_id' => 'self.id',
 315   });
 316
 317 The condition C<$cond> needs to be an SQL::Abstract-style
 318 representation of the join between the tables. For example, if you're
 319 creating a rel from Author to Book,
 320
 321   { 'foreign.author_id' => 'self.id' }
 322
 323 will result in the JOIN clause
 324
 325   author me JOIN book foreign ON foreign.author_id = me.id
 326
 327 You can specify as many foreign => self mappings as necessary.
 328
 329 Valid attributes are as follows:
 330
 331 =over 4
 332
 333 =item join_type
 334
 335 Explicitly specifies the type of join to use in the relationship. Any
 336 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 337 the SQL command immediately before C<JOIN>.
 338
 339 =item proxy
 340
 341 An arrayref containing a list of accessors in the foreign class to proxy in
 342 the main class. If, for example, you do the following:
 343
 344   CD->might_have(liner_notes => 'LinerNotes', undef, {
 345     proxy => [ qw/notes/ ],
 346   });
 347
 348 Then, assuming LinerNotes has an accessor named notes, you can do:
 349
 350   my $cd = CD->find(1);
 351   $cd->notes('Notes go here'); # set notes -- LinerNotes object is
 352                                # created if it doesn't exist
 353
 354 =item accessor
 355
 356 Specifies the type of accessor that should be created for the
 357 relationship. Valid values are C<single> (for when there is only a single
 358 related object), C<multi> (when there can be many), and C<filter> (for
 359 when there is a single related object, but you also want the relationship
 360 accessor to double as a column accessor). For C<multi> accessors, an
 361 add_to_* method is also created, which calls C<create_related> for the
 362 relationship.
 363
 364 =back
 365
 366 =cut
 367
 368 sub add_relationship {
 369   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 370   $self->throw_exception("Can't create relationship without join condition")
 371     unless $cond;
 372   $attrs ||= {};
 373
 374   my %rels = %{ $self->_relationships };
 375   $rels{$rel} = { class => $f_source_name,
 376                   source => $f_source_name,
 377                   cond  => $cond,
 378                   attrs => $attrs };
 379   $self->_relationships(\%rels);
 380
 381   return $self;
 382
 383   # XXX disabled. doesn't work properly currently. skip in tests.
 384
 385   my $f_source = $self->schema->source($f_source_name);
 386   unless ($f_source) {
 387     eval "require $f_source_name;";
 388     if ($@) {
 389       die $@ unless $@ =~ /Can't locate/;
 390     }
 391     $f_source = $f_source_name->result_source;
 392     #my $s_class = ref($self->schema);
 393     #$f_source_name =~ m/^${s_class}::(.*)$/;
 394     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 395     #$f_source = $self->schema->source($f_source_name);
 396   }
 397   return unless $f_source; # Can't test rel without f_source
 398
 399   eval { $self->resolve_join($rel, 'me') };
 400
 401   if ($@) { # If the resolve failed, back out and re-throw the error
 402     delete $rels{$rel}; #
 403     $self->_relationships(\%rels);
 404     $self->throw_exception("Error creating relationship $rel: $@");
 405   }
 406   1;
 407 }
 408
 409 =head2 relationships
 410
 411 Returns all valid relationship names for this source
 412
 413 =cut
 414
 415 sub relationships {
 416   return keys %{shift->_relationships};
 417 }
 418
 419 =head2 relationship_info
 420
 421 =over 4
 422
 423 =item Arguments: ($relname)
 424
 425 =back
 426
 427 Returns the relationship information for the specified relationship 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 1 if the source has a relationship of this name, 0 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     while (my ($k, $v) = each %{$cond}) {
 512       # XXX should probably check these are valid columns
 513       $k =~ s/^foreign\.// ||
 514         $self->throw_exception("Invalid rel cond key ${k}");
 515       $v =~ s/^self\.// ||
 516         $self->throw_exception("Invalid rel cond val ${v}");
 517       if (ref $for) { # Object
 518         #warn "$self $k $for $v";
 519         $ret{$k} = $for->get_column($v);
 520         #warn %ret;
 521       } elsif (ref $as) { # reverse object
 522         $ret{$v} = $as->get_column($k);
 523       } else {
 524         $ret{"${as}.${k}"} = "${for}.${v}";
 525       }
 526     }
 527     return \%ret;
 528   } elsif (ref $cond eq 'ARRAY') {
 529     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 530   } else {
 531    die("Can't handle this yet :(");
 532   }
 533 }
 534
 535 =head2 resolve_prefetch
 536
 537 =over 4
 538
 539 =item Arguments: (hashref/arrayref/scalar)
 540
 541 =back
 542
 543 Accepts one or more relationships for the current source and returns an
 544 array of column names for each of those relationships. Column names are
 545 prefixed relative to the current source, in accordance with where they appear
 546 in the supplied relationships. Examples:
 547
 548   my $source = $schema->resultset('Tag')->source;
 549   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 550
 551   # @columns =
 552   #(
 553   #  'cd.cdid',
 554   #  'cd.artist',
 555   #  'cd.title',
 556   #  'cd.year',
 557   #  'cd.artist.artistid',
 558   #  'cd.artist.name'
 559   #)
 560
 561   @columns = $source->resolve_prefetch( qw[/ cd /] );
 562
 563   # @columns =
 564   #(
 565   #   'cd.cdid',
 566   #   'cd.artist',
 567   #   'cd.title',
 568   #   'cd.year'
 569   #)
 570
 571   $source = $schema->resultset('CD')->source;
 572   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 573
 574   # @columns =
 575   #(
 576   #  'artist.artistid',
 577   #  'artist.name',
 578   #  'producer.producerid',
 579   #  'producer.name'
 580   #)
 581
 582 =cut
 583
 584 sub resolve_prefetch {
 585   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 586   $seen ||= {};
 587   #$alias ||= $self->name;
 588   #warn $alias, Dumper $pre;
 589   if( ref $pre eq 'ARRAY' ) {
 590     return
 591       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 592         @$pre;
 593   }
 594   elsif( ref $pre eq 'HASH' ) {
 595     my @ret =
 596     map {
 597       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 598       $self->related_source($_)->resolve_prefetch(
 599                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 600     } keys %$pre;
 601     #die Dumper \@ret;
 602     return @ret;
 603   }
 604   elsif( ref $pre ) {
 605     $self->throw_exception(
 606       "don't know how to resolve prefetch reftype ".ref($pre));
 607   }
 608   else {
 609     my $count = ++$seen->{$pre};
 610     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 611     my $rel_info = $self->relationship_info( $pre );
 612     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 613       unless $rel_info;
 614     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 615     my $rel_source = $self->related_source($pre);
 616
 617     if (exists $rel_info->{attrs}{accessor}
 618          && $rel_info->{attrs}{accessor} eq 'multi') {
 619       $self->throw_exception(
 620         "Can't prefetch has_many ${pre} (join cond too complex)")
 621         unless ref($rel_info->{cond}) eq 'HASH';
 622       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 623                     keys %{$rel_info->{cond}};
 624       $collapse->{"${as_prefix}${pre}"} = \@key;
 625       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 626                    ? @{$rel_info->{attrs}{order_by}}
 627                    : (defined $rel_info->{attrs}{order_by}
 628                        ? ($rel_info->{attrs}{order_by})
 629                        : ()));
 630       push(@$order, map { "${as}.$_" } (@key, @ord));
 631     }
 632
 633     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 634       $rel_source->columns;
 635     #warn $alias, Dumper (\@ret);
 636     #return @ret;
 637   }
 638 }
 639
 640 =head2 related_source
 641
 642 =over 4
 643
 644 =item Arguments: ($relname)
 645
 646 =back
 647
 648 Returns the result source object for the given relationship
 649
 650 =cut
 651
 652 sub related_source {
 653   my ($self, $rel) = @_;
 654   if( !$self->has_relationship( $rel ) ) {
 655     $self->throw_exception("No such relationship '$rel'");
 656   }
 657   return $self->schema->source($self->relationship_info($rel)->{source});
 658 }
 659
 660 =head2 related_class
 661
 662 =over 4
 663
 664 =item Arguments: ($relname)
 665
 666 =back
 667
 668 Returns the class object for the given relationship
 669
 670 =cut
 671
 672 sub related_class {
 673   my ($self, $rel) = @_;
 674   if( !$self->has_relationship( $rel ) ) {
 675     $self->throw_exception("No such relationship '$rel'");
 676   }
 677   return $self->schema->class($self->relationship_info($rel)->{source});
 678 }
 679
 680 =head2 resultset
 681
 682 Returns a resultset for the given source. This will initially be created
 683 on demand by calling
 684
 685   $self->resultset_class->new($self, $self->resultset_attributes)
 686
 687 but is cached from then on unless resultset_class changes.
 688
 689 =head2 resultset_class
 690
 691 Set the class of the resultset, this is useful if you want to create your
 692 own resultset methods. Create your own class derived from
 693 L<DBIx::Class::ResultSet>, and set it here.
 694
 695 =head2 resultset_attributes
 696
 697 Specify here any attributes you wish to pass to your specialised resultset.
 698
 699 =cut
 700
 701 sub resultset {
 702   my $self = shift;
 703   $self->throw_exception(
 704     'resultset does not take any arguments. If you want another resultset, '.
 705     'call it on the schema instead.'
 706   ) if scalar @_;
 707   return $self->{_resultset}
 708     if ref $self->{_resultset} eq $self->resultset_class;
 709   return $self->{_resultset} = $self->resultset_class->new(
 710     $self, $self->{resultset_attributes}
 711   );
 712 }
 713
 714 =head2 throw_exception
 715
 716 See throw_exception in L<DBIx::Class::Schema>.
 717
 718 =cut
 719
 720 sub throw_exception {
 721   my $self = shift;
 722   if (defined $self->schema) {
 723     $self->schema->throw_exception(@_);
 724   } else {
 725     croak(@_);
 726   }
 727 }
 728
 729
 730 =head1 AUTHORS
 731
 732 Matt S. Trout <mst@shadowcatsystems.co.uk>
 733
 734 =head1 LICENSE
 735
 736 You may distribute this code under the same terms as Perl itself.
 737
 738 =cut
 739