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 (defun 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       (cond ((integerp ret)
 513              (or (zerop ret)
 514                  (error "%s" (car (split-string (buffer-string) "\n")))))
 515             ((and (setq ret (buffer-string)); Nemacs
 516                   (string-match "ldap_delete:" ret))
 517              (error "%s" (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       (cond ((integerp ret)
 571              (or (zerop ret)
 572                  (error "%s" (car (split-string (buffer-string) "\n")))))
 573             ((and (setq ret (buffer-string)); Nemacs
 574                   (string-match "ldap_modify:" ret))
 575              (error "%s" (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       (cond ((integerp ret)
 611              (or (zerop ret)
 612                  (error "%s" (car (split-string (buffer-string) "\n")))))
 613             ((and (setq ret (buffer-string)) ; Nemacs
 614                   (string-match "ldap_add:" ret))
 615              (error "%s" (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                ;; When openldap's `ldapsearch' uses referral,
 696                ;; it's exit status becomes `32'.
 697                (/= ret 32))
 698           (error "LDAP error: \"No such object\""))
 699       (goto-char (point-min))
 700       (setq start (point))
 701       (while (and (not (eobp))
 702                   (re-search-forward "^$" nil t)) ; empty line is a delimiter.
 703         (if verbose
 704             (message "Parsing ldap results...%d" (setq i (+ i 1))))
 705         (save-excursion
 706           (save-restriction
 707             (narrow-to-region start (point))
 708             (if attrs
 709                 (setq attrs-result (delq
 710                                     nil
 711                                     (mapcar
 712                                      (lambda (attr)
 713                                        ;; dn is not an attribute.
 714                                        (unless (string= attr "dn")
 715                                          (if (setq value
 716                                                    (ldap/field-body attr))
 717                                              (if attrsonly
 718                                                  (list attr)
 719                                                (nconc (list attr) value)))))
 720                                      attrs)))
 721               (setq attrs-result (ldap/collect-field "dn"))
 722               (if attrsonly
 723                   (setq attrs-result (mapcar (lambda (x) (list (car x)))
 724                                              attrs-result))))
 725             (setq result
 726                   (cons
 727                    (if withdn
 728                        (if attrs-result
 729                            (nconc (ldap/field-body "dn") attrs-result)
 730                          (ldap/field-body "dn"))
 731                      attrs-result)
 732                    result))))
 733         (if (not (eobp)) (forward-char 1))
 734         (setq start (point)))
 735       (if verbose
 736           (message "Parsing ldap results...done"))
 737       (delq nil (nreverse result)))))
 738
 739 (defun ldap/field-end ()
 740   "Move to end of field and return this point."
 741   (if (re-search-forward ldap-ldif-next-field-head-regexp nil t)
 742       (goto-char (match-beginning 0))
 743     (if (re-search-forward "^$" nil t)
 744         (goto-char (1- (match-beginning 0)))
 745       (end-of-line)))
 746   (point))
 747
 748 (defun ldap/field-body (name)
 749   "Return field body list of NAME."
 750   (save-excursion
 751     (goto-char (point-min))
 752     (let ((case-fold-search t)
 753           (field-body nil)
 754           body)
 755       ;; search for the line which have name with options.
 756       (while (re-search-forward (concat "^" name
 757                                         "\\(;[a-zA-Z0-9-]+\\)?:[ \t]*") nil t)
 758         ;; Base64
 759         (if (string-match "^:[ \t]*" (setq body
 760                                            (buffer-substring-no-properties
 761                                             (match-end 0)
 762                                             (ldap/field-end))))
 763             (setq body (base64-decode-string (substring body (match-end 0)))))
 764         (setq field-body (nconc field-body (list body))))
 765       field-body)))
 766
 767 (defun ldap/collect-field (without)
 768   "Collect fields without WITHOUT."
 769   (goto-char (point-min))
 770   (let ((regexp (concat "\\(" ldap-ldif-field-head-regexp "\\)[ \t]*"))
 771         dest name name-option body entry)
 772     (while (re-search-forward regexp nil t)
 773       ;; name with options.
 774       (setq name-option (split-string (downcase (buffer-substring-no-properties
 775                                                  (match-beginning 1)
 776                                                  (1- (match-end 1))))
 777                                       ";"))
 778       ;; XXX options are discarded.
 779       (setq name (car name-option))
 780       (setq body (buffer-substring-no-properties
 781                   (match-end 0) (ldap/field-end)))
 782       (if (string-match "^:[ \t]*" body)
 783           (setq body (base64-decode-string (substring body (match-end 0)))))
 784       (unless (string= name without)
 785         (if (setq entry (assoc name dest))
 786             (nconc entry (list body))
 787           (setq dest (cons (list name body) dest)))))
 788     (nreverse dest)))
 789
 790 ;;; Coding/decoding functions
 791 ;;
 792 (defun ldap-encode-boolean (bool)
 793   "Encode BOOL to LDAP type."
 794   (if bool
 795       "TRUE"
 796     "FALSE"))
 797
 798 (defun ldap-decode-boolean (str)
 799   "Decode STR to elisp type."
 800   (cond
 801    ((string-equal str "TRUE")
 802     t)
 803    ((string-equal str "FALSE")
 804     nil)
 805    (t
 806     (error "Wrong LDAP boolean string: %s" str))))
 807
 808 (defun ldap-encode-country-string (str)
 809   "Encode STR to LDAP country string."
 810   ;; We should do something useful here...
 811   (if (not (= 2 (length str)))
 812       (error "Invalid country string: %s" str)))
 813
 814 (defun ldap-decode-string (str)
 815   "Decode LDAP STR."
 816   (if (and (fboundp 'decode-coding-string)
 817            ldap-coding-system)
 818       (decode-coding-string str ldap-coding-system)
 819     str))
 820
 821 (defun ldap-encode-string (str)
 822   "Encode LDAP STR."
 823   (if (and (fboundp 'encode-coding-string)
 824            ldap-coding-system)
 825       (encode-coding-string str ldap-coding-system)
 826     str))
 827
 828 (defun ldap-decode-address (str)
 829   "Decode LDAP address STR."
 830   (mapconcat 'ldap-decode-string
 831              (split-string str "\\$")
 832              "\n"))
 833
 834 (defun ldap-encode-address (str)
 835   "Encode address STR to LDAP type."
 836   (mapconcat 'ldap-encode-string
 837              (split-string str "\n")
 838              "$"))
 839
 840 ;;; LDAP protocol functions
 841 ;;
 842 (defun ldap-get-host-parameter (host parameter)
 843   "Get HOST's PARAMETER in `ldap-host-parameters-alist'."
 844   (plist-get (cdr (assoc host ldap-host-parameters-alist))
 845              parameter))
 846
 847 (defun ldap-encode-attribute (attr)
 848   "Encode the attribute/value pair ATTR according to LDAP rules.
 849 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
 850 and the corresponding decoder is then retrieved from
 851 `ldap-attribute-syntax-encoders' and applied on the value(s)."
 852   (let* ((name (car attr))
 853          (values (cdr attr))
 854          (syntax-id (cdr (assq (intern (downcase name))
 855                                ldap-attribute-syntaxes-alist)))
 856          encoder)
 857     (if syntax-id
 858         (setq encoder (aref ldap-attribute-syntax-encoders
 859                             (1- syntax-id)))
 860       (setq encoder ldap-default-attribute-encoder))
 861     (if encoder
 862         (cons name (mapcar encoder values))
 863       attr)))
 864
 865 (defun ldap-decode-attribute (attr)
 866   "Decode the attribute/value pair ATTR according to LDAP rules.
 867 The attribute name is looked up in `ldap-attribute-syntaxes-alist'
 868 and the corresponding decoder is then retrieved from
 869 `ldap-attribute-syntax-decoders' and applied on the value(s)."
 870   (if (consp attr)
 871       (let* ((name (car attr))
 872              (values (cdr attr))
 873              (syntax-id (cdr (assq (intern (downcase name))
 874                                    ldap-attribute-syntaxes-alist)))
 875              decoder)
 876         (if syntax-id
 877             (setq decoder (aref ldap-attribute-syntax-decoders
 878                                 (1- syntax-id)))
 879           (setq decoder ldap-default-attribute-decoder))
 880         (if decoder
 881             (cons name (mapcar decoder values))
 882           attr))
 883     attr))
 884
 885 (defun ldap-search (arg1 &rest args)
 886   "Perform an LDAP search.if ARG1 is LDAP object, invoke `ldap-search-basic'.
 887 Otherwise, invoke `ldap-search-entries'.  ARGS are passed to each function."
 888       (apply (if (ldapp arg1)
 889                  'ldap-search-basic
 890                'ldap-search-entries) arg1 args))
 891
 892 (make-obsolete 'ldap-search
 893                "Use `ldap-search-entries' instead or
 894 `ldap-search-basic' for the low-level search API.")
 895
 896 (defun ldap-search-entries (filter &optional host attributes attrsonly withdn)
 897   "Perform an LDAP search.
 898 FILTER is the search filter in RFC1558 syntax, i.e., something that
 899 looks like \"(cn=John Smith)\".
 900 HOST is the LDAP host on which to perform the search.
 901 ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all.
 902 If ATTRSONLY is non nil, the attributes will be retrieved without
 903 the associated values.
 904 If WITHDN is non-nil each entry in the result will be prepennded with
 905 its distinguished name DN.
 906 Additional search parameters can be specified through
 907 `ldap-host-parameters-alist' which see.
 908 The function returns a list of matching entries.  Each entry is itself
 909 an alist of attribute/value pairs optionally preceded by the DN of the
 910 entry according to the value of WITHDN."
 911   (interactive "sFilter:")
 912   (or host
 913       (setq host ldap-default-host)
 914       (error "No LDAP host specified"))
 915   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 916         ldap
 917         result)
 918     (if ldap-verbose
 919         (message "Opening LDAP connection to %s..." host))
 920     (setq ldap (ldap-open host host-plist))
 921     (if ldap-verbose
 922         (message "Searching with LDAP on %s..." host))
 923     (setq result (ldap-search ldap (ldap-encode-string filter)
 924                               (plist-get host-plist 'base)
 925                               (plist-get host-plist 'scope)
 926                               attributes attrsonly withdn
 927                               ldap-verbose))
 928     (ldap-close ldap)
 929     (with-temp-buffer
 930       (set-buffer-multibyte nil)
 931       (if ldap-ignore-attribute-codings
 932           result
 933         (mapcar
 934          (lambda (record)
 935            (mapcar 'ldap-decode-attribute record))
 936          result)))))
 937
 938 (defun ldap-add-entries (entries &optional host binddn passwd)
 939   "Add entries to an LDAP directory.
 940 ENTRIES is a list of entry specifications of
 941 the form (DN (ATTR . VALUE) (ATTR . VALUE) ...) where
 942 DN is the distinguished name of an entry to add, the following
 943 are cons cells containing attribute/value string pairs.
 944 HOST is the LDAP host, defaulting to `ldap-default-host'
 945 BINDDN is the DN to bind as to the server
 946 PASSWD is the corresponding password"
 947   (or host
 948       (setq host ldap-default-host)
 949       (error "No LDAP host specified"))
 950   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 951         ldap
 952         (i 1))
 953     (if (or binddn passwd)
 954         (setq host-plist (copy-seq host-plist)))
 955     (if binddn
 956         (setq host-plist (plist-put host-plist 'binddn binddn)))
 957     (if passwd
 958         (setq host-plist (plist-put host-plist 'passwd passwd)))
 959     (if ldap-verbose
 960         (message "Opening LDAP connection to %s..." host))
 961     (setq ldap (ldap-open host host-plist))
 962     (if ldap-verbose
 963         (message "Adding LDAP entries..."))
 964     (mapc (lambda (thisentry)
 965             (setcdr thisentry
 966                     (mapcar
 967                      (lambda (add-spec)
 968                        (setq add-spec (ldap-encode-attribute
 969                                        (list (car add-spec)
 970                                              (cdr add-spec))))
 971                        (cons (nth 0 add-spec)
 972                              (nth 1 add-spec)))
 973                      (cdr thisentry)))
 974             (setq thisentry (ldap-encode-attribute thisentry))
 975             (ldap-add ldap (car thisentry) (cdr thisentry))
 976             (if ldap-verbose
 977                 (message "%d added" i))
 978             (setq i (1+ i)))
 979           entries)
 980     (ldap-close ldap)))
 981
 982 (defun ldap-modify-entries (entry-mods &optional host binddn passwd)
 983   "Modify entries of an LDAP directory.
 984 ENTRY-MODS is a list of entry modifications of the form
 985   \(DN MOD-SPEC1 MOD-SPEC2 ...\) where DN is the distinguished name of
 986 the entry to modify, the following are modification specifications.
 987 A modification specification is itself a list of the form
 988 \(MOD-OP ATTR VALUE1 VALUE2 ...\) MOD-OP and ATTR are mandatory,
 989 VALUEs are optional depending on MOD-OP.
 990 MOD-OP is the type of modification, one of the symbols `add', `delete'
 991 or `replace'.  ATTR is the LDAP attribute type to modify.
 992 HOST is the LDAP host, defaulting to `ldap-default-host'
 993 BINDDN is the DN to bind as to the server
 994 PASSWD is the corresponding password"
 995   (or host
 996       (setq host ldap-default-host)
 997       (error "No LDAP host specified"))
 998   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
 999         ldap
1000         (i 1))
1001     (if (or binddn passwd)
1002         (setq host-plist (copy-seq host-plist)))
1003     (if binddn
1004         (setq host-plist (plist-put host-plist 'binddn binddn)))
1005     (if passwd
1006         (setq host-plist (plist-put host-plist 'passwd passwd)))
1007     (if ldap-verbose
1008         (message "Opening LDAP connection to %s..." host))
1009     (setq ldap (ldap-open host host-plist))
1010     (if ldap-verbose
1011         (message "Modifying LDAP entries..."))
1012     (mapc
1013      (lambda (thisentry)
1014        (setcdr thisentry
1015                (mapcar
1016                 (lambda (mod-spec)
1017                   (if (or (eq (car mod-spec) 'add)
1018                           (eq (car mod-spec) 'replace))
1019                       (append (list (nth 0 mod-spec))
1020                               (ldap-encode-attribute
1021                                (cdr mod-spec)))))
1022                 (cdr thisentry)))
1023        (ldap-modify ldap (car thisentry) (cdr thisentry))
1024        (if ldap-verbose
1025            (message "%d modified" i))
1026        (setq i (1+ i)))
1027      entry-mods)
1028     (ldap-close ldap)))
1029
1030 (defun ldap-delete-entries (dn &optional host binddn passwd)
1031   "Delete an entry from an LDAP directory.
1032 DN is the distinguished name of an entry to delete or
1033 a list of those.
1034 HOST is the LDAP host, defaulting to `ldap-default-host'
1035 BINDDN is the DN to bind as to the server
1036 PASSWD is the corresponding password."
1037   (or host
1038       (setq host ldap-default-host)
1039       (error "No LDAP host specified"))
1040   (let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
1041         ldap)
1042     (if (or binddn passwd)
1043         (setq host-plist (copy-seq host-plist)))
1044     (if binddn
1045         (setq host-plist (plist-put host-plist 'binddn binddn)))
1046     (if passwd
1047         (setq host-plist (plist-put host-plist 'passwd passwd)))
1048     (if ldap-verbose
1049         (message "Opening LDAP connection to %s..." host))
1050     (setq ldap (ldap-open host host-plist))
1051     (if (consp dn)
1052         (let ((i 1))
1053           (if ldap-verbose
1054               (message "Deleting LDAP entries..."))
1055           (mapc
1056            (lambda (thisdn)
1057              (ldap-delete ldap thisdn)
1058              (if ldap-verbose
1059                  (message "%d deleted" i))
1060              (setq i (1+ i)))
1061            dn))
1062       (if ldap-verbose
1063           (message "Deleting LDAP entry..."))
1064       (ldap-delete ldap dn))
1065     (ldap-close ldap)))
1066 ;; end of ldap-static-if
1067 )
1068
1069 (provide 'pldap)
1070
1071 ;;; pldap.el ends here