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