[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 resultset_attributes 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->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
  $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
  $new->{_columns} = { %{$new->{_columns}||{}} };
  $new->{_relationships} = { %{$new->{_relationships}||{}} };
  $new->{name} ||= "!!NAME NOT SET!!";
  return $new;
}

=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 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 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});
}

=head2 resultset

Returns a resultset for the given source created by calling

$self->resultset_class->new($self, $self->resultset_attributes)

=head2 resultset_class

Simple accessor.

=head2 resultset_attributes

Simple accessor.

=cut

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

=cut

=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' =>
5ac6a044	15	qw/_ordered_columns _columns _primaries _unique_constraints name resultset_class resultset_attributes 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';
5ac6a044	37	$new->{resultset_attributes} = { %{$new->{resultset_attributes} \|\| {}} };
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
5ac6a044	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
9c992ba1	62	sub add_columns {
9c992ba1	63	my ($self, @cols) = @_;
571dced3	64	$self->_ordered_columns( \@cols )
571dced3	65	if !$self->_ordered_columns;
20518cb4	66	my @added;
20518cb4	67	my $columns = $self->_columns;
9c992ba1	68	while (my $col = shift @cols) {
53509665	69
30126ac7	70	my $column_info = ref $cols[0] ? shift(@cols) : {};
53509665	71	# If next entry is { ... } use that for the column info, if not
	72	# use an empty hashref
	73
20518cb4	74	push(@added, $col) unless exists $columns->{$col};
	75
	76	$columns->{$col} = $column_info;
9c992ba1	77	}
20518cb4	78	push @{ $self->_ordered_columns }, @added;
30126ac7	79	return $self;
9c992ba1	80	}
	81
	82	*add_column = \&add_columns;
	83
3842b955	84	=head2 has_column
3842b955	85
9c992ba1	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) = @_;
701da8c4	107	$self->throw_exception("No such column $column")
701da8c4	108	unless exists $self->_columns->{$column};
a953d8d9	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	}
9c992ba1	124	return $self->_columns->{$column};
	125	}
	126
	127	=head2 columns
	128
20518cb4	129	my @column_names = $obj->columns;
	130
	131	Returns all column names in the order they were declared to add_columns
87f0da6a	132
87f0da6a	133	=cut
9c992ba1	134
9c992ba1	135	sub columns {
701da8c4	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}\|\|[]};
571dced3	139	}
571dced3	140
87f0da6a	141	=head2 set_primary_key(@cols)
87f0da6a	142
9c992ba1	143	Defines one or more columns as primary key for this source. Should be
9c992ba1	144	called after C<add_columns>.
87f0da6a	145
	146	Additionally, defines a unique constraint named C<primary>.
	147
	148	=cut
9c992ba1	149
	150	sub set_primary_key {
	151	my ($self, @cols) = @_;
	152	# check if primary key columns are valid columns
	153	for (@cols) {
701da8c4	154	$self->throw_exception("No such column $_ on table ".$self->name)
9c992ba1	155	unless $self->has_column($_);
	156	}
	157	$self->_primaries(\@cols);
87f0da6a	158
87f0da6a	159	$self->add_unique_constraint(primary => \@cols);
9c992ba1	160	}
9c992ba1	161
87f0da6a	162	=head2 primary_columns
87f0da6a	163
9c992ba1	164	Read-only accessor which returns the list of primary keys.
30126ac7	165
87f0da6a	166	=cut
9c992ba1	167
	168	sub primary_columns {
	169	return @{shift->_primaries\|\|[]};
	170	}
	171
87f0da6a	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) {
701da8c4	186	$self->throw_exception("No such column $_ on table ".$self->name)
87f0da6a	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
9c992ba1	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
8452e496	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
fc69fea6	256	__PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/ ] });
8452e496	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) = @_;
701da8c4	278	$self->throw_exception("Can't create relationship without join condition") unless $cond;
8452e496	279	$attrs \|\|= {};
87772e46	280
8452e496	281	my %rels = %{ $self->_relationships };
8452e496	282	$rels{$rel} = { class => $f_source_name,
87772e46	283	source => $f_source_name,
8452e496	284	cond => $cond,
	285	attrs => $attrs };
	286	$self->_relationships(\%rels);
	287
30126ac7	288	return $self;
87772e46	289
953a18ef	290	# XXX disabled. doesn't work properly currently. skip in tests.
953a18ef	291
8452e496	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;
87772e46	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);
8452e496	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);
701da8c4	311	$self->throw_exception("Error creating relationship $rel: $@");
8452e496	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
953a18ef	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
8452e496	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 {
87772e46	355	my ($self, $join, $alias) = @_;
	356	if (ref $join eq 'ARRAY') {
	357	return map { $self->resolve_join($_, $alias) } @$join;
	358	} elsif (ref $join eq 'HASH') {
	359	return map { $self->resolve_join($_, $alias),
	360	$self->related_source($_)->resolve_join($join->{$_}, $_) }
	361	keys %$join;
	362	} elsif (ref $join) {
701da8c4	363	$self->throw_exception("No idea how to resolve join reftype ".ref $join);
87772e46	364	} else {
3842b955	365	my $rel_info = $self->relationship_info($join);
701da8c4	366	$self->throw_exception("No such relationship ${join}") unless $rel_info;
3842b955	367	my $type = $rel_info->{attrs}{join_type} \|\| '';
953a18ef	368	return [ { $join => $self->related_source($join)->from,
953a18ef	369	-join_type => $type },
3842b955	370	$self->resolve_condition($rel_info->{cond}, $join, $alias) ];
953a18ef	371	}
	372	}
	373
