[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 Scalar::Util qw/weaken/;

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 || {}}, _resultset => undef }, $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!!";
  $new->{_columns_info_loaded} ||= 0;
  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};
  #warn $self->{_columns_info_loaded}, "\n";
  if ( ! $self->_columns->{$column}->{data_type} 
       && ! $self->{_columns_info_loaded} 
       && $self->schema && $self->storage() ){
      $self->{_columns_info_loaded}++;
      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;
      } elsif (ref $as) { # reverse object
        $ret{$v} = $as->get_column($k);
      } 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} if ref $self->{_resultset} eq $self->resultset_class;
  return $self->{_resultset} = do {
    my $rs = $self->resultset_class->new($self, $self->{resultset_attributes});
    weaken $rs->result_source;
    $rs;
  };
}

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