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