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

package DBIx::Class::ResultSource;

use strict;
use warnings;

use DBIx::Class::ResultSet;
use Carp::Clan qw/^DBIx::Class/;

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) = @_;
  $self->throw_exception("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 {
  my $self=shift;
  $self->throw_exception("columns() is a read-only accessor, did you mean add_columns()?") if (@_ > 1);
  return @{$self->{_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_exception("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_exception("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) = @_;
  $self->throw_exception("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);
    $self->throw_exception("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) {
    $self->throw_exception("No idea how to resolve join reftype ".ref $join);
  } else {
    my $rel_info = $self->relationship_info($join);
    $self->throw_exception("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\.// || $self->throw_exception("Invalid rel cond key ${k}");
      $v =~ s/^self\.// || $self->throw_exception("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 ) {
    $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
  }
  else {
    my $rel_info = $self->relationship_info( $pre );
    $self->throw_exception( $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 ) ) {
    $self->throw_exception("No such relationship '$rel'");
  }
  return $self->schema->source($self->relationship_info($rel)->{source});
}

1;

=head2 throw_exception

See schema's throw_exception

=cut

sub throw_exception {
  my $self = shift;
  if (defined $self->schema) { 
    $self->schema->throw_exception(@_);
  } else {
    croak(@_);
  }
}


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