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
  11 use base qw/DBIx::Class/;
  12 __PACKAGE__->load_components(qw/AccessorGroup/);
  13
  14 __PACKAGE__->mk_group_accessors('simple' =>
  15   qw/_ordered_columns _columns _primaries _unique_constraints name resultset_attributes schema from _relationships/);
  16 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class result_class/);
  17
  18 =head1 NAME
  19
  20 DBIx::Class::ResultSource - Result source object
  21
  22 =head1 SYNOPSIS
  23
  24 =head1 DESCRIPTION
  25
  26 A ResultSource is a component of a schema from which results can be directly
  27 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
  28
  29 =head1 METHODS
  30
  31 =cut
  32
  33 sub new {
  34   my ($class, $attrs) = @_;
  35   $class = ref $class if ref $class;
  36   my $new = bless({ %{$attrs || {}} }, $class);
  37   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  38   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
  39   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  40   $new->{_columns} = { %{$new->{_columns}||{}} };
  41   $new->{_relationships} = { %{$new->{_relationships}||{}} };
  42   $new->{name} ||= "!!NAME NOT SET!!";
  43   $new->{_columns_info_loaded} ||= 0;
  44   return $new;
  45 }
  46
  47 =head2 add_columns
  48
  49   $table->add_columns(qw/col1 col2 col3/);
  50
  51   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  52
  53 Adds columns to the result source. If supplied key => hashref pairs uses
  54 the hashref as the column_info for that column.
  55
  56 =head2 add_column
  57
  58   $table->add_column('col' => \%info?);
  59
  60 Convenience alias to add_columns
  61
  62 =cut
  63
  64 sub add_columns {
  65   my ($self, @cols) = @_;
  66   $self->_ordered_columns( \@cols )
  67     if !$self->_ordered_columns;
  68   my @added;
  69   my $columns = $self->_columns;
  70   while (my $col = shift @cols) {
  71
  72     my $column_info = ref $cols[0] ? shift(@cols) : {};
  73       # If next entry is { ... } use that for the column info, if not
  74       # use an empty hashref
  75
  76     push(@added, $col) unless exists $columns->{$col};
  77
  78     $columns->{$col} = $column_info;
  79   }
  80   push @{ $self->_ordered_columns }, @added;
  81   return $self;
  82 }
  83
  84 *add_column = \&add_columns;
  85
  86 =head2 has_column
  87
  88   if ($obj->has_column($col)) { ... }
  89
  90 Returns 1 if the source has a column of this name, 0 otherwise.
  91
  92 =cut
  93
  94 sub has_column {
  95   my ($self, $column) = @_;
  96   return exists $self->_columns->{$column};
  97 }
  98
  99 =head2 column_info
 100
 101   my $info = $obj->column_info($col);
 102
 103 Returns the column metadata hashref for a column.
 104
 105 =cut
 106
 107 sub column_info {
 108   my ($self, $column) = @_;
 109   $self->throw_exception("No such column $column")
 110     unless exists $self->_columns->{$column};
 111   #warn $self->{_columns_info_loaded}, "\n";
 112   if ( ! $self->_columns->{$column}->{data_type}
 113        && ! $self->{_columns_info_loaded}
 114        && $self->schema && $self->storage() ){
 115       $self->{_columns_info_loaded}++;
 116       my $info;
 117 ############ eval for the case of storage without table
 118       eval{
 119           $info = $self->storage->columns_info_for ( $self->from() );
 120       };
 121       if ( ! $@ ){
 122           for my $col ( keys %{$self->_columns} ){
 123               for my $i ( keys %{$info->{$col}} ){
 124                   $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
 125               }
 126           }
 127       }
 128   }
 129   return $self->_columns->{$column};
 130 }
 131
 132 =head2 columns
 133
 134   my @column_names = $obj->columns;
 135
 136 Returns all column names in the order they were declared to add_columns
 137
 138 =cut
 139
 140 sub columns {
 141   my $self=shift;
 142   $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
 143   return @{$self->{_ordered_columns}||[]};
 144 }
 145
 146 =head2 set_primary_key(@cols)
 147
 148 Defines one or more columns as primary key for this source. Should be
 149 called after C<add_columns>.
 150
 151 Additionally, defines a unique constraint named C<primary>.
 152
 153 =cut
 154
 155 sub set_primary_key {
 156   my ($self, @cols) = @_;
 157   # check if primary key columns are valid columns
 158   for (@cols) {
 159     $self->throw_exception("No such column $_ on table ".$self->name)
 160       unless $self->has_column($_);
 161   }
 162   $self->_primaries(\@cols);
 163
 164   $self->add_unique_constraint(primary => \@cols);
 165 }
 166
 167 =head2 primary_columns
 168
 169 Read-only accessor which returns the list of primary keys.
 170
 171 =cut
 172
 173 sub primary_columns {
 174   return @{shift->_primaries||[]};
 175 }
 176
 177 =head2 add_unique_constraint
 178
 179 Declare a unique constraint on this source. Call once for each unique
 180 constraint.
 181
 182   # For e.g. UNIQUE (column1, column2)
 183   __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
 184
 185 =cut
 186
 187 sub add_unique_constraint {
 188   my ($self, $name, $cols) = @_;
 189
 190   for (@$cols) {
 191     $self->throw_exception("No such column $_ on table ".$self->name)
 192       unless $self->has_column($_);
 193   }
 194
 195   my %unique_constraints = $self->unique_constraints;
 196   $unique_constraints{$name} = $cols;
 197   $self->_unique_constraints(\%unique_constraints);
 198 }
 199
 200 =head2 unique_constraints
 201
 202 Read-only accessor which returns the list of unique constraints on this source.
 203
 204 =cut
 205
 206 sub unique_constraints {
 207   return %{shift->_unique_constraints||{}};
 208 }
 209
 210 =head2 from
 211
 212 Returns an expression of the source to be supplied to storage to specify
 213 retrieval from this source; in the case of a database the required FROM clause
 214 contents.
 215
 216 =cut
 217
 218 =head2 storage
 219
 220 Returns the storage handle for the current schema
 221
 222 =cut
 223
 224 sub storage { shift->schema->storage; }
 225
 226 =head2 add_relationship
 227
 228   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 229
 230 The relation name can be arbitrary, but must be unique for each relationship
 231 attached to this result source. 'related_source' should be the name with
 232 which the related result source was registered with the current schema
 233 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
 234
 235 The condition needs to be an SQL::Abstract-style representation of the join
 236 between the tables. For example, if you're creating a rel from Foo to Bar,
 237
 238   { 'foreign.foo_id' => 'self.id' }
 239
 240 will result in the JOIN clause
 241
 242   foo me JOIN bar bar ON bar.foo_id = me.id
 243
 244 You can specify as many foreign => self mappings as necessary.
 245
 246 Valid attributes are as follows:
 247
 248 =over 4
 249
 250 =item join_type
 251
 252 Explicitly specifies the type of join to use in the relationship. Any SQL
 253 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
 254 command immediately before C<JOIN>.
 255
 256 =item proxy
 257
 258 An arrayref containing a list of accessors in the foreign class to proxy in
 259 the main class. If, for example, you do the following:
 260
 261   __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
 262
 263 Then, assuming Bar has an accessor named margle, you can do:
 264
 265   my $obj = Foo->find(1);
 266   $obj->margle(10); # set margle; Bar object is created if it doesn't exist
 267
 268 =item accessor
 269
 270 Specifies the type of accessor that should be created for the relationship.
 271 Valid values are C<single> (for when there is only a single related object),
 272 C<multi> (when there can be many), and C<filter> (for when there is a single
 273 related object, but you also want the relationship accessor to double as
 274 a column accessor). For C<multi> accessors, an add_to_* method is also
 275 created, which calls C<create_related> for the relationship.
 276
 277 =back
 278
 279 =cut
 280
 281 sub add_relationship {
 282   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 283   $self->throw_exception("Can't create relationship without join condition") unless $cond;
 284   $attrs ||= {};
 285
 286   my %rels = %{ $self->_relationships };
 287   $rels{$rel} = { class => $f_source_name,
 288                   source => $f_source_name,
 289                   cond  => $cond,
 290                   attrs => $attrs };
 291   $self->_relationships(\%rels);
 292
 293   return $self;
 294
 295   # XXX disabled. doesn't work properly currently. skip in tests.
 296
 297   my $f_source = $self->schema->source($f_source_name);
 298   unless ($f_source) {
 299     eval "require $f_source_name;";
 300     if ($@) {
 301       die $@ unless $@ =~ /Can't locate/;
 302     }
 303     $f_source = $f_source_name->result_source;
 304     #my $s_class = ref($self->schema);
 305     #$f_source_name =~ m/^${s_class}::(.*)$/;
 306     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 307     #$f_source = $self->schema->source($f_source_name);
 308   }
 309   return unless $f_source; # Can't test rel without f_source
 310
 311   eval { $self->resolve_join($rel, 'me') };
 312
 313   if ($@) { # If the resolve failed, back out and re-throw the error
 314     delete $rels{$rel}; #
 315     $self->_relationships(\%rels);
 316     $self->throw_exception("Error creating relationship $rel: $@");
 317   }
 318   1;
 319 }
 320
 321 =head2 relationships()
 322
 323 Returns all valid relationship names for this source
 324
 325 =cut
 326
 327 sub relationships {
 328   return keys %{shift->_relationships};
 329 }
 330
 331 =head2 relationship_info($relname)
 332
 333 Returns the relationship information for the specified relationship name
 334
 335 =cut
 336
 337 sub relationship_info {
 338   my ($self, $rel) = @_;
 339   return $self->_relationships->{$rel};
 340 }
 341
 342 =head2 has_relationship($rel)
 343
 344 Returns 1 if the source has a relationship of this name, 0 otherwise.
 345
 346 =cut
 347
 348 sub has_relationship {
 349   my ($self, $rel) = @_;
 350   return exists $self->_relationships->{$rel};
 351 }
 352
 353 =head2 resolve_join($relation)
 354
 355 Returns the join structure required for the related result source
 356
 357 =cut
 358
 359 sub resolve_join {
 360   my ($self, $join, $alias, $seen) = @_;
 361   $seen ||= {};
 362   if (ref $join eq 'ARRAY') {
 363     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 364   } elsif (ref $join eq 'HASH') {
 365     return
 366       map {
 367         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 368         ($self->resolve_join($_, $alias, $seen),
 369           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 370       } keys %$join;
 371   } elsif (ref $join) {
 372     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 373   } else {
 374     my $count = ++$seen->{$join};
 375     #use Data::Dumper; warn Dumper($seen);
 376     my $as = ($count > 1 ? "${join}_${count}" : $join);
 377     my $rel_info = $self->relationship_info($join);
 378     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 379     my $type = $rel_info->{attrs}{join_type} || '';
 380     return [ { $as => $self->related_source($join)->from,
 381                -join_type => $type },
 382              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 383   }
 384 }
 385
 386 =head2 resolve_condition($cond, $as, $alias|$object)
 387
 388 Resolves the passed condition to a concrete query fragment. If given an alias,
 389 returns a join condition; if given an object, inverts that object to produce
 390 a related conditional from that object.
 391
 392 =cut
 393
 394 sub resolve_condition {
 395   my ($self, $cond, $as, $for) = @_;
 396   #warn %$cond;
 397   if (ref $cond eq 'HASH') {
 398     my %ret;
 399     while (my ($k, $v) = each %{$cond}) {
 400       # XXX should probably check these are valid columns
 401       $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
 402       $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
 403       if (ref $for) { # Object
 404         #warn "$self $k $for $v";
 405         $ret{$k} = $for->get_column($v);
 406         #warn %ret;
 407       } else {
 408         $ret{"${as}.${k}"} = "${for}.${v}";
 409       }
 410     }
 411     return \%ret;
 412   } elsif (ref $cond eq 'ARRAY') {
 413     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 414   } else {
 415    die("Can't handle this yet :(");
 416   }
 417 }
 418
 419 =head2 resolve_prefetch (hashref/arrayref/scalar)
 420
 421 Accepts one or more relationships for the current source and returns an
 422 array of column names for each of those relationships. Column names are
 423 prefixed relative to the current source, in accordance with where they appear
 424 in the supplied relationships. Examples:
 425
 426   my $source = $schema->resultset('Tag')->source;
 427   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 428
 429   # @columns =
 430   #(
 431   #  'cd.cdid',
 432   #  'cd.artist',
 433   #  'cd.title',
 434   #  'cd.year',
 435   #  'cd.artist.artistid',
 436   #  'cd.artist.name'
 437   #)
 438
 439   @columns = $source->resolve_prefetch( qw[/ cd /] );
 440
 441   # @columns =
 442   #(
 443   #   'cd.cdid',
 444   #   'cd.artist',
 445   #   'cd.title',
 446   #   'cd.year'
 447   #)
 448
 449   $source = $schema->resultset('CD')->source;
 450   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 451
 452   # @columns =
 453   #(
 454   #  'artist.artistid',
 455   #  'artist.name',
 456   #  'producer.producerid',
 457   #  'producer.name'
 458   #)
 459
 460 =cut
 461
 462 sub resolve_prefetch {
 463   my ($self, $pre, $alias, $seen) = @_;
 464   $seen ||= {};
 465   use Data::Dumper;
 466   #$alias ||= $self->name;
 467   #warn $alias, Dumper $pre;
 468   if( ref $pre eq 'ARRAY' ) {
 469     return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
 470   }
 471   elsif( ref $pre eq 'HASH' ) {
 472     my @ret =
 473     map {
 474       $self->resolve_prefetch($_, $alias, $seen),
 475       $self->related_source($_)->resolve_prefetch(
 476                                    $pre->{$_}, "${alias}.$_", $seen)
 477         } keys %$pre;
 478     #die Dumper \@ret;
 479     return @ret;
 480   }
 481   elsif( ref $pre ) {
 482     $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
 483   }
 484   else {
 485     my $count = ++$seen->{$pre};
 486     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 487     my $rel_info = $self->relationship_info( $pre );
 488     $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
 489     my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
 490     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 491       $self->related_source($pre)->columns;
 492     #warn $alias, Dumper (\@ret);
 493     #return @ret;
 494   }
 495 }
 496
 497 =head2 related_source($relname)
 498
 499 Returns the result source for the given relationship
 500
 501 =cut
 502
 503 sub related_source {
 504   my ($self, $rel) = @_;
 505   if( !$self->has_relationship( $rel ) ) {
 506     $self->throw_exception("No such relationship '$rel'");
 507   }
 508   return $self->schema->source($self->relationship_info($rel)->{source});
 509 }
 510
 511 =head2 resultset
 512
 513 Returns a resultset for the given source created by calling
 514
 515 $self->resultset_class->new($self, $self->resultset_attributes)
 516
 517 =head2 resultset_class
 518
 519 Simple accessor.
 520
 521 =head2 resultset_attributes
 522
 523 Simple accessor.
 524
 525 =cut
 526
 527 sub resultset {
 528   my $self = shift;
 529   return $self->resultset_class->new($self, $self->{resultset_attributes});
 530 }
 531
 532 =head2 throw_exception
 533
 534 See schema's throw_exception
 535
 536 =cut
 537
 538 sub throw_exception {
 539   my $self = shift;
 540   if (defined $self->schema) {
 541     $self->schema->throw_exception(@_);
 542   } else {
 543     croak(@_);
 544   }
 545 }
 546
 547
 548 =head1 AUTHORS
 549
 550 Matt S. Trout <mst@shadowcatsystems.co.uk>
 551
 552 =head1 LICENSE
 553
 554 You may distribute this code under the same terms as Perl itself.
 555
 556 =cut
 557