lib/LiCoM/Person.pm

   1 package LiCoM::Person;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp (qw(cluck confess));
   7 use Encode (qw(encode decode is_utf8));
   8
   9 use LiCoM::Config (qw(get_config));
  10 use LiCoM::Connection (qw($Ldap));
  11
  12 use Net::LDAP;
  13 use Net::LDAP::Filter;
  14
  15 =head1 NAME
  16
  17 Person - High level interface for address books using an LDAP-backend.
  18
  19 =cut
  20
  21 our %ValidFields =
  22 (
  23         telephoneNumber                 => 1,
  24         facsimileTelephoneNumber        => 1,
  25         sn                              => 0,
  26         cn                              => 0,
  27         givenName                       => 0,
  28         homePhone                       => 1,
  29         homePostalAddress               => 1,
  30         labeledURI                      => 1,
  31         mail                            => 1,
  32         mobile                          => 1,
  33         userPassword                    => 0
  34 );
  35
  36 our %ExternalNames =
  37 (
  38         officephone     => 'telephoneNumber',
  39         fax             => 'facsimileTelephoneNumber',
  40         lastname        => 'sn',
  41         name            => 'cn',
  42         firstname       => 'givenName',
  43         homephone       => 'homePhone',
  44         address         => 'homePostalAddress',
  45         uri             => 'labeledURI',
  46         mail            => 'mail',
  47         cellphone       => 'mobile',
  48         password        => 'userPassword'
  49 );
  50
  51 return (1);
  52
  53 sub new
  54 {
  55         my $pkg = shift;
  56         my $entry = shift;
  57         my $obj = {};
  58
  59         $obj->{'dn'} = $entry->dn ();
  60         $obj->{'ldap'} = $entry;
  61
  62         for (keys %ValidFields)
  63         {
  64                 my $key = $_;
  65                 my $val = $entry->get_value ($key, asref => $ValidFields{$key});
  66
  67                 if (ref ($val))
  68                 {
  69                         $obj->{$key} = [map { decode ('UTF-8', $_) } (@$val)];
  70                 }
  71                 else
  72                 {
  73                         $obj->{$key} = decode ('UTF-8', $val);
  74                 }
  75         }
  76
  77         return (bless ($obj, $pkg));
  78 }
  79
  80 =head1 STATIC FUNCTIONS
  81
  82 =over 4
  83
  84 =item LiCoM::Person-E<gt>B<load> (I<$cn>)
  85
  86 Loads the given CN and returns the B<Person>-object.
  87
  88 =cut
  89
  90 sub load
  91 {
  92         my $pkg = shift;
  93         my $cn = shift;
  94
  95         my ($retval) = search ($pkg, [[cn => $cn]]);
  96
  97         if (!$retval)
  98         {
  99                 cluck ("CN '$cn' could not be found");
 100                 return;
 101         }
 102
 103         return ($retval);
 104 }
 105
 106 =item LiCoM::Person-E<gt>B<create> (B<lastname> =E<gt> I<$lastname>, B<firstname> =E<gt> I<$firstname>, ...)
 107
 108 Create a new I<Net::LDAP::Entry>-object and return it's corresponding
 109 I<Person>-object.
 110
 111 =cut
 112
 113 sub create
 114 {
 115         my $pkg = shift;
 116
 117         my %hash = @_;
 118         my $entry = Net::LDAP::Entry->new ();
 119         my $dn;
 120         my $ou;
 121
 122         $entry->add (objectClass => [qw(person organizationalPerson inetOrgPerson)]);
 123
 124         for (keys %hash)
 125         {
 126                 my $key = $_;
 127                 my $val = $hash{$key};
 128                 my $field = defined ($ExternalNames{$key}) ? $ExternalNames{$key} : $key;
 129
 130                 if (!defined ($ValidFields{$field}))
 131                 {
 132                         warn ("Invalid field $field");
 133                         next;
 134                 }
 135
 136                 if ($ValidFields{$field})
 137                 {
 138                         if (ref ($val) eq 'ARRAY')
 139                         {
 140                                 $entry->add ($field => [map { encode ('UTF-8', $_) } (@$val)]) if (@$val);
 141                         }
 142                         elsif (!ref ($val))
 143                         {
 144                                 $entry->add ($field => [encode ('UTF-8', $val)]) if ($val);
 145                         }
 146                         else
 147                         {
 148                                 warn ("You cannot pass ref-type " . ref ($val));
 149                         }
 150                 }
 151                 else
 152                 {
 153                         my $temp;
 154                         if (ref ($val) eq 'ARRAY')
 155                         {
 156                                 $temp = encode ('UTF-8', $val->[0]);
 157                         }
 158                         elsif (!ref ($val))
 159                         {
 160                                 $temp = encode ('UTF-8', $val);
 161                         }
 162                         else
 163                         {
 164                                 warn ("You cannot pass ref-type " . ref ($val));
 165                         }
 166
 167                         $entry->add ($field => $temp) if (defined ($temp) and $temp);
 168                 }
 169         }
 170
 171         # $sn and $gn are UTF-8
 172         my $sn = $entry->get_value ('sn');
 173         my $gn = $entry->get_value ('givenName');
 174
 175         if (!defined ($sn) or !defined ($gn))
 176         {
 177                 warn ("sn or givenName not given");
 178                 return;
 179         }
 180
 181         $ou = encode ('UTF-8', 'Person');
 182         $dn = "cn=$sn $gn,ou=$ou," . encode ('UTF-8', get_config ('base_dn'));
 183
 184         $entry->add (cn => "$sn $gn", ou => $ou);
 185         $entry->dn ($dn);
 186
 187         $entry->changetype ('add');
 188         my $mesg = $entry->update ($Ldap);
 189
 190         if ($mesg->is_error ())
 191         {
 192                 my $tmp = decode ('UTF-8', $dn);
 193                 warn ("Error while creating entry '$tmp' on LDAP server: " . $mesg->error_text ());
 194                 return;
 195         }
 196
 197         return (new ($pkg, $entry));
 198 }
 199
 200 =item LiCoM::Person-E<gt>B<search> (B<firstname> =E<gt> I<"Flor*">)
 201
 202 Search for the given patterns. Returns a list of I<Person>-objects.
 203
 204   @filter =
 205   (
 206     [
 207       [field => value], # OR
 208       [field => value]
 209     ], # AND
 210     ...
 211   );
 212
 213 =cut
 214
 215 sub search
 216 {
 217         my $pkg = shift;
 218
 219         my @patterns = @_;
 220         my @konjunct = ();
 221         my $filter;
 222
 223         my $mesg;
 224         my @retval = ();
 225
 226         for (@patterns)
 227         {
 228                 my $dj = $_;
 229                 my @disjunc = ();
 230
 231                 for (@$dj)
 232                 {
 233                         my $field = $_->[0];
 234                         my $value = $_->[1];
 235
 236                         $field = $ExternalNames{$field} if (defined ($ExternalNames{$field}));
 237                         if (!defined ($ValidFields{$field}))
 238                         {
 239                                 warn ("Not a valid field: $field");
 240                                 next;
 241                         }
 242
 243                         $value =~ s/([\(\)\\])/\\$1/g;
 244
 245                         confess ("Value is not UTF-8 encoded: `$value'") if (!is_utf8 ($value));
 246
 247                         push (@disjunc, "($field=$value)");
 248                 }
 249
 250                 if (@disjunc)
 251                 {
 252                         my $tmp;
 253                         if (scalar (@disjunc) == 1)
 254                         {
 255                                 $tmp = $disjunc[0];
 256                         }
 257                         else
 258                         {
 259                                 $tmp = join ('', '(|', @disjunc, ')');
 260                         }
 261                         push (@konjunct, $tmp);
 262                 }
 263         }
 264
 265         if (@konjunct)
 266         {
 267                 $filter = join ('', '(&(objectclass=inetOrgPerson)', @konjunct, ')');
 268         }
 269         else
 270         {
 271                 $filter = '(objectclass=inetOrgPerson)';
 272         }
 273
 274         $mesg = $Ldap->search
 275         (
 276                 base   => 'ou=Person,' . get_config ('base_dn'),
 277                 filter => encode ('UTF-8', $filter)
 278         );
 279
 280         if ($mesg->is_error ())
 281         {
 282                 warn ("Error while querying LDAP server: " . $mesg->error_text ());
 283                 return (qw());
 284         }
 285
 286         for ($mesg->entries ())
 287         {
 288                 my $entry = $_;
 289                 my $obj = new ($pkg, $entry);
 290
 291                 push (@retval, $obj);
 292         }
 293
 294         return (@retval);
 295 }
 296
 297 =item LiCoM::Person-E<gt>B<get_user> (I<$dn>)
 298
 299 Returns the cn and, if defined, the user-id of this dn.
 300
 301 =cut
 302
 303 sub get_user
 304 {
 305         my $pkg = shift;
 306         my $dn = shift;
 307         my ($search) = $dn =~ m/cn\s*=\s*([^,]+)/i;
 308
 309         return unless ($search);
 310
 311         my $cn = '';
 312         my $id = '';
 313
 314         my $mesg = $Ldap->search
 315         (
 316                 base   => 'ou=Person,' . get_config ('base_dn'),
 317                 filter => "(cn=$search)"
 318         );
 319
 320         if ($mesg->is_error ())
 321         {
 322                 cluck ("Error while querying LDAP server: " . $mesg->error_text ());
 323                 return;
 324         }
 325
 326         for ($mesg->entries ())
 327         {
 328                 my $e = $_;
 329                 my ($t_cn) = $e->get_value ('cn', asref => 0);
 330                 my ($t_id) = $e->get_value ('uid', asref => 0);
 331
 332                 if (!$id or $t_id)
 333                 {
 334                         $cn = $t_cn;
 335                         $id = $t_id;
 336                 }
 337         }
 338
 339         return ($cn, $id);
 340 }
 341
 342 =back
 343
 344 =head1 METHODS
 345
 346 =over 4
 347
 348 =item I<$obj>-E<gt>B<delete> ()
 349
 350 Deletes the record.
 351
 352 =cut
 353
 354 sub delete
 355 {
 356         my $obj = shift;
 357         my $entry = $obj->{'ldap'};
 358
 359         $entry->changetype ('delete');
 360         $entry->delete ();
 361         $entry->update ($Ldap);
 362
 363         %$obj = ();
 364 }
 365
 366 =item I<$obj>-E<gt>B<lastname> ([I<$lastname>])
 367
 368 Get or set the lastname.
 369
 370 =cut
 371
 372 sub _update_dn
 373 {
 374         confess ("Wrong number of arguments") if (@_ != 3);
 375         my $obj = shift;
 376
 377         my $obj_new;
 378         my %hash_new;
 379
 380         my $sn = shift;
 381         my $gn = shift;
 382
 383         my $entry = $obj->{'ldap'};
 384
 385         if (($sn eq $obj->{'sn'}) && ($gn eq $obj->{'givenName'}))
 386         {
 387                 return;
 388         }
 389
 390         $hash_new{$_} = $obj->{$_} for (keys %ValidFields);
 391         $hash_new{'sn'} = $sn;
 392         $hash_new{'givenName'} = $gn;
 393         delete ($hash_new{'cn'});
 394
 395         $obj_new = LiCoM::Person->create (%hash_new)
 396                 or confess ("Cannot duplicate LDAP entry");
 397
 398         $obj->delete ();
 399
 400         %$obj = %$obj_new;
 401
 402         return ($obj->{'dn'});
 403 }
 404
 405 sub lastname
 406 {
 407         my $obj = shift;
 408
 409         if (@_)
 410         {
 411                 _update_dn ($obj, shift, $obj->{'givenName'});
 412         }
 413
 414         return ($obj->{'sn'});
 415 }
 416
 417 =item I<$obj>-E<gt>B<firstname> ([I<$firstname>])
 418
 419 Get or set the firstname.
 420
 421 =cut
 422
 423 sub firstname
 424 {
 425         my $obj = shift;
 426
 427         if (@_)
 428         {
 429                 _update_dn ($obj, $obj->{'sn'}, shift);
 430         }
 431
 432         return ($obj->{'givenName'});
 433 }
 434
 435 =item I<$obj>-E<gt>B<name> ()
 436
 437 Returns the CN.
 438
 439 =cut
 440
 441 sub name
 442 {
 443         my $obj = shift;
 444         return ($obj->{'cn'});
 445 }
 446
 447 =item I<$obj>-E<gt>B<address> ([I<@address>])
 448
 449 =item I<$obj>-E<gt>B<homephone> ([I<@homephone>])
 450
 451 =item I<$obj>-E<gt>B<cellphone> ([I<@cellphone>])
 452
 453 =item I<$obj>-E<gt>B<officephone> ([I<@officephone>])
 454
 455 =item I<$obj>-E<gt>B<fax> ([I<@fax>])
 456
 457 =item I<$obj>-E<gt>B<mail> ([I<@mail>])
 458
 459 =item I<$obj>-E<gt>B<uri> ([I<@uri>])
 460
 461 Get or set the attribute. This is the same as calling S<I<$obj>-E<gt>B<set>
 462 (I<$field>, I<\@values>)> or S<I<$obj>-E<gt>B<get> (I<$field>)>.
 463
 464 =cut
 465
 466 sub AUTOLOAD
 467 {
 468         my $obj = shift;
 469         my @values = @_;
 470         my $field = $Person::AUTOLOAD;
 471
 472         return (undef) unless ($field);
 473
 474         $field =~ s/.*:://;
 475
 476         return (set ($obj, $field, @values ? [@values] : undef))
 477 }
 478
 479 =item I<$obj>-E<gt>B<get> (I<$field>)
 480
 481 Returs the value(s) of field I<$field>.
 482
 483 =cut
 484
 485 sub get
 486 {
 487         my $obj = shift;
 488         my $field = shift;
 489
 490         if (wantarray ())
 491         {
 492                 return (set ($obj, $field, undef));
 493         }
 494         else
 495         {
 496                 return (scalar (set ($obj, $field, undef)));
 497         }
 498 }
 499
 500 =item I<$obj>-E<gt>B<set> (I<$field>, I<\@values>)
 501
 502 Sets the field I<$field> to the value(s) I<\@valued>. Pass an empty array-ref
 503 to delete the field.
 504
 505 =cut
 506
 507 sub set
 508 {
 509         my $obj = shift;
 510         my $field = shift;
 511         my $value = @_ ? shift : undef;
 512         my $entry = $obj->{'ldap'};
 513
 514         if (defined ($ExternalNames{$field}))
 515         {
 516                 $field = $ExternalNames{$field};
 517         }
 518         if (!defined ($ValidFields{$field}))
 519         {
 520                 return;
 521         }
 522
 523         if (defined ($value))
 524         {
 525                 $_ = encode ('UTF-8', $_) for (@$value);
 526
 527                 $entry->changetype ('modify');
 528
 529                 if ($ValidFields{$field})
 530                 {
 531                         $entry->replace ($field, [@$value]);
 532                         $obj->{$field} = $value;
 533                 }
 534                 else
 535                 {
 536                         splice (@$value, 1) if (scalar (@$value) > 1);
 537                         $entry->replace ($field, $value);
 538                         $obj->{$field} = $value->[0];
 539                 }
 540
 541                 $entry->update ($Ldap);
 542         }
 543
 544         if (!defined ($obj->{$field}) and $ValidFields{$field})
 545         {
 546                 $obj->{$field} = [];
 547         }
 548
 549         if (wantarray () and $ValidFields{$field})
 550         {
 551                 return (@{$obj->{$field}});
 552         }
 553         else
 554         {
 555                 return ($obj->{$field});
 556         }
 557 }
 558
 559 =back
 560
 561 =head1 AUTHOR
 562
 563 Florian octo Forster E<lt>octo at verplant.orgE<gt>
 564
 565 =cut