[288] | 1 | package LATMOS::Accounts::Bases::Ldap::objects; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
| 6 | |
---|
| 7 | use base qw(LATMOS::Accounts::Bases::Objects); |
---|
| 8 | use Net::LDAP; |
---|
| 9 | use Net::LDAP::Entry; |
---|
| 10 | use Net::LDAP::Control::Paged; |
---|
| 11 | use Net::LDAP::Constant qw( LDAP_CONTROL_PAGED ); |
---|
| 12 | use Net::LDAP::Util qw( escape_filter_value ); |
---|
| 13 | use LATMOS::Accounts::Log; |
---|
| 14 | |
---|
| 15 | our $VERSION = (q$Rev: 652 $ =~ /^Rev: (\d+) /)[0]; |
---|
| 16 | |
---|
| 17 | =head1 NAME |
---|
| 18 | |
---|
| 19 | LATMOS::Ldap - Perl extension for blah blah blah |
---|
| 20 | |
---|
| 21 | =head1 SYNOPSIS |
---|
| 22 | |
---|
| 23 | use LATMOS::Ldap; |
---|
| 24 | blah blah blah |
---|
| 25 | |
---|
| 26 | =head1 DESCRIPTION |
---|
| 27 | |
---|
| 28 | Stub documentation for LATMOS::Ldap, created by h2xs. It looks like the |
---|
| 29 | author of the extension was negligent enough to leave the stub |
---|
| 30 | unedited. |
---|
| 31 | |
---|
| 32 | Blah blah blah. |
---|
| 33 | |
---|
| 34 | =head1 FUNCTIONS |
---|
| 35 | |
---|
| 36 | =cut |
---|
| 37 | |
---|
[861] | 38 | sub _get_attr_schema { |
---|
| 39 | my ($class, $base, $info) = @_; |
---|
| 40 | $info ||= {}; |
---|
| 41 | |
---|
| 42 | foreach (qw( |
---|
| 43 | createTimestamp |
---|
| 44 | creatorsName |
---|
| 45 | entryUUID |
---|
| 46 | modifiersName |
---|
| 47 | modifyTimestamp |
---|
| 48 | entryCSN |
---|
| 49 | )) { |
---|
| 50 | $info->{$_} = { ro => 1 }; |
---|
| 51 | } |
---|
| 52 | |
---|
[1117] | 53 | $info->{$class->_key_attribute($base)}{ro} = 1; |
---|
| 54 | $info->{$class->_dn_attribute($base)}{ro} = 1; |
---|
| 55 | |
---|
[861] | 56 | return $info; |
---|
| 57 | } |
---|
| 58 | |
---|
[1117] | 59 | sub _key_attribute { |
---|
| 60 | my ($self, $base) = @_; |
---|
| 61 | $base ||= $self->base; |
---|
| 62 | |
---|
| 63 | $base->config($self->type . '_key_attribute') || $self->_key_attr || 'cn'; |
---|
| 64 | } |
---|
| 65 | |
---|
| 66 | sub _dn_attribute { |
---|
| 67 | my ($self, $base) = @_; |
---|
| 68 | $base ||= $self->base; |
---|
| 69 | |
---|
| 70 | $base->config($self->type . '_dn_attribute') || $self->_key_attr || 'cn'; |
---|
| 71 | } |
---|
| 72 | |
---|
[288] | 73 | sub list { |
---|
| 74 | my ($class, $base) = @_; |
---|
| 75 | |
---|
| 76 | my @uids; |
---|
| 77 | eval { |
---|
| 78 | my $xx = $base->_unlimited_search( |
---|
[1117] | 79 | attrs => [ $class->_key_attribute($base) ], |
---|
[288] | 80 | base => $base->object_base_dn($class->type), |
---|
| 81 | filter => $class->_class_filter, |
---|
| 82 | callback => sub { |
---|
| 83 | my ($mesg, $entry) = @_; |
---|
| 84 | #$mesg->code and die $mesg->error; |
---|
| 85 | $entry or return; |
---|
| 86 | ref $entry eq 'Net::LDAP::Entry' or return; |
---|
[1117] | 87 | push(@uids, $entry->get_value( $class->_key_attribute($base) )); |
---|
[288] | 88 | }, |
---|
| 89 | ); |
---|
| 90 | }; |
---|
| 91 | |
---|
| 92 | return @uids; |
---|
| 93 | |
---|
| 94 | } |
---|
| 95 | |
---|
| 96 | sub new { |
---|
| 97 | my ($class, $base, $uid) = @_; |
---|
| 98 | |
---|
| 99 | my $mesg = $base->ldap->search( |
---|
| 100 | filter => sprintf( |
---|
| 101 | '(&%s (%s=%s))', |
---|
| 102 | $class->_class_filter, |
---|
[1117] | 103 | $class->_key_attribute($base), |
---|
[288] | 104 | escape_filter_value($uid), |
---|
| 105 | ), |
---|
| 106 | base => $base->object_base_dn($class->type), |
---|
[1115] | 107 | attrs => [ $class->_canonical_fields($base, 'r') ], |
---|
[288] | 108 | ); |
---|
| 109 | |
---|
[1493] | 110 | if ($mesg->code) { |
---|
| 111 | $base->log(LA_ERR, 'Cannot fetch %s/%s: %s', $class->type, $uid, $mesg->code); |
---|
| 112 | return; |
---|
| 113 | } |
---|
[288] | 114 | |
---|
| 115 | my ($entry, @others) = $mesg->entries; |
---|
| 116 | |
---|
[1493] | 117 | if(@others) { # we cannot have multiple entries... |
---|
| 118 | $base->la_log(LA_ERR, 'Multiple entry found forr %s/%s', $class->type, $uid); |
---|
| 119 | return; |
---|
| 120 | } |
---|
| 121 | if (!$entry) { |
---|
| 122 | $base->log(LA_DEBUG, 'Cannot fetch %s/%s: no entry returned', $class->type, $uid); |
---|
| 123 | return; |
---|
| 124 | } |
---|
[288] | 125 | bless({ entry => $entry, _base => $base, _id => $uid }, $class); |
---|
| 126 | } |
---|
| 127 | |
---|
| 128 | sub _delete { |
---|
| 129 | my ($class, $base, $uid) = @_; |
---|
| 130 | my $obj = $class->new($base, $uid) or return; |
---|
| 131 | |
---|
| 132 | my $mesg = $base->ldap->delete($obj->{entry}->dn); |
---|
| 133 | |
---|
| 134 | if ($mesg->code) { |
---|
| 135 | $base->log(LA_ERR, "Cannot delete object %s: %s", $uid, $mesg->error); |
---|
| 136 | return; |
---|
| 137 | } else { |
---|
| 138 | $base->log(LA_INFO, "Object (%s) %s delete", $class->type, $uid); |
---|
| 139 | return 1 |
---|
| 140 | } |
---|
| 141 | } |
---|
| 142 | |
---|
[715] | 143 | sub _rename { |
---|
| 144 | my ($class, $base, $uid, $newuid) = @_; |
---|
| 145 | my $obj = $class->new($base, $uid) or return; |
---|
| 146 | |
---|
[1117] | 147 | my $mesg; |
---|
| 148 | if ($class->_key_attribute($base) eq |
---|
| 149 | $class->_dn_attribute($base)) { |
---|
| 150 | $mesg = $base->ldap->moddn( $obj->{entry}, |
---|
| 151 | newrdn => $class->_dn_attribute($base) . '=' . escape_filter_value($newuid), |
---|
| 152 | deleteoldrdn => 1,) |
---|
| 153 | } else { |
---|
| 154 | $obj->{entry}->replace($class->_key_attribute($base), $newuid); |
---|
| 155 | $mesg = $obj->{entry}->update($base->ldap); |
---|
| 156 | } |
---|
[715] | 157 | |
---|
| 158 | if ($mesg->code) { |
---|
| 159 | $base->log(LA_ERR, "Cannot rename object %s: %s", $uid, $mesg->error); |
---|
| 160 | return; |
---|
| 161 | } else { |
---|
| 162 | return 1; |
---|
| 163 | } |
---|
| 164 | } |
---|
| 165 | |
---|
[1023] | 166 | =head2 ldap |
---|
| 167 | |
---|
| 168 | A shortcut to return the L<Net::LDAP> object |
---|
| 169 | |
---|
| 170 | =cut |
---|
| 171 | |
---|
[288] | 172 | sub ldap { |
---|
| 173 | return $_[0]->base->{_ldap}; |
---|
| 174 | } |
---|
| 175 | |
---|
| 176 | sub get_field { |
---|
| 177 | my ($self, $field) = @_; |
---|
| 178 | |
---|
| 179 | $field eq 'dn' and return $self->{entry}->dn; |
---|
| 180 | my ($first, @others) = $self->{entry}->get_value($field); |
---|
| 181 | return @others ? [ sort($first, @others) ] : $first; |
---|
| 182 | } |
---|
| 183 | |
---|
| 184 | sub _populate_entry { |
---|
[308] | 185 | my ($self, $entry, $field, $value, $base) = @_; |
---|
[861] | 186 | my $val = ref $self ? $self->get_field($field) : undef; |
---|
[288] | 187 | my $tr = join(', ', map { $_ || '' } ($field, $val, $value)); |
---|
| 188 | if ($value) { |
---|
| 189 | if ((!$val) || $val ne $value) { |
---|
| 190 | $entry->replace($field, $value); |
---|
| 191 | } |
---|
| 192 | } elsif($val) { |
---|
| 193 | $entry->delete($field); |
---|
| 194 | } |
---|
| 195 | } |
---|
| 196 | |
---|
| 197 | sub set_fields { |
---|
| 198 | my ($self, %fields) = @_; |
---|
| 199 | |
---|
[292] | 200 | { |
---|
| 201 | my $oclass = join(',', sort $self->{entry}->get_value('objectClass')); |
---|
| 202 | my $cclass = join(',', sort $self->_my_ldap_classes); |
---|
| 203 | if ($oclass ne $cclass) { |
---|
| 204 | $self->{entry}->replace( |
---|
| 205 | 'objectClass' => [ $self->_my_ldap_classes ] |
---|
| 206 | ); |
---|
| 207 | } |
---|
| 208 | } |
---|
[288] | 209 | foreach (keys %fields) { |
---|
[861] | 210 | my $attr = $self->attribute($_) or do { |
---|
| 211 | $self->base->log(LA_ERR, "Unknow attribute %s (%s)", |
---|
| 212 | $_, $self->type); |
---|
| 213 | return; |
---|
| 214 | }; |
---|
| 215 | $attr->ro and next; |
---|
[288] | 216 | $self->_populate_entry($self->{entry}, $_, $fields{$_}); |
---|
| 217 | } |
---|
| 218 | |
---|
| 219 | my $mesg = $self->{entry}->update($self->base->ldap); |
---|
| 220 | |
---|
| 221 | if ($mesg->code && $mesg->code != 82) { |
---|
[292] | 222 | $self->base->log(LA_ERR, "Cannot set attributes: %s", $mesg->error); |
---|
[288] | 223 | return; |
---|
| 224 | } else { return 1 } |
---|
| 225 | } |
---|
| 226 | |
---|
| 227 | 1; |
---|
| 228 | |
---|
| 229 | __END__ |
---|
| 230 | |
---|
| 231 | =head1 SEE ALSO |
---|
| 232 | |
---|
| 233 | =head1 AUTHOR |
---|
| 234 | |
---|
| 235 | Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.frE<gt> |
---|
| 236 | |
---|
| 237 | =head1 COPYRIGHT AND LICENSE |
---|
| 238 | |
---|
| 239 | Copyright (C) 2008 CNRS SA/CETP/LATMOS |
---|
| 240 | |
---|
| 241 | This library is free software; you can redistribute it and/or modify |
---|
| 242 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 243 | at your option, any later version of Perl 5 you may have available. |
---|
| 244 | |
---|
| 245 | |
---|
| 246 | =cut |
---|