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