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 =head2 resolve_prefetch (hashref/arrayref/scalar)
 411
 412 Accepts one or more relationships for the current source and returns an
 413 array of column names for each of those relationships. Column names are
 414 prefixed relative to the current source, in accordance with where they appear
 415 in the supplied relationships. Examples:
 416
 417   my $source = $schema->$resultset('Tag')->source;
 418   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 419
 420   # @columns =
 421   #(
 422   #  'cd.cdid',
 423   #  'cd.artist',
 424   #  'cd.title',
 425   #  'cd.year',
 426   #  'cd.artist.artistid',
 427   #  'cd.artist.name'
 428   #)
 429
 430   @columns = $source->resolve_prefetch( qw[/ cd /] );
 431
 432   # @columns =
 433   #(
 434   #   'cd.cdid',
 435   #   'cd.artist',
 436   #   'cd.title',
 437   #   'cd.year'
 438   #)
 439
 440   $source = $schema->resultset('CD')->source;
 441   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 442
 443   # @columns =
 444   #(
 445   #  'artist.artistid',
 446   #  'artist.name',
 447   #  'producer.producerid',
 448   #  'producer.name'
 449   #)
 450
 451 =cut
 452
 453 sub resolve_prefetch {
 454   my( $self, $pre, $alias ) = @_;
 455   use Data::Dumper;
 456   #$alias ||= $self->name;
 457   #warn $alias, Dumper $pre;
 458   if( ref $pre eq 'ARRAY' ) {
 459     return map { $self->resolve_prefetch( $_, $alias ) } @$pre;
 460   }
 461   elsif( ref $pre eq 'HASH' ) {
 462     my @ret =
 463     map {
 464       $self->resolve_prefetch($_, $alias),
 465       $self->related_source($_)->resolve_prefetch( $pre->{$_}, $_ )
 466     }
 467     keys %$pre;
 468     #die Dumper \@ret;
 469     return @ret;
 470   }
 471   elsif( ref $pre ) {
 472     croak( "don't know how to resolve prefetch reftype " . ref $pre);
 473   }
 474   else {
 475     my $rel_info = $self->relationship_info( $pre );
 476     croak( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
 477     my $prefix = $alias && $alias ne 'me' ? "$alias.$pre" : $pre;
 478     my @ret = map { "$prefix.$_" } $self->related_source($pre)->columns;
 479     #warn $alias, Dumper (\@ret);
 480     return @ret;
 481   }
 482 }
 483
 484 =head2 related_source($relname)
 485
 486 Returns the result source for the given relationship
 487
 488 =cut
 489
 490 sub related_source {
 491   my ($self, $rel) = @_;
 492   if( !$self->has_relationship( $rel ) ) {
 493     croak "No such relationship '$rel'";
 494   }
 495   return $self->schema->source($self->relationship_info($rel)->{source});
 496 }
 497
 498 1;
 499
 500 =head1 AUTHORS
 501
 502 Matt S. Trout <mst@shadowcatsystems.co.uk>
 503
 504 =head1 LICENSE
 505
 506 You may distribute this code under the same terms as Perl itself.
 507
 508 =cut
 509