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