/[emacs]/emacs/lisp/net/eudcb-ldap.el
ViewVC logotype

Diff of /emacs/lisp/net/eudcb-ldap.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pj, Sat Jan 5 23:36:20 2002 UTC revision 1.3 by pj, Sun Jan 6 15:07:49 2002 UTC
# Line 24  Line 24 
24  ;; Boston, MA 02111-1307, USA.  ;; Boston, MA 02111-1307, USA.
25    
26  ;;; Commentary:  ;;; Commentary:
27  ;;    This library provides specific LDAP protocol support for the  ;;    This library provides specific LDAP protocol support for the
28  ;;    Emacs Unified Directory Client package  ;;    Emacs Unified Directory Client package
29    
30  ;;; Installation:  ;;; Installation:
# Line 53  Line 53 
53      (phone . telephonenumber))      (phone . telephonenumber))
54    "Alist mapping EUDC attribute names to LDAP names.")    "Alist mapping EUDC attribute names to LDAP names.")
55    
56  (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal  (eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal
57                     'ldap)                     'ldap)
58  (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list  (eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list
59                     'ldap)                     'ldap)
60  (eudc-protocol-set 'eudc-protocol-attributes-translation-alist  (eudc-protocol-set 'eudc-protocol-attributes-translation-alist
61                     'eudc-ldap-attributes-translation-alist 'ldap)                     'eudc-ldap-attributes-translation-alist 'ldap)
62  (eudc-protocol-set 'eudc-bbdb-conversion-alist  (eudc-protocol-set 'eudc-bbdb-conversion-alist
63                     'eudc-ldap-bbdb-conversion-alist                     'eudc-ldap-bbdb-conversion-alist
64                     'ldap)                     'ldap)
65  (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)  (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)
66  (eudc-protocol-set 'eudc-attribute-display-method-alist  (eudc-protocol-set 'eudc-attribute-display-method-alist
67                     '(("jpegphoto" . eudc-display-jpeg-inline)                     '(("jpegphoto" . eudc-display-jpeg-inline)
68                       ("labeledurl" . eudc-display-url)                       ("labeledurl" . eudc-display-url)
69                       ("audio" . eudc-display-sound)                       ("audio" . eudc-display-sound)
70                       ("labeleduri" . eudc-display-url)                       ("labeleduri" . eudc-display-url)
71                       ("url" . eudc-display-url))                       ("url" . eudc-display-url))
72                     'ldap)                     'ldap)
73  (eudc-protocol-set 'eudc-switch-to-server-hook  (eudc-protocol-set 'eudc-switch-to-server-hook
74                     '(eudc-ldap-check-base)                     '(eudc-ldap-check-base)
75                     'ldap)                     'ldap)
76    
77  (defun eudc-ldap-cleanup-record-simple (record)  (defun eudc-ldap-cleanup-record-simple (record)
78    "Do some cleanup in a RECORD to make it suitable for EUDC."    "Do some cleanup in a RECORD to make it suitable for EUDC."
79    (mapcar    (mapcar
80     (function     (function
81      (lambda (field)      (lambda (field)
82        (cons (intern (car field))        (cons (intern (car field))
83              (if (cdr (cdr field))              (if (cdr (cdr field))
# Line 92  Line 92 
92  ;;   Make the record a cons-cell instead of a list if the it's single-valued  ;;   Make the record a cons-cell instead of a list if the it's single-valued
93  ;;   Filter the $ character in addresses into \n if not done by the LDAP lib  ;;   Filter the $ character in addresses into \n if not done by the LDAP lib
94  (defun eudc-ldap-cleanup-record-filtering-addresses (record)  (defun eudc-ldap-cleanup-record-filtering-addresses (record)
95    (mapcar    (mapcar
96     (function     (function
97      (lambda (field)      (lambda (field)
98        (let ((name (intern (car field)))        (let ((name (intern (car field)))
99              (value (cdr field)))              (value (cdr field)))
# Line 107  Line 107 
107    
108  (defun eudc-ldap-simple-query-internal (query &optional return-attrs)  (defun eudc-ldap-simple-query-internal (query &optional return-attrs)
109    "Query the LDAP server with QUERY.    "Query the LDAP server with QUERY.
110  QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid  QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
111  LDAP attribute names.    LDAP attribute names.
112  RETURN-ATTRS is a list of attributes to return, defaulting to  RETURN-ATTRS is a list of attributes to return, defaulting to
113  `eudc-default-return-attributes'."  `eudc-default-return-attributes'."
114    (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)    (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
115                               eudc-server                               eudc-server
# Line 118  RETURN-ATTRS is a list of attributes to Line 118  RETURN-ATTRS is a list of attributes to
118          final-result)          final-result)
119      (if (or (not (boundp 'ldap-ignore-attribute-codings))      (if (or (not (boundp 'ldap-ignore-attribute-codings))
120              ldap-ignore-attribute-codings)              ldap-ignore-attribute-codings)
121          (setq result          (setq result
122                (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))                (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))
123        (setq result (mapcar 'eudc-ldap-cleanup-record-simple result)))        (setq result (mapcar 'eudc-ldap-cleanup-record-simple result)))
124    
# Line 128  RETURN-ATTRS is a list of attributes to Line 128  RETURN-ATTRS is a list of attributes to
128          (setq result (eudc-filter-partial-records result return-attrs)))          (setq result (eudc-filter-partial-records result return-attrs)))
129      ;; Apply eudc-duplicate-attribute-handling-method      ;; Apply eudc-duplicate-attribute-handling-method
130      (if (not (eq 'list eudc-duplicate-attribute-handling-method))      (if (not (eq 'list eudc-duplicate-attribute-handling-method))
131          (mapcar          (mapcar
132           (function (lambda (record)           (function (lambda (record)
133                       (setq final-result                       (setq final-result
134                             (append (eudc-filter-duplicate-attributes record)                             (append (eudc-filter-duplicate-attributes record)
135                                     final-result))))                                     final-result))))
136           result))           result))
# Line 143  attribute names are returned. Default to Line 143  attribute names are returned. Default to
143    (interactive)    (interactive)
144    (or eudc-server    (or eudc-server
145        (call-interactively 'eudc-set-server))        (call-interactively 'eudc-set-server))
146    (let ((ldap-host-parameters-alist    (let ((ldap-host-parameters-alist
147           (list (cons eudc-server           (list (cons eudc-server
148                       '(scope subtree sizelimit 1)))))                       '(scope subtree sizelimit 1)))))
149      (mapcar 'eudc-ldap-cleanup-record      (mapcar 'eudc-ldap-cleanup-record
150              (ldap-search              (ldap-search
151               (eudc-ldap-format-query-as-rfc1558               (eudc-ldap-format-query-as-rfc1558
152                (list (cons "objectclass"                (list (cons "objectclass"
153                            (or objectclass                            (or objectclass
154                                "person"))))                                "person"))))
# Line 156  attribute names are returned. Default to Line 156  attribute names are returned. Default to
156    
157  (defun eudc-ldap-escape-query-special-chars (string)  (defun eudc-ldap-escape-query-special-chars (string)
158    "Value is STRING with characters forbidden in LDAP queries escaped."    "Value is STRING with characters forbidden in LDAP queries escaped."
159  ;; Note that * should also be escaped but in most situations I suppose  ;; Note that * should also be escaped but in most situations I suppose
160  ;; the user doesn't want this  ;; the user doesn't want this
161    (eudc-replace-in-string    (eudc-replace-in-string
162     (eudc-replace-in-string     (eudc-replace-in-string
163      (eudc-replace-in-string      (eudc-replace-in-string
164        (eudc-replace-in-string        (eudc-replace-in-string
165         string         string
166         "\\\\" "\\5c")         "\\\\" "\\5c")
167        "(" "\\28")        "(" "\\28")
168       ")" "\\29")       ")" "\\29")
# Line 170  attribute names are returned. Default to Line 170  attribute names are returned. Default to
170    
171  (defun eudc-ldap-format-query-as-rfc1558 (query)  (defun eudc-ldap-format-query-as-rfc1558 (query)
172    "Format the EUDC QUERY list as a RFC1558 LDAP search filter."    "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
173    (format "(&%s)"    (format "(&%s)"
174            (apply 'concat            (apply 'concat
175                   (mapcar '(lambda (item)                   (mapcar '(lambda (item)
176                              (format "(%s=%s)"                              (format "(%s=%s)"
177                                      (car item)                                      (car item)
178                                      (eudc-ldap-escape-query-special-chars (cdr item))))                                      (eudc-ldap-escape-query-special-chars (cdr item))))
179                           query))))                           query))))
180    
181    
182  ;;}}}          ;;}}}
183    
184  ;;{{{      High-level interfaces (interactive functions)  ;;{{{      High-level interfaces (interactive functions)
185    
# Line 196  attribute names are returned. Default to Line 196  attribute names are returned. Default to
196      ;; If the server is not in ldap-host-parameters-alist we add it for the      ;; If the server is not in ldap-host-parameters-alist we add it for the
197      ;; user      ;; user
198      (if (null (assoc eudc-server ldap-host-parameters-alist))      (if (null (assoc eudc-server ldap-host-parameters-alist))
199          (setq ldap-host-parameters-alist          (setq ldap-host-parameters-alist
200                (cons (list eudc-server) ldap-host-parameters-alist)))                (cons (list eudc-server) ldap-host-parameters-alist)))
201      (customize-variable 'ldap-host-parameters-alist)))      (customize-variable 'ldap-host-parameters-alist)))
202    
203  ;;;}}}  ;;}}}
204    
205    
206  (eudc-register-protocol 'ldap)  (eudc-register-protocol 'ldap)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26