[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, $seen) = @_;
  $seen ||= {};
  if (ref $join eq 'ARRAY') {
    return map { $self->resolve_join($_, $alias, $seen) } @$join;
  } elsif (ref $join eq 'HASH') {
    return
      map { $self->resolve_join($_, $alias, $seen),
            $self->related_source($_)->resolve_join($join->{$_}, $_, $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});
}

=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 {
489709af	355	my ($self, $join, $alias, $seen) = @_;
489709af	356	$seen \|\|= {};
87772e46	357	if (ref $join eq 'ARRAY') {
489709af	358	return map { $self->resolve_join($_, $alias, $seen) } @$join;
87772e46	359	} elsif (ref $join eq 'HASH') {
489709af	360	return
	361	map { $self->resolve_join($_, $alias, $seen),
	362	$self->related_source($_)->resolve_join($join->{$_}, $_, $seen) }
87772e46	363	keys %$join;
87772e46	364	} elsif (ref $join) {
701da8c4	365	$self->throw_exception("No idea how to resolve join reftype ".ref $join);
87772e46	366	} else {
489709af	367	my $count = ++$seen->{$join};
	368	#use Data::Dumper; warn Dumper($seen);
	369	my $as = ($count > 1 ? "${join}_${count}" : $join);
3842b955	370	my $rel_info = $self->relationship_info($join);
701da8c4	371	$self->throw_exception("No such relationship ${join}") unless $rel_info;
3842b955	372	my $type = $rel_info->{attrs}{join_type} \|\| '';
489709af	373	return [ { $as => $self->related_source($join)->from,
953a18ef	374	-join_type => $type },
489709af	375	$self->resolve_condition($rel_info->{cond}, $as, $alias) ];
953a18ef	376	}
	377	}
	378
489709af	379	=head2 resolve_condition($cond, $as, $alias\|$object)
953a18ef	380
3842b955	381	Resolves the passed condition to a concrete query fragment. If given an alias,
953a18ef	382	returns a join condition; if given an object, inverts that object to produce
	383	a related conditional from that object.
	384
	385	=cut
	386
	387	sub resolve_condition {
489709af	388	my ($self, $cond, $as, $for) = @_;
953a18ef	389	#warn %$cond;
	390	if (ref $cond eq 'HASH') {
	391	my %ret;
	392	while (my ($k, $v) = each %{$cond}) {
	393	# XXX should probably check these are valid columns
701da8c4	394	$k =~ s/^foreign\.// \|\| $self->throw_exception("Invalid rel cond key ${k}");
701da8c4	395	$v =~ s/^self\.// \|\| $self->throw_exception("Invalid rel cond val ${v}");
953a18ef	396	if (ref $for) { # Object
3842b955	397	#warn "$self $k $for $v";
	398	$ret{$k} = $for->get_column($v);
	399	#warn %ret;
953a18ef	400	} else {
489709af	401	$ret{"${as}.${k}"} = "${for}.${v}";
953a18ef	402	}
953a18ef	403	}
953a18ef	404	return \%ret;
5efe4c79	405	} elsif (ref $cond eq 'ARRAY') {
489709af	406	return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
953a18ef	407	} else {
953a18ef	408	die("Can't handle this yet :(");
87772e46	409	}
	410	}
	411
b3e8ac9b	412	=head2 resolve_prefetch (hashref/arrayref/scalar)
	413
	414	Accepts one or more relationships for the current source and returns an
	415	array of column names for each of those relationships. Column names are
	416	prefixed relative to the current source, in accordance with where they appear
	417	in the supplied relationships. Examples:
	418
