[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSource.pm

package DBIx::Class::ResultSource;

use strict;
use warnings;

use DBIx::Class::ResultSet;

use Carp qw/croak/;

use Storable;

use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/AccessorGroup/);

__PACKAGE__->mk_group_accessors('simple' =>
  qw/_ordered_columns _columns _primaries _unique_constraints name resultset_class result_class schema from _relationships/);

=head1 NAME 

DBIx::Class::ResultSource - Result source object

=head1 SYNOPSIS

=head1 DESCRIPTION

A ResultSource is a component of a schema from which results can be directly
retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)

=head1 METHODS

=cut

sub new {
  my ($class, $attrs) = @_;
  $class = ref $class if ref $class;
  my $new = bless({ %{$attrs || {}} }, $class);
  $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  $new->{_columns} = { %{$new->{_columns}||{}} };
  $new->{_relationships} = { %{$new->{_relationships}||{}} };
  $new->{name} ||= "!!NAME NOT SET!!";
  return $new;
}

sub add_columns {
  my ($self, @cols) = @_;
  $self->_ordered_columns( \@cols )
    if !$self->_ordered_columns;
  my @added;
  my $columns = $self->_columns;
  while (my $col = shift @cols) {

    my $column_info = ref $cols[0] ? shift(@cols) : {};
      # If next entry is { ... } use that for the column info, if not
      # use an empty hashref

    push(@added, $col) unless exists $columns->{$col};

    $columns->{$col} = $column_info;
  }
  push @{ $self->_ordered_columns }, @added;
  return $self;
}

*add_column = \&add_columns;

=head2 add_columns

  $table->add_columns(qw/col1 col2 col3/);

  $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);

Adds columns to the result source. If supplied key => hashref pairs uses
the hashref as the column_info for that column.

=head2 add_column

  $table->add_column('col' => \%info?);

Convenience alias to add_columns

=cut

sub resultset {
  my $self = shift;
  return $self->resultset_class->new($self);
}

=head2 has_column

  if ($obj->has_column($col)) { ... }                                           
                                                                                
Returns 1 if the source has a column of this name, 0 otherwise.
                                                                                
=cut                                                                            

sub has_column {
  my ($self, $column) = @_;
  return exists $self->_columns->{$column};
}

=head2 column_info 

  my $info = $obj->column_info($col);                                           

Returns the column metadata hashref for a column.
                                                                                
=cut                                                                            

sub column_info {
  my ($self, $column) = @_;
  croak "No such column $column" unless exists $self->_columns->{$column};
  if ( (! $self->_columns->{$column}->{data_type})
       && $self->schema && $self->storage() ){
      my $info;
############ eval for the case of storage without table 
      eval{
          $info = $self->storage->columns_info_for ( $self->from() );
      };
      if ( ! $@ ){
          for my $col ( keys %{$self->_columns} ){
              for my $i ( keys %{$info->{$col}} ){
                  $self->_columns()->{$col}->{$i} = $info->{$col}->{$i};
              }
          }
      }
  }
  return $self->_columns->{$column};
}

=head2 columns

  my @column_names = $obj->columns;

Returns all column names in the order they were declared to add_columns

=cut

sub columns {
  croak "columns() is a read-only accessor, did you mean add_columns()?" if (@_ > 1);
  return @{shift->{_ordered_columns}||[]};
}

=head2 set_primary_key(@cols)

Defines one or more columns as primary key for this source. Should be
called after C<add_columns>.

Additionally, defines a unique constraint named C<primary>.

=cut

sub set_primary_key {
  my ($self, @cols) = @_;
  # check if primary key columns are valid columns
  for (@cols) {
    $self->throw("No such column $_ on table ".$self->name)
      unless $self->has_column($_);
  }
  $self->_primaries(\@cols);

  $self->add_unique_constraint(primary => \@cols);
}

=head2 primary_columns

Read-only accessor which returns the list of primary keys.

=cut

sub primary_columns {
  return @{shift->_primaries||[]};
}

=head2 add_unique_constraint

Declare a unique constraint on this source. Call once for each unique
constraint.

  # For e.g. UNIQUE (column1, column2)
  __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);

=cut

sub add_unique_constraint {
  my ($self, $name, $cols) = @_;

  for (@$cols) {
    $self->throw("No such column $_ on table ".$self->name)
      unless $self->has_column($_);
  }

  my %unique_constraints = $self->unique_constraints;
  $unique_constraints{$name} = $cols;
  $self->_unique_constraints(\%unique_constraints);
}

