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