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