lib/DBIx/Class/ResultSource.pm

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