5ac6a044	419	my $source = $schema->resultset('Tag')->source;
b3e8ac9b	420	@columns = $source->resolve_prefetch( { cd => 'artist' } );
	421
	422	# @columns =
	423	#(
	424	# 'cd.cdid',
	425	# 'cd.artist',
	426	# 'cd.title',
	427	# 'cd.year',
	428	# 'cd.artist.artistid',
	429	# 'cd.artist.name'
	430	#)
	431
	432	@columns = $source->resolve_prefetch( qw[/ cd /] );
	433
	434	# @columns =
	435	#(
	436	# 'cd.cdid',
	437	# 'cd.artist',
	438	# 'cd.title',
	439	# 'cd.year'
	440	#)
	441
	442	$source = $schema->resultset('CD')->source;
	443	@columns = $source->resolve_prefetch( qw[/ artist producer /] );
	444
	445	# @columns =
	446	#(
	447	# 'artist.artistid',
	448	# 'artist.name',
	449	# 'producer.producerid',
	450	# 'producer.name'
	451	#)
	452
	453	=cut
	454
	455	sub resolve_prefetch {
489709af	456	my ($self, $pre, $alias, $seen) = @_;
489709af	457	$seen \|\|= {};
b3e8ac9b	458	use Data::Dumper;
	459	#$alias \|\|= $self->name;
	460	#warn $alias, Dumper $pre;
	461	if( ref $pre eq 'ARRAY' ) {
489709af	462	return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
b3e8ac9b	463	}
	464	elsif( ref $pre eq 'HASH' ) {
	465	my @ret =
	466	map {
489709af	467	$self->resolve_prefetch($_, $alias, $seen),
	468	$self->related_source($_)->resolve_prefetch(
	469	$pre->{$_}, "${alias}.$_", $seen)
	470	} keys %$pre;
b3e8ac9b	471	#die Dumper \@ret;
	472	return @ret;
	473	}
	474	elsif( ref $pre ) {
701da8c4	475	$self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
b3e8ac9b	476	}
b3e8ac9b	477	else {
489709af	478	my $count = ++$seen->{$pre};
489709af	479	my $as = ($count > 1 ? "${pre}_${count}" : $pre);
b3e8ac9b	480	my $rel_info = $self->relationship_info( $pre );
701da8c4	481	$self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
489709af	482	my $as_prefix = ($alias =~ /^.?\.(.)$/ ? $1.'.' : '');
	483	return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
	484	$self->related_source($pre)->columns;
b3e8ac9b	485	#warn $alias, Dumper (\@ret);
489709af	486	#return @ret;
b3e8ac9b	487	}
b3e8ac9b	488	}
953a18ef	489
87772e46	490	=head2 related_source($relname)
	491
	492	Returns the result source for the given relationship
	493
	494	=cut
	495
	496	sub related_source {
	497	my ($self, $rel) = @_;
aea52c85	498	if( !$self->has_relationship( $rel ) ) {
701da8c4	499	$self->throw_exception("No such relationship '$rel'");
aea52c85	500	}
87772e46	501	return $self->schema->source($self->relationship_info($rel)->{source});
8452e496	502	}
8452e496	503
5ac6a044	504	=head2 resultset
	505
	506	Returns a resultset for the given source created by calling
	507
	508	$self->resultset_class->new($self, $self->resultset_attributes)
	509
	510	=head2 resultset_class
	511
	512	Simple accessor.
	513
	514	=head2 resultset_attributes
	515
	516	Simple accessor.
	517
	518	=cut
	519
	520	sub resultset {
	521	my $self = shift;
	522	return $self->resultset_class->new($self, $self->{resultset_attributes});
	523	}
	524
	525	=cut
9c992ba1	526
701da8c4	527	=head2 throw_exception
	528
	529	See schema's throw_exception
	530
	531	=cut
	532
	533	sub throw_exception {
	534	my $self = shift;
	535	if (defined $self->schema) {
	536	$self->schema->throw_exception(@_);
	537	} else {
	538	croak(@_);
	539	}
	540	}
	541
	542
9c992ba1	543	=head1 AUTHORS
	544
	545	Matt S. Trout <mst@shadowcatsystems.co.uk>
	546
	547	=head1 LICENSE
	548
	549	You may distribute this code under the same terms as Perl itself.
	550
	551	=cut
	552