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