[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_attributes schema from _relationships/);
__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class result_class/);

=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, $seen) = @_;
  $seen ||= {};
  if (ref $join eq 'ARRAY') {
    return map { $self->resolve_join($_, $alias, $seen) } @$join;
  } elsif (ref $join eq 'HASH') {
    return
      map {
        my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
        ($self->resolve_join($_, $alias, $seen),
          $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
      } keys %$join;
  } elsif (ref $join) {
    $self->throw_exception("No idea how to resolve join reftype ".ref $join);
  } else {
    my $count = ++$seen->{$join};
    #use Data::Dumper; warn Dumper($seen);
    my $as = ($count > 1 ? "${join}_${count}" : $join);
    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 [ { $as => $self->related_source($join)->from,
               -join_type => $type },
             $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
  }
}

=head2 resolve_condition($cond, $as, $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, $as, $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{"${as}.${k}"} = "${for}.${v}";
      }
    }
    return \%ret;
  } elsif (ref $cond eq 'ARRAY') {
    return [ map { $self->resolve_condition($_, $as, $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, $seen) = @_;
  $seen ||= {};
  use Data::Dumper;
  #$alias ||= $self->name;
  #warn $alias, Dumper $pre;
  if( ref $pre eq 'ARRAY' ) {
    return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
  }
  elsif( ref $pre eq 'HASH' ) {
    my @ret =
    map {
      $self->resolve_prefetch($_, $alias, $seen),
      $self->related_source($_)->resolve_prefetch(
                                   $pre->{$_}, "${alias}.$_", $seen)
        } 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 $count = ++$seen->{$pre};
    my $as = ($count > 1 ? "${pre}_${count}" : $pre);
    my $rel_info = $self->relationship_info( $pre );
    $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
    my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
    return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
      $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});
}

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