elmo/pldap.el

   1 ;;; pldap.el -- A portable LDAP support for Emacs.
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4 ;; Copyright (C) 2000 Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Original was ldap.el:
   7 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
   8 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
   9
  10 ;; pldap.el:
  11 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
  12 ;; Maintainer: Yuuichi Teranishi <teranisi@gohome.org>
  13 ;; Keywords: emulating, LDAP, comm
  14 ;; Created: 15 June 2000
  15
  16 ;; This file is not part of GNU Emacs
  17
  18 ;; This program is free software; you can redistribute it and/or modify
  19 ;; it under the terms of the GNU General Public License as published by
  20 ;; the Free Software Foundation; either version 2, or (at your option)
  21 ;; any later version.
  22 ;;
  23 ;; This program is distributed in the hope that it will be useful,
  24 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26 ;; GNU General Public License for more details.
  27 ;;
  28 ;; You should have received a copy of the GNU General Public License
  29 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  31 ;; Boston, MA 02111-1307, USA.
  32 ;;
  33
  34 ;;; Commentary:
  35
  36 ;;; Code:
  37 ;;
  38
  39 (eval-when-compile (require 'cl))
  40
  41 (defmacro ldap-static-if (cond then &rest else)
  42   "`if' expression but COND is evaluated at compile-time."
  43   (if (eval cond)
  44       then
  45     (` (progn  (,@ else)))))
  46
  47 (ldap-static-if (and (not (featurep 'pldap))
  48                      (fboundp 'ldap-open))
  49     ;; You have built-in ldap feature (XEmacs).
  50     (require 'ldap)
  51
  52 ;; You don't have built-in ldap feature.
  53 ;; Use external program.
  54
  55 ;;; For LDIF encoding.
  56 ;; SAFE-CHAR                = %x01-09 / %x0B-0C / %x0E-7F
  57 (defconst ldap-ldif-safe-char-regexp
  58   "[\000-\011\013\014\016-\177]"
  59   "A Regexp for safe-char.")
  60 ;; SAFE-INIT-CHAR           = %x01-09 / %x0B-0C / %x0E-1F /
  61 ;;                            %x21-39 / %x3B / %x3D-7F
  62 (defconst ldap-ldif-safe-init-char-regexp
  63   "[\001-\011\013\014\016-\037\038-\071\073\075-\177]"
  64   "A Regexp for safe-init-char.")
  65 ;; SAFE-STRING              = [SAFE-INIT-CHAR *SAFE-CHAR]
  66 (defconst ldap-ldif-safe-string-regexp
  67   (concat ldap-ldif-safe-init-char-regexp ldap-ldif-safe-char-regexp "*")
  68   "A Regexp for safe-string.")
  69
  70 (defconst ldap-ldif-field-name-regexp "[a-zA-Z][a-zA-Z0-9-]*"
  71   "A Regexp for field name.")
  72
  73 (defconst ldap-ldif-field-head-regexp
  74   (concat "^" ldap-ldif-field-name-regexp ":")
  75   "A Regexp for field head.")
  76
  77 (defconst ldap-ldif-next-field-head-regexp
  78   (concat "\n" ldap-ldif-field-name-regexp ":")
  79   "A Regexp for next field head.")
  80
  81 (defmacro ldap/ldif-safe-string-p (string)
  82   "Return t if STRING is a safe-string for LDIF."
  83   ;; Need better implentation.
  84   (` (string-match ldap-ldif-safe-string-regexp (, string))))
  85
  86 (defgroup ldap nil
  87   "Lightweight Directory Access Protocol"
  88   :group 'comm)
  89
  90 (defvar ldap-search-program "ldapsearch"
  91   "LDAP search program.")
  92
  93 (defvar ldap-add-program "ldapadd"
  94   "LDAP add program.")
  95
  96 (defvar ldap-delete-program "ldapdelete"
  97   "LDAP delete program.")
  98
  99 (defvar ldap-modify-program "ldapmodify"
 100   "LDAP modify program.")
 101
 102 (defcustom ldap-search-program-arguments '("-L" "-B")
 103   "*A list of additional arguments to pass to `ldapsearch'.
 104 It is recommended to use the `-T' switch with Nescape's
 105 implementation to avoid line wrapping.
 106 `-L' is needed to get LDIF outout.
 107 The `-B' switch should be used to enable the retrieval of
 108 binary values."
 109   :type '(repeat :tag "`ldapsearch' Arguments"
 110                  (string :tag "Argument"))
 111   :group 'ldap)
 112
 113 (defcustom ldap-default-host nil
 114   "*Default LDAP server hostname.
 115 A TCP port number can be appended to that name using a colon as
 116 a separator."
 117   :type '(choice (string :tag "Host name")
 118                  (const :tag "Use library default" nil))
 119   :group 'ldap)
 120
 121 (defcustom ldap-default-port nil
 122   "*Default TCP port for LDAP connections.
 123 Initialized from the LDAP library at build time.  Default value is 389."
 124   :type '(choice (const :tag "Use library default" nil)
 125                  (integer :tag "Port number"))
 126   :group 'ldap)
 127
 128 (defcustom ldap-default-base nil
 129   "*Default base for LDAP searches.
 130 This is a string using the syntax of RFC 1779.
 131 For instance, \"o=ACME, c=US\" limits the search to the
 132 Acme organization in the United States."
 133   :type '(choice (const :tag "Use library default" nil)
 134                  (string :tag "Search base"))
 135   :group 'ldap)
 136
 137 (defcustom ldap-host-parameters-alist nil
 138   "*Alist of host-specific options for LDAP transactions.
 139 The format of each list element is:
 140 \(HOST PROP1 VAL1 PROP2 VAL2 ...)
 141 HOST is the hostname of an LDAP server (with an optional TCP port number
 142 appended to it  using a colon as a separator).
 143 PROPn and VALn are property/value pairs describing parameters for the server.
 144 Valid properties include:
 145   `binddn' is the distinguished name of the user to bind as
 146     (in RFC 1779 syntax).
 147   `passwd' is the password to use for simple authentication.
 148   `auth' is the authentication method to use.
 149     Possible values are: `simple', `krbv41' and `krbv42'.
 150   `base' is the base for the search as described in RFC 1779.
 151   `scope' is one of the three symbols `subtree', `base' or `onelevel'.
 152   `deref' is one of the symbols `never', `always', `search' or `find'.
 153   `timelimit' is the timeout limit for the connection in seconds.
 154   `sizelimit' is the maximum number of matches to return."
 155   :type '(repeat :menu-tag "Host parameters"
 156                  :tag "Host parameters"
 157                  (list :menu-tag "Host parameters"
 158                        :tag "Host parameters"
 159                        :value nil
 160                        (string :tag "Host name")
 161                        (checklist :inline t
 162                                   :greedy t
 163                                   (list
 164                                    :tag "Search Base"
 165                                    :inline t
 166                                    (const :tag "Search Base" base)
 167                                    string)
 168                                   (list
 169                                    :tag "Binding DN"
 170                                    :inline t
 171                                    (const :tag "Binding DN" binddn)
 172                                    string)
 173                                   (list
 174                                    :tag "Password"
 175                                    :inline t
 176                                    (const :tag "Password" passwd)
 177                                    string)
 178                                   (list
 179                                    :tag "Authentication Method"
 180                                    :inline t
 181                                    (const :tag "Authentication Method" auth)
 182                                    (choice
 183                                     (const :menu-tag "None" :tag "None" nil)
 184                                     (const :menu-tag "Simple" :tag "Simple" simple)
 185                                     (const :menu-tag "Kerberos 4.1" :tag "Kerberos 4.1" krbv41)
 186                                     (const :menu-tag "Kerberos 4.2" :tag "Kerberos 4.2" krbv42)))
 187                                   (list
 188                                    :tag "Search Scope"
 189                                    :inline t
 190                                    (const :tag "Search Scope" scope)
 191                                    (choice
 192                                     (const :menu-tag "Default" :tag "Default" nil)
 193                                     (const :menu-tag "Subtree" :tag "Subtree" subtree)
 194                                     (const :menu-tag "Base" :tag "Base" base)
 195                                     (const :menu-tag "One Level" :tag "One Level" onelevel)))
 196                                   (list
 197                                    :tag "Dereferencing"
 198                                    :inline t
 199                                    (const :tag "Dereferencing" deref)
 200                                    (choice
 201                                     (const :menu-tag "Default" :tag "Default" nil)
 202                                     (const :menu-tag "Never" :tag "Never" never)
 203                                     (const :menu-tag "Always" :tag "Always" always)
 204                                     (const :menu-tag "When searching" :tag "When searching" search)
 205                                     (const :menu-tag "When locating base" :tag "When locating base" find)))
 206                                   (list
 207                                    :tag "Time Limit"
 208                                    :inline t
 209                                    (const :tag "Time Limit" timelimit)
 210                                    (integer :tag "(in seconds)"))
 211                                   (list
 212                                    :tag "Size Limit"
 213                                    :inline t
 214                                    (const :tag "Size Limit" sizelimit)
 215                                    (integer :tag "(number of records)")))))
 216 :group 'ldap)
 217
 218 (defcustom ldap-verbose nil
 219   "*If non-nil, LDAP operations echo progress messages."
 220   :type 'boolean
 221   :group 'ldap)
 222
 223 (defcustom ldap-ignore-attribute-codings nil
 224   "*If non-nil, do not perform any encoding/decoding on LDAP attribute values."
 225   :type 'boolean
 226   :group 'ldap)
 227
 228 (defcustom ldap-default-attribute-encoder nil
 229   "*Encoder function to use for attributes whose syntax is unknown."
 230   :type 'symbol
 231   :group 'ldap)
 232
 233 (defcustom ldap-default-attribute-decoder nil
 234   "*Decoder function to use for attributes whose syntax is unknown."
 235   :type 'symbol
 236   :group 'ldap)
 237
 238 (defcustom ldap-coding-system (if (boundp 'NEMACS) 0
 239                                 nil)
 240   "*Coding system of LDAP string values.
 241 LDAP v3 specifies the coding system of strings to be UTF-8.
 242 Mule support is needed for this."
 243   :type 'symbol
 244   :group 'ldap)
 245
 246 (defvar ldap-attribute-syntax-encoders
 247   [nil                                  ; 1  ACI Item                        N
 248    nil                                  ; 2  Access Point                    Y
 249    nil                                  ; 3  Attribute Type Description      Y
 250    nil                                  ; 4  Audio                           N
 251    nil                                  ; 5  Binary                          N
 252    nil                                  ; 6  Bit String                      Y
 253    ldap-encode-boolean                  ; 7  Boolean                         Y
 254    nil                                  ; 8  Certificate                     N
 255    nil                                  ; 9  Certificate List                N
 256    nil                                  ; 10 Certificate Pair                N
 257    ldap-encode-country-string           ; 11 Country String                  Y
 258    ldap-encode-string                   ; 12 DN                              Y
 259    nil                                  ; 13 Data Quality Syntax             Y
 260    nil                                  ; 14 Delivery Method                 Y
 261    ldap-encode-string                   ; 15 Directory String                Y
 262    nil                                  ; 16 DIT Content Rule Description    Y
 263    nil                                  ; 17 DIT Structure Rule Description  Y
 264    nil                                  ; 18 DL Submit Permission            Y
 265    nil                                  ; 19 DSA Quality Syntax              Y
 266    nil                                  ; 20 DSE Type                        Y
 267    nil                                  ; 21 Enhanced Guide                  Y
 268    nil                                  ; 22 Facsimile Telephone Number      Y
 269    nil                                  ; 23 Fax                             N
 270    nil                                  ; 24 Generalized Time                Y
 271    nil                                  ; 25 Guide                           Y
 272    nil                                  ; 26 IA5 String                      Y
 273    number-to-string                     ; 27 INTEGER                         Y
 274    nil                                  ; 28 JPEG                            N
 275    nil                                  ; 29 Master And Shadow Access Points Y
 276    nil                                  ; 30 Matching Rule Description       Y
 277    nil                                  ; 31 Matching Rule Use Description   Y
 278    nil                                  ; 32 Mail Preference                 Y
 279    nil                                  ; 33 MHS OR Address                  Y
 280    nil                                  ; 34 Name And Optional UID           Y
 281    nil                                  ; 35 Name Form Description           Y
 282    nil                                  ; 36 Numeric String                  Y
 283    nil                                  ; 37 Object Class Description        Y
 284    nil                                  ; 38 OID                             Y
 285    nil                                  ; 39 Other Mailbox                   Y
 286    nil                                  ; 40 Octet String                    Y
 287    ldap-encode-address                  ; 41 Postal Address                  Y
 288    nil                                  ; 42 Protocol Information            Y
 289    nil                                  ; 43 Presentation Address            Y
 290    ldap-encode-string                   ; 44 Printable String                Y
 291    nil                                  ; 45 Subtree Specification           Y
 292    nil                                  ; 46 Supplier Information            Y
 293    nil                                  ; 47 Supplier Or Consumer            Y
 294    nil                                  ; 48 Supplier And Consumer           Y
 295    nil                                  ; 49 Supported Algorithm             N
 296    nil                                  ; 50 Telephone Number                Y
 297    nil                                  ; 51 Teletex Terminal Identifier     Y
 298    nil                                  ; 52 Telex Number                    Y
 299    nil                                  ; 53 UTC Time                        Y
 300    nil                                  ; 54 LDAP Syntax Description         Y
 301    nil                                  ; 55 Modify Rights                   Y
 302    nil                                  ; 56 LDAP Schema Definition          Y
 303    nil                                  ; 57 LDAP Schema Description         Y
 304    nil                                  ; 58 Substring Assertion             Y
 305    ]
 306   "A vector of functions used to encode LDAP attribute values.
 307 The sequence of functions corresponds to the sequence of LDAP attribute syntax
 308 object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
 309 RFC2252 section 4.3.2")
 310
 311 (defvar ldap-attribute-syntax-decoders
 312   [nil                                  ; 1  ACI Item                        N
 313    nil                                  ; 2  Access Point                    Y
 314    nil                                  ; 3  Attribute Type Description      Y
 315    nil                                  ; 4  Audio                           N
 316    nil                                  ; 5  Binary                          N
 317    nil                                  ; 6  Bit String                      Y
 318    ldap-decode-boolean                  ; 7  Boolean                         Y
 319    nil                                  ; 8  Certificate                     N
 320    nil                                  ; 9  Certificate List                N
 321    nil                                  ; 10 Certificate Pair                N
 322    ldap-decode-string                   ; 11 Country String                  Y
 323    ldap-decode-string                   ; 12 DN                              Y
 324    nil                                  ; 13 Data Quality Syntax             Y
 325    nil                                  ; 14 Delivery Method                 Y
 326    ldap-decode-string                   ; 15 Directory String                Y
 327    nil                                  ; 16 DIT Content Rule Description    Y
 328    nil                                  ; 17 DIT Structure Rule Description  Y
 329    nil                                  ; 18 DL Submit Permission            Y
 330    nil                                  ; 19 DSA Quality Syntax              Y
 331    nil                                  ; 20 DSE Type                        Y
 332    nil                                  ; 21 Enhanced Guide                  Y
 333    nil                                  ; 22 Facsimile Telephone Number      Y
 334    nil                                  ; 23 Fax                             N
 335    nil                                  ; 24 Generalized Time                Y
 336    nil                                  ; 25 Guide                           Y
 337    nil                                  ; 26 IA5 String                      Y
 338    string-to-number                     ; 27 INTEGER                         Y
 339    nil                                  ; 28 JPEG                            N
 340    nil                                  ; 29 Master And Shadow Access Points Y
 341    nil                                  ; 30 Matching Rule Description       Y
 342    nil                                  ; 31 Matching Rule Use Description   Y
 343    nil                                  ; 32 Mail Preference                 Y
 344    nil                                  ; 33 MHS OR Address                  Y
 345    nil                                  ; 34 Name And Optional UID           Y
 346    nil                                  ; 35 Name Form Description           Y
 347    nil                                  ; 36 Numeric String                  Y
 348    nil                                  ; 37 Object Class Description        Y
 349    nil                                  ; 38 OID                             Y
 350    nil                                  ; 39 Other Mailbox                   Y
 351    nil                                  ; 40 Octet String                    Y
 352    ldap-decode-address                  ; 41 Postal Address                  Y
 353    nil                                  ; 42 Protocol Information            Y
 354    nil                                  ; 43 Presentation Address            Y
 355    ldap-decode-string                   ; 44 Printable String                Y
 356    nil                                  ; 45 Subtree Specification           Y
 357    nil                                  ; 46 Supplier Information            Y
 358    nil                                  ; 47 Supplier Or Consumer            Y
 359    nil                                  ; 48 Supplier And Consumer           Y
 360    nil                                  ; 49 Supported Algorithm             N
 361    nil                                  ; 50 Telephone Number                Y
 362    nil                                  ; 51 Teletex Terminal Identifier     Y
 363    nil                                  ; 52 Telex Number                    Y
 364    nil                                  ; 53 UTC Time                        Y
 365    nil                                  ; 54 LDAP Syntax Description         Y
 366    nil                                  ; 55 Modify Rights                   Y
 367    nil                                  ; 56 LDAP Schema Definition          Y
 368    nil                                  ; 57 LDAP Schema Description         Y
 369    nil                                  ; 58 Substring Assertion             Y
 370    ]
 371   "A vector of functions used to decode LDAP attribute values.
 372 The sequence of functions corresponds to the sequence of LDAP attribute syntax
 373 object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
 374 RFC2252 section 4.3.2")
 375
 376 (defvar ldap-attribute-syntaxes-alist
 377   '((createtimestamp . 24)
 378     (modifytimestamp . 24)
 379     (creatorsname . 12)
 380     (modifiersname . 12)
 381     (subschemasubentry . 12)
 382     (attributetypes . 3)
 383     (objectclasses . 37)
 384     (matchingrules . 30)
 385     (matchingruleuse . 31)
 386     (namingcontexts . 12)
 387     (altserver . 26)
 388     (supportedextension . 38)
 389     (supportedcontrol . 38)
 390     (supportedsaslmechanisms . 15)
 391     (supportedldapversion . 27)
 392     (ldapsyntaxes . 16)
 393     (ditstructurerules . 17)
 394     (nameforms . 35)
 395     (ditcontentrules . 16)
 396     (objectclass . 38)
 397     (aliasedobjectname . 12)
 398     (cn . 15)
 399     (sn . 15)
 400     (serialnumber . 44)
 401     (c . 15)
 402     (l . 15)
 403     (st . 15)
 404     (street . 15)
 405     (o . 15)
 406     (ou . 15)
 407     (title . 15)
 408     (description . 15)
 409     (searchguide . 25)
 410     (businesscategory . 15)
 411     (postaladdress . 41)
 412     (postalcode . 15)
 413     (postofficebox . 15)
 414     (physicaldeliveryofficename . 15)
 415     (telephonenumber . 50)
 416     (telexnumber . 52)
 417     (telexterminalidentifier . 51)
 418     (facsimiletelephonenumber . 22)
 419     (x121address . 36)
 420     (internationalisdnnumber . 36)
 421     (registeredaddress . 41)
 422     (destinationindicator . 44)
 423     (preferreddeliverymethod . 14)
 424     (presentationaddress . 43)
 425     (supportedapplicationcontext . 38)
 426     (member . 12)
 427     (owner . 12)
 428     (roleoccupant . 12)
 429     (seealso . 12)
 430     (userpassword . 40)
 431     (usercertificate . 8)
 432     (cacertificate . 8)
 433     (authorityrevocationlist . 9)
 434     (certificaterevocationlist . 9)
 435     (crosscertificatepair . 10)
 436     (name . 15)
 437     (givenname . 15)
 438     (initials . 15)
 439     (generationqualifier . 15)
 440     (x500uniqueidentifier . 6)
 441     (dnqualifier . 44)
 442     (enhancedsearchguide . 21)
 443     (protocolinformation . 42)
 444     (distinguishedname . 12)
 445     (uniquemember . 34)
 446     (houseidentifier . 15)
 447     (supportedalgorithms . 49)
 448     (deltarevocationlist . 9)
 449     (dmdname . 15))
 450   "A map of LDAP attribute names to their type object id minor number.
 451 This table is built from RFC2252 Section 5 and RFC2256 Section 5")
 452
 453 ;;; LDAP primitive functions.
 454 ;;
 455 ;; LDAP object is
 456 ;; (__ldap-object HOSTNAME PLIST)
 457
 458 (defun ldapp (object)
 459   "Return t if OBJECT is a LDAP connection."
 460   (and (listp object)
 461        (eq (car object) '__ldap-object)))
 462
 463 (defun ldap-open (host &optional plist)
 464   "Open a LDAP connection to HOST.
 465 PLIST is a plist containing additional parameters for the connection.
 466 Valid keys in that list are:
 467   `port' the TCP port to use for the connection if different from
 468 `ldap-default-port'.
 469   `auth' is the authentication method to use, possible values depend on
 470 the LDAP library: `simple', `krbv41' and `krbv42'.
 471   `binddn' is the distinguished name of the user to bind as
 472  (in RFC 1779 syntax).
 473   `passwd' is the password to use for simple authentication.
 474   `deref' is one of the symbols `never', `always', `search' or `find'.
 475   `timelimit' is the timeout limit for the connection in seconds.
 476   `sizelimit' is the maximum number of matches to return."
 477   (list '__ldap-object host plist))
 478
 479 (defun ldap-host (ldap)
 480   "Return the server host of the connection LDAP, as a string."
 481   (nth 1 ldap))
 482
 483 (defun ldap-close (ldap)
 484   "Close an LDAP connection."
 485   t)
 486
 487 (defun ldap-delete (ldap dn)
 488   "Delete an entry to an LDAP directory.
 489 LDAP is an LDAP connection object created with `ldap-open'.
 490 DN is the distinguished name of the entry to delete."
 491   (let* ((plist (or (nth 2 ldap)
 492                     (cdr (assoc (ldap-host ldap)
 493                                 ldap-host-parameters-alist))))
 494          (port   (plist-get plist 'port))
 495          (binddn (plist-get plist 'binddn))
 496          (passwd (plist-get plist 'passwd))
 497          arglist ret)
 498     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 499     (if (and port (not (equal 389 port)))
 500         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 501     (if (and binddn
 502              (not (equal "" binddn)))
 503         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 504     (if (and passwd
 505              (not (equal "" passwd)))
 506         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 507     (with-temp-buffer
 508       (setq ret (apply 'call-process
 509                        ldap-delete-program
 510                        nil (current-buffer) t
 511                        (append arglist
 512                                (list dn))))
 513       (if (integerp ret)
 514           (if (not (zerop ret))
 515               (error (car (split-string (buffer-string) "\n"))))
 516         (if (and (setq ret (buffer-string)); Nemacs
 517                  (string-match "ldap_delete:" ret))
 518             (error (car (split-string ret "\n"))))))))
 519
 520 (defmacro ldap/ldif-insert-field (attr value)
 521   (` (if (not (ldap/ldif-safe-string-p (, value)))
 522          (insert (, attr) ":: " (base64-encode-string (, value)) "\n")
 523        (insert (, attr) ": " (, value) "\n"))))
 524
 525 (defun ldap-modify (ldap dn mods)
 526   "Add an entry to an LDAP directory.
 527 LDAP is an LDAP connection object created with `ldap-open'.
 528 DN is the distinguished name of the entry to modify.
 529 MODS is a list of modifications to apply.
 530 A modification is a list of the form (MOD-OP ATTR VALUE1 VALUE2 ...)
 531 MOD-OP and ATTR are mandatory, VALUEs are optional depending on MOD-OP.
 532 MOD-OP is the type of modification, one of the symbols `add', `delete'
 533 or `replace'.  ATTR is the LDAP attribute type to modify."
 534   (let* ((plist (or (nth 2 ldap)
 535                     (cdr (assoc (ldap-host ldap)
 536                                 ldap-host-parameters-alist))))
 537          (port   (plist-get plist 'port))
 538          (binddn (plist-get plist 'binddn))
 539          (passwd (plist-get plist 'passwd))
 540          arglist ret)
 541     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 542     (if (and port (not (equal 389 port)))
 543         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 544     (if (and binddn
 545              (not (equal "" binddn)))
 546         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 547     (if (and passwd
 548              (not (equal "" passwd)))
 549         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 550     (with-temp-buffer
 551       (ldap/ldif-insert-field "dn" dn)
 552       (insert "changetype: modify\n")
 553       (while mods
 554         (cond
 555          ((eq (nth 0 (car mods)) 'add)
 556           (insert "add: " (nth 1 (car mods)) "\n")
 557           (ldap/ldif-insert-field (nth 1 (car mods)) (nth 2 (car mods)))
 558           (insert "-\n"))
 559          ((eq (nth 0 (car mods)) 'delete)
 560           (insert "delete: " (nth 1 (car mods)) "\n-\n"))
 561          ((eq (nth 0 (car mods)) 'replace)
 562           (insert "replace: " (nth 1 (car mods)) "\n")
 563           (ldap/ldif-insert-field (nth 1 (car mods)) (nth 2 (car mods)))
 564           (insert "-\n")))
 565         (setq mods (cdr mods)))
 566       (setq ret (apply 'call-process-region
 567                        (point-min) (point-max)
 568                        ldap-modify-program
 569                        t t nil
 570                        arglist))
 571       (if (integerp ret)
 572           (if (not (zerop ret))
 573               (error (car (split-string (buffer-string) "\n"))))
 574         (if (and (setq ret (buffer-string)); Nemacs
 575                  (string-match "ldap_modify:" ret))
 576             (error (car (split-string ret "\n"))))))))
 577
 578 (defun ldap-add (ldap dn entry)
 579   "Add an entry to an LDAP directory.
 580 LDAP is an LDAP connection object created with `ldap-open'.
 581 DN is the distinguished name of the entry to add.
 582 ENTRY is an entry specification, i.e., a list of cons cells
 583 containing attribute/value string pairs."
 584   (let* ((plist (or (nth 2 ldap)
 585                     (cdr (assoc (ldap-host ldap)
 586                                 ldap-host-parameters-alist))))
 587          (port   (plist-get plist 'port))
 588          (binddn (plist-get plist 'binddn))
 589          (passwd (plist-get plist 'passwd))
 590          arglist ret)
 591     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 592     (if (and port (not (equal 389 port)))
 593         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 594     (if (and binddn
 595              (not (equal "" binddn)))
 596         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 597     (if (and passwd
 598              (not (equal "" passwd)))
 599         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 600     (with-temp-buffer
 601       (set-buffer-multibyte nil)
 602       (ldap/ldif-insert-field "dn" dn)
 603       (while entry
 604         (ldap/ldif-insert-field (car (car entry)) (cdr (car entry)))
 605         (setq entry (cdr entry)))
 606       (setq ret (apply 'call-process-region
 607                        (point-min) (point-max)
 608                        ldap-add-program
 609                        t t nil
 610                        arglist))
 611       (if (integerp ret)
 612           (if (not (zerop ret))
 613               (error (car (split-string (buffer-string) "\n"))))
 614         (if (and (setq ret (buffer-string)) ; Nemacs
 615                  (string-match "ldap_add:" ret))
 616             (error (car (split-string ret "\n"))))))))
 617
 618 (defun ldap-search-basic (ldap filter base scope
 619                                &optional attrs attrsonly withdn verbose)
 620   "Perform a search on a LDAP server.  (Use external program `ldapsearch')
 621 FILTER is a filter string for the search as described in RFC 1558.
 622 BASE is the distinguished name at which to start the search.
 623 SCOPE is one of the symbols `base', `onelevel' or `subtree' indicating
 624 the scope of the search.
 625 ATTRS is a list of strings indicating which attributes to retrieve
 626  for each matching entry.  If nil return all available attributes.
 627 If ATTRSONLY is non-nil then only the attributes are retrieved, not
 628 the associated values.
 629 If WITHDN is non-nil each entry in the result will be prepended with
 630 its distinguished name DN.
 631 If VERBOSE is non-nil progress messages will be echoed.
 632 The function returns a list of matching entries.  Each entry is itself
 633 an alist of attribute/value pairs optionally preceded by the DN of the
 634 entry according to the value of WITHDN."
 635   (let* ((plist (or (nth 2 ldap)
 636                     (cdr (assoc (ldap-host ldap)
 637                                 ldap-host-parameters-alist))))
 638          (port   (plist-get plist 'port))
 639          (base (or base (plist-get plist 'base) ldap-default-base))
 640          (scope (or scope (plist-get plist 'scope)))
 641          (binddn (plist-get plist 'binddn))
 642          (passwd (plist-get plist 'passwd))
 643          (deref (plist-get plist 'deref))
 644          (timelimit (plist-get plist 'timelimit))
 645          (sizelimit (plist-get plist 'sizelimit))
 646          start value attrs-result
 647          (i 0)
 648          result arglist ret)
 649     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 650     (if (and port (not (equal 389 port)))
 651         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 652     (if (and base
 653              (not (equal "" base)))
 654         (setq arglist (nconc arglist (list (format "-b%s" base)))))
 655     (if (and scope
 656              (not (equal "" scope)))
 657         (setq
 658          arglist
 659          (nconc
 660           arglist
 661           (list (format "-s%s"
 662                         (cond ((eq scope 'onelevel) "one")
 663                               ((eq scope 'base) "base")
 664                               ((eq scope 'subtree) "sub")
 665                               ((null scope) "sub")
 666                               (t (error "Invalid scope: %s" scope))))))))
 667     (if (and binddn
 668              (not (equal "" binddn)))
 669         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 670     (if (and passwd
 671              (not (equal "" passwd)))
 672         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 673     (if (and deref
 674              (not (equal "" deref)))
 675         (setq arglist (nconc arglist (list (format "-a%s" deref)))))
 676     (if (and timelimit
 677              (not (equal "" timelimit)))
 678         (setq arglist (nconc arglist (list (format "-l%s" timelimit)))))
 679     (if (and sizelimit
 680              (not (equal "" sizelimit)))
 681         (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
 682     (with-temp-buffer
 683       (set-buffer-multibyte nil)
 684       (setq ret (apply 'call-process
 685                        ldap-search-program
 686                        nil (current-buffer) t
 687                        (append arglist
 688                                ldap-search-program-arguments
 689                                (list filter)
 690                                attrs)))
 691       (if (and (integerp ret)
 692                (not (zerop ret)))
 693           (error "LDAP error: \"No such object\""))
 694       (goto-char (point-min))
 695       (setq start (point))
 696       (while (and (not (eobp))
 697                   (re-search-forward "^$" nil t)) ; empty line is a delimiter.
 698         (if verbose
 699             (message "Parsing ldap results...%d" (setq i (+ i 1))))
 700         (save-excursion
 701           (save-restriction
 702             (narrow-to-region start (point))
 703             (if attrs
 704                 (setq attrs-result (delq
 705                                     nil
 706                                     (mapcar
 707                                      (lambda (attr)
 708                                        ;; dn is not an attribute.
 709                                        (unless (string= attr "dn")
 710                                          (if (setq value
 711                                                    (ldap/field-body attr))
 712                                              (if attrsonly
 713                                                  (list attr)
 714                                                (nconc (list attr) value)))))
 715                                      attrs)))
 716               (setq attrs-result (ldap/collect-field "dn"))
 717               (if attrsonly
 718                   (setq attrs-result (mapcar (lambda (x) (list (car x)))
 719                                              attrs-result))))
 720             (setq result
 721                   (cons
 722                    (if withdn
 723                        (if attrs-result
 724                            (nconc (ldap/field-body "dn") attrs-result)
 725                          (ldap/field-body "dn"))
 726                      attrs-result)
 727                    result))))
 728         (if (not (eobp)) (forward-char 1))
 729         (setq start (point)))
 730       (if verbose
 731           (message "Parsing ldap results...done"))
 732       (delq nil (nreverse result)))))
 733
 734 (defun ldap/field-end ()
 735   "Move to end of field and return this point."
 736   (if (re-search-forward ldap-ldif-next-field-head-regexp nil t)
 737       (goto-char (match-beginning 0))
 738     (if (re-search-forward "^$" nil t)
 739         (goto-char (1- (match-beginning 0)))
 740       (end-of-line)))
 741   (point))
 742
 743 (defun ldap/field-body (name)
 744   "Return field body list of NAME."
 745   (save-excursion
 746     (goto-char (point-min))
 747     (let ((case-fold-search t)
 748           (field-body nil)
 749           body)
 750       (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
 751         ;; Base64
 752         (if (string-match "^:[ \t]*" (setq body
 753                                            (buffer-substring-no-properties
 754                                             (match-end 0)
 755                                             (ldap/field-end))))
 756             (setq body (base64-decode-string (substring body (match-end 0)))))
 757         (setq field-body (nconc field-body (list body))))
 758       field-body)))
 759
 760 (defun ldap/collect-field (without)
 761   "Collect fields without WITHOUT."
 762   (goto-char (point-min))
 763   (let ((regexp (concat "\\(" ldap-ldif-field-head-regexp "\\)[ \t]*"))
 764         dest name body entry)
 765     (while (re-search-forward regexp nil t)
 766       (setq name (downcase (buffer-substring-no-properties
 767                             (match-beginning 1)(1- (match-end 1)))))
 768       (setq body (buffer-substring-no-properties
 769                   (match-end 0) (ldap/field-end)))
 770       (if (string-match "^:[ \t]*" body)
 771           (setq body (base64-decode-string (substring body (match-end 0)))))
 772       (unless (string= name without)
 773         (if (setq entry (assoc name dest))
 774             (nconc entry (list body))
 775           (setq dest (cons (list name body) dest)))))
 776     (nreverse dest)))
 777
 778 ;;; Coding/decoding functions
 779 ;;
 780 (defun ldap-encode-boolean (bool)
 781   "Encode BOOL to LDAP type."
 782   (if bool
 783       "TRUE"
 784     "FALSE"))
 785
 786 (defun ldap-decode-boolean (str)
 787   "Decode STR to elisp type."
 788   (cond
 789    ((string-equal str "TRUE")
 790     t)
 791    ((string-equal str "FALSE")
 792     nil)
 793    (t
 794     (error "Wrong LDAP boolean string: %s" str))))
 795
 796 (defun ldap-encode-country-string (str)
 797   "Encode STR to LDAP country string."
 798   ;; We should do something useful here...
 799   (if (not (= 2 (length str)))
 800       (error "Invalid country string: %s" str)))
 801
 802 (defun ldap-decode-string (str)
 803   "Decode LDAP STR."
 804   (if (fboundp 'decode-coding-string)
 805       (decode-coding-string str ldap-coding-system)))
 806
 807 (defun ldap-encode-string (str)
 808   "Encode LDAP STR."
 809   (if (fboundp 'encode-coding-string)
 810       (encode-coding-string str ldap-coding-system)))
 811
 812 (defun ldap-decode-address (str)
 813   "Decode LDAP address STR."
 814   (mapconcat 'ldap-decode-string
 815              (split-string str "\\$")
 816              "\n"))
 817
 818 (defun ldap-encode-address (str)
 819   "Encode address STR to LDAP type."
 820   (mapconcat 'ldap-encode-string
 821              (split-string str "\n")
 822              "$"))
 823
 824 ;;; LDAP protocol functions
 825 ;;
 826 (defun ldap-get-host-parameter (host parameter)
 827   "Get HOST's PARAMETER in `ldap-host-parameters-alist'."
 828   (plist-get (cdr (assoc host ldap-host-parameters-alist))
 829              parameter))
 830
 831 (defun ldap-encode-attribute (attr)
 832   "Encode the attribute/value pair ATTR according to LDAP rules.
 833 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
 834 and the corresponding decoder is then retrieved from
 835 `ldap-attribute-syntax-encoders' and applied on the value(s)."
 836   (let* ((name (car attr))
 837          (values (cdr attr))
 838          (syntax-id (cdr (assq (intern (downcase name))
 839                                ldap-attribute-syntaxes-alist)))
 840          encoder)
 841     (if syntax-id
 842         (setq encoder (aref ldap-attribute-syntax-encoders
 843                             (1- syntax-id)))
 844       (setq encoder ldap-default-attribute-encoder))
 845     (if encoder
 846         (cons name (mapcar encoder values))
 847       attr)))
 848
 849 (defun ldap-decode-attribute (attr)
 850   "Decode the attribute/value pair ATTR according to LDAP rules.
 851 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
 852 and the corresponding decoder is then retrieved from
 853 `ldap-attribute-syntax-decoders' and applied on the value(s)."
 854   (if (consp attr)
 855       (let* ((name (car attr))
 856              (values (cdr attr))
 857              (syntax-id (cdr (assq (intern (downcase name))
 858                                    ldap-attribute-syntaxes-alist)))
 859              decoder)
 860         (if syntax-id
 861             (setq decoder (aref ldap-attribute-syntax-decoders
 862                                 (1- syntax-id)))
 863           (setq decoder ldap-default-attribute-decoder))
 864         (if decoder
 865             (cons name (mapcar decoder values))
 866           attr))
 867     attr))
 868
 869 (defun ldap-search (arg1 &rest args)
 870   "Perform an LDAP search.if ARG1 is LDAP object, invoke `ldap-search-basic'.
 871 Otherwise, invoke `ldap-search-entries'.  ARGS are passed to each function."
 872       (apply (if (ldapp arg1)
 873                  'ldap-search-basic
 874                'ldap-search-entries) arg1 args))
 875
 876 (make-obsolete 'ldap-search
 877                "Use `ldap-search-entries' instead or
 878 `ldap-search-basic' for the low-level search API.")
 879
 880 (defun ldap-search-entries (filter &optional host attributes attrsonly withdn)
 881   "Perform an LDAP search.
 882 FILTER is the search filter in RFC1558 syntax, i.e., something that
 883 looks like \"(cn=John Smith)\".
 884 HOST is the LDAP host on which to perform the search.
 885 ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all.
 886 If ATTRSONLY is non nil, the attributes will be retrieved without
 887 the associated values.
 888 If WITHDN is non-nil each entry in the result will be prepennded with
 889 its distinguished name DN.
 890 Additional search parameters can be specified through
 891 `ldap-host-parameters-alist' which see.
 892 The function returns a list of matching entries.  Each entry is itself
 893 an alist of attribute/value pairs optionally preceded by the DN of the
 894 entry according to the value of WITHDN."
 895   (interactive "sFilter:")
 896   (or host
 897       (setq host ldap-default-host)
 898       (error "No LDAP host specified"))
 899   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 900         ldap
 901         result)
 902     (if ldap-verbose
 903         (message "Opening LDAP connection to %s..." host))
 904     (setq ldap (ldap-open host host-plist))
 905     (if ldap-verbose
 906         (message "Searching with LDAP on %s..." host))
 907     (setq result (ldap-search ldap filter
 908                               (plist-get host-plist 'base)
 909                               (plist-get host-plist 'scope)
 910                               attributes attrsonly withdn
 911                               ldap-verbose))
 912     (ldap-close ldap)
 913     (with-temp-buffer
 914       (set-buffer-multibyte nil)
 915       (if ldap-ignore-attribute-codings
 916           result
 917         (mapcar (function
 918                  (lambda (record)
 919                    (mapcar 'ldap-decode-attribute record)))
 920                 result)))))
 921
 922 (defun ldap-add-entries (entries &optional host binddn passwd)
 923   "Add entries to an LDAP directory.
 924 ENTRIES is a list of entry specifications of
 925 the form (DN (ATTR . VALUE) (ATTR . VALUE) ...) where
 926 DN is the distinguished name of an entry to add, the following
 927 are cons cells containing attribute/value string pairs.
 928 HOST is the LDAP host, defaulting to `ldap-default-host'
 929 BINDDN is the DN to bind as to the server
 930 PASSWD is the corresponding password"
 931   (or host
 932       (setq host ldap-default-host)
 933       (error "No LDAP host specified"))
 934   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 935         ldap
 936         (i 1))
 937     (if (or binddn passwd)
 938         (setq host-plist (copy-seq host-plist)))
 939     (if binddn
 940         (setq host-plist (plist-put host-plist 'binddn binddn)))
 941     (if passwd
 942         (setq host-plist (plist-put host-plist 'passwd passwd)))
 943     (if ldap-verbose
 944         (message "Opening LDAP connection to %s..." host))
 945     (setq ldap (ldap-open host host-plist))
 946     (if ldap-verbose
 947         (message "Adding LDAP entries..."))
 948     (mapcar (lambda (thisentry)
 949               (setcdr thisentry
 950                       (mapcar
 951                        (lambda (add-spec)
 952                          (setq add-spec (ldap-encode-attribute
 953                                          (list (car add-spec)
 954                                                (cdr add-spec))))
 955                          (cons (nth 0 add-spec)
 956                                (nth 1 add-spec)))
 957                        (cdr thisentry)))
 958               (setq thisentry (ldap-encode-attribute thisentry))
 959               (ldap-add ldap (car thisentry) (cdr thisentry))
 960               (if ldap-verbose
 961                   (message "%d added" i))
 962               (setq i (1+ i)))
 963             entries)
 964     (ldap-close ldap)))
 965
 966 (defun ldap-modify-entries (entry-mods &optional host binddn passwd)
 967   "Modify entries of an LDAP directory.
 968 ENTRY-MODS is a list of entry modifications of the form
 969   \(DN MOD-SPEC1 MOD-SPEC2 ...\) where DN is the distinguished name of
 970 the entry to modify, the following are modification specifications.
 971 A modification specification is itself a list of the form
 972 \(MOD-OP ATTR VALUE1 VALUE2 ...\) MOD-OP and ATTR are mandatory,
 973 VALUEs are optional depending on MOD-OP.
 974 MOD-OP is the type of modification, one of the symbols `add', `delete'
 975 or `replace'.  ATTR is the LDAP attribute type to modify.
 976 HOST is the LDAP host, defaulting to `ldap-default-host'
 977 BINDDN is the DN to bind as to the server
 978 PASSWD is the corresponding password"
 979   (or host
 980       (setq host ldap-default-host)
 981       (error "No LDAP host specified"))
 982   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 983         ldap
 984         (i 1))
 985     (if (or binddn passwd)
 986         (setq host-plist (copy-seq host-plist)))
 987     (if binddn
 988         (setq host-plist (plist-put host-plist 'binddn binddn)))
 989     (if passwd
 990         (setq host-plist (plist-put host-plist 'passwd passwd)))
 991     (if ldap-verbose
 992         (message "Opening LDAP connection to %s..." host))
 993     (setq ldap (ldap-open host host-plist))
 994     (if ldap-verbose
 995         (message "Modifying LDAP entries..."))
 996     (mapcar (lambda (thisentry)
 997               (setcdr thisentry
 998                       (mapcar
 999                        (lambda (mod-spec)
1000                          (if (or (eq (car mod-spec) 'add)
1001                                  (eq (car mod-spec) 'replace))
1002                              (append (list (nth 0 mod-spec))
1003                                      (ldap-encode-attribute
1004                                       (cdr mod-spec)))))
1005                        (cdr thisentry)))
1006               (ldap-modify ldap (car thisentry) (cdr thisentry))
1007               (if ldap-verbose
1008                   (message "%d modified" i))
1009               (setq i (1+ i)))
1010             entry-mods)
1011     (ldap-close ldap)))
1012
1013 (defun ldap-delete-entries (dn &optional host binddn passwd)
1014   "Delete an entry from an LDAP directory.
1015 DN is the distinguished name of an entry to delete or
1016 a list of those.
1017 HOST is the LDAP host, defaulting to `ldap-default-host'
1018 BINDDN is the DN to bind as to the server
1019 PASSWD is the corresponding password."
1020   (or host
1021       (setq host ldap-default-host)
1022       (error "No LDAP host specified"))
1023   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
1024         ldap)
1025     (if (or binddn passwd)
1026         (setq host-plist (copy-seq host-plist)))
1027     (if binddn
1028         (setq host-plist (plist-put host-plist 'binddn binddn)))
1029     (if passwd
1030         (setq host-plist (plist-put host-plist 'passwd passwd)))
1031     (if ldap-verbose
1032         (message "Opening LDAP connection to %s..." host))
1033     (setq ldap (ldap-open host host-plist))
1034     (if (consp dn)
1035         (let ((i 1))
1036           (if ldap-verbose
1037               (message "Deleting LDAP entries..."))
1038           (mapcar (function
1039                    (lambda (thisdn)
1040                      (ldap-delete ldap thisdn)
1041                      (if ldap-verbose
1042                          (message "%d deleted" i))
1043                      (setq i (1+ i))))
1044                   dn))
1045       (if ldap-verbose
1046           (message "Deleting LDAP entry..."))
1047       (ldap-delete ldap dn))
1048     (ldap-close ldap)))
1049 ;; end of ldap-static-if
1050 )
1051
1052 (provide 'pldap)
1053
1054 ;;; pldap.el ends here