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