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