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
 210
 211 =head3 Arguments: (@cols)
 212
 213 Defines one or more columns as primary key for this source. Should be
 214 called after C<add_columns>.
 215
 216 Additionally, defines a unique constraint named C<primary>.
 217
 218 The primary key columns are used by L<DBIx::Class::PK::Auto> to
 219 retrieve automatically created values from the database.
 220
 221 =cut
 222
 223 sub set_primary_key {
 224   my ($self, @cols) = @_;
 225   # check if primary key columns are valid columns
 226   for (@cols) {
 227     $self->throw_exception("No such column $_ on table ".$self->name)
 228       unless $self->has_column($_);
 229   }
 230   $self->_primaries(\@cols);
 231
 232   $self->add_unique_constraint(primary => \@cols);
 233 }
 234
 235 =head2 primary_columns
 236
 237 Read-only accessor which returns the list of primary keys.
 238
 239 =cut
 240
 241 sub primary_columns {
 242   return @{shift->_primaries||[]};
 243 }
 244
 245 =head2 add_unique_constraint
 246
 247 Declare a unique constraint on this source. Call once for each unique
 248 constraint. Unique constraints are used when you call C<find> on a
 249 L<DBIx::Class::ResultSet>, only columns in the constraint are searched,
 250
 251   # For e.g. UNIQUE (column1, column2)
 252   __PACKAGE__->add_unique_constraint(constraint_name => [ qw/column1 column2/ ]);
 253
 254 =cut
 255
 256 sub add_unique_constraint {
 257   my ($self, $name, $cols) = @_;
 258
 259   for (@$cols) {
 260     $self->throw_exception("No such column $_ on table ".$self->name)
 261       unless $self->has_column($_);
 262   }
 263
 264   my %unique_constraints = $self->unique_constraints;
 265   $unique_constraints{$name} = $cols;
 266   $self->_unique_constraints(\%unique_constraints);
 267 }
 268
 269 =head2 unique_constraints
 270
 271 Read-only accessor which returns the list of unique constraints on this source.
 272
 273 =cut
 274
 275 sub unique_constraints {
 276   return %{shift->_unique_constraints||{}};
 277 }
 278
 279 =head2 from
 280
 281 Returns an expression of the source to be supplied to storage to specify
 282 retrieval from this source; in the case of a database the required FROM clause
 283 contents.
 284
 285 =cut
 286
 287 =head2 storage
 288
 289 Returns the storage handle for the current schema.
 290
 291 See also: L<DBIx::Class::Storage>
 292
 293 =cut
 294
 295 sub storage { shift->schema->storage; }
 296
 297 =head2 add_relationship
 298
 299   $source->add_relationship('relname', 'related_source', $cond, $attrs);
 300
 301 The relation name can be arbitrary, but must be unique for each relationship
 302 attached to this result source. 'related_source' should be the name with
 303 which the related result source was registered with the current schema
 304 (for simple schemas this is usally either Some::Namespace::Foo or just Foo)
 305
 306 The condition needs to be an SQL::Abstract-style representation of the join
 307 between the tables. For example, if you're creating a rel from Author to Book,
 308
 309   { 'foreign.author_id' => 'self.id' }
 310
 311 will result in the JOIN clause
 312
 313   author me JOIN book foreign ON foreign.author_id = me.id
 314
 315 You can specify as many foreign => self mappings as necessary.
 316
 317 Valid attributes are as follows:
 318
 319 =over 4
 320
 321 =item join_type
 322
 323 Explicitly specifies the type of join to use in the relationship. Any
 324 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
 325 the SQL command immediately before C<JOIN>.
 326
 327 =item proxy
 328
 329 An arrayref containing a list of accessors in the foreign class to
 330 proxy in the main class. If, for example, you do the following:
 331
 332   __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => [ qw/margle/] });
 333
 334 Then, assuming Bar has an accessor named margle, you can do:
 335
 336   my $obj = Foo->find(1);
 337   $obj->margle(10); # set margle; Bar object is created if it doesn't exist
 338
 339 =item accessor
 340
 341 Specifies the type of accessor that should be created for the
 342 relationship. Valid values are C<single> (for when there is only a single
 343 related object), C<multi> (when there can be many), and C<filter> (for
 344 when there is a single related object, but you also want the relationship
 345 accessor to double as a column accessor). For C<multi> accessors, an
 346 add_to_* method is also created, which calls C<create_related> for the
 347 relationship.
 348
 349 =back
 350
 351 =cut
 352
 353 sub add_relationship {
 354   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
 355   $self->throw_exception("Can't create relationship without join condition") unless $cond;
 356   $attrs ||= {};
 357
 358   my %rels = %{ $self->_relationships };
 359   $rels{$rel} = { class => $f_source_name,
 360                   source => $f_source_name,
 361                   cond  => $cond,
 362                   attrs => $attrs };
 363   $self->_relationships(\%rels);
 364
 365   return $self;
 366
 367   # XXX disabled. doesn't work properly currently. skip in tests.
 368
 369   my $f_source = $self->schema->source($f_source_name);
 370   unless ($f_source) {
 371     eval "require $f_source_name;";
 372     if ($@) {
 373       die $@ unless $@ =~ /Can't locate/;
 374     }
 375     $f_source = $f_source_name->result_source;
 376     #my $s_class = ref($self->schema);
 377     #$f_source_name =~ m/^${s_class}::(.*)$/;
 378     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
 379     #$f_source = $self->schema->source($f_source_name);
 380   }
 381   return unless $f_source; # Can't test rel without f_source
 382
 383   eval { $self->resolve_join($rel, 'me') };
 384
 385   if ($@) { # If the resolve failed, back out and re-throw the error
 386     delete $rels{$rel}; #
 387     $self->_relationships(\%rels);
 388     $self->throw_exception("Error creating relationship $rel: $@");
 389   }
 390   1;
 391 }
 392
 393 =head2 relationships
 394
 395 Returns all valid relationship names for this source
 396
 397 =cut
 398
 399 sub relationships {
 400   return keys %{shift->_relationships};
 401 }
 402
 403 =head2 relationship_info
 404
 405 =head3 Arguments: ($relname)
 406
 407 Returns the relationship information for the specified relationship name
 408
 409 =cut
 410
 411 sub relationship_info {
 412   my ($self, $rel) = @_;
 413   return $self->_relationships->{$rel};
 414 }
 415
 416 =head2 has_relationship
 417
 418 =head3 Arguments: ($rel)
 419
 420 Returns 1 if the source has a relationship of this name, 0 otherwise.
 421
 422 =cut
 423
 424 sub has_relationship {
 425   my ($self, $rel) = @_;
 426   return exists $self->_relationships->{$rel};
 427 }
 428
 429 =head2 resolve_join
 430
 431 =head3 Arguments: ($relation)
 432
 433 Returns the join structure required for the related result source
 434
 435 =cut
 436
 437 sub resolve_join {
 438   my ($self, $join, $alias, $seen) = @_;
 439   $seen ||= {};
 440   if (ref $join eq 'ARRAY') {
 441     return map { $self->resolve_join($_, $alias, $seen) } @$join;
 442   } elsif (ref $join eq 'HASH') {
 443     return
 444       map {
 445         my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
 446         ($self->resolve_join($_, $alias, $seen),
 447           $self->related_source($_)->resolve_join($join->{$_}, $as, $seen));
 448       } keys %$join;
 449   } elsif (ref $join) {
 450     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
 451   } else {
 452     my $count = ++$seen->{$join};
 453     #use Data::Dumper; warn Dumper($seen);
 454     my $as = ($count > 1 ? "${join}_${count}" : $join);
 455     my $rel_info = $self->relationship_info($join);
 456     $self->throw_exception("No such relationship ${join}") unless $rel_info;
 457     my $type = $rel_info->{attrs}{join_type} || '';
 458     return [ { $as => $self->related_source($join)->from,
 459                -join_type => $type },
 460              $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
 461   }
 462 }
 463
 464 =head2 resolve_condition
 465
 466 =head3 Arguments: ($cond, $as, $alias|$object)
 467
 468 Resolves the passed condition to a concrete query fragment. If given an alias,
 469 returns a join condition; if given an object, inverts that object to produce
 470 a related conditional from that object.
 471
 472 =cut
 473
 474 sub resolve_condition {
 475   my ($self, $cond, $as, $for) = @_;
 476   #warn %$cond;
 477   if (ref $cond eq 'HASH') {
 478     my %ret;
 479     while (my ($k, $v) = each %{$cond}) {
 480       # XXX should probably check these are valid columns
 481       $k =~ s/^foreign\.// || $self->throw_exception("Invalid rel cond key ${k}");
 482       $v =~ s/^self\.// || $self->throw_exception("Invalid rel cond val ${v}");
 483       if (ref $for) { # Object
 484         #warn "$self $k $for $v";
 485         $ret{$k} = $for->get_column($v);
 486         #warn %ret;
 487       } else {
 488         $ret{"${as}.${k}"} = "${for}.${v}";
 489       }
 490     }
 491     return \%ret;
 492   } elsif (ref $cond eq 'ARRAY') {
 493     return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
 494   } else {
 495    die("Can't handle this yet :(");
 496   }
 497 }
 498
 499 =head2 resolve_prefetch
 500
 501 =head3 Arguments: (hashref/arrayref/scalar)
 502
 503 Accepts one or more relationships for the current source and returns an
 504 array of column names for each of those relationships. Column names are
 505 prefixed relative to the current source, in accordance with where they appear
 506 in the supplied relationships. Examples:
 507
 508   my $source = $schema->resultset('Tag')->source;
 509   @columns = $source->resolve_prefetch( { cd => 'artist' } );
 510
 511   # @columns =
 512   #(
 513   #  'cd.cdid',
 514   #  'cd.artist',
 515   #  'cd.title',
 516   #  'cd.year',
 517   #  'cd.artist.artistid',
 518   #  'cd.artist.name'
 519   #)
 520
 521   @columns = $source->resolve_prefetch( qw[/ cd /] );
 522
 523   # @columns =
 524   #(
 525   #   'cd.cdid',
 526   #   'cd.artist',
 527   #   'cd.title',
 528   #   'cd.year'
 529   #)
 530
 531   $source = $schema->resultset('CD')->source;
 532   @columns = $source->resolve_prefetch( qw[/ artist producer /] );
 533
 534   # @columns =
 535   #(
 536   #  'artist.artistid',
 537   #  'artist.name',
 538   #  'producer.producerid',
 539   #  'producer.name'
 540   #)
 541
 542 =cut
 543
 544 sub resolve_prefetch {
 545   my ($self, $pre, $alias, $seen) = @_;
 546   $seen ||= {};
 547   use Data::Dumper;
 548   #$alias ||= $self->name;
 549   #warn $alias, Dumper $pre;
 550   if( ref $pre eq 'ARRAY' ) {
 551     return map { $self->resolve_prefetch( $_, $alias, $seen ) } @$pre;
 552   }
 553   elsif( ref $pre eq 'HASH' ) {
 554     my @ret =
 555     map {
 556       $self->resolve_prefetch($_, $alias, $seen),
 557       $self->related_source($_)->resolve_prefetch(
 558                                    $pre->{$_}, "${alias}.$_", $seen)
 559         } keys %$pre;
 560     #die Dumper \@ret;
 561     return @ret;
 562   }
 563   elsif( ref $pre ) {
 564     $self->throw_exception( "don't know how to resolve prefetch reftype " . ref $pre);
 565   }
 566   else {
 567     my $count = ++$seen->{$pre};
 568     my $as = ($count > 1 ? "${pre}_${count}" : $pre);
 569     my $rel_info = $self->relationship_info( $pre );
 570     $self->throw_exception( $self->name . " has no such relationship '$pre'" ) unless $rel_info;
 571     my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
 572     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
 573       $self->related_source($pre)->columns;
 574     #warn $alias, Dumper (\@ret);
 575     #return @ret;
 576   }
 577 }
 578
 579 =head2 related_source
 580
 581 =head3 Arguments: ($relname)
 582
 583 Returns the result source object for the given relationship
 584
 585 =cut
 586
 587 sub related_source {
 588   my ($self, $rel) = @_;
 589   if( !$self->has_relationship( $rel ) ) {
 590     $self->throw_exception("No such relationship '$rel'");
 591   }
 592   return $self->schema->source($self->relationship_info($rel)->{source});
 593 }
 594
 595 =head2 resultset
 596
 597 Returns a resultset for the given source, by calling:
 598
 599   $self->resultset_class->new($self, $self->resultset_attributes)
 600
 601 =head2 resultset_class
 602
 603 Set the class of the resultset, this is useful if you want to create your
 604 own resultset methods. Create your own class derived from
 605 L<DBIx::Class::ResultSet>, and set it here.
 606
 607 =head2 resultset_attributes
 608
 609 Specify here any attributes you wish to pass to your specialised resultset.
 610
 611 =cut
 612
 613 sub resultset {
 614   my $self = shift;
 615   return $self->resultset_class->new($self, $self->{resultset_attributes});
 616 }
 617
 618 =head2 throw_exception
 619
 620 See throw_exception in L<DBIx::Class::Schema>.
 621
 622 =cut
 623
 624 sub throw_exception {
 625   my $self = shift;
 626   if (defined $self->schema) {
 627     $self->schema->throw_exception(@_);
 628   } else {
 629     croak(@_);
 630   }
 631 }
 632
 633
 634 =head1 AUTHORS
 635
 636 Matt S. Trout <mst@shadowcatsystems.co.uk>
 637
 638 =head1 LICENSE
 639
 640 You may distribute this code under the same terms as Perl itself.
 641
 642 =cut
 643