=head2 unique_constraints

Read-only accessor which returns the list of unique constraints on this source.

=cut

sub unique_constraints {
  return %{shift->_unique_constraints||{}};
}

=head2 from

Returns an expression of the source to be supplied to storage to specify
retrieval from this source; in the case of a database the required FROM clause
contents.

=cut

=head2 storage

Returns the storage handle for the current schema

=cut

sub storage { shift->schema->storage; }

=head2 add_relationship

  $source->add_relationship('relname', 'related_source', $cond, $attrs);

The relation name can be arbitrary, but must be unique for each relationship
attached to this result source. 'related_source' should be the name with
which the related result source was registered with the current schema
(for simple schemas this is usally either Some::Namespace::Foo or just Foo)

The condition needs to be an SQL::Abstract-style representation of the join
between the tables. For example, if you're creating a rel from Foo to Bar,

  { 'foreign.foo_id' => 'self.id' }                                             
                                                                                
will result in the JOIN clause                                                  
                                                                                
  foo me JOIN bar bar ON bar.foo_id = me.id                                     
                                                                                
You can specify as many foreign => self mappings as necessary.

Valid attributes are as follows:                                                
                                                                                
=over 4                                                                         
                                                                                
=item join_type                                                                 
                                                                                
Explicitly specifies the type of join to use in the relationship. Any SQL       
join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL      
command immediately before C<JOIN>.                                             
                                                                                
=item proxy                                                                     
                                                                                
An arrayref containing a list of accessors in the foreign class to proxy in     
the main class. If, for example, you do the following:                          
                                                                                
  __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => qw[/ margle /] });    
                                                                                
Then, assuming Bar has an accessor named margle, you can do:                    
                                                                                
  my $obj = Foo->find(1);                                                       
  $obj->margle(10); # set margle; Bar object is created if it doesn't exist     
                                                                                
=item accessor                                                                  
                                                                                
Specifies the type of accessor that should be created for the relationship.     
Valid values are C<single> (for when there is only a single related object),    
C<multi> (when there can be many), and C<filter> (for when there is a single    
related object, but you also want the relationship accessor to double as        
a column accessor). For C<multi> accessors, an add_to_* method is also          
created, which calls C<create_related> for the relationship.                    
                                                                                
=back

=cut

sub add_relationship {
  my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
  croak "Can't create relationship without join condition" unless $cond;
  $attrs ||= {};

  my %rels = %{ $self->_relationships };
  $rels{$rel} = { class => $f_source_name,
                  source => $f_source_name,
                  cond  => $cond,
                  attrs => $attrs };
  $self->_relationships(\%rels);

  return $self;

  # XXX disabled. doesn't work properly currently. skip in tests.

  my $f_source = $self->schema->source($f_source_name);
  unless ($f_source) {
    eval "require $f_source_name;";
    if ($@) {
      die $@ unless $@ =~ /Can't locate/;
    }
    $f_source = $f_source_name->result_source;
    #my $s_class = ref($self->schema);
    #$f_source_name =~ m/^${s_class}::(.*)$/;
    #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
    #$f_source = $self->schema->source($f_source_name);
  }
  return unless $f_source; # Can't test rel without f_source

  eval { $self->resolve_join($rel, 'me') };

  if ($@) { # If the resolve failed, back out and re-throw the error
    delete $rels{$rel}; # 
    $self->_relationships(\%rels);
    croak "Error creating relationship $rel: $@";
  }
  1;
}

=head2 relationships()

Returns all valid relationship names for this source

=cut

sub relationships {
  return keys %{shift->_relationships};
}

=head2 relationship_info($relname)

Returns the relationship information for the specified relationship name

=cut

sub relationship_info {
  my ($self, $rel) = @_;
  return $self->_relationships->{$rel};
} 

=head2 has_relationship($rel)

Returns 1 if the source has a relationship of this name, 0 otherwise.
                                                                                
=cut                                                                            

sub has_relationship {
  my ($self, $rel) = @_;
  return exists $self->_relationships->{$rel};
}

=head2 resolve_join($relation)

Returns the join structure required for the related result source

=cut

