/usr/share/perl5/Class/DBI/Relationship/HasMany.pm is in libclass-dbi-perl 3.0.17-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | package Class::DBI::Relationship::HasMany;
use strict;
use warnings;
use base 'Class::DBI::Relationship';
sub remap_arguments {
my ($proto, $class, $accessor, $f_class, $f_key, $args) = @_;
return $class->_croak($class->name . " needs an accessor name")
unless $accessor;
return $class->_croak($class->name . " needs a foreign class")
unless $f_class;
{
no strict 'refs';
defined &{"$class\::$accessor"}
and return $class->_carp("$accessor method already exists in $class\n");
}
my @f_method = ();
if (ref $f_class eq "ARRAY") {
($f_class, @f_method) = @$f_class;
}
$class->_require_class($f_class);
if (ref $f_key eq "HASH") { # didn't supply f_key, this is really $args
$args = $f_key;
$f_key = "";
}
$f_key ||= do {
my $meta = $f_class->meta_info('has_a');
my ($col) = grep $meta->{$_}->foreign_class eq $class, keys %$meta;
$col || $class->table_alias;
};
if (ref $f_key eq "ARRAY") {
return $class->_croak("Multi-column foreign keys not supported")
if @$f_key > 1;
$f_key = $f_key->[0];
}
$args ||= {};
$args->{mapping} = \@f_method;
$args->{foreign_key} = $f_key;
$args->{order_by} ||= $args->{sort}; # deprecated 0.96
warn "sort argument to has_many deprecated in favour of order_by"
if $args->{sort}; # deprecated 0.96
return ($class, $accessor, $f_class, $args);
}
sub _set_up_class_data {
my $self = shift;
$self->class->_extend_class_data(
__hasa_list => $self->foreign_class => $self->args->{foreign_key});
$self->SUPER::_set_up_class_data;
}
sub triggers {
my $self = shift;
if ($self->args->{no_cascade_delete}) { # old undocumented way
warn "no_cascade_delete deprecated in favour of cascade => None";
return;
}
my $strategy = $self->args->{cascade} || "Delete";
$strategy = "Class::DBI::Cascade::$strategy" unless $strategy =~ /::/;
$self->foreign_class->_require_class($strategy);
$strategy->can('cascade')
or return $self->_croak("$strategy is not a valid Cascade Strategy");
my $strat_obj = $strategy->new($self);
return (before_delete => sub { $strat_obj->cascade(@_) });
}
sub methods {
my $self = shift;
my $accessor = $self->accessor;
return (
$accessor => $self->_has_many_method,
"add_to_$accessor" => $self->_method_add_to,
);
}
sub _method_add_to {
my $rel = shift;
my $accessor = $rel->accessor;
return sub {
my ($self, $data) = @_;
my $class = ref $self
or return $self->_croak("add_to_$accessor called as class method");
return $self->_croak("add_to_$accessor needs data")
unless ref $data eq "HASH";
my $meta = $class->meta_info($rel->name => $accessor);
my ($f_class, $f_key, $args) =
($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
$data->{$f_key} = $self->id;
# See if has_many constraints were defined and auto fill them
if (defined $args->{constraint} && ref $args->{constraint} eq 'HASH') {
while (my ($k, $v) = each %{ $args->{constraint} }) {
$self->_croak(
"Can't add_to_$accessor with $k = $data->{$k} (must be $v)")
if defined($data->{$k}) && $data->{$k} ne $v;
$data->{$k} = $v;
}
}
$f_class->insert($data);
};
}
sub _has_many_method {
my $self = shift;
my $run_search = $self->_hm_run_search;
my @mapping = @{ $self->args->{mapping} } or return $run_search;
return sub {
return $run_search->(@_)->set_mapping_method(@mapping)
unless wantarray;
my @ret = $run_search->(@_);
foreach my $meth (@mapping) { @ret = map $_->$meth(), @ret }
return @ret;
}
}
sub _hm_run_search {
my $rel = shift;
my ($class, $accessor) = ($rel->class, $rel->accessor);
return sub {
my ($self, @search_args) = @_;
@search_args = %{ $search_args[0] } if ref $search_args[0] eq "HASH";
my $meta = $class->meta_info($rel->name => $accessor);
my ($f_class, $f_key, $args) =
($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
if (ref $self) { # For $artist->cds
unshift @search_args, %{ $args->{constraint} }
if defined($args->{constraint}) && ref $args->{constraint} eq 'HASH';
unshift @search_args, ($f_key => $self->id);
push @search_args, { order_by => $args->{order_by} }
if defined $args->{order_by};
return $f_class->search(@search_args);
} else { # For Artist->cds
# Cross-table join as class method
# This stuff is highly experimental and will probably change beyond
# recognition. Use at your own risk...
my %kv = @search_args;
my $query = Class::DBI::Query->new({ owner => $f_class });
$query->kings($class, $f_class);
$query->add_restriction(sprintf "%s.%s = %s.%s",
$f_class->table_alias, $f_key, $class->table_alias,
$class->primary_column);
$query->add_restriction("$_ = ?") for keys %kv;
my $sth = $query->run(values %kv);
return $f_class->sth_to_objects($sth);
}
};
}
1;
|