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 relation name can be arbitrary, but must be unique for each relationship
 297 attached to this result source. 'related_source' should be the name with
 298 which the related result source was registered with the current schema
 299 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
 300
 301 The condition needs to be an SQL::Abstract-style representation of the join
 302 between the tables. For example, if you're creating a rel from Author to Book,
 303
 304   { 'foreign.author_id' => 'self.id' }
 305
 306 will result in the JOIN clause
 307
 308   author me JOIN book foreign ON foreign.author_id = me.id
 309
 310 You can specify as many foreign => self mappings as necessary.
 311
 312 Valid attributes are as follows:
 313
 314 =over 4
 315
 316 =item join_type
 317
 318 Explicitly specifies the type of join to use in the relationship. Any
 319 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 320 the SQL command immediately before C<JOIN>.
 321
 322 =item proxy
 323
 324 An arrayref containing a list of accessors in the foreign class to
 325 proxy in the main class. If, for example, you do the following:
 326
 327   __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/] });
 328
 329 Then, assuming Bar has an accessor named margle, you can do:
 330
 331   my $obj = Foo->find(1);
 332   $obj->margle(10); # set margle; Bar object is created if it doesn't exist
 333
 334 =item accessor
 335
 336 Specifies the type of accessor that should be created for the
 337 relationship. Valid values are C<single> (for when there is only a single
 338 related object), C<multi> (when there can be many), and C<filter> (for
 339 when there is a single related object, but you also want the relationship
 340 accessor to double as a column accessor). For C<multi> accessors, an
 341 add_to_* method is also created, which calls C<create_related> for the
 342 relationship.
 343
 344 =back
 345
 346 =cut
 347
 348 sub add_relationship {
 349   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 350   $self->throw_exception("Can't create relationship without join condition") unless $cond;
 351   $attrs ||= {};
 352
 353   my %rels = %{ $self->_relationships };
 354   $rels{$rel} = { class => $f_source_name,
 355                   source => $f_source_name,
 356                   cond  => $cond,
 357                   attrs => $attrs };
 358   $self->_relationships(\%rels);
 359
 360   return $self;
 361
 362   # XXX disabled. doesn't work properly currently. skip in tests.
 363
 364   my $f_source = $self->schema->source($f_source_name);
 365   unless ($f_source) {
 366     eval "require $f_source_name;";
 367     if ($@) {
 368       die $@ unless $@ =~ /Can't locate/;
 369     }
 370     $f_source = $f_source_name->result_source;
 371     #my $s_class = ref($self->schema);
 372     #$f_source_name =~ m/^${s_class}::(.*)$/;
 373     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 374     #$f_source = $self->schema->source($f_source_name);
 375   }
 376   return unless $f_source; # Can't test rel without f_source
 377
 378   eval { $self->resolve_join($rel, 'me') };
 379
 380   if ($@) { # If the resolve failed, back out and re-throw the error
 381     delete $rels{$rel}; #
 382     $self->_relationships(\%rels);
 383     $self->throw_exception("Error creating relationship $rel: $@");
 384   }
 385   1;
 386 }
 387
 388 =head2 relationships
 389
 390 Returns all valid relationship names for this source
 391
 392 =cut
 393
 394 sub relationships {
 395   return keys %{shift->_relationships};
 396 }
 397
 398 =head2 relationship_info
 399
 400 =head3 Arguments: ($relname)
 401
 402 Returns the relationship information for the specified relationship name
 403
 404 =cut
 405
 406 sub relationship_info {
 407   my ($self, $rel) = @_;
 408   return $self->_relationships->{$rel};
 409 }
 410
 411 =head2 has_relationship
 412
 413 =head3 Arguments: ($rel)
 414
 415 Returns 1 if the source has a relationship of this name, 0 otherwise.
 416
 417 =cut
 418
 419 sub has_relationship {
 420   my ($self, $rel) = @_;
 421   return exists $self->_relationships->{$rel};
 422 }
 423
 424 =head2 resolve_join
 425
 426 =head3 Arguments: ($relation)
 427
 428 Returns the join structure required for the related result source
 429
 430 =cut
 431
 432 sub resolve_join {
 433   my ($self, $join, $alias, $seen) = @_;
 434   $seen ||= {};
 435   if (ref $join eq 'ARRAY') {
 436     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 437   } elsif (ref $join eq 'HASH') {
 438     return
 439       map {
 440         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 441         ($self->resolve_join($_, $alias, $seen),
 442           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 443       } keys %$join;
 444   } elsif (ref $join) {
 445     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 446   } else {
 447     my $count = ++$seen->{$join};
 448     #use Data::Dumper; warn Dumper($seen);
 449     my $as = ($count > 1 ? "${join}_${count}" : $join);
 450     my $rel_info = $self->relationship_info($join);
 451     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 452     my $type = $rel_info->{attrs}{join_type} || '';
 453     return [ { $as => $self->related_source($join)->from,
 454                -join_type => $type },
 455              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 456   }
 457 }
 458
 459 =head2 resolve_condition
 460
 461 =head3 Arguments: ($cond, $as, $alias|$object)
 462
 463 Resolves the passed condition to a concrete query fragment. If given an alias,
 464 returns a join condition; if given an object, inverts that object to produce
 465 a related conditional from that object.
 466
 467 =cut
 468
 469 sub resolve_condition {
 470   my ($self, $cond, $as, $for) = @_;
 471   #warn %$cond;
 472   if (ref $cond eq 'HASH') {
 473     my %ret;
 474     while (my ($k, $v) = each %{$cond}) {
 475       # XXX should probably check these are valid columns
 476       $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
 477       $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
 478       if (ref $for) { # Object
 479         #warn "$self $k $for $v";
 480         $ret{$k} = $for->get_column($v);
 481         #warn %ret;
 482       } elsif (ref $as) { # reverse object
 483         $ret{$v} = $as->get_column($k);
 484       } else {
 485         $ret{"${as}.${k}"} = "${for}.${v}";
 486       }
 487     }
 488     return \%ret;
 489   } elsif (ref $cond eq 'ARRAY') {
 490     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 491   } else {
 492    die("Can't handle this yet :(");
 493   }
 494 }
 495
 496 =head2 resolve_prefetch
 497
 498 =head3 Arguments: (hashref/arrayref/scalar)
 499
 500 Accepts one or more relationships for the current source and returns an
 501 array of column names for each of those relationships. Column names are
 502 prefixed relative to the current source, in accordance with where they appear
 503 in the supplied relationships. Examples:
 504
 505   my $source = $schema->resultset('Tag')->source;
 506   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 507
 508   # @columns =
 509   #(
 510   #  'cd.cdid',
 511   #  'cd.artist',
 512   #  'cd.title',
 513   #  'cd.year',
 514   #  'cd.artist.artistid',
 515   #  'cd.artist.name'
 516   #)
 517
 518   @columns = $source->resolve_prefetch( qw[/ cd /] );
 519
 520   # @columns =
 521   #(
 522   #   'cd.cdid',
 523   #   'cd.artist',
 524   #   'cd.title',
 525   #   'cd.year'
 526   #)
 527
 528   $source = $schema->resultset('CD')->source;
 529   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 530
 531   # @columns =
 532   #(
 533   #  'artist.artistid',
 534   #  'artist.name',
 535   #  'producer.producerid',
 536   #  'producer.name'
 537   #)
 538
 539 =cut
 540
 541 sub resolve_prefetch {
 542   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
 543   $seen ||= {};
 544   #$alias ||= $self->name;
 545   #warn $alias, Dumper $pre;
 546   if( ref $pre eq 'ARRAY' ) {
 547     return
 548       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
 549         @$pre;
 550   }
 551   elsif( ref $pre eq 'HASH' ) {
 552     my @ret =
 553     map {
 554       $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
 555       $self->related_source($_)->resolve_prefetch(
 556                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
 557     } keys %$pre;
 558     #die Dumper \@ret;
 559     return @ret;
 560   }
 561   elsif( ref $pre ) {
 562     $self->throw_exception(
 563       "don't know how to resolve prefetch reftype ".ref($pre));
 564   }
 565   else {
 566     my $count = ++$seen->{$pre};
 567     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 568     my $rel_info = $self->relationship_info( $pre );
 569     $self->throw_exception( $self->name . " has no such relationship '$pre'" )
 570       unless $rel_info;
 571     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
 572     my $rel_source = $self->related_source($pre);
 573
 574     if (exists $rel_info->{attrs}{accessor}
 575          && $rel_info->{attrs}{accessor} eq 'multi') {
 576       $self->throw_exception(
 577         "Can't prefetch has_many ${pre} (join cond too complex)")
 578         unless ref($rel_info->{cond}) eq 'HASH';
 579       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
 580                     keys %{$rel_info->{cond}};
 581       $collapse->{"${as_prefix}${pre}"} = \@key;
 582       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
 583                    ? @{$rel_info->{attrs}{order_by}}
 584                    : (defined $rel_info->{attrs}{order_by}
 585                        ? ($rel_info->{attrs}{order_by})
 586                        : ()));
 587       push(@$order, map { "${as}.$_" } (@key, @ord));
 588     }
 589
 590     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 591       $rel_source->columns;
 592     #warn $alias, Dumper (\@ret);
 593     #return @ret;
 594   }
 595 }
 596
 597 =head2 related_source
 598
 599 =head3 Arguments: ($relname)
 600
 601 Returns the result source object for the given relationship
 602
 603 =cut
 604
 605 sub related_source {
 606   my ($self, $rel) = @_;
 607   if( !$self->has_relationship( $rel ) ) {
 608     $self->throw_exception("No such relationship '$rel'");
 609   }
 610   return $self->schema->source($self->relationship_info($rel)->{source});
 611 }
 612
 613 =head2 resultset
 614
 615 Returns a resultset for the given source, by calling:
 616
 617   $self->resultset_class->new($self, $self->resultset_attributes)
 618
 619 =head2 resultset_class
 620
 621 Set the class of the resultset, this is useful if you want to create your
 622 own resultset methods. Create your own class derived from
 623 L<DBIx::Class::ResultSet>, and set it here.
 624
 625 =head2 resultset_attributes
 626
 627 Specify here any attributes you wish to pass to your specialised resultset.
 628
 629 =cut
 630
 631 sub resultset {
 632   my $self = shift;
 633   $self->throw_exception('resultset does not take any arguments. If you want another resultset, call it on the schema instead.') if scalar @_;
 634   return $self->{_resultset} if ref $self->{_resultset} eq $self->resultset_class;
 635   return $self->{_resultset} = $self->resultset_class->new($self, $self->{resultset_attributes});
 636 }
 637
 638 =head2 throw_exception
 639
 640 See throw_exception in L<DBIx::Class::Schema>.
 641
 642 =cut
 643
 644 sub throw_exception {
 645   my $self = shift;
 646   if (defined $self->schema) {
 647     $self->schema->throw_exception(@_);
 648   } else {
 649     croak(@_);
 650   }
 651 }
 652
 653
 654 =head1 AUTHORS
 655
 656 Matt S. Trout <mst@shadowcatsystems.co.uk>
 657
 658 =head1 LICENSE
 659
 660 You may distribute this code under the same terms as Perl itself.
 661
 662 =cut
 663