3842b955	374	=head2 resolve_condition($cond, $rel, $alias\|$object)
953a18ef	375
3842b955	376	Resolves the passed condition to a concrete query fragment. If given an alias,
953a18ef	377	returns a join condition; if given an object, inverts that object to produce
	378	a related conditional from that object.
	379
	380	=cut
	381
	382	sub resolve_condition {
3842b955	383	my ($self, $cond, $rel, $for) = @_;
953a18ef	384	#warn %$cond;
	385	if (ref $cond eq 'HASH') {
	386	my %ret;
	387	while (my ($k, $v) = each %{$cond}) {
	388	# XXX should probably check these are valid columns
701da8c4	389	$k =~ s/^foreign\.// \|\| $self->throw_exception("Invalid rel cond key ${k}");
701da8c4	390	$v =~ s/^self\.// \|\| $self->throw_exception("Invalid rel cond val ${v}");
953a18ef	391	if (ref $for) { # Object
3842b955	392	#warn "$self $k $for $v";
	393	$ret{$k} = $for->get_column($v);
	394	#warn %ret;
953a18ef	395	} else {
3842b955	396	$ret{"${rel}.${k}"} = "${for}.${v}";
953a18ef	397	}
953a18ef	398	}
953a18ef	399	return \%ret;
5efe4c79	400	} elsif (ref $cond eq 'ARRAY') {
5efe4c79	401	return [ map { $self->resolve_condition($_, $rel, $for) } @$cond ];
953a18ef	402	} else {
953a18ef	403	die("Can't handle this yet :(");
87772e46	404	}
	405	}
	406
b3e8ac9b	407	=head2 resolve_prefetch (hashref/arrayref/scalar)
	408
	409	Accepts one or more relationships for the current source and returns an
	410	array of column names for each of those relationships. Column names are
	411	prefixed relative to the current source, in accordance with where they appear
	412	in the supplied relationships. Examples:
	413
5ac6a044	414	my $source = $schema->resultset('Tag')->source;
b3e8ac9b	415	@columns = $source->resolve_prefetch( { cd => 'artist' } );
	416
	417	# @columns =
	418	#(
	419	# 'cd.cdid',
	420	# 'cd.artist',
	421	# 'cd.title',
	422	# 'cd.year',
	423	# 'cd.artist.artistid',
	424	# 'cd.artist.name'
	425	#)
	426
	427	@columns = $source->resolve_prefetch( qw[/ cd /] );
	428
	429	# @columns =
	430	#(
	431	# 'cd.cdid',
	432	# 'cd.artist',
	433	# 'cd.title',
	434	# 'cd.year'
	435	#)
	436
	437	$source = $schema->resultset('CD')->source;
	438	@columns = $source->resolve_prefetch( qw[/ artist producer /] );
	439
	440	# @columns =
	441	#(
	442	# 'artist.artistid',
	443	# 'artist.name',
	444	# 'producer.producerid',
	445	# 'producer.name'
	446	#)
	447
	448	=cut
	449
	450	sub resolve_prefetch {
	451	my( $self, $pre, $alias ) = @_;
	452	use Data::Dumper;
	453	#$alias \|\|= $self->name;
	454	#warn $alias, Dumper $pre;
	455	if( ref $pre eq 'ARRAY' ) {
	456	return map { $self->resolve_prefetch( $_, $alias ) } @$pre;
	457	}
	458	elsif( ref $pre eq 'HASH' ) {
	459	my @ret =
	460	map {
	461	$self->resolve_prefetch($_, $alias),
	462	$self->related_source($_)->resolve_prefetch( $pre->{$_}, $_ )
	463	}
	464	keys %$pre;
	465	#die Dumper \@ret;
	466	return @ret;
	467	}
	468	elsif( ref $pre ) {
701da8c4	469	$self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
b3e8ac9b	470	}
	471	else {
	472	my $rel_info = $self->relationship_info( $pre );
701da8c4	473	$self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
b3e8ac9b	474	my $prefix = $alias && $alias ne 'me' ? "$alias.$pre" : $pre;
	475	my @ret = map { "$prefix.$_" } $self->related_source($pre)->columns;
	476	#warn $alias, Dumper (\@ret);
	477	return @ret;
	478	}
	479	}
953a18ef	480
87772e46	481	=head2 related_source($relname)
	482
	483	Returns the result source for the given relationship
	484
	485	=cut
	486
	487	sub related_source {
	488	my ($self, $rel) = @_;
aea52c85	489	if( !$self->has_relationship( $rel ) ) {
701da8c4	490	$self->throw_exception("No such relationship '$rel'");
aea52c85	491	}
87772e46	492	return $self->schema->source($self->relationship_info($rel)->{source});
8452e496	493	}
8452e496	494
5ac6a044	495	=head2 resultset
	496
	497	Returns a resultset for the given source created by calling
	498
	499	$self->resultset_class->new($self, $self->resultset_attributes)
	500
	501	=head2 resultset_class
	502
	503	Simple accessor.
	504
	505	=head2 resultset_attributes
	506
	507	Simple accessor.
	508
	509	=cut
	510
	511	sub resultset {
	512	my $self = shift;
	513	return $self->resultset_class->new($self, $self->{resultset_attributes});
	514	}
	515
	516	=cut
9c992ba1	517
701da8c4	518	=head2 throw_exception
	519
	520	See schema's throw_exception
	521
	522	=cut
	523
	524	sub throw_exception {
	525	my $self = shift;
	526	if (defined $self->schema) {
	527	$self->schema->throw_exception(@_);
	528	} else {
	529	croak(@_);
	530	}
	531	}
	532
	533
9c992ba1	534	=head1 AUTHORS
	535
	536	Matt S. Trout <mst@shadowcatsystems.co.uk>
	537
	538	=head1 LICENSE
	539
	540	You may distribute this code under the same terms as Perl itself.
	541
	542	=cut
	543