sub load_components {
my $class = shift;
my @comp = map { "DBIx::Class::$_" } grep { $_ !~ /^#/ } @_;
+ $class->_load_components(@comp);
+}
+
+sub load_own_components {
+ my $class = shift;
+ my @comp = map { "${class}::$_" } grep { $_ !~ /^#/ } @_;
+ $class->_load_components(@comp);
+}
+
+sub _load_components {
+ my ($class, @comp) = @_;
foreach my $comp (@comp) {
eval "use $comp";
die $@ if $@;
use warnings;
use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/
- CDBICompat::Constraints
- CDBICompat::Triggers
- CDBICompat::ReadOnly
- CDBICompat::GetSet
- CDBICompat::LiveObjectIndex
- CDBICompat::AttributeAPI
- CDBICompat::Stringify
- CDBICompat::DestroyWarning
- CDBICompat::Constructor
- CDBICompat::AccessorMapping
- CDBICompat::ColumnCase
- CDBICompat::MightHave
- CDBICompat::HasMany
- CDBICompat::HasA
- CDBICompat::LazyLoading
- CDBICompat::AutoUpdate
- CDBICompat::TempColumns
- CDBICompat::Retrieve
- CDBICompat::ColumnGroups
- CDBICompat::ImaDBI/);
-
- #DBIx::Class::CDBICompat::ObjIndexStubs
+__PACKAGE__->load_own_components(qw/
+ Constraints
+ Triggers
+ ReadOnly
+ GetSet
+ LiveObjectIndex
+ AttributeAPI
+ Stringify
+ DestroyWarning
+ Constructor
+ AccessorMapping
+ ColumnCase
+ MightHave
+ HasMany
+ HasA
+ LazyLoading
+ AutoUpdate
+ TempColumns
+ Retrieve
+ ColumnGroups
+ ImaDBI/);
+
+ #DBIx::Class::ObjIndexStubs
1;
=head1 NAME
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/
- Relationship::Accessor
- Relationship::CascadeActions
- Relationship::ProxyMethods
Relationship
InflateColumn
- #SQL::OrderBy
SQL::Abstract
PK
Table
use strict;
use warnings;
-use base qw/Class::Data::Inheritable/;
+use base qw/DBIx::Class Class::Data::Inheritable/;
+
+__PACKAGE__->load_own_components(qw/Accessor CascadeActions ProxyMethods Base/);
__PACKAGE__->mk_classdata('_relationships', { } );
=cut
-sub add_relationship {
- my ($class, $rel, $f_class, $cond, $attrs) = @_;
- die "Can't create relationship without join condition" unless $cond;
- $attrs ||= {};
- eval "use $f_class;";
- my %rels = %{ $class->_relationships };
- $rels{$rel} = { class => $f_class,
- cond => $cond,
- attrs => $attrs };
- $class->_relationships(\%rels);
- #warn %{$f_class->_columns};
-
- return unless eval { %{$f_class->_columns}; }; # Foreign class not loaded
- my %join = (%$attrs, _action => 'join',
- _aliases => { 'self' => 'me', 'foreign' => $rel },
- _classes => { 'me' => $class, $rel => $f_class });
- eval { $class->_cond_resolve($cond, \%join) };
-
- if ($@) { # If the resolve failed, back out and re-throw the error
- delete $rels{$rel}; #
- $class->_relationships(\%rels);
- $class->throw("Error creating relationship $rel: $@");
- }
- 1;
-}
-
-sub _cond_key {
- my ($self, $attrs, $key) = @_;
- my $action = $attrs->{_action} || '';
- if ($action eq 'convert') {
- unless ($key =~ s/^foreign\.//) {
- $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
- }
- return $key;
- } elsif ($action eq 'join') {
- my ($type, $field) = split(/\./, $key);
- if (my $alias = $attrs->{_aliases}{$type}) {
- my $class = $attrs->{_classes}{$alias};
- $self->throw("Unknown column $field on $class as $alias")
- unless exists $class->_columns->{$field};
- return join('.', $alias, $field);
- } else {
- $self->throw( "Unable to resolve type ${type}: only have aliases for ".
- join(', ', keys %{$attrs->{_aliases} || {}}) );
- }
- }
- return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
-}
-
-sub _cond_value {
- my ($self, $attrs, $key, $value) = @_;
- my $action = $attrs->{_action} || '';
- if ($action eq 'convert') {
- unless ($value =~ s/^self\.//) {
- $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
- }
- unless ($self->_columns->{$value}) {
- $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
- }
- push(@{$attrs->{bind}}, $self->get_column($value));
- return '?';
- } elsif ($action eq 'join') {
- my ($type, $field) = split(/\./, $value);
- if (my $alias = $attrs->{_aliases}{$type}) {
- my $class = $attrs->{_classes}{$alias};
- $self->throw("Unknown column $field on $class as $alias")
- unless exists $class->_columns->{$field};
- return join('.', $alias, $field);
- } else {
- $self->throw( "Unable to resolve type ${type}: only have aliases for ".
- join(', ', keys %{$attrs->{_aliases} || {}}) );
- }
- }
-
- return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
-}
-
-sub search_related {
- my $self = shift;
- return $self->_query_related('search', @_);
-}
-
-sub count_related {
- my $self = shift;
- return $self->_query_related('count', @_);
-}
-
-sub _query_related {
- my $self = shift;
- my $meth = shift;
- my $rel = shift;
- my $attrs = { };
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %{ pop(@_) } };
- }
- my $rel_obj = $self->_relationships->{$rel};
- $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
- $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
-
- $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
- my $query = ((@_ > 1) ? {@_} : shift);
-
- $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
- # to merge into the AST really?
- my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
- $query = ($query ? { '-and' => [ \$cond, $query ] } : \$cond);
- #use Data::Dumper; warn Dumper($query);
- #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}});
- delete $attrs->{_action};
- return $self->resolve_class($rel_obj->{class}
- )->$meth($query, $attrs);
-}
-
-sub create_related {
- my $class = shift;
- return $class->new_related(@_)->insert;
-}
-
-sub new_related {
- my ($self, $rel, $values, $attrs) = @_;
- $self->throw( "Can't call new_related as class method" )
- unless ref $self;
- $self->throw( "new_related needs a hash" )
- unless (ref $values eq 'HASH');
- my $rel_obj = $self->_relationships->{$rel};
- $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
- $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
- unless ref $rel_obj->{cond} eq 'HASH';
- $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
- my %fields = %$values;
- while (my ($k, $v) = each %{$rel_obj->{cond}}) {
- $self->_cond_value($attrs, $k => $v);
- $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
- }
- return $self->resolve_class($rel_obj->{class})->new(\%fields);
-}
-
-sub find_or_create_related {
- my $self = shift;
- return ($self->search_related(@_))[0] || $self->create_related(@_);
-}
-
-sub set_from_related {
- my ($self, $rel, $f_obj) = @_;
- my $rel_obj = $self->_relationships->{$rel};
- $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
- my $cond = $rel_obj->{cond};
- $self->throw( "set_from_related can only handle a hash condition; the "
- ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
- unless ref $cond eq 'HASH';
- my $f_class = $self->resolve_class($rel_obj->{class});
- $self->throw( "Object $f_obj isn't a ".$f_class )
- unless $f_obj->isa($f_class);
- foreach my $key (keys %$cond) {
- next if ref $cond->{$key}; # Skip literals and complex conditions
- $self->throw("set_from_related can't handle $key as key")
- unless $key =~ m/^foreign\.([^\.]+)$/;
- my $val = $f_obj->get_column($1);
- $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
- unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
- $self->set_column($1 => $val);
- }
- return 1;
-}
-
-sub update_from_related {
- my $self = shift;
- $self->set_from_related(@_);
- $self->update;
-}
-
-sub delete_related {
- my $self = shift;
- return $self->search_related(@_)->delete;
-}
-
1;
=back
--- /dev/null
+package DBIx::Class::Relationship::Base;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_relationships', { } );
+
+=head1 NAME
+
+DBIx::Class::Relationship - Inter-table relationships
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+This class handles relationships between the tables in your database
+model. It allows your to set up relationships, and to perform joins
+on searches.
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
+sub add_relationship {
+ my ($class, $rel, $f_class, $cond, $attrs) = @_;
+ die "Can't create relationship without join condition" unless $cond;
+ $attrs ||= {};
+ eval "use $f_class;";
+ my %rels = %{ $class->_relationships };
+ $rels{$rel} = { class => $f_class,
+ cond => $cond,
+ attrs => $attrs };
+ $class->_relationships(\%rels);
+ #warn %{$f_class->_columns};
+
+ return unless eval { %{$f_class->_columns}; }; # Foreign class not loaded
+ my %join = (%$attrs, _action => 'join',
+ _aliases => { 'self' => 'me', 'foreign' => $rel },
+ _classes => { 'me' => $class, $rel => $f_class });
+ eval { $class->_cond_resolve($cond, \%join) };
+
+ if ($@) { # If the resolve failed, back out and re-throw the error
+ delete $rels{$rel}; #
+ $class->_relationships(\%rels);
+ $class->throw("Error creating relationship $rel: $@");
+ }
+ 1;
+}
+
+sub _cond_key {
+ my ($self, $attrs, $key) = @_;
+ my $action = $attrs->{_action} || '';
+ if ($action eq 'convert') {
+ unless ($key =~ s/^foreign\.//) {
+ $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
+ }
+ return $key;
+ } elsif ($action eq 'join') {
+ my ($type, $field) = split(/\./, $key);
+ if (my $alias = $attrs->{_aliases}{$type}) {
+ my $class = $attrs->{_classes}{$alias};
+ $self->throw("Unknown column $field on $class as $alias")
+ unless exists $class->_columns->{$field};
+ return join('.', $alias, $field);
+ } else {
+ $self->throw( "Unable to resolve type ${type}: only have aliases for ".
+ join(', ', keys %{$attrs->{_aliases} || {}}) );
+ }
+ }
+ return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
+}
+
+sub _cond_value {
+ my ($self, $attrs, $key, $value) = @_;
+ my $action = $attrs->{_action} || '';
+ if ($action eq 'convert') {
+ unless ($value =~ s/^self\.//) {
+ $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
+ }
+ unless ($self->_columns->{$value}) {
+ $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
+ }
+ push(@{$attrs->{bind}}, $self->get_column($value));
+ return '?';
+ } elsif ($action eq 'join') {
+ my ($type, $field) = split(/\./, $value);
+ if (my $alias = $attrs->{_aliases}{$type}) {
+ my $class = $attrs->{_classes}{$alias};
+ $self->throw("Unknown column $field on $class as $alias")
+ unless exists $class->_columns->{$field};
+ return join('.', $alias, $field);
+ } else {
+ $self->throw( "Unable to resolve type ${type}: only have aliases for ".
+ join(', ', keys %{$attrs->{_aliases} || {}}) );
+ }
+ }
+
+ return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
+}
+
+sub search_related {
+ my $self = shift;
+ return $self->_query_related('search', @_);
+}
+
+sub count_related {
+ my $self = shift;
+ return $self->_query_related('count', @_);
+}
+
+sub _query_related {
+ my $self = shift;
+ my $meth = shift;
+ my $rel = shift;
+ my $attrs = { };
+ if (@_ > 1 && ref $_[$#_] eq 'HASH') {
+ $attrs = { %{ pop(@_) } };
+ }
+ my $rel_obj = $self->_relationships->{$rel};
+ $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
+ $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
+
+ $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
+ my $query = ((@_ > 1) ? {@_} : shift);
+
+ $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
+ # to merge into the AST really?
+ my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
+ $query = ($query ? { '-and' => [ \$cond, $query ] } : \$cond);
+ #use Data::Dumper; warn Dumper($query);
+ #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}});
+ delete $attrs->{_action};
+ return $self->resolve_class($rel_obj->{class}
+ )->$meth($query, $attrs);
+}
+
+sub create_related {
+ my $class = shift;
+ return $class->new_related(@_)->insert;
+}
+
+sub new_related {
+ my ($self, $rel, $values, $attrs) = @_;
+ $self->throw( "Can't call new_related as class method" )
+ unless ref $self;
+ $self->throw( "new_related needs a hash" )
+ unless (ref $values eq 'HASH');
+ my $rel_obj = $self->_relationships->{$rel};
+ $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
+ $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
+ unless ref $rel_obj->{cond} eq 'HASH';
+ $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
+ my %fields = %$values;
+ while (my ($k, $v) = each %{$rel_obj->{cond}}) {
+ $self->_cond_value($attrs, $k => $v);
+ $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
+ }
+ return $self->resolve_class($rel_obj->{class})->new(\%fields);
+}
+
+sub find_or_create_related {
+ my $self = shift;
+ return ($self->search_related(@_))[0] || $self->create_related(@_);
+}
+
+sub set_from_related {
+ my ($self, $rel, $f_obj) = @_;
+ my $rel_obj = $self->_relationships->{$rel};
+ $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
+ my $cond = $rel_obj->{cond};
+ $self->throw( "set_from_related can only handle a hash condition; the "
+ ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
+ unless ref $cond eq 'HASH';
+ my $f_class = $self->resolve_class($rel_obj->{class});
+ $self->throw( "Object $f_obj isn't a ".$f_class )
+ unless $f_obj->isa($f_class);
+ foreach my $key (keys %$cond) {
+ next if ref $cond->{$key}; # Skip literals and complex conditions
+ $self->throw("set_from_related can't handle $key as key")
+ unless $key =~ m/^foreign\.([^\.]+)$/;
+ my $val = $f_obj->get_column($1);
+ $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
+ unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
+ $self->set_column($1 => $val);
+ }
+ return 1;
+}
+
+sub update_from_related {
+ my $self = shift;
+ $self->set_from_related(@_);
+ $self->update;
+}
+
+sub delete_related {
+ my $self = shift;
+ return $self->search_related(@_)->delete;
+}
+
+1;
+
+=back
+
+=head1 AUTHORS
+
+Matt S. Trout <perl-stuff@trout.me.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+++ /dev/null
-package DBIx::Class::SQL::OrderBy;
-
-use strict;
-use warnings;
-
-sub _cond_resolve {
- my ($self, $cond, $attrs, @rest) = @_;
- return $self->NEXT::ACTUAL::_cond_resolve($cond, $attrs, @rest)
- unless wantarray;
- my ($sql, @bind) = $self->NEXT::ACTUAL::_cond_resolve($cond, $attrs, @rest);
- if ($attrs->{order_by}) {
- $sql .= " ORDER BY ".join(', ', (ref $attrs->{order_by} eq 'ARRAY'
- ? @{$attrs->{order_by}}
- : $attrs->{order_by}));
- }
- return ($sql, @bind);
-}
-
-1;
-
-=head1 NAME
-
-DBIx::Class::SQL::OrderBy - Implements sorting for DBIC's SQL backend
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This class implements the order_by attribute to L<DBIx::Class>'s search
-builder.
-
-=cut
-
-=head1 AUTHORS
-
-Matt S. Trout <perl-stuff@trout.me.uk>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
return $new->insert;
}
-#sub _cond_resolve {
-# my ($self, $query, $attrs) = @_;
-# return '1 = 1' unless keys %$query;
-# my $op = $attrs->{'cmp'} || '=';
-# my $cond = join(' AND ',
-# map { (defined $query->{$_}
-# ? "$_ $op ?"
-# : (do { delete $query->{$_}; "$_ IS NULL"; }));
-# } keys %$query);
-# return ($cond, values %$query);
-#}
-
=item table
__PACKAGE__->table('tbl_name');
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff