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   # XXX disabled. doesn't work properly currently. skip in tests.
 246
 247   my $f_source = $self->schema->source($f_source_name);
 248   unless ($f_source) {
 249     eval "require $f_source_name;";
 250     if ($@) {
 251       die $@ unless $@ =~ /Can't locate/;
 252     }
 253     $f_source = $f_source_name->result_source;
 254     #my $s_class = ref($self->schema);
 255     #$f_source_name =~ m/^${s_class}::(.*)$/;
 256     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 257     #$f_source = $self->schema->source($f_source_name);
 258   }
 259   return unless $f_source; # Can't test rel without f_source
 260
 261   eval { $self->resolve_join($rel, 'me') };
 262
 263   if ($@) { # If the resolve failed, back out and re-throw the error
 264     delete $rels{$rel}; #
 265     $self->_relationships(\%rels);
 266     die "Error creating relationship $rel: $@";
 267   }
 268   1;
 269 }
 270
 271 =head2 relationships()
 272
 273 Returns all valid relationship names for this source
 274
 275 =cut
 276
 277 sub relationships {
 278   return keys %{shift->_relationships};
 279 }
 280
 281 =head2 relationship_info($relname)
 282
 283 Returns the relationship information for the specified relationship name
 284
 285 =cut
 286
 287 sub relationship_info {
 288   my ($self, $rel) = @_;
 289   return $self->_relationships->{$rel};
 290 }
 291
 292 =head2 has_relationship($rel)
 293
 294 Returns 1 if the source has a relationship of this name, 0 otherwise.
 295
 296 =cut
 297
 298 sub has_relationship {
 299   my ($self, $rel) = @_;
 300   return exists $self->_relationships->{$rel};
 301 }
 302
 303 =head2 resolve_join($relation)
 304
 305 Returns the join structure required for the related result source
 306
 307 =cut
 308
 309 sub resolve_join {
 310   my ($self, $join, $alias) = @_;
 311   if (ref $join eq 'ARRAY') {
 312     return map { $self->resolve_join($_, $alias) } @$join;
 313   } elsif (ref $join eq 'HASH') {
 314     return map { $self->resolve_join($_, $alias),
 315                  $self->related_source($_)->resolve_join($join->{$_}, $_) }
 316            keys %$join;
 317   } elsif (ref $join) {
 318     die("No idea how to resolve join reftype ".ref $join);
 319   } else {
 320     my $rel_info = $self->relationship_info($join);
 321     die("No such relationship ${join}") unless $rel_info;
 322     my $type = $rel_info->{attrs}{join_type} || '';
 323     return [ { $join => $self->related_source($join)->from,
 324                -join_type => $type },
 325              $self->resolve_condition($rel_info->{cond}, $join, $alias) ];
 326   }
 327 }
 328
 329 =head2 resolve_condition($cond, $rel, $alias|$object)
 330
 331 Resolves the passed condition to a concrete query fragment. If given an alias,
 332 returns a join condition; if given an object, inverts that object to produce
 333 a related conditional from that object.
 334
 335 =cut
 336
 337 sub resolve_condition {
 338   my ($self, $cond, $rel, $for) = @_;
 339   #warn %$cond;
 340   if (ref $cond eq 'HASH') {
 341     my %ret;
 342     while (my ($k, $v) = each %{$cond}) {
 343       # XXX should probably check these are valid columns
 344       $k =~ s/^foreign\.// || die "Invalid rel cond key ${k}";
 345       $v =~ s/^self\.// || die "Invalid rel cond val ${v}";
 346       if (ref $for) { # Object
 347         #warn "$self $k $for $v";
 348         $ret{$k} = $for->get_column($v);
 349         #warn %ret;
 350       } else {
 351         $ret{"${rel}.${k}"} = "${for}.${v}";
 352       }
 353     }
 354     return \%ret;
 355   } else {
 356    die("Can't handle this yet :(");
 357   }
 358 }
 359
 360
 361 =head2 related_source($relname)
 362
 363 Returns the result source for the given relationship
 364
 365 =cut
 366
 367 sub related_source {
 368   my ($self, $rel) = @_;
 369   return $self->schema->source($self->relationship_info($rel)->{source});
 370 }
 371
 372 1;
 373
 374 =head1 AUTHORS
 375
 376 Matt S. Trout <mst@shadowcatsystems.co.uk>
 377
 378 =head1 LICENSE
 379
 380 You may distribute this code under the same terms as Perl itself.
 381
 382 =cut
 383