[300] | 1 | package LATMOS::Accounts::Bases::Sql::Aliases; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
| 6 | |
---|
| 7 | use base qw(LATMOS::Accounts::Bases::Sql::objects); |
---|
[369] | 8 | use LATMOS::Accounts::Log; |
---|
[300] | 9 | |
---|
| 10 | our $VERSION = (q$Rev: 341 $ =~ /^Rev: (\d+) /)[0]; |
---|
| 11 | |
---|
| 12 | =head1 NAME |
---|
| 13 | |
---|
[1023] | 14 | LATMOS::Accounts::Bases::Sql::Aliases - Mail alias object |
---|
[300] | 15 | |
---|
| 16 | =cut |
---|
| 17 | |
---|
[1014] | 18 | sub _object_table { 'aliases' } |
---|
[300] | 19 | |
---|
[1014] | 20 | sub _key_field { 'name' } |
---|
[300] | 21 | |
---|
[1014] | 22 | sub _has_extended_attributes { 1 } |
---|
[300] | 23 | |
---|
[861] | 24 | sub _get_attr_schema { |
---|
| 25 | my ($class, $base) = @_; |
---|
| 26 | |
---|
| 27 | $class->SUPER::_get_attr_schema($base, |
---|
| 28 | { |
---|
| 29 | name => { |
---|
| 30 | ro => 1, |
---|
| 31 | }, |
---|
| 32 | forward => { |
---|
| 33 | mandatory => 1, |
---|
| 34 | multiple => 1, |
---|
[1299] | 35 | monitored => 1, |
---|
[861] | 36 | }, |
---|
[959] | 37 | finalpoint => { ro => 1, multiple => 1 }, |
---|
[861] | 38 | parents => { ro => 1, }, |
---|
| 39 | anyparents => { ro => 1, }, |
---|
[959] | 40 | sameforward => { ro => 1, multiple => 1 }, |
---|
| 41 | samedestination => { ro => 1, multiple => 1 }, |
---|
[861] | 42 | user => { |
---|
| 43 | ro => 1, |
---|
| 44 | reference => 'user', |
---|
| 45 | }, |
---|
[939] | 46 | expire => { |
---|
| 47 | inline => 1, |
---|
| 48 | formtype => 'DATE', |
---|
| 49 | }, |
---|
[861] | 50 | } |
---|
| 51 | ) |
---|
[369] | 52 | } |
---|
| 53 | |
---|
[499] | 54 | sub new { |
---|
| 55 | my ($class, $base, $id) = @_; |
---|
| 56 | my $sth = $base->db->prepare_cached(q{ |
---|
| 57 | select name from aliases where lower(name) = lower(?) |
---|
| 58 | }); |
---|
| 59 | $sth->execute($id); |
---|
| 60 | my $res = $sth->fetchrow_hashref; |
---|
| 61 | $sth->finish; |
---|
| 62 | if ($res) { |
---|
| 63 | $class->SUPER::new($base, $res->{name}); |
---|
| 64 | } else { |
---|
| 65 | return; |
---|
| 66 | } |
---|
| 67 | } |
---|
| 68 | |
---|
[369] | 69 | sub _create { |
---|
| 70 | my ($class, $base, $id, %data) = @_; |
---|
[493] | 71 | $data{'forward'} = [ $data{'forward'} ] unless(ref $data{'forward'}); |
---|
[369] | 72 | my $sth = $base->db->prepare_cached(q{ |
---|
| 73 | select name from aliases where lower(name) = lower(?) |
---|
| 74 | limit 1 |
---|
| 75 | }); |
---|
| 76 | $sth->execute($id); |
---|
| 77 | my $res = $sth->fetchrow_hashref; |
---|
[371] | 78 | $sth->finish; |
---|
[369] | 79 | if ($res) { |
---|
| 80 | $base->log(LA_ERR, "Aliases %s already exists as %s", |
---|
| 81 | $id, $res->{name}); |
---|
| 82 | return; |
---|
| 83 | } else { |
---|
[370] | 84 | return $class->SUPER::_create($base, $id, %data); |
---|
[369] | 85 | } |
---|
| 86 | } |
---|
| 87 | |
---|
| 88 | sub get_field { |
---|
| 89 | my ($self, $field) = @_; |
---|
| 90 | if ($field eq 'finalpoint') { |
---|
| 91 | my $sth = $self->db->prepare_cached(q{ |
---|
| 92 | select forward from aliases where lower(name) = lower(?) |
---|
| 93 | limit 1 |
---|
| 94 | }); |
---|
[928] | 95 | my @res = (); |
---|
[1161] | 96 | my @next = @{ $self->get_field('forward') || [] }; |
---|
[928] | 97 | while (my $next = shift(@next)) { |
---|
[369] | 98 | $sth->execute($next); |
---|
| 99 | if (my $res = $sth->fetchrow_hashref) { |
---|
[928] | 100 | push(@next, @{ $res->{forward} }); |
---|
[369] | 101 | } else { |
---|
[928] | 102 | push(@res, $next); |
---|
[369] | 103 | } |
---|
| 104 | } |
---|
[371] | 105 | $sth->finish; |
---|
[928] | 106 | return @res ? \@res : undef; |
---|
[369] | 107 | } |
---|
| 108 | if ($field =~ /^(parents|anyparents|sameforward|samedestination)$/) { |
---|
| 109 | my $sth = $self->db->prepare_cached(q{ |
---|
[462] | 110 | select name from aliases where array[lower($1)] <@ |
---|
| 111 | string_to_array(lower(array_to_string("forward", ',')), ',') |
---|
[369] | 112 | }); |
---|
| 113 | my @tocheck = ($field =~ /^sameforward$/ |
---|
| 114 | ? $self->get_field('forward') |
---|
| 115 | : ($field =~ /^samedestination$/ |
---|
| 116 | ? $self->get_field('finalpoint') |
---|
| 117 | : $self->id)); |
---|
| 118 | my @results; |
---|
| 119 | my @already; |
---|
| 120 | while (my $next = shift(@tocheck)) { |
---|
| 121 | # endless loop detection |
---|
| 122 | grep { $next eq $_ } @already and do { |
---|
| 123 | push(@results, 'LOOP'); |
---|
| 124 | next; |
---|
| 125 | }; |
---|
| 126 | push(@already, $next); |
---|
| 127 | $sth->execute($next); |
---|
| 128 | while (my $res = $sth->fetchrow_hashref) { |
---|
| 129 | push(@tocheck, $res->{name}); |
---|
| 130 | $res->{name} eq $self->id and next; |
---|
| 131 | push(@results, $res->{name}); |
---|
| 132 | } |
---|
| 133 | $field =~ /^(parents|sameforward)$/ and last; # No recursive search |
---|
| 134 | } |
---|
| 135 | return scalar(@results) <= 1 ? $results[0] : \@results; |
---|
| 136 | } |
---|
| 137 | $self->SUPER::get_field($field); |
---|
| 138 | } |
---|
| 139 | |
---|
[493] | 140 | sub set_fields { |
---|
| 141 | my ($self, %attrs) = @_; |
---|
| 142 | foreach (keys %attrs) { |
---|
| 143 | /^forward$/ and do { |
---|
| 144 | $attrs{$_} = [ $attrs{$_} ] unless(ref $attrs{$_}); |
---|
| 145 | }; |
---|
| 146 | } |
---|
| 147 | $self->SUPER::set_fields(%attrs); |
---|
| 148 | } |
---|
| 149 | |
---|
[300] | 150 | 1; |
---|
| 151 | |
---|
| 152 | __END__ |
---|
| 153 | |
---|
| 154 | =head1 SEE ALSO |
---|
| 155 | |
---|
[1023] | 156 | L<LATMOS::Accounts::Bases::Sql> |
---|
| 157 | |
---|
| 158 | L<LATMOS::Accounts::Bases::Sql::Revaliases> |
---|
| 159 | |
---|
[300] | 160 | =head1 AUTHOR |
---|
| 161 | |
---|
| 162 | Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt> |
---|
| 163 | |
---|
| 164 | =head1 COPYRIGHT AND LICENSE |
---|
| 165 | |
---|
| 166 | Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS |
---|
| 167 | |
---|
| 168 | This library is free software; you can redistribute it and/or modify |
---|
| 169 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 170 | at your option, any later version of Perl 5 you may have available. |
---|
| 171 | |
---|
| 172 | |
---|
| 173 | =cut |
---|