1 ;;; ph.el --- Client for the CCSO directory system (aka PH/QI)
3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
5 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
6 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
11 ;; This file is part of GNU Emacs
13 ;; GNU Emacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to
25 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
29 ;; This package provides functions to query CCSO PH/QI nameservers
30 ;; through an interactive form or replace inline query strings in
31 ;; buffers with appropriately formatted query results (especially
32 ;; used to expand email addresses in message buffers). It also
33 ;; interfaces with the BBDB package to let you register entries of
34 ;; the CCSO PH/QI directory into your own database. The CCSO PH/QI
35 ;; white pages system was developped at UIUC and is in use in more
36 ;; than 300 sites in the world. The distribution can be found at
37 ;; ftp://uiarchive.cso.uiuc.edu/pub/packages/ph Traditionally the
38 ;; server is called QI while the client is called PH.
41 ;; This package uses the custom and widget libraries. If they are not already
42 ;; installed on your system get them from http://www.dina.kvl.dk/~abraham/custom/
43 ;; Then uncomment and add the following to your .emacs file:
45 ;; (eval-after-load "message"
46 ;; '(define-key message-mode-map [(control ?c) (tab)] 'ph-expand-inline))
47 ;; (eval-after-load "mail"
48 ;; '(define-key mail-mode-map [(control ?c) (tab)] 'ph-expand-inline))
49 ;; See the info file for details
51 ;; This package runs under XEmacs 19.15 or 20 and under Emacs 19.34 and above
54 ;; - Provided you did the installation as proposed in the above section,
55 ;; inline expansion will be available when you compose an email
56 ;; message. Type the name of somebody recorded in your PH/QI server and hit
57 ;; C-c TAB, this will overwrite the name with the corresponding email
59 ;; - M-x ph-customize to customize inline expansion and other features to
61 ;; - Look for the Ph submenu in the Tools menu for more.
62 ;; See the info file for details.
68 (if (not (fboundp 'make-overlay))
71 (autoload 'custom-menu-create "cus-edit")
73 ;;{{{ Package customization variables
76 "CCSO (PH/QI) directory system client"
80 (defcustom ph-server nil
81 "*The name or IP address of the CCSO (PH/QI) server.
82 A port number may be specified by appending a colon and a
83 number to the name of the server."
84 :type '(string :tag "Server")
87 (defcustom ph-strict-return-matches t
88 "*If non-nil, entries not containing all requested return fields are ignored."
92 (defcustom ph-default-return-fields nil
93 "*A list of the default fields to extract from CCSO entries.
94 If it contains `all' then all available fields are returned.
95 nil means return the default fields as configured in the server."
96 :type '(repeat (symbol :tag "Field name"))
99 (defcustom ph-multiple-match-handling-method 'select
100 "*What to do when multiple entries match an inline expansion query.
102 `first' (equivalent to nil) which means consider the first match,
103 `select' pop-up a selection buffer,
104 `all' use all matches,
105 `abort' the operation is aborted, an error is signaled."
106 :type '(choice :menu-tag "Method"
107 (const :menu-tag "First" first)
108 (const :menu-tag "Select" select)
109 (const :menu-tag "All" all)
110 (const :menu-tag "Abort" abort)
111 (const :menu-tag "None" nil))
114 (defcustom ph-duplicate-fields-handling-method '((email . duplicate))
115 "*A method to handle entries containing duplicate fields.
116 This is either an alist (FIELD . METHOD) or a symbol METHOD.
117 The alist form of the variable associates a method to an individual field,
118 the second form specifies a method applicable to all fields.
119 Available methods are:
120 `list' or nil lets the value of the field be a list of values,
121 `first' keeps the first value and discards the others,
122 `concat' concatenates the values into a single multiline string,
123 `duplicate' duplicates the entire entry into as many instances as
125 :type '(choice (const :menu-tag "List" list)
126 (const :menu-tag "First" first)
127 (const :menu-tag "Concat" concat)
128 (const :menu-tag "Duplicate" duplicate)
129 (repeat :menu-tag "Per Field Specification"
130 :tag "Per Field Specification"
131 (cons :tag "Field/Method"
133 (symbol :tag "Field name")
134 (choice :tag "Method"
136 (const :menu-tag "List" list)
137 (const :menu-tag "First" first)
138 (const :menu-tag "Concat" concat)
139 (const :menu-tag "Duplicate" duplicate)))))
143 (defcustom ph-inline-query-format-list nil
144 "*Format of an inline expansion query.
145 If the inline query string consists of several words, this list specifies
146 how these individual words are associated to CCSO database field names.
147 If nil all the words will be mapped onto the default CCSO database key."
148 :type '(repeat (symbol :tag "Field name"))
151 (defcustom ph-expanding-overwrites-query t
152 "*If non nil, expanding a query overwrites the query string."
156 (defcustom ph-inline-expansion-format '("%s" email)
157 "*A list specifying the format of the expansion of inline queries.
158 This variable controls what `ph-expand-inline' actually inserts in the buffer.
159 First element is a string passed to `format'. Remaining elements are symbols
160 indicating CCSO database field names, corresponding field values are passed
161 as additional arguments to `format'."
162 :type '(list (string :tag "Format String")
168 (defcustom ph-form-fields '(name email phone)
169 "*A list of fields presented in the query form."
170 :tag "Default Fields in Query Forms"
171 :type '(repeat (symbol :tag "Field name"))
174 (defcustom ph-fieldname-formstring-alist '((url . "URL")
175 (callsign . "HAM Call Sign")
178 (firstname . "First Name"))
179 "*Map CCSO database field names into prompt strings for query/response.
180 Prompt strings for fields that are not listed here
181 are derived by splitting the field name
182 at `_' signs and capitalizing the individual words."
183 :tag "Mapping of Field Names onto Prompt Strings"
184 :type '(repeat (cons :tag "Field"
186 (string :tag "Prompt string")))
189 (defcustom ph-bbdb-conversion-alist
192 (address . (ph-bbdbify-address address "Address"))
193 (phone . ((ph-bbdbify-phone phone "Phone")
194 (ph-bbdbify-phone office_phone "Office Phone"))))
195 "*A mapping from BBDB to PH/QI fields.
196 This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
197 BBDB-FIELD is the name of a field that must be defined in your BBDB
198 environment (standard field names are `name', `company', `net', `phone',
199 `address' and `notes'). SPEC-OR-LIST is either a single SPEC or a list
200 of SPECs. Lists of specs are valid only for the `phone' and `address'
201 BBDB fields. SPECs are sexps which are evaluated:
202 a string evaluates to itself,
203 a symbol evaluates to the symbol value. Symbols naming PH/QI fields
204 present in the record evaluate to the value of the field in the record,
205 a form is evaluated as a function. The argument list may contain PH/QI
206 field names which eval to the corresponding values in the
207 record. The form evaluation should return something appropriate for
208 the particular BBDB-FIELD (see `bbdb-create-internal').
209 `ph-bbdbify-phone' and `ph-bbdbify-address' are provided as convenience
210 functions to parse phones and addresses."
211 :tag "BBDB to CCSO Field Name Mapping"
212 :type '(repeat (cons :tag "Field Name"
213 (symbol :tag "BBDB Field")
214 (sexp :tag "Conversion Spec")))
217 (defcustom ph-options-file "~/.ph-options"
218 "*A file where the PH `servers' hotlist is stored."
219 :type '(file :Tag "File Name:"))
221 (defcustom ph-mode-hook nil
222 "*Normal hook run on entry to PH mode."
223 :type '(repeat (sexp :tag "Hook")))
228 ;;{{{ Internal cooking
231 (defconst ph-xemacs-p (string-match "XEmacs" emacs-version))
232 (defconst ph-emacs-p (not ph-xemacs-p))
233 (defconst ph-xemacs-mule-p (and ph-xemacs-p
235 (defconst ph-emacs-mule-p (and ph-emacs-p
238 (defvar ph-server-hotlist nil)
240 (defconst ph-default-server-port 105
241 "Default TCP port for CCSO directory services.")
243 (defvar ph-form-widget-list nil)
244 (defvar ph-process-buffer nil)
245 (defvar ph-read-point)
247 ;;; Load the options file
248 (if (and (and (locate-library ph-options-file)
249 (message "")) ; Remove modeline message
250 (not (featurep 'ph-options-file)))
251 (load ph-options-file))
260 "Major mode used in buffers displaying the results of PH queries.
261 There is no sense in calling this command from a buffer other than
262 one containing the results of a PH query.
264 These are the special commands of PH mode:
265 q -- kill this buffer.
266 f -- Display a form to query the CCSO PH/QI nameserver.
267 n -- Move to next record.
268 p -- Move to previous record."
270 (kill-all-local-variables)
271 (setq major-mode 'ph-mode)
272 (setq mode-name "PH")
273 (use-local-map ph-mode-map)
274 (setq mode-popup-menu (ph-menu))
275 (run-hooks 'ph-mode-hook)
278 (defun ph-display-records (records &optional raw-field-names)
279 "Display the record list RECORDS in a formatted buffer.
280 If RAW-FIELD-NAMES is non-nil, the raw field names are displayed
281 otherwise they are formatted according to `ph-fieldname-formstring-alist'."
282 (let ((buffer (get-buffer-create "*PH Query Results*"))
288 (switch-to-buffer buffer)
289 (setq buffer-read-only t)
290 (setq inhibit-read-only t)
292 (insert "PH Query Result\n")
293 (insert "===============\n\n\n")
295 (insert "No match found.\n"
296 (if ph-strict-return-matches
297 "Try setting ph-strict-return-matches to nil or change ph-default-return-fields."
299 ;; Replace field names with prompt strings, compute prompt max width
307 (setq field-name (if raw-field-names
308 (symbol-name (car field))
309 (or (and (assq (car field) ph-fieldname-formstring-alist)
310 (cdr (assq (car field) ph-fieldname-formstring-alist)))
311 (capitalize (mapconcat '(lambda (char)
314 (char-to-string char)))
315 (symbol-name (car field))
317 (if (> (length field-name) width)
318 (setq width (length field-name)))
319 (cons field-name (cdr field))))
325 ;; Actually insert the field/value pairs
328 (setq field-beg (point))
329 (insert (format (concat "%" width "s: ") (car field)))
330 (put-text-property field-beg (point) 'face 'bold)
333 (indent-to (+ 2 width))
335 (if (stringp (cdr field))
336 (split-string (cdr field) "\n")
339 ;; Store the record internal format in some convenient place
340 (overlay-put (make-overlay beg (point))
343 (setq records (cdr records))
347 (widget-create 'push-button
348 :notify (lambda (&rest ignore)
352 (widget-create 'push-button
353 :notify (lambda (&rest ignore)
361 (defun ph-process-form ()
362 "Process the form in current buffer and display the results."
365 (if (not (and (boundp 'ph-form-widget-list)
366 ph-form-widget-list))
367 (error "Not in a PH query form buffer")
370 (setq value (widget-value (cdr wid-field)))
371 (if (not (string= value ""))
372 (setq query-alist (cons (cons (car wid-field) value)
375 (kill-buffer (current-buffer))
376 (ph-display-records (ph-query-internal query-alist))
380 (defun ph-query-internal (query &optional return-fields)
381 "Query the PH/QI server with QUERY.
382 QUERY can be a string NAME or a list made of strings NAME
383 and/or cons cells (KEY . VALUE) where KEYs should be valid
384 CCSO database keys. NAME is equivalent to (DEFAULT . NAME),
385 where DEFAULT is the default key of the database.
386 RETURN-FIELDS is a list of database fields to return,
387 defaulting to `ph-default-return-fields'."
389 (if (null return-fields)
390 (setq return-fields ph-default-return-fields))
395 (mapconcat (function (lambda (elt)
396 (if (stringp elt) elt)
397 (format "%s=%s" (car elt) (cdr elt))))
401 (concat " return " (mapconcat 'symbol-name return-fields " ")))))
402 (and (> (length request) 6)
403 (ph-do-request request)
404 (ph-parse-query-result return-fields))))
406 (defun ph-parse-query-result (&optional fields)
407 "Return a list of alists of key/values from in `ph-process-buffer'.
408 Fields not in FIELDS are discarded."
417 (message "Parsing results...")
418 (set-buffer ph-process-buffer)
419 (goto-char (point-min))
420 (while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t)
422 (setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))
427 (while (re-search-forward line-regexp nil t)
429 (if (string= "-508" (match-string 1))
430 ;; A field is missing in this entry. Skip it or skip the
431 ;; whole record (see ph-strict-return-matches)
432 (if (not ph-strict-return-matches)
434 (while (re-search-forward line-regexp nil t))
437 (setq key (and (not (string= (match-string 2) ""))
438 (intern (match-string 2)))
439 value (match-string 3))
441 (eq key current-key))
443 (setq current-key key))
444 (if (or (null fields)
446 (memq current-key fields))
448 (setq record (cons (cons key value) record)) ; New key
449 (setcdr (car record) (if (listp (ph-cdar record))
450 (append (ph-cdar record) (list value))
451 (list (ph-cdar record) value))))))))
455 (setq record (nreverse record)))
456 (setq record (if (not (eq 'list ph-duplicate-fields-handling-method))
457 (ph-filter-duplicate-fields record)
459 (setq records (append record records))))
465 (defun ph-filter-duplicate-fields (record)
466 "Filter RECORD according to `ph-duplicate-fields-handling-method'."
472 ;; Search for multiple records
474 (not (listp (ph-cdar rec))))
475 (setq rec (cdr rec)))
477 (if (null (ph-cdar rec))
478 (list record) ; No duplicate fields in this record
481 (if (listp (cdr field))
482 (setq duplicates (cons field duplicates))
483 (setq unique (cons field unique)))))
485 (setq result (list unique))
488 (let ((method (if (consp ph-duplicate-fields-handling-method)
489 (cdr (assq (car field) ph-duplicate-fields-handling-method))
490 ph-duplicate-fields-handling-method)))
492 ((or (null method) (eq 'list method))
494 (ph-add-field-to-records field result)))
497 (ph-add-field-to-records (cons (car field) (ph-cadr field)) result)))
500 (ph-add-field-to-records (cons (car field)
505 ((eq 'duplicate method)
507 (ph-distribute-field-on-records field result)))))))
511 (defun ph-add-field-to-records (field records)
512 "Add FIELD to each individual record in RECORDS and return the resulting list."
518 (defun ph-distribute-field-on-records (field records)
519 "Duplicate each individual record in RECORDS according to value of FIELD.
520 Each copy is added a new field containing one of the values of FIELD."
522 (values (cdr field)))
523 ;; Uniquify values first
525 (setcdr values (delete (car values) (cdr values)))
526 (setq values (cdr values)))
529 (let ((result-list (copy-sequence records)))
530 (setq result-list (ph-add-field-to-records (cons (car field) value)
532 (setq result (append result-list result))
538 (defun ph-do-request (request)
539 "Send REQUEST to the server.
540 Wait for response and return the buffer containing it."
545 (message "Contacting server...")
546 (setq process (ph-open-session))
549 (set-buffer (setq buffer (process-buffer process)))
550 (ph-send-command process request)
551 (message "Request sent, waiting for reply...")
552 (ph-read-response process))))
554 (ph-close-session process)))
557 (defun ph-open-session (&optional server)
558 "Open a connection to the given CCSO SERVER.
559 SERVER is either a string naming the server or a list (NAME PORT)."
565 (setq server (or ph-server
566 (call-interactively 'ph-set-server))))
567 (string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server)
568 (setq host (match-string 1 server))
569 (setq port (or (match-string 3 server)
570 ph-default-server-port))
571 (setq ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
573 (set-buffer ph-process-buffer)
575 (setq ph-read-point (point))
576 (and ph-xemacs-mule-p
577 (set-buffer-file-coding-system 'binary t)))
578 (setq process (open-network-stream "ph" ph-process-buffer host port))
581 (process-kill-without-query process)
585 (defun ph-close-session (process)
587 (set-buffer (process-buffer process))
588 (ph-send-command process "quit")
589 (ph-read-response process)
590 (if (fboundp 'add-async-timeout)
591 (add-async-timeout 10 'delete-process process)
592 (run-at-time 2 nil 'delete-process process))))
594 (defun ph-send-command (process command)
595 (goto-char (point-max))
596 (process-send-string process command)
597 (process-send-string process "\r\n")
600 (defun ph-read-response (process &optional return-response)
601 "Read a response from the PH/QI query process PROCESS.
602 Returns nil if response starts with an error code. If the
603 response is successful the return code or the reponse itself is returned
604 depending on RETURN-RESPONSE."
605 (let ((case-fold-search nil)
608 (goto-char ph-read-point)
609 ;; CCSO protocol : response complete if status >= 200
610 (while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t))
611 (accept-process-output process)
612 (goto-char ph-read-point))
613 (setq match-end (point))
614 (goto-char ph-read-point)
615 (if (and (setq return-code (match-string 1))
616 (setq return-code (string-to-number return-code))
617 (>= (abs return-code) 300))
618 (progn (setq ph-read-point match-end) nil)
619 (setq ph-read-point match-end)
621 (buffer-substring (point) match-end)
624 (defun ph-create-bbdb-record (record)
625 "Create a BBDB record using the RECORD alist.
626 RECORD is an alist of (KEY . VALUE) where KEY is a symbol naming a field
627 of the PH/QI database and VALUE is the corresponding value for the record."
628 ;; This function runs in a special context where lisp symbols corresponding
629 ;; to field names in record are bound to the corresponding values
631 `(let* (,@(mapcar '(lambda (c)
632 (list (car c) (if (listp (cdr c))
633 (list 'quote (cdr c))
646 ;; BBDB standard fields
647 (setq bbdb-name (ph-parse-spec (cdr (assq 'name ph-bbdb-conversion-alist)) record nil)
648 bbdb-company (ph-parse-spec (cdr (assq 'company ph-bbdb-conversion-alist)) record nil)
649 bbdb-net (ph-parse-spec (cdr (assq 'net ph-bbdb-conversion-alist)) record nil)
650 bbdb-notes (ph-parse-spec (cdr (assq 'notes ph-bbdb-conversion-alist)) record nil))
651 (setq spec (cdr (assq 'address ph-bbdb-conversion-alist)))
652 (setq bbdb-address (delq nil (ph-parse-spec (if (listp (car spec))
656 (setq spec (cdr (assq 'phone ph-bbdb-conversion-alist)))
657 (setq bbdb-phones (delq nil (ph-parse-spec (if (listp (car spec))
661 ;; BBDB custom fields
662 (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
665 (if (and (not (memq (car mapping)
666 '(name company net address phone notes)))
667 (setq value (ph-parse-spec (cdr mapping) record nil)))
668 (cons (car mapping) value))))
669 ph-bbdb-conversion-alist)))
670 (setq bbdb-notes (delq nil bbdb-notes))
671 (setq bbdb-record (bbdb-create-internal bbdb-name
678 (bbdb-display-records (list bbdb-record))
681 (defun ph-parse-spec (spec record recurse)
682 "Parse the conversion SPEC using RECORD.
683 If RECURSE is non-nil then SPEC may be a list of atomic specs."
689 (fboundp (car spec))))
692 (void-variable nil)))
695 (mapcar '(lambda (spec-elem)
696 (ph-parse-spec spec-elem record nil))
699 (error "Invalid specification for `%s' in `ph-bbdb-conversion-alist'" spec))))
701 (defun ph-bbdbify-address (addr location)
702 "Parse ADDR into a vector compatible with BBDB.
703 ADDR should be an address string of no more than four lines or a
705 The last line is searched for the zip code, city and state name.
706 LOCATION is used as the address location for bbdb."
707 (let* ((addr-components (if (listp addr)
709 (reverse (split-string addr "\n"))))
710 (lastl (pop addr-components))
712 (setq addr-components (nreverse addr-components))
715 ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" lastl)
716 (setq city (match-string 1 lastl)
717 state (match-string 2 lastl)
718 zip (string-to-number (match-string 3 lastl))))
720 ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" lastl)
721 (setq city (match-string 2 lastl)
722 zip (string-to-number (match-string 1 lastl))))
724 (error "Cannot parse the address; see `ph-bbdb-conversion-alist'")))
726 (or (nth 0 addr-components) "")
727 (or (nth 1 addr-components) "")
728 (or (nth 2 addr-components) "")
733 (defun ph-bbdbify-phone (phone location)
734 "Parse PHONE into a vector compatible with BBDB.
735 PHONE is either a string supposedly containing a phone number or
736 a list of such strings which are concatenated.
737 LOCATION is used as the phone location for bbdb."
742 (setq phone-list (bbdb-parse-phone-number phone))
744 (if (string= "phone number unparsable." (ph-cadr err))
745 (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
746 (error "Phone number unparsable")
747 (setq phone-list (list (bbdb-string-trim phone))))
748 (signal (car err) (cdr err)))))
749 (if (= 3 (length phone-list))
750 (setq phone-list (append phone-list '(nil))))
751 (apply 'vector location phone-list)))
753 (vector location (mapconcat 'identity phone ", ")))
755 (error "Invalid phone specification"))))
759 ;;{{{ High-level interfaces (interactive functions)
761 (defun ph-customize ()
762 "Customize the PH package."
764 (customize-group 'ph))
766 (defun ph-set-server (server)
767 "Set the PH server to SERVER."
768 (interactive "sNew PH/QI Server: ")
769 (message "Selected PH/QI server is now %s" server)
770 (setq ph-server server))
773 (defun ph-get-email (name)
774 "Get the email field of NAME from the PH/QI directory server."
775 (interactive "sName: ")
776 (let ((email (cdaar (ph-query-internal name '(email)))))
780 (message "No record matching %s" name)))
784 (defun ph-get-phone (name)
785 "Get the phone field of NAME from the PH/QI directory server."
786 (interactive "sName: ")
787 (let ((phone (cdaar (ph-query-internal name '(phone)))))
791 (message "No record matching %s" name)))
794 (defun ph-get-field-list ()
795 "Return a list of valid field names for current server.
796 When called interactively the list is formatted in a dedicated buffer
797 otherwise a list of symbols is returned."
799 (ph-do-request "fields")
801 (let ((ph-duplicate-fields-handling-method 'list))
802 (ph-display-records (ph-parse-query-result) t))
804 (ph-parse-query-result)))
808 (defun ph-expand-inline (&optional replace)
809 "Query the PH server, and expand the query string before point.
810 The query string consists of the buffer substring from the point back to
811 the preceding comma, colon or beginning of line. If it contains more than
812 one word, the variable `ph-inline-query-format-list' controls to map these
813 onto CCSO database field names.
814 After querying the server for the given string, the expansion specified by
815 `ph-inline-expansion-format' is inserted in the buffer at point.
816 If REPLACE is t, then this expansion replaces the name in the buffer.
817 If `ph-expanding-overwrites-query' is t, that inverts the meaning of REPLACE."
821 (if (re-search-backward "[:,][ \t]*"
826 (goto-char (match-end 0)))
828 (words (buffer-substring beg end))
831 (query-format ph-inline-query-format-list)
837 (if (or (not query-format)
838 (not (string-match "[ \t]+" words)))
840 (setq words (split-string words "[ \t]+"))
841 (while (and words query-format)
842 (setq query-alist (cons (cons (car query-format) (car words)) query-alist))
843 (setq words (cdr words)
844 query-format (cdr query-format)))
846 (setcdr (car query-alist)
847 (concat (ph-cdar query-alist) " "
848 (mapconcat 'identity words " "))))
849 ;; Uniquify query-alist
850 (setq query-alist (nreverse query-alist))
852 (setq key (caar query-alist)
853 val (ph-cdar query-alist)
854 cell (assq key query))
856 (setcdr cell (concat val " " (cdr cell)))
857 (setq query (cons (car query-alist) query))))
858 (setq query-alist (cdr query-alist)))
860 (setq response (ph-query-internal query (cdr ph-inline-expansion-format)))
863 (error "No match found")
865 ;; Process response through ph-inline-expansion-format
867 (setq response-strings
869 (car ph-inline-expansion-format)
872 (or (cdr (assq field (car response)))
874 (cdr ph-inline-expansion-format)))
876 (setq response (cdr response)))
879 (and replace (not ph-expanding-overwrites-query))
880 (and (not replace) ph-expanding-overwrites-query))
881 (delete-region beg end))
883 ((or (= (length response-strings) 1)
884 (null ph-multiple-match-handling-method)
885 (eq ph-multiple-match-handling-method 'first))
886 (insert (car response-strings)))
887 ((eq ph-multiple-match-handling-method 'select)
888 (with-output-to-temp-buffer "*Completions*"
889 (display-completion-list response-strings)))
890 ((eq ph-multiple-match-handling-method 'all)
891 (insert (mapconcat 'identity response-strings ", ")))
892 ((eq ph-multiple-match-handling-method 'abort)
893 (error "There is more than one match for the query"))
899 (defun ph-query-form (&optional get-fields-from-server)
900 "Display a form to query the CCSO PH/QI nameserver.
901 If given a non-nil argument the function first queries the server
902 for the existing fields and displays a corresponding form."
904 (let ((fields (or (and get-fields-from-server
907 (buffer (get-buffer-create "*PH/QI Query Form*"))
913 (switch-to-buffer buffer)
914 (setq inhibit-read-only t)
916 (kill-all-local-variables)
917 (make-local-variable 'ph-form-widget-list)
918 (widget-insert "PH/QI Query Form\n")
919 (widget-insert "================\n\n")
920 (widget-insert "Current server is: " (or ph-server
921 (call-interactively 'ph-set-server)) "\n")
922 ;; Loop over prompt strings to find the biggest one
926 (setq field-name (or (and (assq field ph-fieldname-formstring-alist)
927 (cdr (assq field ph-fieldname-formstring-alist)))
928 (capitalize (symbol-name field))))
929 (if (> (length field-name) width)
930 (setq width (length field-name)))
931 (cons field field-name)))
933 ;; Insert the first widget out of the mapcar to leave the cursor
934 ;; in the first field
935 (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr (car fields))))
937 (setq widget (widget-create 'editable-field :size 15))
938 (setq ph-form-widget-list (cons (cons (car (car fields)) widget)
939 ph-form-widget-list))
940 (setq fields (cdr fields))
943 (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr field)))
944 (setq widget (widget-create 'editable-field
946 (setq ph-form-widget-list (cons (cons (car field) widget)
947 ph-form-widget-list))))
949 (widget-insert "\n\n")
950 (widget-create 'push-button
951 :notify (lambda (&rest ignore)
955 (widget-create 'push-button
956 :notify (lambda (&rest ignore)
960 (widget-create 'push-button
961 :notify (lambda (&rest ignore)
964 (goto-char (1+ pt)) ; 1+ for some extent boundary reason
965 (use-local-map widget-keymap)
969 (defun ph-bookmark-server (server)
970 "Add SERVER to the PH `servers' hotlist."
971 (interactive "sPH server: ")
972 (if (member server ph-server-hotlist)
973 (error "%s is already in the hotlist" server)
974 (setq ph-server-hotlist (cons server ph-server-hotlist))
978 (defun ph-bookmark-current-server ()
979 "Add current server to the PH `servers' hotlist."
981 (ph-bookmark-server ph-server))
983 (defun ph-save-options ()
984 "Save options (essentially the hotlist) to `ph-options-file'."
987 (set-buffer (find-file-noselect ph-options-file t))
988 ;; delete the previous setq
989 (let ((standard-output (current-buffer))
994 (let ((sexp (condition-case nil
995 (read (current-buffer))
996 (end-of-file (throw 'found nil)))))
999 (if (and (eq (car sexp) 'setq)
1000 (eq (ph-cadr sexp) 'ph-server-hotlist))
1002 (delete-region (save-excursion
1007 (if (and (eq (car sexp) 'provide)
1008 (equal (ph-cadr sexp) '(quote ph-options-file)))
1012 (throw 'found t)))))))
1013 (if (eq (point-min) (point-max))
1014 (princ ";; This file was automatically generated by ph.el\n\n"))
1017 (princ "(setq ph-server-hotlist '")
1018 (prin1 ph-server-hotlist)
1021 (princ "(provide 'ph-options-file)\n"))
1025 (defun ph-insert-record-at-point-into-bbdb ()
1026 "Insert record at point into the BBDB database.
1027 This function can only be called from a PH/QI query result buffer."
1029 (let ((record (and (overlays-at (point))
1030 (overlay-get (car (overlays-at (point))) 'ph-record))))
1032 (error "Point is not over a record")
1033 (ph-create-bbdb-record record))))
1035 (defun ph-try-bbdb-insert ()
1036 "Call `ph-insert-record-at-point-into-bbdb' if on a record."
1038 (and (or (featurep 'bbdb)
1039 (prog1 (locate-library "bbdb") (message "")))
1040 (overlays-at (point))
1041 (overlay-get (car (overlays-at (point))) 'ph-record)
1042 (ph-insert-record-at-point-into-bbdb)))
1044 (defun ph-move-to-next-record ()
1045 "Move to next record, in a buffer displaying PH query results."
1047 (if (not (eq major-mode 'ph-mode))
1048 (error "Not in a PH buffer")
1049 (let ((pt (next-overlay-change (point))))
1050 (if (< pt (point-max))
1052 (error "No more records after point")))))
1054 (defun ph-move-to-previous-record ()
1055 "Move to previous record, in a buffer displaying PH query results."
1057 (if (not (eq major-mode 'ph-mode))
1058 (error "Not in a PH buffer")
1059 (let ((pt (previous-overlay-change (point))))
1060 (if (> pt (point-min))
1062 (error "No more records before point")))))
1068 ;;{{{ Menus an keymaps
1072 (defvar ph-mode-map (let ((map (make-sparse-keymap)))
1073 (define-key map "q" 'kill-this-buffer)
1074 (define-key map "x" 'kill-this-buffer)
1075 (define-key map "f" 'ph-query-form)
1076 (define-key map "b" 'ph-try-bbdb-insert)
1077 (define-key map "n" 'ph-move-to-next-record)
1078 (define-key map "p" 'ph-move-to-previous-record)
1080 (set-keymap-parent ph-mode-map widget-keymap)
1082 (defconst ph-tail-menu
1084 ["Query Form" ph-query-form t]
1085 ["Expand Inline" ph-expand-inline t]
1087 ["Get Email" ph-get-email t]
1088 ["Get Phone" ph-get-phone t]
1089 ["List Valid Field Names" ph-get-field-list t]
1091 ,(cons "Customize" (cdr (custom-menu-create 'ph)))))
1093 (defconst ph-server-menu
1094 '(["---" ph-bookmark-server t]
1095 ["Bookmark Current Server" ph-bookmark-current-server t]
1096 ["New Server" ph-set-server t]))
1106 (setq command (intern (concat "ph-set-server-" server)))
1107 (if (not (fboundp command))
1108 (fset command `(lambda ()
1110 (setq ph-server ,server)
1111 (message "Selected PH/QI server is now %s" ,server))))
1112 (vector server command t)))
1117 (defun ph-install-menu ()
1120 (add-submenu '("Tools") (ph-menu)))
1122 (easy-menu-define ph-menu-map ph-mode-map "PH Menu" (ph-menu))
1127 (easy-menu-create-keymaps "Ph" (cdr (ph-menu))))))