lib/LiCoM/Person.pm

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