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