sub resolve_join {
  my ($self, $join, $alias) = @_;
  if (ref $join eq 'ARRAY') {
    return map { $self->resolve_join($_, $alias) } @$join;
  } elsif (ref $join eq 'HASH') {
    return map { $self->resolve_join($_, $alias),
                 $self->related_source($_)->resolve_join($join->{$_}, $_) }
           keys %$join;
  } elsif (ref $join) {
    croak ("No idea how to resolve join reftype ".ref $join);
  } else {
    my $rel_info = $self->relationship_info($join);
    croak("No such relationship ${join}") unless $rel_info;
    my $type = $rel_info->{attrs}{join_type} || '';
    return [ { $join => $self->related_source($join)->from,
               -join_type => $type },
             $self->resolve_condition($rel_info->{cond}, $join, $alias) ];
  }
}

=head2 resolve_condition($cond, $rel, $alias|$object)

Resolves the passed condition to a concrete query fragment. If given an alias,
returns a join condition; if given an object, inverts that object to produce
a related conditional from that object.

=cut

sub resolve_condition {
  my ($self, $cond, $rel, $for) = @_;
  #warn %$cond;
  if (ref $cond eq 'HASH') {
    my %ret;
    while (my ($k, $v) = each %{$cond}) {
      # XXX should probably check these are valid columns
      $k =~ s/^foreign\.// || croak "Invalid rel cond key ${k}";
      $v =~ s/^self\.// || croak "Invalid rel cond val ${v}";
      if (ref $for) { # Object
        #warn "$self $k $for $v";
        $ret{$k} = $for->get_column($v);
        #warn %ret;
      } else {
        $ret{"${rel}.${k}"} = "${for}.${v}";
      }
    }
    return \%ret;
  } elsif (ref $cond eq 'ARRAY') {
    return [ map { $self->resolve_condition($_, $rel, $for) } @$cond ];
  } else {
   die("Can't handle this yet :(");
  }
}

=head2 resolve_prefetch (hashref/arrayref/scalar)
 
Accepts one or more relationships for the current source and returns an
array of column names for each of those relationships. Column names are
prefixed relative to the current source, in accordance with where they appear
in the supplied relationships. Examples:

  my $source = $schema->$resultset('Tag')->source;
  @columns = $source->resolve_prefetch( { cd => 'artist' } );

  # @columns =
  #(
  #  'cd.cdid',
  #  'cd.artist',
  #  'cd.title',
  #  'cd.year',
  #  'cd.artist.artistid',
  #  'cd.artist.name'
  #)

  @columns = $source->resolve_prefetch( qw[/ cd /] );

  # @columns =
  #(
  #   'cd.cdid',
  #   'cd.artist',
  #   'cd.title',
  #   'cd.year'
  #)

  $source = $schema->resultset('CD')->source;
  @columns = $source->resolve_prefetch( qw[/ artist producer /] );

  # @columns =
  #(
  #  'artist.artistid',
  #  'artist.name',
  #  'producer.producerid',
  #  'producer.name'
  #)  
  
=cut

sub resolve_prefetch {
  my( $self, $pre, $alias ) = @_;
  use Data::Dumper;
  #$alias ||= $self->name;
  #warn $alias, Dumper $pre;
  if( ref $pre eq 'ARRAY' ) {
    return map { $self->resolve_prefetch( $_, $alias ) } @$pre;
  }
  elsif( ref $pre eq 'HASH' ) {
    my @ret =
    map {
      $self->resolve_prefetch($_, $alias),
      $self->related_source($_)->resolve_prefetch( $pre->{$_}, $_ )
    }
    keys %$pre;
    #die Dumper \@ret;
    return @ret;
  }
  elsif( ref $pre ) {
    croak( "don't know how to resolve prefetch reftype " . ref $pre);
  }
  else {
    my $rel_info = $self->relationship_info( $pre );
    croak( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
    my $prefix = $alias && $alias ne 'me' ? "$alias.$pre" : $pre;
    my @ret = map { "$prefix.$_" } $self->related_source($pre)->columns;
    #warn $alias, Dumper (\@ret);
    return @ret;
  }
}

=head2 related_source($relname)

Returns the result source for the given relationship

=cut

sub related_source {
  my ($self, $rel) = @_;
  if( !$self->has_relationship( $rel ) ) {
    croak "No such relationship '$rel'";
  }
  return $self->schema->source($self->relationship_info($rel)->{source});
}

1;

=head1 AUTHORS

Matt S. Trout <mst@shadowcatsystems.co.uk>

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

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