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   my @added;
  48   my $columns = $self->_columns;
  49   while (my $col = shift @cols) {
  50
  51     my $column_info = ref $cols[0] ? shift : {};
  52       # If next entry is { ... } use that for the column info, if not
  53       # use an empty hashref
  54
  55     push(@added, $col) unless exists $columns->{$col};
  56
  57     $columns->{$col} = $column_info;
  58   }
  59   push @{ $self->_ordered_columns }, @added;
  60 }
  61
  62 *add_column = \&add_columns;
  63
  64 =head2 add_columns
  65
  66   $table->add_columns(qw/col1 col2 col3/);
  67
  68   $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
  69
  70 Adds columns to the result source. If supplied key => hashref pairs uses
  71 the hashref as the column_info for that column.
  72
  73 =head2 add_column
  74
  75   $table->add_column('col' => \%info?);
  76
  77 Convenience alias to add_columns
  78
  79 =cut
  80
  81 sub resultset {
  82   my $self = shift;
  83   return $self->resultset_class->new($self);
  84 }
  85
  86 =head2 has_column
  87
  88   if ($obj->has_column($col)) { ... }
  89
  90 Returns 1 if the source has a column of this name, 0 otherwise.
  91
  92 =cut
  93
  94 sub has_column {
  95   my ($self, $column) = @_;
  96   return exists $self->_columns->{$column};
  97 }
  98
  99 =head2 column_info
 100
 101   my $info = $obj->column_info($col);
 102
 103 Returns the column metadata hashref for a column.
 104
 105 =cut
 106
 107 sub column_info {
 108   my ($self, $column) = @_;
 109   croak "No such column $column" unless exists $self->_columns->{$column};
 110   return $self->_columns->{$column};
 111 }
 112
 113 =head2 columns
 114
 115   my @column_names = $obj->columns;
 116
 117 Returns all column names in the order they were declared to add_columns
 118
 119 =cut
 120
 121 sub columns {
 122   croak "columns() is a read-only accessor, did you mean add_columns()?" if (@_ > 1);
 123   return @{shift->{_ordered_columns}||[]};
 124 }
 125
 126 =head2 set_primary_key(@cols)
 127
 128 Defines one or more columns as primary key for this source. Should be
 129 called after C<add_columns>.
 130
 131 =cut
 132
 133 sub set_primary_key {
 134   my ($self, @cols) = @_;
 135   # check if primary key columns are valid columns
 136   for (@cols) {
 137     $self->throw("No such column $_ on table ".$self->name)
 138       unless $self->has_column($_);
 139   }
 140   $self->_primaries(\@cols);
 141 }
 142
 143 =head2 primary_columns
 144
 145 Read-only accessor which returns the list of primary keys.
 146
 147 =cut
 148
 149 sub primary_columns {
 150   return @{shift->_primaries||[]};
 151 }
 152
 153 =head2 from
 154
 155 Returns an expression of the source to be supplied to storage to specify
 156 retrieval from this source; in the case of a database the required FROM clause
 157 contents.
 158
 159 =cut
 160
 161 =head2 storage
 162
 163 Returns the storage handle for the current schema
 164
 165 =cut
 166
 167 sub storage { shift->schema->storage; }
 168
 169 =head2 add_relationship
 170
 171   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 172
 173 The relation name can be arbitrary, but must be unique for each relationship
 174 attached to this result source. 'related_source' should be the name with
 175 which the related result source was registered with the current schema
 176 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
 177
 178 The condition needs to be an SQL::Abstract-style representation of the join
 179 between the tables. For example, if you're creating a rel from Foo to Bar,
 180
 181   { 'foreign.foo_id' => 'self.id' }
 182
 183 will result in the JOIN clause
 184
 185   foo me JOIN bar bar ON bar.foo_id = me.id
 186
 187 You can specify as many foreign => self mappings as necessary.
 188
 189 Valid attributes are as follows:
 190
 191 =over 4
 192
 193 =item join_type
 194
 195 Explicitly specifies the type of join to use in the relationship. Any SQL
 196 join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
 197 command immediately before C<JOIN>.
 198
 199 =item proxy
 200
 201 An arrayref containing a list of accessors in the foreign class to proxy in
 202 the main class. If, for example, you do the following:
 203
 204   __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => qw[/ margle /] });
 205
 206 Then, assuming Bar has an accessor named margle, you can do:
 207
 208   my $obj = Foo->find(1);
 209   $obj->margle(10); # set margle; Bar object is created if it doesn't exist
 210
 211 =item accessor
 212
 213 Specifies the type of accessor that should be created for the relationship.
 214 Valid values are C<single> (for when there is only a single related object),
 215 C<multi> (when there can be many), and C<filter> (for when there is a single
 216 related object, but you also want the relationship accessor to double as
 217 a column accessor). For C<multi> accessors, an add_to_* method is also
 218 created, which calls C<create_related> for the relationship.
 219
 220 =back
 221
 222 =cut
 223
 224 sub add_relationship {
 225   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 226   die "Can't create relationship without join condition" unless $cond;
 227   $attrs ||= {};
 228
 229   my %rels = %{ $self->_relationships };
 230   $rels{$rel} = { class => $f_source_name,
 231                   source => $f_source_name,
 232                   cond  => $cond,
 233                   attrs => $attrs };
 234   $self->_relationships(\%rels);
 235
 236   return 1;
 237
 238   # XXX disabled. doesn't work properly currently. skip in tests.
 239
 240   my $f_source = $self->schema->source($f_source_name);
 241   unless ($f_source) {
 242     eval "require $f_source_name;";
 243     if ($@) {
 244       die $@ unless $@ =~ /Can't locate/;
 245     }
 246     $f_source = $f_source_name->result_source;
 247     #my $s_class = ref($self->schema);
 248     #$f_source_name =~ m/^${s_class}::(.*)$/;
 249     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 250     #$f_source = $self->schema->source($f_source_name);
 251   }
 252   return unless $f_source; # Can't test rel without f_source
 253
 254   eval { $self->resolve_join($rel, 'me') };
 255
 256   if ($@) { # If the resolve failed, back out and re-throw the error
 257     delete $rels{$rel}; #
 258     $self->_relationships(\%rels);
 259     die "Error creating relationship $rel: $@";
 260   }
 261   1;
 262 }
 263
 264 =head2 relationships()
 265
 266 Returns all valid relationship names for this source
 267
 268 =cut
 269
 270 sub relationships {
 271   return keys %{shift->_relationships};
 272 }
 273
 274 =head2 relationship_info($relname)
 275
 276 Returns the relationship information for the specified relationship name
 277
 278 =cut
 279
 280 sub relationship_info {
 281   my ($self, $rel) = @_;
 282   return $self->_relationships->{$rel};
 283 }
 284
 285 =head2 has_relationship($rel)
 286
 287 Returns 1 if the source has a relationship of this name, 0 otherwise.
 288
 289 =cut
 290
 291 sub has_relationship {
 292   my ($self, $rel) = @_;
 293   return exists $self->_relationships->{$rel};
 294 }
 295
 296 =head2 resolve_join($relation)
 297
 298 Returns the join structure required for the related result source
 299
 300 =cut
 301
 302 sub resolve_join {
 303   my ($self, $join, $alias) = @_;
 304   if (ref $join eq 'ARRAY') {
 305     return map { $self->resolve_join($_, $alias) } @$join;
 306   } elsif (ref $join eq 'HASH') {
 307     return map { $self->resolve_join($_, $alias),
 308                  $self->related_source($_)->resolve_join($join->{$_}, $_) }
 309            keys %$join;
 310   } elsif (ref $join) {
 311     die("No idea how to resolve join reftype ".ref $join);
 312   } else {
 313     my $rel_info = $self->relationship_info($join);
 314     die("No such relationship ${join}") unless $rel_info;
 315     my $type = $rel_info->{attrs}{join_type} || '';
 316     return [ { $join => $self->related_source($join)->from,
 317                -join_type => $type },
 318              $self->resolve_condition($rel_info->{cond}, $join, $alias) ];
 319   }
 320 }
 321
 322 =head2 resolve_condition($cond, $rel, $alias|$object)
 323
 324 Resolves the passed condition to a concrete query fragment. If given an alias,
 325 returns a join condition; if given an object, inverts that object to produce
 326 a related conditional from that object.
 327
 328 =cut
 329
 330 sub resolve_condition {
 331   my ($self, $cond, $rel, $for) = @_;
 332   #warn %$cond;
 333   if (ref $cond eq 'HASH') {
 334     my %ret;
 335     while (my ($k, $v) = each %{$cond}) {
 336       # XXX should probably check these are valid columns
 337       $k =~ s/^foreign\.// || die "Invalid rel cond key ${k}";
 338       $v =~ s/^self\.// || die "Invalid rel cond val ${v}";
 339       if (ref $for) { # Object
 340         #warn "$self $k $for $v";
 341         $ret{$k} = $for->get_column($v);
 342         #warn %ret;
 343       } else {
 344         $ret{"${rel}.${k}"} = "${for}.${v}";
 345       }
 346     }
 347     return \%ret;
 348   } elsif (ref $cond eq 'ARRAY') {
 349     return [ map { $self->resolve_condition($_, $rel, $for) } @$cond ];
 350   } else {
 351    die("Can't handle this yet :(");
 352   }
 353 }
 354
 355
 356 =head2 related_source($relname)
 357
 358 Returns the result source for the given relationship
 359
 360 =cut
 361
 362 sub related_source {
 363   my ($self, $rel) = @_;
 364   return $self->schema->source($self->relationship_info($rel)->{source});
 365 }
 366
 367 1;
 368
 369 =head1 AUTHORS
 370
 371 Matt S. Trout <mst@shadowcatsystems.co.uk>
 372
 373 =head1 LICENSE
 374
 375 You may distribute this code under the same terms as Perl itself.
 376
 377 =cut
 378