aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorRichard M. Stallman2004-11-01 07:47:18 +0000
committerRichard M. Stallman2004-11-01 07:47:18 +0000
commite2c76fd857e1174126d92b134fd76def53c65b40 (patch)
tree72bfb4e1d62b2eb21e26df708e51fd17f9058ab6 /lisp
parent9d0d10708496729d062ae04fe2f191c16dc831b3 (diff)
downloademacs-e2c76fd857e1174126d92b134fd76def53c65b40.tar.gz
emacs-e2c76fd857e1174126d92b134fd76def53c65b40.zip
(eudc-display-records): Use with-output-to-temp-buffer;
don't select the temporary buffer. (eudc-get-email): New optional arg ERROR; don't use interactive-p. (eudc-get-phone): Likewise.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/net/eudc.el142
1 files changed, 72 insertions, 70 deletions
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 6d12d5e6364..bcdd1d195bf 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -462,73 +462,73 @@ attribute name ATTR."
462 "Display the record list RECORDS in a formatted buffer. 462 "Display the record list RECORDS in a formatted buffer.
463If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed 463If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
464otherwise they are formatted according to `eudc-user-attribute-names-alist'." 464otherwise they are formatted according to `eudc-user-attribute-names-alist'."
465 (let ((buffer (get-buffer-create "*Directory Query Results*")) 465 (let (inhibit-read-only
466 inhibit-read-only
467 precords 466 precords
468 (width 0) 467 (width 0)
469 beg 468 beg
470 first-record 469 first-record
471 attribute-name) 470 attribute-name)
472 (switch-to-buffer buffer) 471 (with-output-to-temp-buffer "*Directory Query Results*"
473 (setq buffer-read-only t) 472 (with-current-buffer standard-output
474 (setq inhibit-read-only t) 473 (setq buffer-read-only t)
475 (erase-buffer) 474 (setq inhibit-read-only t)
476 (insert "Directory Query Result\n") 475 (erase-buffer)
477 (insert "======================\n\n\n") 476 (insert "Directory Query Result\n")
478 (if (null records) 477 (insert "======================\n\n\n")
479 (insert "No match found.\n" 478 (if (null records)
480 (if eudc-strict-return-matches 479 (insert "No match found.\n"
481 "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n" 480 (if eudc-strict-return-matches
482 "")) 481 "Try setting `eudc-strict-return-matches' to nil or change `eudc-default-return-attributes'.\n"
483 ;; Replace field names with user names, compute max width 482 ""))
484 (setq precords 483 ;; Replace field names with user names, compute max width
485 (mapcar 484 (setq precords
486 (function
487 (lambda (record)
488 (mapcar 485 (mapcar
489 (function 486 (function
490 (lambda (field) 487 (lambda (record)
491 (setq attribute-name 488 (mapcar
492 (if raw-attr-names 489 (function
493 (symbol-name (car field)) 490 (lambda (field)
494 (eudc-format-attribute-name-for-display (car field)))) 491 (setq attribute-name
495 (if (> (length attribute-name) width) 492 (if raw-attr-names
496 (setq width (length attribute-name))) 493 (symbol-name (car field))
497 (cons attribute-name (cdr field)))) 494 (eudc-format-attribute-name-for-display (car field))))
498 record))) 495 (if (> (length attribute-name) width)
499 records)) 496 (setq width (length attribute-name)))
500 ;; Display the records 497 (cons attribute-name (cdr field))))
501 (setq first-record (point)) 498 record)))
502 (mapcar 499 records))
503 (function 500 ;; Display the records
504 (lambda (record) 501 (setq first-record (point))
505 (setq beg (point)) 502 (mapcar
506 ;; Map over the record fields to print the attribute/value pairs 503 (function
507 (mapcar (function 504 (lambda (record)
508 (lambda (field) 505 (setq beg (point))
509 (eudc-print-record-field field width))) 506 ;; Map over the record fields to print the attribute/value pairs
510 record) 507 (mapcar (function
511 ;; Store the record internal format in some convenient place 508 (lambda (field)
512 (overlay-put (make-overlay beg (point)) 509 (eudc-print-record-field field width)))
513 'eudc-record 510 record)
514 (car records)) 511 ;; Store the record internal format in some convenient place
515 (setq records (cdr records)) 512 (overlay-put (make-overlay beg (point))
516 (insert "\n"))) 513 'eudc-record
517 precords)) 514 (car records))
518 (insert "\n") 515 (setq records (cdr records))
519 (widget-create 'push-button 516 (insert "\n")))
520 :notify (lambda (&rest ignore) 517 precords))
521 (eudc-query-form)) 518 (insert "\n")
522 "New query") 519 (widget-create 'push-button
523 (widget-insert " ") 520 :notify (lambda (&rest ignore)
524 (widget-create 'push-button 521 (eudc-query-form))
525 :notify (lambda (&rest ignore) 522 "New query")
526 (kill-this-buffer)) 523 (widget-insert " ")
527 "Quit") 524 (widget-create 'push-button
528 (eudc-mode) 525 :notify (lambda (&rest ignore)
529 (widget-setup) 526 (kill-this-buffer))
530 (if first-record 527 "Quit")
531 (goto-char first-record)))) 528 (eudc-mode)
529 (widget-setup)
530 (if first-record
531 (goto-char first-record))))))
532 532
533(defun eudc-process-form () 533(defun eudc-process-form ()
534 "Process the query form in current buffer and display the results." 534 "Process the query form in current buffer and display the results."
@@ -709,34 +709,36 @@ server for future sessions."
709 (eudc-save-options))) 709 (eudc-save-options)))
710 710
711;;;###autoload 711;;;###autoload
712(defun eudc-get-email (name) 712(defun eudc-get-email (name &optional error)
713 "Get the email field of NAME from the directory server." 713 "Get the email field of NAME from the directory server.
714 (interactive "sName: ") 714If ERROR is non-nil, report an error if there is none."
715 (interactive "sName: \np")
715 (or eudc-server 716 (or eudc-server
716 (call-interactively 'eudc-set-server)) 717 (call-interactively 'eudc-set-server))
717 (let ((result (eudc-query (list (cons 'name name)) '(email))) 718 (let ((result (eudc-query (list (cons 'name name)) '(email)))
718 email) 719 email)
719 (if (null (cdr result)) 720 (if (null (cdr result))
720 (setq email (eudc-cdaar result)) 721 (setq email (eudc-cdaar result))
721 (error "Multiple match. Use the query form")) 722 (error "Multiple match--use the query form"))
722 (if (interactive-p) 723 (if error
723 (if email 724 (if email
724 (message "%s" email) 725 (message "%s" email)
725 (error "No record matching %s" name))) 726 (error "No record matching %s" name)))
726 email)) 727 email))
727 728
728;;;###autoload 729;;;###autoload
729(defun eudc-get-phone (name) 730(defun eudc-get-phone (name &optional error)
730 "Get the phone field of NAME from the directory server." 731 "Get the phone field of NAME from the directory server.
731 (interactive "sName: ") 732If ERROR is non-nil, report an error if there is none."
733 (interactive "sName: \np")
732 (or eudc-server 734 (or eudc-server
733 (call-interactively 'eudc-set-server)) 735 (call-interactively 'eudc-set-server))
734 (let ((result (eudc-query (list (cons 'name name)) '(phone))) 736 (let ((result (eudc-query (list (cons 'name name)) '(phone)))
735 phone) 737 phone)
736 (if (null (cdr result)) 738 (if (null (cdr result))
737 (setq phone (eudc-cdaar result)) 739 (setq phone (eudc-cdaar result))
738 (error "Multiple match. Use the query form")) 740 (error "Multiple match--use the query form"))
739 (if (interactive-p) 741 (if error
740 (if phone 742 (if phone
741 (message "%s" phone) 743 (message "%s" phone)
742 (error "No record matching %s" name))) 744 (error "No record matching %s" name)))