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   my %rels = %{ $self->_relationships };
 236   $rels{$rel} = { class => $f_source_name,
 237                   cond  => $cond,
 238                   attrs => $attrs };
 239   $self->_relationships(\%rels);
 240
 241   my $f_source = $self->schema->source($f_source_name);
 242   unless ($f_source) {
 243     eval "require $f_source_name;";
 244     if ($@) {
 245       die $@ unless $@ =~ /Can't locate/;
 246     }
 247     $f_source = $f_source_name->result_source;
 248   }
 249   return unless $f_source; # Can't test rel without f_source
 250
 251   eval { $self->resolve_join($rel, 'me') };
 252
 253   if ($@) { # If the resolve failed, back out and re-throw the error
 254     delete $rels{$rel}; #
 255     $self->_relationships(\%rels);
 256     die "Error creating relationship $rel: $@";
 257   }
 258   1;
 259 }
 260
 261 =head2 relationships()
 262
 263 Returns all valid relationship names for this source
 264
 265 =cut
 266
 267 sub relationships {
 268   return keys %{shift->_relationships};
 269 }
 270
 271 =head2 relationship_info($relname)
 272
 273 Returns the relationship information for the specified relationship name
 274
 275 =cut
 276
 277 sub relationship_info {
 278   my ($self, $rel) = @_;
 279   return $self->_relationships->{$rel};
 280 }
 281
 282 =head2 resolve_join($relation)
 283
 284 Returns the join structure required for the related result source
 285
 286 =cut
 287
 288 sub resolve_join {
 289   shift->result_class->_resolve_join(@_);
 290 }
 291
 292 1;
 293
 294 =head1 AUTHORS
 295
 296 Matt S. Trout <mst@shadowcatsystems.co.uk>
 297
 298 =head1 LICENSE
 299
 300 You may distribute this code under the same terms as Perl itself.
 301
 302 =cut
 303