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