lib/DBIx/Class/ResultSource.pm

   1 package DBIx::Class::ResultSource;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::ResultSet;
   7
   8 use Carp qw/croak/;
   9
  10 use base qw/DBIx::Class/;
  11 __PACKAGE__->load_components(qw/AccessorGroup/);
  12
  13 __PACKAGE__->mk_group_accessors('simple' =>
  14   qw/_ordered_columns _columns _primaries name resultset_class result_class schema from _relationships/);
  15
  16 =head1 NAME
  17
  18 DBIx::Class::ResultSource - Result source object
  19
  20 =head1 SYNOPSIS
  21
  22 =head1 DESCRIPTION
  23
  24 A ResultSource is a component of a schema from which results can be directly
  25 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
  26
  27 =head1 METHODS
  28
  29 =cut
  30
  31 sub new {
  32   my ($class, $attrs) = @_;
  33   $class = ref $class if ref $class;
  34   my $new = bless({ %{$attrs || {}} }, $class);
  35   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
  36   $new->{_ordered_columns} ||= [];
  37   $new->{_columns} ||= {};
  38   $new->{_relationships} ||= {};
  39   $new->{name} ||= "!!NAME NOT SET!!";
  40   return $new;
  41 }
  42
  43 sub add_columns {
  44   my ($self, @cols) = @_;
  45   $self->_ordered_columns( \@cols )
  46     if !$self->_ordered_columns;
  47   push @{ $self->_ordered_columns }, @cols;
  48   while (my $col = shift @cols) {
  49
  50     my $column_info = ref $cols[0] ? shift : {};
  51       # If next entry is { ... } use that for the column info, if not
  52       # use an empty hashref
  53
  54     $self->_columns->{$col} = $column_info;
  55   }
  56 }
  57
  58 *add_column = \&add_columns;
  59
  60 =head2 add_columns
  61
  62   $table->add_columns(qw/col1 col2 col3/);
  63
  64   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  65
  66 Adds columns to the result source. If supplied key => hashref pairs uses
  67 the hashref as the column_info for that column.
  68
  69 =head2 add_column
  70
  71   $table->add_column('col' => \%info?);
  72
  73 Convenience alias to add_columns
  74
  75 =cut
  76
  77 sub resultset {
  78   my $self = shift;
  79   return $self->resultset_class->new($self);
  80 }
  81
  82 =head2 has_column
  83
  84   if ($obj->has_column($col)) { ... }
  85
  86 Returns 1 if the source has a column of this name, 0 otherwise.
  87
  88 =cut
  89
  90 sub has_column {
  91   my ($self, $column) = @_;
  92   return exists $self->_columns->{$column};
  93 }
  94
  95 =head2 column_info
  96
  97   my $info = $obj->column_info($col);
  98
  99 Returns the column metadata hashref for a column.
 100
 101 =cut
 102
 103 sub column_info {
 104   my ($self, $column) = @_;
 105   croak "No such column $column" unless exists $self->_columns->{$column};
 106   return $self->_columns->{$column};
 107 }
 108
 109 =head2 columns
 110
 111   my @column_names = $obj->columns;
 112
 113 =cut
 114
 115 sub columns {
 116   croak "columns() is a read-only accessor, did you mean add_columns()?" if (@_ > 1);
 117   return keys %{shift->_columns};
 118 }
 119
 120 =head2 ordered_columns
 121
 122   my @column_names = $obj->ordered_columns;
 123
 124 Like columns(), but returns column names using the order in which they were
 125 originally supplied to add_columns().
 126
 127 =cut
 128
 129 sub ordered_columns {
 130   return @{shift->{_ordered_columns}||[]};
 131 }
 132
 133 =head2 set_primary_key(@cols)
 134
 135 Defines one or more columns as primary key for this source. Should be
 136 called after C<add_columns>.
 137
 138 =cut
 139
 140 sub set_primary_key {
 141   my ($self, @cols) = @_;
 142   # check if primary key columns are valid columns
 143   for (@cols) {
 144     $self->throw("No such column $_ on table ".$self->name)
 145       unless $self->has_column($_);
 146   }
 147   $self->_primaries(\@cols);
 148 }
 149
 150 =head2 primary_columns
 151
 152 Read-only accessor which returns the list of primary keys.
 153
 154 =cut
 155
 156 sub primary_columns {
 157   return @{shift->_primaries||[]};
 158 }
 159
 160 =head2 from
 161
 162 Returns an expression of the source to be supplied to storage to specify
 163 retrieval from this source; in the case of a database the required FROM clause
 164 contents.
 165
 166 =cut
 167
 168 =head2 storage
 169
 170 Returns the storage handle for the current schema
 171
 172 =cut
 173
 174 sub storage { shift->schema->storage; }
 175
 176 =head2 add_relationship
 177
 178   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 179
 180 The relation name can be arbitrary, but must be unique for each relationship
 181 attached to this result source. 'related_source' should be the name with
 182 which the related result source was registered with the current schema
 183 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
 184
 185 The condition needs to be an SQL::Abstract-style representation of the join
 186 between the tables. For example, if you're creating a rel from Foo to Bar,
 187
 188   { 'foreign.foo_id' => 'self.id' }
 189
 190 will result in the JOIN clause
 191
 192   foo me JOIN bar bar ON bar.foo_id = me.id
 193
 194 You can specify as many foreign => self mappings as necessary.
 195
 196 Valid attributes are as follows:
 197
 198 =over 4
 199
 200 =item join_type
 201
 202 Explicitly specifies the type of join to use in the relationship. Any SQL
 203 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
 204 command immediately before C<JOIN>.
 205
 206 =item proxy
 207
 208 An arrayref containing a list of accessors in the foreign class to proxy in
 209 the main class. If, for example, you do the following:
 210
 211   __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => qw[/ margle /] });
 212
 213 Then, assuming Bar has an accessor named margle, you can do:
 214
 215   my $obj = Foo->find(1);
 216   $obj->margle(10); # set margle; Bar object is created if it doesn't exist
 217
 218 =item accessor
 219
 220 Specifies the type of accessor that should be created for the relationship.
 221 Valid values are C<single> (for when there is only a single related object),
 222 C<multi> (when there can be many), and C<filter> (for when there is a single
 223 related object, but you also want the relationship accessor to double as
 224 a column accessor). For C<multi> accessors, an add_to_* method is also
 225 created, which calls C<create_related> for the relationship.
 226
 227 =back
 228
 229 =cut
 230
 231 sub add_relationship {
 232   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 233   die "Can't create relationship without join condition" unless $cond;
 234   $attrs ||= {};
 235
 236   my %rels = %{ $self->_relationships };
 237   $rels{$rel} = { class => $f_source_name,
 238                   source => $f_source_name,
 239                   cond  => $cond,
 240                   attrs => $attrs };
 241   $self->_relationships(\%rels);
 242
 243   return 1;
 244
 245   my $f_source = $self->schema->source($f_source_name);
 246   unless ($f_source) {
 247     eval "require $f_source_name;";
 248     if ($@) {
 249       die $@ unless $@ =~ /Can't locate/;
 250     }
 251     $f_source = $f_source_name->result_source;
 252     #my $s_class = ref($self->schema);
 253     #$f_source_name =~ m/^${s_class}::(.*)$/;
 254     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 255     #$f_source = $self->schema->source($f_source_name);
 256   }
 257   return unless $f_source; # Can't test rel without f_source
 258
 259   eval { $self->resolve_join($rel, 'me') };
 260
 261   if ($@) { # If the resolve failed, back out and re-throw the error
 262     delete $rels{$rel}; #
 263     $self->_relationships(\%rels);
 264     die "Error creating relationship $rel: $@";
 265   }
 266   1;
 267 }
 268
 269 =head2 relationships()
 270
 271 Returns all valid relationship names for this source
 272
 273 =cut
 274
 275 sub relationships {
 276   return keys %{shift->_relationships};
 277 }
 278
 279 =head2 relationship_info($relname)
 280
 281 Returns the relationship information for the specified relationship name
 282
 283 =cut
 284
 285 sub relationship_info {
 286   my ($self, $rel) = @_;
 287   return $self->_relationships->{$rel};
 288 }
 289
 290 =head2 resolve_join($relation)
 291
 292 Returns the join structure required for the related result source
 293
 294 =cut
 295
 296 sub resolve_join {
 297   my ($self, $join, $alias) = @_;
 298   if (ref $join eq 'ARRAY') {
 299     return map { $self->resolve_join($_, $alias) } @$join;
 300   } elsif (ref $join eq 'HASH') {
 301     return map { $self->resolve_join($_, $alias),
 302                  $self->related_source($_)->resolve_join($join->{$_}, $_) }
 303            keys %$join;
 304   } elsif (ref $join) {
 305     die("No idea how to resolve join reftype ".ref $join);
 306   } else {
 307     my $rel_obj = $self->relationship_info($join);
 308     #use Data::Dumper; warn Dumper($class->result_source) unless $rel_obj;
 309     die("No such relationship ${join}") unless $rel_obj;
 310     my $j_class = $self->related_source($join)->result_class;
 311     my %join = (_action => 'join',
 312          _aliases => { 'self' => $alias, 'foreign' => $join },
 313          _classes => { $alias => $self->result_class, $join => $j_class });
 314     my $j_cond = $j_class->resolve_condition($rel_obj->{cond}, \%join);
 315     return [ { $join => $j_class->_table_name,
 316                -join_type => $rel_obj->{attrs}{join_type} || '' }, $j_cond ];
 317   }
 318 }
 319
 320 =head2 related_source($relname)
 321
 322 Returns the result source for the given relationship
 323
 324 =cut
 325
 326 sub related_source {
 327   my ($self, $rel) = @_;
 328   return $self->schema->source($self->relationship_info($rel)->{source});
 329 }
 330
 331 1;
 332
 333 =head1 AUTHORS
 334
 335 Matt S. Trout <mst@shadowcatsystems.co.uk>
 336
 337 =head1 LICENSE
 338
 339 You may distribute this code under the same terms as Perl itself.
 340
 341 =cut
 342