1;;; eudc.el --- Emacs Unified Directory Client 2 3;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Oscar Figueiredo <oscar@cpe.fr> 7;; Maintainer: Pavel Jan�k <Pavel@Janik.cz> 8;; Keywords: comm 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28;; This package provides a common interface to query directory servers using 29;; different protocols such as LDAP, CCSO PH/QI or BBDB. Queries can be 30;; made through an interactive form or inline. Inline query strings in 31;; buffers are expanded with appropriately formatted query results 32;; (especially used to expand email addresses in message buffers). EUDC 33;; also interfaces with the BBDB package to let you register query results 34;; into your own BBDB database. 35 36;;; Usage: 37;; EUDC comes with an extensive documentation, please refer to it. 38;; 39;; The main entry points of EUDC are: 40;; `eudc-query-form': Query a directory server from a query form 41;; `eudc-expand-inline': Query a directory server for the e-mail address 42;; of the name before cursor and insert it in the 43;; buffer 44;; `eudc-get-phone': Get a phone number from a directory server 45;; `eudc-get-email': Get an e-mail address from a directory server 46;; `eudc-customize': Customize various aspects of EUDC 47 48;;; Code: 49 50(require 'wid-edit) 51 52(eval-and-compile 53 (if (not (fboundp 'make-overlay)) 54 (require 'overlay)) 55 (if (not (fboundp 'unless)) 56 (require 'cl))) 57 58(unless (fboundp 'custom-menu-create) 59 (autoload 'custom-menu-create "cus-edit")) 60 61(require 'eudc-vars) 62 63 64 65;;{{{ Internal cooking 66 67;;{{{ Internal variables and compatibility tricks 68 69(defconst eudc-xemacs-p (string-match "XEmacs" emacs-version)) 70(defconst eudc-emacs-p (not eudc-xemacs-p)) 71(defconst eudc-xemacs-mule-p (and eudc-xemacs-p 72 (featurep 'mule))) 73(defconst eudc-emacs-mule-p (and eudc-emacs-p 74 (featurep 'mule))) 75 76(defvar eudc-form-widget-list nil) 77(defvar eudc-mode-map nil) 78 79(defvar mode-popup-menu) 80 81;; List of known servers 82;; Alist of (SERVER . PROTOCOL) 83(defvar eudc-server-hotlist nil) 84 85;; List of variables that have server- or protocol-local bindings 86(defvar eudc-local-vars nil) 87 88;; Protocol local. Query function 89(defvar eudc-query-function nil) 90 91;; Protocol local. A function that retrieves a list of valid attribute names 92(defvar eudc-list-attributes-function nil) 93 94;; Protocol local. A mapping between EUDC attribute names and corresponding 95;; protocol specific names. The following names are defined by EUDC and may be 96;; included in that list: `name' , `firstname', `email', `phone' 97(defvar eudc-protocol-attributes-translation-alist nil) 98 99;; Protocol local. Mapping between protocol attribute names and BBDB field 100;; names 101(defvar eudc-bbdb-conversion-alist nil) 102 103;; Protocol/Server local. Hook called upon switching to that server 104(defvar eudc-switch-to-server-hook nil) 105 106;; Protocol/Server local. Hook called upon switching from that server 107(defvar eudc-switch-from-server-hook nil) 108 109;; Protocol local. Whether the protocol supports queries with no specified 110;; attribute name 111(defvar eudc-protocol-has-default-query-attributes nil) 112 113(defun eudc-cadr (obj) 114 (car (cdr obj))) 115 116(defun eudc-cdar (obj) 117 (cdr (car obj))) 118 119(defun eudc-caar (obj) 120 (car (car obj))) 121 122(defun eudc-cdaar (obj) 123 (cdr (car (car obj)))) 124 125(defun eudc-plist-member (plist prop) 126 "Return t if PROP has a value specified in PLIST." 127 (if (not (= 0 (% (length plist) 2))) 128 (error "Malformed plist")) 129 (catch 'found 130 (while plist 131 (if (eq prop (car plist)) 132 (throw 'found t)) 133 (setq plist (cdr (cdr plist)))) 134 nil)) 135 136;; Emacs' plist-get lacks third parameter 137(defun eudc-plist-get (plist prop &optional default) 138 "Extract a value from a property list. 139PLIST is a property list, which is a list of the form 140\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value 141corresponding to the given PROP, or DEFAULT if PROP is not 142one of the properties on the list." 143 (if (eudc-plist-member plist prop) 144 (plist-get plist prop) 145 default)) 146 147(defun eudc-lax-plist-get (plist prop &optional default) 148 "Extract a value from a lax property list. 149 150PLIST is a lax property list, which is a list of the form (PROP1 151VALUE1 PROP2 VALUE2...), where comparisons between properties are done 152using `equal' instead of `eq'. This function returns the value 153corresponding to PROP, or DEFAULT if PROP is not one of the 154properties on the list." 155 (if (not (= 0 (% (length plist) 2))) 156 (error "Malformed plist")) 157 (catch 'found 158 (while plist 159 (if (equal prop (car plist)) 160 (throw 'found (car (cdr plist)))) 161 (setq plist (cdr (cdr plist)))) 162 default)) 163 164(if (not (fboundp 'split-string)) 165 (defun split-string (string &optional pattern) 166 "Return a list of substrings of STRING which are separated by PATTERN. 167If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." 168 (or pattern 169 (setq pattern "[ \f\t\n\r\v]+")) 170 (let (parts (start 0)) 171 (when (string-match pattern string 0) 172 (if (> (match-beginning 0) 0) 173 (setq parts (cons (substring string 0 (match-beginning 0)) nil))) 174 (setq start (match-end 0)) 175 (while (and (string-match pattern string start) 176 (> (match-end 0) start)) 177 (setq parts (cons (substring string start (match-beginning 0)) parts) 178 start (match-end 0)))) 179 (nreverse (if (< start (length string)) 180 (cons (substring string start) parts) 181 parts))))) 182 183(defun eudc-replace-in-string (str regexp newtext) 184 "Replace all matches in STR for REGEXP with NEWTEXT. 185Value is the new string." 186 (let ((rtn-str "") 187 (start 0) 188 match prev-start) 189 (while (setq match (string-match regexp str start)) 190 (setq prev-start start 191 start (match-end 0) 192 rtn-str 193 (concat rtn-str 194 (substring str prev-start match) 195 newtext))) 196 (concat rtn-str (substring str start)))) 197 198;;}}} 199 200;;{{{ Server and Protocol Variable Routines 201 202(defun eudc-server-local-variable-p (var) 203 "Return non-nil if VAR has server-local bindings." 204 (eudc-plist-member (get var 'eudc-locals) 'server)) 205 206(defun eudc-protocol-local-variable-p (var) 207 "Return non-nil if VAR has protocol-local bindings." 208 (eudc-plist-member (get var 'eudc-locals) 'protocol)) 209 210(defun eudc-default-set (var val) 211 "Set the EUDC default value of VAR to VAL. 212The current binding of VAR is not changed." 213 (put var 'eudc-locals 214 (plist-put (get var 'eudc-locals) 'default val)) 215 (add-to-list 'eudc-local-vars var)) 216 217(defun eudc-protocol-set (var val &optional protocol) 218 "Set the PROTOCOL-local binding of VAR to VAL. 219If omitted PROTOCOL defaults to the current value of `eudc-protocol'. 220The current binding of VAR is changed only if PROTOCOL is omitted." 221 (if (eq 'unbound (eudc-variable-default-value var)) 222 (eudc-default-set var (symbol-value var))) 223 (let* ((eudc-locals (get var 'eudc-locals)) 224 (protocol-locals (eudc-plist-get eudc-locals 'protocol))) 225 (setq protocol-locals (plist-put protocol-locals (or protocol 226 eudc-protocol) val)) 227 (setq eudc-locals 228 (plist-put eudc-locals 'protocol protocol-locals)) 229 (put var 'eudc-locals eudc-locals) 230 (add-to-list 'eudc-local-vars var) 231 (unless protocol 232 (eudc-update-variable var)))) 233 234(defun eudc-server-set (var val &optional server) 235 "Set the SERVER-local binding of VAR to VAL. 236If omitted SERVER defaults to the current value of `eudc-server'. 237The current binding of VAR is changed only if SERVER is omitted." 238 (if (eq 'unbound (eudc-variable-default-value var)) 239 (eudc-default-set var (symbol-value var))) 240 (let* ((eudc-locals (get var 'eudc-locals)) 241 (server-locals (eudc-plist-get eudc-locals 'server))) 242 (setq server-locals (plist-put server-locals (or server 243 eudc-server) val)) 244 (setq eudc-locals 245 (plist-put eudc-locals 'server server-locals)) 246 (put var 'eudc-locals eudc-locals) 247 (add-to-list 'eudc-local-vars var) 248 (unless server 249 (eudc-update-variable var)))) 250 251 252(defun eudc-set (var val) 253 "Set the most local (server, protocol or default) binding of VAR to VAL. 254The current binding of VAR is also set to VAL" 255 (cond 256 ((not (eq 'unbound (eudc-variable-server-value var))) 257 (eudc-server-set var val)) 258 ((not (eq 'unbound (eudc-variable-protocol-value var))) 259 (eudc-protocol-set var val)) 260 (t 261 (eudc-default-set var val))) 262 (set var val)) 263 264(defun eudc-variable-default-value (var) 265 "Return the default binding of VAR. 266Return `unbound' if VAR has no EUDC default value." 267 (let ((eudc-locals (get var 'eudc-locals))) 268 (if (and (boundp var) 269 eudc-locals) 270 (eudc-plist-get eudc-locals 'default 'unbound) 271 'unbound))) 272 273(defun eudc-variable-protocol-value (var &optional protocol) 274 "Return the value of VAR local to PROTOCOL. 275Return `unbound' if VAR has no value local to PROTOCOL. 276PROTOCOL defaults to `eudc-protocol'" 277 (let* ((eudc-locals (get var 'eudc-locals)) 278 protocol-locals) 279 (if (not (and (boundp var) 280 eudc-locals 281 (eudc-plist-member eudc-locals 'protocol))) 282 'unbound 283 (setq protocol-locals (eudc-plist-get eudc-locals 'protocol)) 284 (eudc-lax-plist-get protocol-locals 285 (or protocol 286 eudc-protocol) 'unbound)))) 287 288(defun eudc-variable-server-value (var &optional server) 289 "Return the value of VAR local to SERVER. 290Return `unbound' if VAR has no value local to SERVER. 291SERVER defaults to `eudc-server'" 292 (let* ((eudc-locals (get var 'eudc-locals)) 293 server-locals) 294 (if (not (and (boundp var) 295 eudc-locals 296 (eudc-plist-member eudc-locals 'server))) 297 'unbound 298 (setq server-locals (eudc-plist-get eudc-locals 'server)) 299 (eudc-lax-plist-get server-locals 300 (or server 301 eudc-server) 'unbound)))) 302 303(defun eudc-update-variable (var) 304 "Set the value of VAR according to its locals. 305If the VAR has a server- or protocol-local value corresponding 306to the current `eudc-server' and `eudc-protocol' then it is set 307accordingly. Otherwise it is set to its EUDC default binding" 308 (let (val) 309 (cond 310 ((not (eq 'unbound (setq val (eudc-variable-server-value var)))) 311 (set var val)) 312 ((not (eq 'unbound (setq val (eudc-variable-protocol-value var)))) 313 (set var val)) 314 ((not (eq 'unbound (setq val (eudc-variable-default-value var)))) 315 (set var val))))) 316 317(defun eudc-update-local-variables () 318 "Update all EUDC variables according to their local settings." 319 (interactive) 320 (mapcar 'eudc-update-variable eudc-local-vars)) 321 322(eudc-default-set 'eudc-query-function nil) 323(eudc-default-set 'eudc-list-attributes-function nil) 324(eudc-default-set 'eudc-protocol-attributes-translation-alist nil) 325(eudc-default-set 'eudc-bbdb-conversion-alist nil) 326(eudc-default-set 'eudc-switch-to-server-hook nil) 327(eudc-default-set 'eudc-switch-from-server-hook nil) 328(eudc-default-set 'eudc-protocol-has-default-query-attributes nil) 329(eudc-default-set 'eudc-attribute-display-method-alist nil) 330 331;;}}} 332 333 334;; Add PROTOCOL to the list of supported protocols 335(defun eudc-register-protocol (protocol) 336 (unless (memq protocol eudc-supported-protocols) 337 (setq eudc-supported-protocols 338 (cons protocol eudc-supported-protocols)) 339 (put 'eudc-protocol 'custom-type 340 `(choice :menu-tag "Protocol" 341 ,@(mapcar (lambda (s) 342 (list 'string ':tag (symbol-name s))) 343 eudc-supported-protocols)))) 344 (or (memq protocol eudc-known-protocols) 345 (setq eudc-known-protocols 346 (cons protocol eudc-known-protocols)))) 347 348 349(defun eudc-translate-query (query) 350 "Translate attribute names of QUERY. 351The translation is done according to 352`eudc-protocol-attributes-translation-alist'." 353 (if eudc-protocol-attributes-translation-alist 354 (mapcar '(lambda (attribute) 355 (let ((trans (assq (car attribute) 356 (symbol-value eudc-protocol-attributes-translation-alist)))) 357 (if trans 358 (cons (cdr trans) (cdr attribute)) 359 attribute))) 360 query) 361 query)) 362 363(defun eudc-translate-attribute-list (list) 364 "Translate a list of attribute names LIST. 365The translation is done according to 366`eudc-protocol-attributes-translation-alist'." 367 (if eudc-protocol-attributes-translation-alist 368 (let (trans) 369 (mapcar '(lambda (attribute) 370 (setq trans (assq attribute 371 (symbol-value eudc-protocol-attributes-translation-alist))) 372 (if trans 373 (cdr trans) 374 attribute)) 375 list)) 376 list)) 377 378(defun eudc-select (choices beg end) 379 "Choose one from CHOICES using a completion. 380BEG and END delimit the text which is to be replaced." 381 (let ((replacement)) 382 (setq replacement 383 (completing-read "Multiple matches found; choose one: " 384 (mapcar 'list choices))) 385 (delete-region beg end) 386 (insert replacement))) 387 388(defun eudc-query (query &optional return-attributes no-translation) 389 "Query the current directory server with QUERY. 390QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute 391name and VALUE the corresponding value. 392If NO-TRANSLATION is non-nil, ATTR is translated according to 393`eudc-protocol-attributes-translation-alist'. 394RETURN-ATTRIBUTES is a list of attributes to return defaulting to 395`eudc-default-return-attributes'." 396 (unless eudc-query-function 397 (error "Don't know how to perform the query")) 398 (if no-translation 399 (funcall eudc-query-function query (or return-attributes 400 eudc-default-return-attributes)) 401 402 (funcall eudc-query-function 403 (eudc-translate-query query) 404 (cond 405 (return-attributes 406 (eudc-translate-attribute-list return-attributes)) 407 ((listp eudc-default-return-attributes) 408 (eudc-translate-attribute-list eudc-default-return-attributes)) 409 (t 410 eudc-default-return-attributes))))) 411 412(defun eudc-format-attribute-name-for-display (attribute) 413 "Format a directory attribute name for display. 414ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced 415by the corresponding user name if any. Otherwise it is capitalized and 416underscore characters are replaced by spaces." 417 (let ((match (assq attribute eudc-user-attribute-names-alist))) 418 (if match 419 (cdr match) 420 (capitalize 421 (mapconcat 'identity 422 (split-string (symbol-name attribute) "_") 423 " "))))) 424 425(defun eudc-print-attribute-value (field) 426 "Insert the value of the directory FIELD at point. 427The directory attribute name in car of FIELD is looked up in 428`eudc-attribute-display-method-alist' and the corresponding method, 429if any, is called to print the value in cdr of FIELD." 430 (let ((match (assoc (downcase (car field)) 431 eudc-attribute-display-method-alist)) 432 (col (current-column)) 433 (val (cdr field))) 434 (if match 435 (progn 436 (eval (list (cdr match) val)) 437 (insert "\n")) 438 (mapcar 439 (function 440 (lambda (val-elem) 441 (indent-to col) 442 (insert val-elem "\n"))) 443 (cond 444 ((listp val) val) 445 ((stringp val) (split-string val "\n")) 446 ((null val) '("")) 447 (t (list val))))))) 448 449(defun eudc-print-record-field (field column-width) 450 "Print the record field FIELD. 451FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL) 452COLUMN-WIDTH is the width of the first display column containing the 453attribute name ATTR." 454 (let ((field-beg (point))) 455;; The record field that is passed to this function has already been processed 456;; by `eudc-format-attribute-name-for-display' so we don't need to call it 457;; again to display the attribute name 458 (insert (format (concat "%" (int-to-string column-width) "s: ") 459 (car field))) 460 (put-text-property field-beg (point) 'face 'bold) 461 (indent-to (+ 2 column-width)) 462 (eudc-print-attribute-value field))) 463 464(defun eudc-display-records (records &optional raw-attr-names) 465 "Display the record list RECORDS in a formatted buffer. 466If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed 467otherwise they are formatted according to `eudc-user-attribute-names-alist'." 468 (let (inhibit-read-only 469 precords 470 (width 0) 471 beg 472 first-record 473 attribute-name) 474 (with-output-to-temp-buffer "*Directory Query Results*" 475 (with-current-buffer standard-output 476 (setq buffer-read-only t) 477 (setq inhibit-read-only t) 478 (erase-buffer) 479 (insert "Directory Query Result\n") 480 (insert "======================\n\n\n") 481 (if (null records) 482 (insert "No match found.\n" 483 (if eudc-strict-return-matches 484 "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n" 485 "")) 486 ;; Replace field names with user names, compute max width 487 (setq precords 488 (mapcar 489 (function 490 (lambda (record) 491 (mapcar 492 (function 493 (lambda (field) 494 (setq attribute-name 495 (if raw-attr-names 496 (symbol-name (car field)) 497 (eudc-format-attribute-name-for-display (car field)))) 498 (if (> (length attribute-name) width) 499 (setq width (length attribute-name))) 500 (cons attribute-name (cdr field)))) 501 record))) 502 records)) 503 ;; Display the records 504 (setq first-record (point)) 505 (mapcar 506 (function 507 (lambda (record) 508 (setq beg (point)) 509 ;; Map over the record fields to print the attribute/value pairs 510 (mapcar (function 511 (lambda (field) 512 (eudc-print-record-field field width))) 513 record) 514 ;; Store the record internal format in some convenient place 515 (overlay-put (make-overlay beg (point)) 516 'eudc-record 517 (car records)) 518 (setq records (cdr records)) 519 (insert "\n"))) 520 precords)) 521 (insert "\n") 522 (widget-create 'push-button 523 :notify (lambda (&rest ignore) 524 (eudc-query-form)) 525 "New query") 526 (widget-insert " ") 527 (widget-create 'push-button 528 :notify (lambda (&rest ignore) 529 (kill-this-buffer)) 530 "Quit") 531 (eudc-mode) 532 (widget-setup) 533 (if first-record 534 (goto-char first-record)))))) 535 536(defun eudc-process-form () 537 "Process the query form in current buffer and display the results." 538 (let (query-alist 539 value) 540 (if (not (and (boundp 'eudc-form-widget-list) 541 eudc-form-widget-list)) 542 (error "Not in a directory query form buffer") 543 (mapcar (function 544 (lambda (wid-field) 545 (setq value (widget-value (cdr wid-field))) 546 (if (not (string= value "")) 547 (setq query-alist (cons (cons (car wid-field) value) 548 query-alist))))) 549 eudc-form-widget-list) 550 (kill-buffer (current-buffer)) 551 (eudc-display-records (eudc-query query-alist) eudc-use-raw-directory-names)))) 552 553 554(defun eudc-filter-duplicate-attributes (record) 555 "Filter RECORD according to `eudc-duplicate-attribute-handling-method'." 556 (let ((rec record) 557 unique 558 duplicates 559 result) 560 561 ;; Search for multiple records 562 (while (and rec 563 (not (listp (eudc-cdar rec)))) 564 (setq rec (cdr rec))) 565 566 (if (null (eudc-cdar rec)) 567 (list record) ; No duplicate attrs in this record 568 (mapcar (function 569 (lambda (field) 570 (if (listp (cdr field)) 571 (setq duplicates (cons field duplicates)) 572 (setq unique (cons field unique))))) 573 record) 574 (setq result (list unique)) 575 ;; Map over the record fields that have multiple values 576 (mapcar 577 (function 578 (lambda (field) 579 (let ((method (if (consp eudc-duplicate-attribute-handling-method) 580 (cdr 581 (assq 582 (or 583 (car 584 (rassq 585 (car field) 586 (symbol-value 587 eudc-protocol-attributes-translation-alist))) 588 (car field)) 589 eudc-duplicate-attribute-handling-method)) 590 eudc-duplicate-attribute-handling-method))) 591 (cond 592 ((or (null method) (eq 'list method)) 593 (setq result 594 (eudc-add-field-to-records field result))) 595 ((eq 'first method) 596 (setq result 597 (eudc-add-field-to-records (cons (car field) 598 (eudc-cadr field)) 599 result))) 600 ((eq 'concat method) 601 (setq result 602 (eudc-add-field-to-records (cons (car field) 603 (mapconcat 604 'identity 605 (cdr field) 606 "\n")) result))) 607 ((eq 'duplicate method) 608 (setq result 609 (eudc-distribute-field-on-records field result))))))) 610 duplicates) 611 result))) 612 613(defun eudc-filter-partial-records (records attrs) 614 "Eliminate records that do not contain all ATTRS from RECORDS." 615 (delq nil 616 (mapcar 617 (function 618 (lambda (rec) 619 (if (eval (cons 'and 620 (mapcar 621 (function 622 (lambda (attr) 623 (consp (assq attr rec)))) 624 attrs))) 625 rec))) 626 records))) 627 628(defun eudc-add-field-to-records (field records) 629 "Add FIELD to each individual record in RECORDS and return the resulting list." 630 (mapcar (function 631 (lambda (r) 632 (cons field r))) 633 records)) 634 635(defun eudc-distribute-field-on-records (field records) 636 "Duplicate each individual record in RECORDS according to value of FIELD. 637Each copy is added a new field containing one of the values of FIELD." 638 (let (result 639 (values (cdr field))) 640 ;; Uniquify values first 641 (while values 642 (setcdr values (delete (car values) (cdr values))) 643 (setq values (cdr values))) 644 (mapcar 645 (function 646 (lambda (value) 647 (let ((result-list (copy-sequence records))) 648 (setq result-list (eudc-add-field-to-records 649 (cons (car field) value) 650 result-list)) 651 (setq result (append result-list result)) 652 ))) 653 (cdr field)) 654 result)) 655 656 657(defun eudc-mode () 658 "Major mode used in buffers displaying the results of directory queries. 659There is no sense in calling this command from a buffer other than 660one containing the results of a directory query. 661 662These are the special commands of EUDC mode: 663 q -- Kill this buffer. 664 f -- Display a form to query the current directory server. 665 n -- Move to next record. 666 p -- Move to previous record. 667 b -- Insert record at point into the BBDB database." 668 (interactive) 669 (kill-all-local-variables) 670 (setq major-mode 'eudc-mode) 671 (setq mode-name "EUDC") 672 (use-local-map eudc-mode-map) 673 (if eudc-emacs-p 674 (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) 675 (setq mode-popup-menu (eudc-menu))) 676 (run-mode-hooks 'eudc-mode-hook)) 677 678;;}}} 679 680;;{{{ High-level interfaces (interactive functions) 681 682(defun eudc-customize () 683 "Customize the EUDC package." 684 (interactive) 685 (customize-group 'eudc)) 686 687;;;###autoload 688(defun eudc-set-server (server protocol &optional no-save) 689 "Set the directory server to SERVER using PROTOCOL. 690Unless NO-SAVE is non-nil, the server is saved as the default 691server for future sessions." 692 (interactive (list 693 (read-from-minibuffer "Directory Server: ") 694 (intern (completing-read "Protocol: " 695 (mapcar '(lambda (elt) 696 (cons (symbol-name elt) 697 elt)) 698 eudc-known-protocols))))) 699 (unless (or (member protocol 700 eudc-supported-protocols) 701 (load (concat "eudcb-" (symbol-name protocol)) t)) 702 (error "Unsupported protocol: %s" protocol)) 703 (run-hooks 'eudc-switch-from-server-hook) 704 (setq eudc-protocol protocol) 705 (setq eudc-server server) 706 (eudc-update-local-variables) 707 (run-hooks 'eudc-switch-to-server-hook) 708 (if (interactive-p) 709 (message "Current directory server is now %s (%s)" eudc-server eudc-protocol)) 710 (if (null no-save) 711 (eudc-save-options))) 712 713;;;###autoload 714(defun eudc-get-email (name &optional error) 715 "Get the email field of NAME from the directory server. 716If ERROR is non-nil, report an error if there is none." 717 (interactive "sName: \np") 718 (or eudc-server 719 (call-interactively 'eudc-set-server)) 720 (let ((result (eudc-query (list (cons 'name name)) '(email))) 721 email) 722 (if (null (cdr result)) 723 (setq email (eudc-cdaar result)) 724 (error "Multiple match--use the query form")) 725 (if error 726 (if email 727 (message "%s" email) 728 (error "No record matching %s" name))) 729 email)) 730 731;;;###autoload 732(defun eudc-get-phone (name &optional error) 733 "Get the phone field of NAME from the directory server. 734If ERROR is non-nil, report an error if there is none." 735 (interactive "sName: \np") 736 (or eudc-server 737 (call-interactively 'eudc-set-server)) 738 (let ((result (eudc-query (list (cons 'name name)) '(phone))) 739 phone) 740 (if (null (cdr result)) 741 (setq phone (eudc-cdaar result)) 742 (error "Multiple match--use the query form")) 743 (if error 744 (if phone 745 (message "%s" phone) 746 (error "No record matching %s" name))) 747 phone)) 748 749(defun eudc-get-attribute-list () 750 "Return a list of valid attributes for the current server. 751When called interactively the list is formatted in a dedicated buffer 752otherwise a list of symbols is returned." 753 (interactive) 754 (if eudc-list-attributes-function 755 (let ((entries (funcall eudc-list-attributes-function (interactive-p)))) 756 (if entries 757 (if (interactive-p) 758 (eudc-display-records entries t) 759 entries))) 760 (error "The %s protocol has no support for listing attributes" eudc-protocol))) 761 762(defun eudc-format-query (words format) 763 "Use FORMAT to build a EUDC query from WORDS." 764 (let (query 765 query-alist 766 key val cell) 767 (if format 768 (progn 769 (while (and words format) 770 (setq query-alist (cons (cons (car format) (car words)) 771 query-alist)) 772 (setq words (cdr words) 773 format (cdr format))) 774 ;; If the same attribute appears more than once, merge 775 ;; the corresponding values 776 (setq query-alist (nreverse query-alist)) 777 (while query-alist 778 (setq key (eudc-caar query-alist) 779 val (eudc-cdar query-alist) 780 cell (assq key query)) 781 (if cell 782 (setcdr cell (concat (cdr cell) " " val)) 783 (setq query (cons (car query-alist) query))) 784 (setq query-alist (cdr query-alist))) 785 query) 786 (if eudc-protocol-has-default-query-attributes 787 (mapconcat 'identity words " ") 788 (list (cons 'name (mapconcat 'identity words " "))))))) 789 790(defun eudc-extract-n-word-formats (format-list n) 791 "Extract a list of N-long formats from FORMAT-LIST. 792If none try N - 1 and so forth." 793 (let (formats) 794 (while (and (null formats) 795 (> n 0)) 796 (setq formats 797 (delq nil 798 (mapcar '(lambda (format) 799 (if (= n 800 (length format)) 801 format 802 nil)) 803 format-list))) 804 (setq n (1- n))) 805 formats)) 806 807 808;;;###autoload 809(defun eudc-expand-inline (&optional replace) 810 "Query the directory server, and expand the query string before point. 811The query string consists of the buffer substring from the point back to 812the preceding comma, colon or beginning of line. 813The variable `eudc-inline-query-format' controls how to associate the 814individual inline query words with directory attribute names. 815After querying the server for the given string, the expansion specified by 816`eudc-inline-expansion-format' is inserted in the buffer at point. 817If REPLACE is non-nil, then this expansion replaces the name in the buffer. 818`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. 819Multiple servers can be tried with the same query until one finds a match, 820see `eudc-inline-expansion-servers'" 821 (interactive) 822 (if (memq eudc-inline-expansion-servers 823 '(current-server server-then-hotlist)) 824 (or eudc-server 825 (call-interactively 'eudc-set-server)) 826 (or eudc-server-hotlist 827 (error "No server in the hotlist"))) 828 (let* ((end (point)) 829 (beg (save-excursion 830 (if (re-search-backward "\\([:,]\\|^\\)[ \t]*" 831 (save-excursion 832 (beginning-of-line) 833 (point)) 834 'move) 835 (goto-char (match-end 0))) 836 (point))) 837 (query-words (split-string (buffer-substring beg end) "[ \t]+")) 838 query-formats 839 response 840 response-string 841 response-strings 842 (eudc-former-server eudc-server) 843 (eudc-former-protocol eudc-protocol) 844 servers) 845 846 ;; Prepare the list of servers to query 847 (setq servers (copy-sequence eudc-server-hotlist)) 848 (setq servers 849 (cond 850 ((eq eudc-inline-expansion-servers 'hotlist) 851 eudc-server-hotlist) 852 ((eq eudc-inline-expansion-servers 'server-then-hotlist) 853 (cons (cons eudc-server eudc-protocol) 854 (delete (cons eudc-server eudc-protocol) servers))) 855 ((eq eudc-inline-expansion-servers 'current-server) 856 (list (cons eudc-server eudc-protocol))) 857 (t 858 (error "Wrong value for `eudc-inline-expansion-servers': %S" 859 eudc-inline-expansion-servers)))) 860 (if (and eudc-max-servers-to-query 861 (> (length servers) eudc-max-servers-to-query)) 862 (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil)) 863 864 (condition-case signal 865 (progn 866 (setq response 867 (catch 'found 868 ;; Loop on the servers 869 (while servers 870 (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t) 871 872 ;; Determine which formats apply in the query-format list 873 (setq query-formats 874 (or 875 (eudc-extract-n-word-formats eudc-inline-query-format 876 (length query-words)) 877 (if (null eudc-protocol-has-default-query-attributes) 878 '(name)))) 879 880 ;; Loop on query-formats 881 (while query-formats 882 (setq response 883 (eudc-query 884 (eudc-format-query query-words (car query-formats)) 885 (eudc-translate-attribute-list 886 (cdr eudc-inline-expansion-format)))) 887 (if response 888 (throw 'found response)) 889 (setq query-formats (cdr query-formats))) 890 (setq servers (cdr servers))) 891 ;; No more servers to try... no match found 892 nil)) 893 894 895 (if (null response) 896 (error "No match") 897 898 ;; Process response through eudc-inline-expansion-format 899 (while response 900 (setq response-string (apply 'format 901 (car eudc-inline-expansion-format) 902 (mapcar (function 903 (lambda (field) 904 (or (cdr (assq field (car response))) 905 ""))) 906 (eudc-translate-attribute-list 907 (cdr eudc-inline-expansion-format))))) 908 (if (> (length response-string) 0) 909 (setq response-strings 910 (cons response-string response-strings))) 911 (setq response (cdr response))) 912 913 (if (or 914 (and replace (not eudc-expansion-overwrites-query)) 915 (and (not replace) eudc-expansion-overwrites-query)) 916 (kill-ring-save beg end)) 917 (cond 918 ((or (= (length response-strings) 1) 919 (null eudc-multiple-match-handling-method) 920 (eq eudc-multiple-match-handling-method 'first)) 921 (delete-region beg end) 922 (insert (car response-strings))) 923 ((eq eudc-multiple-match-handling-method 'select) 924 (eudc-select response-strings beg end)) 925 ((eq eudc-multiple-match-handling-method 'all) 926 (delete-region beg end) 927 (insert (mapconcat 'identity response-strings ", "))) 928 ((eq eudc-multiple-match-handling-method 'abort) 929 (error "There is more than one match for the query")))) 930 (or (and (equal eudc-server eudc-former-server) 931 (equal eudc-protocol eudc-former-protocol)) 932 (eudc-set-server eudc-former-server eudc-former-protocol t))) 933 (t 934 (or (and (equal eudc-server eudc-former-server) 935 (equal eudc-protocol eudc-former-protocol)) 936 (eudc-set-server eudc-former-server eudc-former-protocol t)) 937 (signal (car signal) (cdr signal)))))) 938 939;;;###autoload 940(defun eudc-query-form (&optional get-fields-from-server) 941 "Display a form to query the directory server. 942If given a non-nil argument GET-FIELDS-FROM-SERVER, the function first 943queries the server for the existing fields and displays a corresponding form." 944 (interactive "P") 945 (let ((fields (or (and get-fields-from-server 946 (eudc-get-attribute-list)) 947 eudc-query-form-attributes)) 948 (buffer (get-buffer-create "*Directory Query Form*")) 949 prompts 950 widget 951 (width 0) 952 inhibit-read-only 953 pt) 954 (switch-to-buffer buffer) 955 (setq inhibit-read-only t) 956 (erase-buffer) 957 (kill-all-local-variables) 958 (make-local-variable 'eudc-form-widget-list) 959 (widget-insert "Directory Query Form\n") 960 (widget-insert "====================\n\n") 961 (widget-insert "Current server is: " (or eudc-server 962 (progn 963 (call-interactively 'eudc-set-server) 964 eudc-server)) 965 "\n") 966 (widget-insert "Protocol : " (symbol-name eudc-protocol) "\n") 967 ;; Build the list of prompts 968 (setq prompts (if eudc-use-raw-directory-names 969 (mapcar 'symbol-name (eudc-translate-attribute-list fields)) 970 (mapcar (function 971 (lambda (field) 972 (or (and (assq field eudc-user-attribute-names-alist) 973 (cdr (assq field eudc-user-attribute-names-alist))) 974 (capitalize (symbol-name field))))) 975 fields))) 976 ;; Loop over prompt strings to find the longest one 977 (mapcar (function 978 (lambda (prompt) 979 (if (> (length prompt) width) 980 (setq width (length prompt))))) 981 prompts) 982 ;; Insert the first widget out of the mapcar to leave the cursor 983 ;; in the first field 984 (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts))) 985 (setq pt (point)) 986 (setq widget (widget-create 'editable-field :size 15)) 987 (setq eudc-form-widget-list (cons (cons (car fields) widget) 988 eudc-form-widget-list)) 989 (setq fields (cdr fields)) 990 (setq prompts (cdr prompts)) 991 (mapcar (function 992 (lambda (field) 993 (widget-insert "\n\n" (format (concat "%" (int-to-string width) "s: ") (car prompts))) 994 (setq widget (widget-create 'editable-field 995 :size 15)) 996 (setq eudc-form-widget-list (cons (cons field widget) 997 eudc-form-widget-list)) 998 (setq prompts (cdr prompts)))) 999 fields) 1000 (widget-insert "\n\n") 1001 (widget-create 'push-button 1002 :notify (lambda (&rest ignore) 1003 (eudc-process-form)) 1004 "Query Server") 1005 (widget-insert " ") 1006 (widget-create 'push-button 1007 :notify (lambda (&rest ignore) 1008 (eudc-query-form)) 1009 "Reset Form") 1010 (widget-insert " ") 1011 (widget-create 'push-button 1012 :notify (lambda (&rest ignore) 1013 (kill-this-buffer)) 1014 "Quit") 1015 (goto-char pt) 1016 (use-local-map widget-keymap) 1017 (widget-setup)) 1018 ) 1019 1020(defun eudc-bookmark-server (server protocol) 1021 "Add SERVER using PROTOCOL to the EUDC `servers' hotlist." 1022 (interactive "sDirectory server: \nsProtocol: ") 1023 (if (member (cons server protocol) eudc-server-hotlist) 1024 (error "%s:%s is already in the hotlist" protocol server) 1025 (setq eudc-server-hotlist (cons (cons server protocol) eudc-server-hotlist)) 1026 (eudc-install-menu) 1027 (eudc-save-options))) 1028 1029(defun eudc-bookmark-current-server () 1030 "Add current server to the EUDC `servers' hotlist." 1031 (interactive) 1032 (eudc-bookmark-server eudc-server eudc-protocol)) 1033 1034(defun eudc-save-options () 1035 "Save options to `eudc-options-file'." 1036 (interactive) 1037 (save-excursion 1038 (set-buffer (find-file-noselect eudc-options-file t)) 1039 (goto-char (point-min)) 1040 ;; delete the previous setq 1041 (let ((standard-output (current-buffer)) 1042 provide-p 1043 set-hotlist-p 1044 set-server-p) 1045 (catch 'found 1046 (while t 1047 (let ((sexp (condition-case nil 1048 (read (current-buffer)) 1049 (end-of-file (throw 'found nil))))) 1050 (if (listp sexp) 1051 (cond 1052 ((eq (car sexp) 'eudc-set-server) 1053 (delete-region (save-excursion 1054 (backward-sexp) 1055 (point)) 1056 (point)) 1057 (setq set-server-p t)) 1058 ((and (eq (car sexp) 'setq) 1059 (eq (eudc-cadr sexp) 'eudc-server-hotlist)) 1060 (delete-region (save-excursion 1061 (backward-sexp) 1062 (point)) 1063 (point)) 1064 (setq set-hotlist-p t)) 1065 ((and (eq (car sexp) 'provide) 1066 (equal (eudc-cadr sexp) '(quote eudc-options-file))) 1067 (setq provide-p t))) 1068 (if (and provide-p 1069 set-hotlist-p 1070 set-server-p) 1071 (throw 'found t)))))) 1072 (if (eq (point-min) (point-max)) 1073 (princ ";; This file was automatically generated by eudc.el.\n\n")) 1074 (or provide-p 1075 (princ "(provide 'eudc-options-file)\n")) 1076 (or (bolp) 1077 (princ "\n")) 1078 (delete-blank-lines) 1079 (princ "(eudc-set-server ") 1080 (prin1 eudc-server) 1081 (princ " '") 1082 (prin1 eudc-protocol) 1083 (princ " t)\n") 1084 (princ "(setq eudc-server-hotlist '") 1085 (prin1 eudc-server-hotlist) 1086 (princ ")\n") 1087 (save-buffer)))) 1088 1089(defun eudc-move-to-next-record () 1090 "Move to next record, in a buffer displaying directory query results." 1091 (interactive) 1092 (if (not (eq major-mode 'eudc-mode)) 1093 (error "Not in a EUDC buffer") 1094 (let ((pt (next-overlay-change (point)))) 1095 (if (< pt (point-max)) 1096 (goto-char (1+ pt)) 1097 (error "No more records after point"))))) 1098 1099(defun eudc-move-to-previous-record () 1100 "Move to previous record, in a buffer displaying directory query results." 1101 (interactive) 1102 (if (not (eq major-mode 'eudc-mode)) 1103 (error "Not in a EUDC buffer") 1104 (let ((pt (previous-overlay-change (point)))) 1105 (if (> pt (point-min)) 1106 (goto-char pt) 1107 (error "No more records before point"))))) 1108 1109;;}}} 1110 1111;;{{{ Menus and keymaps 1112 1113(require 'easymenu) 1114 1115(setq eudc-mode-map 1116 (let ((map (make-sparse-keymap))) 1117 (define-key map "q" 'kill-this-buffer) 1118 (define-key map "x" 'kill-this-buffer) 1119 (define-key map "f" 'eudc-query-form) 1120 (define-key map "b" 'eudc-try-bbdb-insert) 1121 (define-key map "n" 'eudc-move-to-next-record) 1122 (define-key map "p" 'eudc-move-to-previous-record) 1123 map)) 1124(set-keymap-parent eudc-mode-map widget-keymap) 1125 1126(defconst eudc-custom-generated-menu (cdr (custom-menu-create 'eudc))) 1127 1128(defconst eudc-tail-menu 1129 `(["---" nil nil] 1130 ["Query with Form" eudc-query-form t] 1131 ["Expand Inline Query" eudc-expand-inline t] 1132 ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb 1133 (and (or (featurep 'bbdb) 1134 (prog1 (locate-library "bbdb") (message ""))) 1135 (overlays-at (point)) 1136 (overlay-get (car (overlays-at (point))) 'eudc-record))] 1137 ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb 1138 (and (eq major-mode 'eudc-mode) 1139 (or (featurep 'bbdb) 1140 (prog1 (locate-library "bbdb") (message ""))))] 1141 ["---" nil nil] 1142 ["Get Email" eudc-get-email t] 1143 ["Get Phone" eudc-get-phone t] 1144 ["List Valid Attribute Names" eudc-get-attribute-list t] 1145 ["---" nil nil] 1146 ,(cons "Customize" eudc-custom-generated-menu))) 1147 1148 1149(defconst eudc-server-menu 1150 '(["---" nil nil] 1151 ["Bookmark Current Server" eudc-bookmark-current-server t] 1152 ["Edit Server List" eudc-edit-hotlist t] 1153 ["New Server" eudc-set-server t])) 1154 1155(defun eudc-menu () 1156 (let (command) 1157 (append '("Directory Search") 1158 (list 1159 (append 1160 '("Server") 1161 (mapcar 1162 (function 1163 (lambda (servspec) 1164 (let* ((server (car servspec)) 1165 (protocol (cdr servspec)) 1166 (proto-name (symbol-name protocol))) 1167 (setq command (intern (concat "eudc-set-server-" 1168 server 1169 "-" 1170 proto-name))) 1171 (if (not (fboundp command)) 1172 (fset command 1173 `(lambda () 1174 (interactive) 1175 (eudc-set-server ,server (quote ,protocol)) 1176 (message "Selected directory server is now %s (%s)" 1177 ,server 1178 ,proto-name)))) 1179 (vector (format "%s (%s)" server proto-name) 1180 command 1181 :style 'radio 1182 :selected `(equal eudc-server ,server))))) 1183 eudc-server-hotlist) 1184 eudc-server-menu)) 1185 eudc-tail-menu))) 1186 1187(defun eudc-install-menu () 1188 (cond 1189 ((and eudc-xemacs-p (featurep 'menubar)) 1190 (add-submenu '("Tools") (eudc-menu))) 1191 (eudc-emacs-p 1192 (cond 1193 ((fboundp 'easy-menu-create-menu) 1194 (define-key 1195 global-map 1196 [menu-bar tools directory-search] 1197 (cons "Directory Search" 1198 (easy-menu-create-menu "Directory Search" (cdr (eudc-menu)))))) 1199 ((fboundp 'easy-menu-add-item) 1200 (let ((menu (eudc-menu))) 1201 (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) 1202 (cdr menu))))) 1203 ((fboundp 'easy-menu-create-keymaps) 1204 (easy-menu-define eudc-menu-map eudc-mode-map "Directory Client Menu" (eudc-menu)) 1205 (define-key 1206 global-map 1207 [menu-bar tools eudc] 1208 (cons "Directory Search" 1209 (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu)))))) 1210 (t 1211 (error "Unknown version of easymenu")))) 1212 )) 1213 1214 1215;;; Load time initializations : 1216 1217;;; Load the options file 1218(if (and (not noninteractive) 1219 (and (locate-library eudc-options-file) 1220 (progn (message "") t)) ; Remove modeline message 1221 (not (featurep 'eudc-options-file))) 1222 (load eudc-options-file)) 1223 1224;;; Install the full menu 1225(unless (featurep 'infodock) 1226 (eudc-install-menu)) 1227 1228 1229;;; The following installs a short menu for EUDC at XEmacs startup. 1230 1231;;;###autoload 1232(defun eudc-load-eudc () 1233 "Load the Emacs Unified Directory Client. 1234This does nothing except loading eudc by autoload side-effect." 1235 (interactive) 1236 nil) 1237 1238;;;###autoload 1239(cond ((not (string-match "XEmacs" emacs-version)) 1240 (defvar eudc-tools-menu (make-sparse-keymap "Directory Search")) 1241 (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu)) 1242 (define-key eudc-tools-menu [phone] 1243 '("Get Phone" . eudc-get-phone)) 1244 (define-key eudc-tools-menu [email] 1245 '("Get Email" . eudc-get-email)) 1246 (define-key eudc-tools-menu [separator-eudc-email] 1247 '("--")) 1248 (define-key eudc-tools-menu [expand-inline] 1249 '("Expand Inline Query" . eudc-expand-inline)) 1250 (define-key eudc-tools-menu [query] 1251 '("Query with Form" . eudc-query-form)) 1252 (define-key eudc-tools-menu [separator-eudc-query] 1253 '("--")) 1254 (define-key eudc-tools-menu [new] 1255 '("New Server" . eudc-set-server)) 1256 (define-key eudc-tools-menu [load] 1257 '("Load Hotlist of Servers" . eudc-load-eudc))) 1258 1259 (t 1260 (let ((menu '("Directory Search" 1261 ["Load Hotlist of Servers" eudc-load-eudc t] 1262 ["New Server" eudc-set-server t] 1263 ["---" nil nil] 1264 ["Query with Form" eudc-query-form t] 1265 ["Expand Inline Query" eudc-expand-inline t] 1266 ["---" nil nil] 1267 ["Get Email" eudc-get-email t] 1268 ["Get Phone" eudc-get-phone t]))) 1269 (if (not (featurep 'eudc-autoloads)) 1270 (if eudc-xemacs-p 1271 (if (and (featurep 'menubar) 1272 (not (featurep 'infodock))) 1273 (add-submenu '("Tools") menu)) 1274 (require 'easymenu) 1275 (cond 1276 ((fboundp 'easy-menu-add-item) 1277 (easy-menu-add-item nil '("tools") 1278 (easy-menu-create-menu (car menu) 1279 (cdr menu)))) 1280 ((fboundp 'easy-menu-create-keymaps) 1281 (define-key 1282 global-map 1283 [menu-bar tools eudc] 1284 (cons "Directory Search" 1285 (easy-menu-create-keymaps "Directory Search" 1286 (cdr menu))))))))))) 1287 1288;;}}} 1289 1290(provide 'eudc) 1291 1292;;; arch-tag: e18872b6-db83-400b-869d-be54e9a4160c 1293;;; eudc.el ends here 1294