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