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