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