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