X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=17e1bf0b8945a23529efa95147ec59e88d6e29fb;hb=e5f4d2a612ba63dacaaf94c125840ed00f66bf03;hp=700d01ec57555506b4df1aa42c84f1156c6e57de;hpb=2053ab2a47d0cbf3db670003d01a9b4650bc46d6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 700d01e..17e1bf0 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -15,9 +15,9 @@ __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns schema from _relationships/); __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class - result_class/); + result_class source_name/); -=head1 NAME +=head1 NAME DBIx::Class::ResultSource - Result source object @@ -63,7 +63,7 @@ keys are currently recognised/used by DBIx::Class: =over 4 -=item accessor +=item accessor Use this to set the name of the accessor for this column. If unset, the name of the column will be used. @@ -83,7 +83,7 @@ whatever your database supports. =item size The length of your column, if it is a column type that can have a size -restriction. This is currently not used by DBIx::Class. +restriction. This is currently not used by DBIx::Class. =item is_nullable @@ -105,7 +105,7 @@ foreign table. This is currently not used by DBIx::Class. Set this to the default value which will be inserted into a column by the database. Can contain either a value or a function. This is -currently not used by DBIx::Class. +currently not used by DBIx::Class. =item sequence @@ -127,7 +127,7 @@ Convenience alias to add_columns. sub add_columns { my ($self, @cols) = @_; $self->_ordered_columns(\@cols) unless $self->_ordered_columns; - + my @added; my $columns = $self->_columns; while (my $col = shift @cols) { @@ -167,16 +167,16 @@ of add_column for information on the contents of the hashref. sub column_info { my ($self, $column) = @_; - $self->throw_exception("No such column $column") + $self->throw_exception("No such column $column") unless exists $self->_columns->{$column}; #warn $self->{_columns_info_loaded}, "\n"; - if ( ! $self->_columns->{$column}{data_type} - and ! $self->{_columns_info_loaded} + if ( ! $self->_columns->{$column}{data_type} + and ! $self->{_columns_info_loaded} and $self->schema and $self->storage ) { $self->{_columns_info_loaded}++; my $info; - # eval for the case of storage without table + # eval for the case of storage without table eval { $info = $self->storage->columns_info_for($self->from) }; unless ($@) { foreach my $col ( keys %{$self->_columns} ) { @@ -205,6 +205,41 @@ sub columns { return @{$self->{_ordered_columns}||[]}; } +=head2 remove_columns + + $table->remove_columns(qw/col1 col2 col3/); + +Removes columns from the result source. + +=head2 remove_column + + $table->remove_column('col'); + +Convenience alias to remove_columns. + +=cut + +sub remove_columns { + my ($self, @cols) = @_; + + return unless $self->_ordered_columns; + + my $columns = $self->_columns; + my @remaining; + + foreach my $col (@{$self->_ordered_columns}) { + push @remaining, $col unless grep(/$col/, @cols); + } + + foreach (@cols) { + undef $columns->{$_}; + }; + + $self->_ordered_columns(\@remaining); +} + +*remove_column = \&remove_columns; + =head2 set_primary_key =over 4 @@ -219,7 +254,7 @@ called after C. Additionally, defines a unique constraint named C. The primary key columns are used by L to -retrieve automatically created values from the database. +retrieve automatically created values from the database. =cut @@ -248,15 +283,16 @@ sub primary_columns { =head2 add_unique_constraint Declare a unique constraint on this source. Call once for each unique -constraint. Unique constraints are used when you call C on a -L. Only columns in the constraint are searched, -for example: +constraint. # For UNIQUE (column1, column2) __PACKAGE__->add_unique_constraint( constraint_name => [ qw/column1 column2/ ], ); +Unique constraints are used, for example, when you call +L. Only columns in the constraint are searched. + =cut sub add_unique_constraint { @@ -292,7 +328,7 @@ clause contents. =head2 storage -Returns the storage handle for the current schema. +Returns the storage handle for the current schema. See also: L @@ -339,11 +375,11 @@ the SQL command immediately before C. An arrayref containing a list of accessors in the foreign class to proxy in the main class. If, for example, you do the following: - + CD->might_have(liner_notes => 'LinerNotes', undef, { proxy => [ qw/notes/ ], }); - + Then, assuming LinerNotes has an accessor named notes, you can do: my $cd = CD->find(1); @@ -353,11 +389,11 @@ Then, assuming LinerNotes has an accessor named notes, you can do: =item accessor Specifies the type of accessor that should be created for the -relationship. Valid values are C (for when there is only a single -related object), C (when there can be many), and C (for -when there is a single related object, but you also want the relationship -accessor to double as a column accessor). For C accessors, an -add_to_* method is also created, which calls C for the +relationship. Valid values are C (for when there is only a single +related object), C (when there can be many), and C (for +when there is a single related object, but you also want the relationship +accessor to double as a column accessor). For C accessors, an +add_to_* method is also created, which calls C for the relationship. =back @@ -398,7 +434,7 @@ sub add_relationship { eval { $self->resolve_join($rel, 'me') }; if ($@) { # If the resolve failed, back out and re-throw the error - delete $rels{$rel}; # + delete $rels{$rel}; # $self->_relationships(\%rels); $self->throw_exception("Error creating relationship $rel: $@"); } @@ -431,7 +467,7 @@ name. sub relationship_info { my ($self, $rel) = @_; return $self->_relationships->{$rel}; -} +} =head2 has_relationship @@ -450,6 +486,113 @@ sub has_relationship { return exists $self->_relationships->{$rel}; } +=head2 reverse_relationship_info + +=over 4 + +=item Arguments: $relname + +=back + +Returns an array of hash references of relationship information for +the other side of the specified relationship name. + +=cut + +sub reverse_relationship_info { + my ($self, $rel) = @_; + my $rel_info = $self->relationship_info($rel); + my $ret = {}; + + return $ret unless ((ref $rel_info->{cond}) eq 'HASH'); + + my @cond = keys(%{$rel_info->{cond}}); + my @refkeys = map {/^\w+\.(\w+)$/} @cond; + my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond; + + # Get the related result source for this relationship + my $othertable = $self->related_source($rel); + + # Get all the relationships for that source that related to this source + # whose foreign column set are our self columns on $rel and whose self + # columns are our foreign columns on $rel. + my @otherrels = $othertable->relationships(); + my $otherrelationship; + foreach my $otherrel (@otherrels) { + my $otherrel_info = $othertable->relationship_info($otherrel); + + my $back = $othertable->related_source($otherrel); + next unless $back->name eq $self->name; + + my @othertestconds; + + if (ref $otherrel_info->{cond} eq 'HASH') { + @othertestconds = ($otherrel_info->{cond}); + } + elsif (ref $otherrel_info->{cond} eq 'ARRAY') { + @othertestconds = @{$otherrel_info->{cond}}; + } + else { + next; + } + + foreach my $othercond (@othertestconds) { + my @other_cond = keys(%$othercond); + my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond; + my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond; + next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) || + !$self->compare_relationship_keys(\@other_refkeys, \@keys)); + $ret->{$otherrel} = $otherrel_info; + } + } + return $ret; +} + +=head2 compare_relationship_keys + +=over 4 + +=item Arguments: $keys1, $keys2 + +=back + +Returns true if both sets of keynames are the same, false otherwise. + +=cut + +sub compare_relationship_keys { + my ($self, $keys1, $keys2) = @_; + + # Make sure every keys1 is in keys2 + my $found; + foreach my $key (@$keys1) { + $found = 0; + foreach my $prim (@$keys2) { + if ($prim eq $key) { + $found = 1; + last; + } + } + last unless $found; + } + + # Make sure every key2 is in key1 + if ($found) { + foreach my $prim (@$keys2) { + $found = 0; + foreach my $key (@$keys1) { + if ($prim eq $key) { + $found = 1; + last; + } + } + last unless $found; + } + } + + return $found; +} + =head2 resolve_join =over 4 @@ -511,9 +654,9 @@ sub resolve_condition { while (my ($k, $v) = each %{$cond}) { # XXX should probably check these are valid columns $k =~ s/^foreign\.// || - $self->throw_exception("Invalid rel cond key ${k}"); + $self->throw_exception("Invalid rel cond key ${k}"); $v =~ s/^self\.// || - $self->throw_exception("Invalid rel cond val ${v}"); + $self->throw_exception("Invalid rel cond val ${v}"); if (ref $for) { # Object #warn "$self $k $for $v"; $ret{$k} = $for->get_column($v); @@ -577,7 +720,7 @@ in the supplied relationships. Examples: # 'artist.name', # 'producer.producerid', # 'producer.name' - #) + #) =cut @@ -711,6 +854,26 @@ sub resultset { ); } +=head2 source_name + +=over 4 + +=item Arguments: $source_name + +=back + +Set the name of the result source when it is loaded into a schema. +This is usefull if you want to refer to a result source by a name other than +its class name. + + package ArchivedBooks; + use base qw/DBIx::Class/; + __PACKAGE__->table('books_archive'); + __PACKAGE__->source_name('Books'); + + # from your schema... + $schema->resultset('Books')->find(1); + =head2 throw_exception See L. @@ -719,7 +882,7 @@ See L. sub throw_exception { my $self = shift; - if (defined $self->schema) { + if (defined $self->schema) { $self->schema->throw_exception(@_); } else { croak(@_);