lib/LiCoM/Person.pm

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