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 '("-LL" "-x")
 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 (`-LL' is needed to get rid of comments from OpenLDAP's ldapsearch.)
 108 `-x' is needed to use simple authentication.
 109 The `-B' switch should be used to enable the retrieval of
 110 binary values."
 111   :type '(repeat :tag "`ldapsearch' Arguments"
 112                  (string :tag "Argument"))
 113   :group 'ldap)
 114
 115 (defcustom ldap-default-host nil
 116   "*Default LDAP server hostname."
 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 nil
 239   "*Coding system of LDAP string values.
 240 LDAP v3 specifies the coding system of strings to be UTF-8.
 241 Mule support is needed for this."
 242   :type 'symbol
 243   :group 'ldap)
 244
 245 (defvar ldap-attribute-syntax-encoders
 246   [nil                                  ; 1  ACI Item                        N
 247    nil                                  ; 2  Access Point                    Y
 248    nil                                  ; 3  Attribute Type Description      Y
 249    nil                                  ; 4  Audio                           N
 250    nil                                  ; 5  Binary                          N
 251    nil                                  ; 6  Bit String                      Y
 252    ldap-encode-boolean                  ; 7  Boolean                         Y
 253    nil                                  ; 8  Certificate                     N
 254    nil                                  ; 9  Certificate List                N
 255    nil                                  ; 10 Certificate Pair                N
 256    ldap-encode-country-string           ; 11 Country String                  Y
 257    ldap-encode-string                   ; 12 DN                              Y
 258    nil                                  ; 13 Data Quality Syntax             Y
 259    nil                                  ; 14 Delivery Method                 Y
 260    ldap-encode-string                   ; 15 Directory String                Y
 261    nil                                  ; 16 DIT Content Rule Description    Y
 262    nil                                  ; 17 DIT Structure Rule Description  Y
 263    nil                                  ; 18 DL Submit Permission            Y
 264    nil                                  ; 19 DSA Quality Syntax              Y
 265    nil                                  ; 20 DSE Type                        Y
 266    nil                                  ; 21 Enhanced Guide                  Y
 267    nil                                  ; 22 Facsimile Telephone Number      Y
 268    nil                                  ; 23 Fax                             N
 269    nil                                  ; 24 Generalized Time                Y
 270    nil                                  ; 25 Guide                           Y
 271    nil                                  ; 26 IA5 String                      Y
 272    number-to-string                     ; 27 INTEGER                         Y
 273    nil                                  ; 28 JPEG                            N
 274    nil                                  ; 29 Master And Shadow Access Points Y
 275    nil                                  ; 30 Matching Rule Description       Y
 276    nil                                  ; 31 Matching Rule Use Description   Y
 277    nil                                  ; 32 Mail Preference                 Y
 278    nil                                  ; 33 MHS OR Address                  Y
 279    nil                                  ; 34 Name And Optional UID           Y
 280    nil                                  ; 35 Name Form Description           Y
 281    nil                                  ; 36 Numeric String                  Y
 282    nil                                  ; 37 Object Class Description        Y
 283    nil                                  ; 38 OID                             Y
 284    nil                                  ; 39 Other Mailbox                   Y
 285    nil                                  ; 40 Octet String                    Y
 286    ldap-encode-address                  ; 41 Postal Address                  Y
 287    nil                                  ; 42 Protocol Information            Y
 288    nil                                  ; 43 Presentation Address            Y
 289    ldap-encode-string                   ; 44 Printable String                Y
 290    nil                                  ; 45 Subtree Specification           Y
 291    nil                                  ; 46 Supplier Information            Y
 292    nil                                  ; 47 Supplier Or Consumer            Y
 293    nil                                  ; 48 Supplier And Consumer           Y
 294    nil                                  ; 49 Supported Algorithm             N
 295    nil                                  ; 50 Telephone Number                Y
 296    nil                                  ; 51 Teletex Terminal Identifier     Y
 297    nil                                  ; 52 Telex Number                    Y
 298    nil                                  ; 53 UTC Time                        Y
 299    nil                                  ; 54 LDAP Syntax Description         Y
 300    nil                                  ; 55 Modify Rights                   Y
 301    nil                                  ; 56 LDAP Schema Definition          Y
 302    nil                                  ; 57 LDAP Schema Description         Y
 303    nil                                  ; 58 Substring Assertion             Y
 304    ]
 305   "A vector of functions used to encode LDAP attribute values.
 306 The sequence of functions corresponds to the sequence of LDAP attribute syntax
 307 object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
 308 RFC2252 section 4.3.2")
 309
 310 (defvar ldap-attribute-syntax-decoders
 311   [nil                                  ; 1  ACI Item                        N
 312    nil                                  ; 2  Access Point                    Y
 313    nil                                  ; 3  Attribute Type Description      Y
 314    nil                                  ; 4  Audio                           N
 315    nil                                  ; 5  Binary                          N
 316    nil                                  ; 6  Bit String                      Y
 317    ldap-decode-boolean                  ; 7  Boolean                         Y
 318    nil                                  ; 8  Certificate                     N
 319    nil                                  ; 9  Certificate List                N
 320    nil                                  ; 10 Certificate Pair                N
 321    ldap-decode-string                   ; 11 Country String                  Y
 322    ldap-decode-string                   ; 12 DN                              Y
 323    nil                                  ; 13 Data Quality Syntax             Y
 324    nil                                  ; 14 Delivery Method                 Y
 325    ldap-decode-string                   ; 15 Directory String                Y
 326    nil                                  ; 16 DIT Content Rule Description    Y
 327    nil                                  ; 17 DIT Structure Rule Description  Y
 328    nil                                  ; 18 DL Submit Permission            Y
 329    nil                                  ; 19 DSA Quality Syntax              Y
 330    nil                                  ; 20 DSE Type                        Y
 331    nil                                  ; 21 Enhanced Guide                  Y
 332    nil                                  ; 22 Facsimile Telephone Number      Y
 333    nil                                  ; 23 Fax                             N
 334    nil                                  ; 24 Generalized Time                Y
 335    nil                                  ; 25 Guide                           Y
 336    nil                                  ; 26 IA5 String                      Y
 337    string-to-number                     ; 27 INTEGER                         Y
 338    nil                                  ; 28 JPEG                            N
 339    nil                                  ; 29 Master And Shadow Access Points Y
 340    nil                                  ; 30 Matching Rule Description       Y
 341    nil                                  ; 31 Matching Rule Use Description   Y
 342    nil                                  ; 32 Mail Preference                 Y
 343    nil                                  ; 33 MHS OR Address                  Y
 344    nil                                  ; 34 Name And Optional UID           Y
 345    nil                                  ; 35 Name Form Description           Y
 346    nil                                  ; 36 Numeric String                  Y
 347    nil                                  ; 37 Object Class Description        Y
 348    nil                                  ; 38 OID                             Y
 349    nil                                  ; 39 Other Mailbox                   Y
 350    nil                                  ; 40 Octet String                    Y
 351    ldap-decode-address                  ; 41 Postal Address                  Y
 352    nil                                  ; 42 Protocol Information            Y
 353    nil                                  ; 43 Presentation Address            Y
 354    ldap-decode-string                   ; 44 Printable String                Y
 355    nil                                  ; 45 Subtree Specification           Y
 356    nil                                  ; 46 Supplier Information            Y
 357    nil                                  ; 47 Supplier Or Consumer            Y
 358    nil                                  ; 48 Supplier And Consumer           Y
 359    nil                                  ; 49 Supported Algorithm             N
 360    nil                                  ; 50 Telephone Number                Y
 361    nil                                  ; 51 Teletex Terminal Identifier     Y
 362    nil                                  ; 52 Telex Number                    Y
 363    nil                                  ; 53 UTC Time                        Y
 364    nil                                  ; 54 LDAP Syntax Description         Y
 365    nil                                  ; 55 Modify Rights                   Y
 366    nil                                  ; 56 LDAP Schema Definition          Y
 367    nil                                  ; 57 LDAP Schema Description         Y
 368    nil                                  ; 58 Substring Assertion             Y
 369    ]
 370   "A vector of functions used to decode LDAP attribute values.
 371 The sequence of functions corresponds to the sequence of LDAP attribute syntax
 372 object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
 373 RFC2252 section 4.3.2")
 374
 375 (defvar ldap-attribute-syntaxes-alist
 376   '((createtimestamp . 24)
 377     (modifytimestamp . 24)
 378     (creatorsname . 12)
 379     (modifiersname . 12)
 380     (subschemasubentry . 12)
 381     (attributetypes . 3)
 382     (objectclasses . 37)
 383     (matchingrules . 30)
 384     (matchingruleuse . 31)
 385     (namingcontexts . 12)
 386     (altserver . 26)
 387     (supportedextension . 38)
 388     (supportedcontrol . 38)
 389     (supportedsaslmechanisms . 15)
 390     (supportedldapversion . 27)
 391     (ldapsyntaxes . 16)
 392     (ditstructurerules . 17)
 393     (nameforms . 35)
 394     (ditcontentrules . 16)
 395     (objectclass . 38)
 396     (aliasedobjectname . 12)
 397     (cn . 15)
 398     (sn . 15)
 399     (serialnumber . 44)
 400     (c . 15)
 401     (l . 15)
 402     (st . 15)
 403     (street . 15)
 404     (o . 15)
 405     (ou . 15)
 406     (title . 15)
 407     (description . 15)
 408     (searchguide . 25)
 409     (businesscategory . 15)
 410     (postaladdress . 41)
 411     (postalcode . 15)
 412     (postofficebox . 15)
 413     (physicaldeliveryofficename . 15)
 414     (telephonenumber . 50)
 415     (telexnumber . 52)
 416     (telexterminalidentifier . 51)
 417     (facsimiletelephonenumber . 22)
 418     (x121address . 36)
 419     (internationalisdnnumber . 36)
 420     (registeredaddress . 41)
 421     (destinationindicator . 44)
 422     (preferreddeliverymethod . 14)
 423     (presentationaddress . 43)
 424     (supportedapplicationcontext . 38)
 425     (member . 12)
 426     (owner . 12)
 427     (roleoccupant . 12)
 428     (seealso . 12)
 429     (userpassword . 40)
 430     (usercertificate . 8)
 431     (cacertificate . 8)
 432     (authorityrevocationlist . 9)
 433     (certificaterevocationlist . 9)
 434     (crosscertificatepair . 10)
 435     (name . 15)
 436     (givenname . 15)
 437     (initials . 15)
 438     (generationqualifier . 15)
 439     (x500uniqueidentifier . 6)
 440     (dnqualifier . 44)
 441     (enhancedsearchguide . 21)
 442     (protocolinformation . 42)
 443     (distinguishedname . 12)
 444     (uniquemember . 34)
 445     (houseidentifier . 15)
 446     (supportedalgorithms . 49)
 447     (deltarevocationlist . 9)
 448     (dmdname . 15))
 449   "A map of LDAP attribute names to their type object id minor number.
 450 This table is built from RFC2252 Section 5 and RFC2256 Section 5")
 451
 452 ;;; LDAP primitive functions.
 453 ;;
 454 ;; LDAP object is
 455 ;; (__ldap-object HOSTNAME PLIST)
 456
 457 (defun ldapp (object)
 458   "Return t if OBJECT is a LDAP connection."
 459   (and (listp object)
 460        (eq (car object) '__ldap-object)))
 461
 462 (defun ldap-open (host &optional plist)
 463   "Open a LDAP connection to HOST.
 464 PLIST is a plist containing additional parameters for the connection.
 465 Valid keys in that list are:
 466   `port' the TCP port to use for the connection if different from
 467 `ldap-default-port'.
 468   `auth' is the authentication method to use, possible values depend on
 469 the LDAP library: `simple', `krbv41' and `krbv42'.
 470   `binddn' is the distinguished name of the user to bind as
 471  (in RFC 1779 syntax).
 472   `passwd' is the password to use for simple authentication.
 473   `deref' is one of the symbols `never', `always', `search' or `find'.
 474   `timelimit' is the timeout limit for the connection in seconds.
 475   `sizelimit' is the maximum number of matches to return."
 476   (list '__ldap-object host plist))
 477
 478 (defun ldap-host (ldap)
 479   "Return the server host of the connection LDAP, as a string."
 480   (nth 1 ldap))
 481
 482 (defun ldap-close (ldap)
 483   "Close an LDAP connection."
 484   t)
 485
 486 (defun ldap-delete (ldap dn)
 487   "Delete an entry to an LDAP directory.
 488 LDAP is an LDAP connection object created with `ldap-open'.
 489 DN is the distinguished name of the entry to delete."
 490   (let* ((plist (or (nth 2 ldap)
 491                     (cdr (assoc (ldap-host ldap)
 492                                 ldap-host-parameters-alist))))
 493          (port   (plist-get plist 'port))
 494          (binddn (plist-get plist 'binddn))
 495          (passwd (plist-get plist 'passwd))
 496          arglist ret)
 497     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 498     (if (and port (not (equal 389 port)))
 499         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 500     (if (and binddn
 501              (not (equal "" binddn)))
 502         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 503     (if (and passwd
 504              (not (equal "" passwd)))
 505         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 506     (with-temp-buffer
 507       (setq ret (apply 'call-process
 508                        ldap-delete-program
 509                        nil (current-buffer) t
 510                        (append arglist
 511                                (list dn))))
 512       (if (integerp ret)
 513           (if (not (zerop ret))
 514               (error (car (split-string (buffer-string) "\n"))))
 515         (if (and (setq ret (buffer-string)); Nemacs
 516                  (string-match "ldap_delete:" ret))
 517             (error (car (split-string ret "\n"))))))))
 518
 519 (defmacro ldap/ldif-insert-field (attr value)
 520   (` (if (not (ldap/ldif-safe-string-p (, value)))
 521          (insert (, attr) ":: " (base64-encode-string (, value)) "\n")
 522        (insert (, attr) ": " (, value) "\n"))))
 523
 524 (defun ldap-modify (ldap dn mods)
 525   "Add an entry to an LDAP directory.
 526 LDAP is an LDAP connection object created with `ldap-open'.
 527 DN is the distinguished name of the entry to modify.
 528 MODS is a list of modifications to apply.
 529 A modification is a list of the form (MOD-OP ATTR VALUE1 VALUE2 ...)
 530 MOD-OP and ATTR are mandatory, VALUEs are optional depending on MOD-OP.
 531 MOD-OP is the type of modification, one of the symbols `add', `delete'
 532 or `replace'.  ATTR is the LDAP attribute type to modify."
 533   (let* ((plist (or (nth 2 ldap)
 534                     (cdr (assoc (ldap-host ldap)
 535                                 ldap-host-parameters-alist))))
 536          (port   (plist-get plist 'port))
 537          (binddn (plist-get plist 'binddn))
 538          (passwd (plist-get plist 'passwd))
 539          arglist ret)
 540     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 541     (if (and port (not (equal 389 port)))
 542         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 543     (if (and binddn
 544              (not (equal "" binddn)))
 545         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 546     (if (and passwd
 547              (not (equal "" passwd)))
 548         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 549     (with-temp-buffer
 550       (ldap/ldif-insert-field "dn" dn)
 551       (insert "changetype: modify\n")
 552       (while mods
 553         (cond
 554          ((eq (nth 0 (car mods)) 'add)
 555           (insert "add: " (nth 1 (car mods)) "\n")
 556           (ldap/ldif-insert-field (nth 1 (car mods)) (nth 2 (car mods)))
 557           (insert "-\n"))
 558          ((eq (nth 0 (car mods)) 'delete)
 559           (insert "delete: " (nth 1 (car mods)) "\n-\n"))
 560          ((eq (nth 0 (car mods)) 'replace)
 561           (insert "replace: " (nth 1 (car mods)) "\n")
 562           (ldap/ldif-insert-field (nth 1 (car mods)) (nth 2 (car mods)))
 563           (insert "-\n")))
 564         (setq mods (cdr mods)))
 565       (setq ret (apply 'call-process-region
 566                        (point-min) (point-max)
 567                        ldap-modify-program
 568                        t t nil
 569                        arglist))
 570       (if (integerp ret)
 571           (if (not (zerop ret))
 572               (error (car (split-string (buffer-string) "\n"))))
 573         (if (and (setq ret (buffer-string)); Nemacs
 574                  (string-match "ldap_modify:" ret))
 575             (error (car (split-string ret "\n"))))))))
 576
 577 (defun ldap-add (ldap dn entry)
 578   "Add an entry to an LDAP directory.
 579 LDAP is an LDAP connection object created with `ldap-open'.
 580 DN is the distinguished name of the entry to add.
 581 ENTRY is an entry specification, i.e., a list of cons cells
 582 containing attribute/value string pairs."
 583   (let* ((plist (or (nth 2 ldap)
 584                     (cdr (assoc (ldap-host ldap)
 585                                 ldap-host-parameters-alist))))
 586          (port   (plist-get plist 'port))
 587          (binddn (plist-get plist 'binddn))
 588          (passwd (plist-get plist 'passwd))
 589          arglist ret)
 590     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 591     (if (and port (not (equal 389 port)))
 592         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 593     (if (and binddn
 594              (not (equal "" binddn)))
 595         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 596     (if (and passwd
 597              (not (equal "" passwd)))
 598         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 599     (with-temp-buffer
 600       (set-buffer-multibyte nil)
 601       (ldap/ldif-insert-field "dn" dn)
 602       (while entry
 603         (ldap/ldif-insert-field (car (car entry)) (cdr (car entry)))
 604         (setq entry (cdr entry)))
 605       (setq ret (apply 'call-process-region
 606                        (point-min) (point-max)
 607                        ldap-add-program
 608                        t t nil
 609                        arglist))
 610       (if (integerp ret)
 611           (if (not (zerop ret))
 612               (error (car (split-string (buffer-string) "\n"))))
 613         (if (and (setq ret (buffer-string)) ; Nemacs
 614                  (string-match "ldap_add:" ret))
 615             (error (car (split-string ret "\n"))))))))
 616
 617 (defun ldap-search-basic (ldap filter base scope
 618                                &optional attrs attrsonly withdn verbose)
 619   "Perform a search on a LDAP server.  (Use external program `ldapsearch')
 620 FILTER is a filter string for the search as described in RFC 1558.
 621 BASE is the distinguished name at which to start the search.
 622 SCOPE is one of the symbols `base', `onelevel' or `subtree' indicating
 623 the scope of the search.
 624 ATTRS is a list of strings indicating which attributes to retrieve
 625  for each matching entry.  If nil return all available attributes.
 626 If ATTRSONLY is non-nil then only the attributes are retrieved, not
 627 the associated values.
 628 If WITHDN is non-nil each entry in the result will be prepended with
 629 its distinguished name DN.
 630 If VERBOSE is non-nil progress messages will be echoed.
 631 The function returns a list of matching entries.  Each entry is itself
 632 an alist of attribute/value pairs optionally preceded by the DN of the
 633 entry according to the value of WITHDN."
 634   (let* ((plist (or (nth 2 ldap)
 635                     (cdr (assoc (ldap-host ldap)
 636                                 ldap-host-parameters-alist))))
 637          (port   (plist-get plist 'port))
 638          (base (or base (plist-get plist 'base) ldap-default-base))
 639          (scope (or scope (plist-get plist 'scope)))
 640          (binddn (plist-get plist 'binddn))
 641          (passwd (plist-get plist 'passwd))
 642          (deref (plist-get plist 'deref))
 643          (timelimit (plist-get plist 'timelimit))
 644          (sizelimit (plist-get plist 'sizelimit))
 645          start value attrs-result
 646          (i 0)
 647          result arglist ret)
 648     (setq arglist (list (format "-h%s" (ldap-host ldap))))
 649     (if (and port (not (equal 389 port)))
 650         (setq arglist (nconc arglist (list (format "-p%d" port)))))
 651     (if (and base
 652              (not (equal "" base)))
 653         (setq arglist (nconc arglist (list (format "-b%s" base)))))
 654     (if (and scope
 655              (not (equal "" scope)))
 656         (setq
 657          arglist
 658          (nconc
 659           arglist
 660           (list (format "-s%s"
 661                         (cond ((eq scope 'onelevel) "one")
 662                               ((eq scope 'base) "base")
 663                               ((eq scope 'subtree) "sub")
 664                               ((null scope) "sub")
 665                               (t (error "Invalid scope: %s" scope))))))))
 666     (if (and binddn
 667              (not (equal "" binddn)))
 668         (setq arglist (nconc arglist (list (format "-D%s" binddn)))))
 669     (if (and passwd
 670              (not (equal "" passwd)))
 671         (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
 672     (if (and deref
 673              (not (equal "" deref)))
 674         (setq arglist (nconc arglist (list (format "-a%s" deref)))))
 675     (if (and timelimit
 676              (not (equal "" timelimit)))
 677         (setq arglist (nconc arglist (list (format "-l%s" timelimit)))))
 678     (if (and sizelimit
 679              (not (equal "" sizelimit)))
 680         (setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
 681     (with-temp-buffer
 682       (set-buffer-multibyte nil)
 683       (setq ret (apply 'call-process
 684                        ldap-search-program
 685                        nil (current-buffer) t
 686                        (append arglist
 687                                ldap-search-program-arguments
 688                                (list filter)
 689                                attrs)))
 690       (if (and (integerp ret)
 691                (not (zerop ret))
 692                ;; When openldap's `ldapsearch' exceeds response size limit,
 693                ;; it's exit status becomes `4'.
 694                (/= ret 4))
 695           (error "LDAP error: \"No such object\""))
 696       (goto-char (point-min))
 697       (setq start (point))
 698       (while (and (not (eobp))
 699                   (re-search-forward "^$" nil t)) ; empty line is a delimiter.
 700         (if verbose
 701             (message "Parsing ldap results...%d" (setq i (+ i 1))))
 702         (save-excursion
 703           (save-restriction
 704             (narrow-to-region start (point))
 705             (if attrs
 706                 (setq attrs-result (delq
 707                                     nil
 708                                     (mapcar
 709                                      (lambda (attr)
 710                                        ;; dn is not an attribute.
 711                                        (unless (string= attr "dn")
 712                                          (if (setq value
 713                                                    (ldap/field-body attr))
 714                                              (if attrsonly
 715                                                  (list attr)
 716                                                (nconc (list attr) value)))))
 717                                      attrs)))
 718               (setq attrs-result (ldap/collect-field "dn"))
 719               (if attrsonly
 720                   (setq attrs-result (mapcar (lambda (x) (list (car x)))
 721                                              attrs-result))))
 722             (setq result
 723                   (cons
 724                    (if withdn
 725                        (if attrs-result
 726                            (nconc (ldap/field-body "dn") attrs-result)
 727                          (ldap/field-body "dn"))
 728                      attrs-result)
 729                    result))))
 730         (if (not (eobp)) (forward-char 1))
 731         (setq start (point)))
 732       (if verbose
 733           (message "Parsing ldap results...done"))
 734       (delq nil (nreverse result)))))
 735
 736 (defun ldap/field-end ()
 737   "Move to end of field and return this point."
 738   (if (re-search-forward ldap-ldif-next-field-head-regexp nil t)
 739       (goto-char (match-beginning 0))
 740     (if (re-search-forward "^$" nil t)
 741         (goto-char (1- (match-beginning 0)))
 742       (end-of-line)))
 743   (point))
 744
 745 (defun ldap/field-body (name)
 746   "Return field body list of NAME."
 747   (save-excursion
 748     (goto-char (point-min))
 749     (let ((case-fold-search t)
 750           (field-body nil)
 751           body)
 752       ;; search for the line which have name with options.
 753       (while (re-search-forward (concat "^" name
 754                                         "\\(;[a-zA-Z0-9-]+\\)?:[ \t]*") nil t)
 755         ;; Base64
 756         (if (string-match "^:[ \t]*" (setq body
 757                                            (buffer-substring-no-properties
 758                                             (match-end 0)
 759                                             (ldap/field-end))))
 760             (setq body (base64-decode-string (substring body (match-end 0)))))
 761         (setq field-body (nconc field-body (list body))))
 762       field-body)))
 763
 764 (defun ldap/collect-field (without)
 765   "Collect fields without WITHOUT."
 766   (goto-char (point-min))
 767   (let ((regexp (concat "\\(" ldap-ldif-field-head-regexp "\\)[ \t]*"))
 768         dest name name-option body entry)
 769     (while (re-search-forward regexp nil t)
 770       ;; name with options.
 771       (setq name-option (split-string (downcase (buffer-substring-no-properties
 772                                                  (match-beginning 1)
 773                                                  (1- (match-end 1))))
 774                                       ";"))
 775       ;; XXX options are discarded.
 776       (setq name (car name-option))
 777       (setq body (buffer-substring-no-properties
 778                   (match-end 0) (ldap/field-end)))
 779       (if (string-match "^:[ \t]*" body)
 780           (setq body (base64-decode-string (substring body (match-end 0)))))
 781       (unless (string= name without)
 782         (if (setq entry (assoc name dest))
 783             (nconc entry (list body))
 784           (setq dest (cons (list name body) dest)))))
 785     (nreverse dest)))
 786
 787 ;;; Coding/decoding functions
 788 ;;
 789 (defun ldap-encode-boolean (bool)
 790   "Encode BOOL to LDAP type."
 791   (if bool
 792       "TRUE"
 793     "FALSE"))
 794
 795 (defun ldap-decode-boolean (str)
 796   "Decode STR to elisp type."
 797   (cond
 798    ((string-equal str "TRUE")
 799     t)
 800    ((string-equal str "FALSE")
 801     nil)
 802    (t
 803     (error "Wrong LDAP boolean string: %s" str))))
 804
 805 (defun ldap-encode-country-string (str)
 806   "Encode STR to LDAP country string."
 807   ;; We should do something useful here...
 808   (if (not (= 2 (length str)))
 809       (error "Invalid country string: %s" str)))
 810
 811 (defun ldap-decode-string (str)
 812   "Decode LDAP STR."
 813   (if (and (fboundp 'decode-coding-string)
 814            ldap-coding-system)
 815       (decode-coding-string str ldap-coding-system)
 816     str))
 817
 818 (defun ldap-encode-string (str)
 819   "Encode LDAP STR."
 820   (if (and (fboundp 'encode-coding-string)
 821            ldap-coding-system)
 822       (encode-coding-string str ldap-coding-system)
 823     str))
 824
 825 (defun ldap-decode-address (str)
 826   "Decode LDAP address STR."
 827   (mapconcat 'ldap-decode-string
 828              (split-string str "\\$")
 829              "\n"))
 830
 831 (defun ldap-encode-address (str)
 832   "Encode address STR to LDAP type."
 833   (mapconcat 'ldap-encode-string
 834              (split-string str "\n")
 835              "$"))
 836
 837 ;;; LDAP protocol functions
 838 ;;
 839 (defun ldap-get-host-parameter (host parameter)
 840   "Get HOST's PARAMETER in `ldap-host-parameters-alist'."
 841   (plist-get (cdr (assoc host ldap-host-parameters-alist))
 842              parameter))
 843
 844 (defun ldap-encode-attribute (attr)
 845   "Encode the attribute/value pair ATTR according to LDAP rules.
 846 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
 847 and the corresponding decoder is then retrieved from
 848 `ldap-attribute-syntax-encoders' and applied on the value(s)."
 849   (let* ((name (car attr))
 850          (values (cdr attr))
 851          (syntax-id (cdr (assq (intern (downcase name))
 852                                ldap-attribute-syntaxes-alist)))
 853          encoder)
 854     (if syntax-id
 855         (setq encoder (aref ldap-attribute-syntax-encoders
 856                             (1- syntax-id)))
 857       (setq encoder ldap-default-attribute-encoder))
 858     (if encoder
 859         (cons name (mapcar encoder values))
 860       attr)))
 861
 862 (defun ldap-decode-attribute (attr)
 863   "Decode the attribute/value pair ATTR according to LDAP rules.
 864 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
 865 and the corresponding decoder is then retrieved from
 866 `ldap-attribute-syntax-decoders' and applied on the value(s)."
 867   (if (consp attr)
 868       (let* ((name (car attr))
 869              (values (cdr attr))
 870              (syntax-id (cdr (assq (intern (downcase name))
 871                                    ldap-attribute-syntaxes-alist)))
 872              decoder)
 873         (if syntax-id
 874             (setq decoder (aref ldap-attribute-syntax-decoders
 875                                 (1- syntax-id)))
 876           (setq decoder ldap-default-attribute-decoder))
 877         (if decoder
 878             (cons name (mapcar decoder values))
 879           attr))
 880     attr))
 881
 882 (defun ldap-search (arg1 &rest args)
 883   "Perform an LDAP search.if ARG1 is LDAP object, invoke `ldap-search-basic'.
 884 Otherwise, invoke `ldap-search-entries'.  ARGS are passed to each function."
 885       (apply (if (ldapp arg1)
 886                  'ldap-search-basic
 887                'ldap-search-entries) arg1 args))
 888
 889 (make-obsolete 'ldap-search
 890                "Use `ldap-search-entries' instead or
 891 `ldap-search-basic' for the low-level search API.")
 892
 893 (defun ldap-search-entries (filter &optional host attributes attrsonly withdn)
 894   "Perform an LDAP search.
 895 FILTER is the search filter in RFC1558 syntax, i.e., something that
 896 looks like \"(cn=John Smith)\".
 897 HOST is the LDAP host on which to perform the search.
 898 ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all.
 899 If ATTRSONLY is non nil, the attributes will be retrieved without
 900 the associated values.
 901 If WITHDN is non-nil each entry in the result will be prepennded with
 902 its distinguished name DN.
 903 Additional search parameters can be specified through
 904 `ldap-host-parameters-alist' which see.
 905 The function returns a list of matching entries.  Each entry is itself
 906 an alist of attribute/value pairs optionally preceded by the DN of the
 907 entry according to the value of WITHDN."
 908   (interactive "sFilter:")
 909   (or host
 910       (setq host ldap-default-host)
 911       (error "No LDAP host specified"))
 912   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 913         ldap
 914         result)
 915     (if ldap-verbose
 916         (message "Opening LDAP connection to %s..." host))
 917     (setq ldap (ldap-open host host-plist))
 918     (if ldap-verbose
 919         (message "Searching with LDAP on %s..." host))
 920     (setq result (ldap-search ldap (ldap-encode-string filter)
 921                               (plist-get host-plist 'base)
 922                               (plist-get host-plist 'scope)
 923                               attributes attrsonly withdn
 924                               ldap-verbose))
 925     (ldap-close ldap)
 926     (with-temp-buffer
 927       (set-buffer-multibyte nil)
 928       (if ldap-ignore-attribute-codings
 929           result
 930         (mapcar (function
 931                  (lambda (record)
 932                    (mapcar 'ldap-decode-attribute record)))
 933                 result)))))
 934
 935 (defun ldap-add-entries (entries &optional host binddn passwd)
 936   "Add entries to an LDAP directory.
 937 ENTRIES is a list of entry specifications of
 938 the form (DN (ATTR . VALUE) (ATTR . VALUE) ...) where
 939 DN is the distinguished name of an entry to add, the following
 940 are cons cells containing attribute/value string pairs.
 941 HOST is the LDAP host, defaulting to `ldap-default-host'
 942 BINDDN is the DN to bind as to the server
 943 PASSWD is the corresponding password"
 944   (or host
 945       (setq host ldap-default-host)
 946       (error "No LDAP host specified"))
 947   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 948         ldap
 949         (i 1))
 950     (if (or binddn passwd)
 951         (setq host-plist (copy-seq host-plist)))
 952     (if binddn
 953         (setq host-plist (plist-put host-plist 'binddn binddn)))
 954     (if passwd
 955         (setq host-plist (plist-put host-plist 'passwd passwd)))
 956     (if ldap-verbose
 957         (message "Opening LDAP connection to %s..." host))
 958     (setq ldap (ldap-open host host-plist))
 959     (if ldap-verbose
 960         (message "Adding LDAP entries..."))
 961     (mapcar (lambda (thisentry)
 962               (setcdr thisentry
 963                       (mapcar
 964                        (lambda (add-spec)
 965                          (setq add-spec (ldap-encode-attribute
 966                                          (list (car add-spec)
 967                                                (cdr add-spec))))
 968                          (cons (nth 0 add-spec)
 969                                (nth 1 add-spec)))
 970                        (cdr thisentry)))
 971               (setq thisentry (ldap-encode-attribute thisentry))
 972               (ldap-add ldap (car thisentry) (cdr thisentry))
 973               (if ldap-verbose
 974                   (message "%d added" i))
 975               (setq i (1+ i)))
 976             entries)
 977     (ldap-close ldap)))
 978
 979 (defun ldap-modify-entries (entry-mods &optional host binddn passwd)
 980   "Modify entries of an LDAP directory.
 981 ENTRY-MODS is a list of entry modifications of the form
 982   \(DN MOD-SPEC1 MOD-SPEC2 ...\) where DN is the distinguished name of
 983 the entry to modify, the following are modification specifications.
 984 A modification specification is itself a list of the form
 985 \(MOD-OP ATTR VALUE1 VALUE2 ...\) MOD-OP and ATTR are mandatory,
 986 VALUEs are optional depending on MOD-OP.
 987 MOD-OP is the type of modification, one of the symbols `add', `delete'
 988 or `replace'.  ATTR is the LDAP attribute type to modify.
 989 HOST is the LDAP host, defaulting to `ldap-default-host'
 990 BINDDN is the DN to bind as to the server
 991 PASSWD is the corresponding password"
 992   (or host
 993       (setq host ldap-default-host)
 994       (error "No LDAP host specified"))
 995   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 996         ldap
 997         (i 1))
 998     (if (or binddn passwd)
 999         (setq host-plist (copy-seq host-plist)))
1000     (if binddn
1001         (setq host-plist (plist-put host-plist 'binddn binddn)))
1002     (if passwd
1003         (setq host-plist (plist-put host-plist 'passwd passwd)))
1004     (if ldap-verbose
1005         (message "Opening LDAP connection to %s..." host))
1006     (setq ldap (ldap-open host host-plist))
1007     (if ldap-verbose
1008         (message "Modifying LDAP entries..."))
1009     (mapcar (lambda (thisentry)
1010               (setcdr thisentry
1011                       (mapcar
1012                        (lambda (mod-spec)
1013                          (if (or (eq (car mod-spec) 'add)
1014                                  (eq (car mod-spec) 'replace))
1015                              (append (list (nth 0 mod-spec))
1016                                      (ldap-encode-attribute
1017                                       (cdr mod-spec)))))
1018                        (cdr thisentry)))
1019               (ldap-modify ldap (car thisentry) (cdr thisentry))
1020               (if ldap-verbose
1021                   (message "%d modified" i))
1022               (setq i (1+ i)))
1023             entry-mods)
1024     (ldap-close ldap)))
1025
1026 (defun ldap-delete-entries (dn &optional host binddn passwd)
1027   "Delete an entry from an LDAP directory.
1028 DN is the distinguished name of an entry to delete or
1029 a list of those.
1030 HOST is the LDAP host, defaulting to `ldap-default-host'
1031 BINDDN is the DN to bind as to the server
1032 PASSWD is the corresponding password."
1033   (or host
1034       (setq host ldap-default-host)
1035       (error "No LDAP host specified"))
1036   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
1037         ldap)
1038     (if (or binddn passwd)
1039         (setq host-plist (copy-seq host-plist)))
1040     (if binddn
1041         (setq host-plist (plist-put host-plist 'binddn binddn)))
1042     (if passwd
1043         (setq host-plist (plist-put host-plist 'passwd passwd)))
1044     (if ldap-verbose
1045         (message "Opening LDAP connection to %s..." host))
1046     (setq ldap (ldap-open host host-plist))
1047     (if (consp dn)
1048         (let ((i 1))
1049           (if ldap-verbose
1050               (message "Deleting LDAP entries..."))
1051           (mapcar (function
1052                    (lambda (thisdn)
1053                      (ldap-delete ldap thisdn)
1054                      (if ldap-verbose
1055                          (message "%d deleted" i))
1056                      (setq i (1+ i))))
1057                   dn))
1058       (if ldap-verbose
1059           (message "Deleting LDAP entry..."))
1060       (ldap-delete ldap dn))
1061     (ldap-close ldap)))
1062 ;; end of ldap-static-if
1063 )
1064
1065 (provide 'pldap)
1066
1067 ;;; pldap.el ends here