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