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