Commit | Line | Data |
---|---|---|
43a51f78 RS |
1 | ;;; ph.el --- Client for the CCSO directory system (aka PH/QI) |
2 | ||
3 | ;; Copyright (C) 1997 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> | |
6 | ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> | |
7 | ;; Created: May 1997 | |
9fb87caf | 8 | ;; Version: 2.8 |
43a51f78 RS |
9 | ;; Keywords: help |
10 | ||
11 | ;; This file is part of GNU Emacs | |
12 | ||
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) | |
16 | ;; any later version. | |
17 | ||
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. | |
22 | ||
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. | |
27 | ||
28 | ;;; Commentary: | |
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 | |
9fb87caf | 32 | ;; used to expand email addresses in message buffers). It also |
43a51f78 RS |
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 | |
9fb87caf | 36 | ;; than 300 sites in the world. The distribution can be found at |
43a51f78 RS |
37 | ;; ftp://uiarchive.cso.uiuc.edu/pub/packages/ph Traditionally the |
38 | ;; server is called QI while the client is called PH. | |
39 | ||
40 | ;;; Installation: | |
9fb87caf | 41 | ;; This package uses the custom and widget libraries. If they are not already |
43a51f78 RS |
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: | |
44 | ;; (require 'ph) | |
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 | |
50 | ||
51 | ;; This package runs under XEmacs 19.15 or 20 and under Emacs 19.34 and above | |
52 | ||
53 | ;;; Usage: | |
54 | ;; - Provided you did the installation as proposed in the above section, | |
55 | ;; inline expansion will be available when you compose an email | |
9fb87caf | 56 | ;; message. Type the name of somebody recorded in your PH/QI server and hit |
43a51f78 RS |
57 | ;; C-c TAB, this will overwrite the name with the corresponding email |
58 | ;; address | |
59 | ;; - M-x ph-customize to customize inline expansion and other features to | |
60 | ;; your needs. | |
61 | ;; - Look for the Ph submenu in the Tools menu for more. | |
62 | ;; See the info file for details. | |
63 | ||
64 | ;;; Code: | |
65 | ||
adbbe690 RS |
66 | (eval-when-compile (require 'cl)) |
67 | ||
43a51f78 RS |
68 | (require 'wid-edit) |
69 | ||
70 | (if (not (fboundp 'make-overlay)) | |
71 | (require 'overlay)) | |
72 | ||
73 | (autoload 'custom-menu-create "cus-edit") | |
74 | ||
75 | ;;{{{ Package customization variables | |
76 | ||
77 | (defgroup ph nil | |
78 | "CCSO (PH/QI) directory system client" | |
79 | :group 'mail | |
80 | :group 'comm) | |
81 | ||
82 | (defcustom ph-server nil | |
83 | "*The name or IP address of the CCSO (PH/QI) server. | |
84 | A port number may be specified by appending a colon and a | |
85 | number to the name of the server." | |
25c49fdc RS |
86 | :type '(choice (string :tag "Server") |
87 | (const nil)) | |
43a51f78 RS |
88 | :group 'ph) |
89 | ||
90 | (defcustom ph-strict-return-matches t | |
9fb87caf | 91 | "*If non-nil, entries not containing all requested return fields are ignored." |
43a51f78 RS |
92 | :type 'boolean |
93 | :group 'ph) | |
94 | ||
95 | (defcustom ph-default-return-fields nil | |
96 | "*A list of the default fields to extract from CCSO entries. | |
97 | If it contains `all' then all available fields are returned. | |
98 | nil means return the default fields as configured in the server." | |
99 | :type '(repeat (symbol :tag "Field name")) | |
100 | :group 'ph) | |
101 | ||
102 | (defcustom ph-multiple-match-handling-method 'select | |
9fb87caf | 103 | "*What to do when multiple entries match an inline expansion query. |
43a51f78 | 104 | Possible values are: |
9fb87caf RS |
105 | `first' (equivalent to nil) which means consider the first match, |
106 | `select' pop-up a selection buffer, | |
107 | `all' use all matches, | |
108 | `abort' the operation is aborted, an error is signaled." | |
43a51f78 RS |
109 | :type '(choice :menu-tag "Method" |
110 | (const :menu-tag "First" first) | |
111 | (const :menu-tag "Select" select) | |
112 | (const :menu-tag "All" all) | |
113 | (const :menu-tag "Abort" abort) | |
114 | (const :menu-tag "None" nil)) | |
115 | :group 'ph) | |
116 | ||
117 | (defcustom ph-duplicate-fields-handling-method '((email . duplicate)) | |
118 | "*A method to handle entries containing duplicate fields. | |
119 | This is either an alist (FIELD . METHOD) or a symbol METHOD. | |
120 | The alist form of the variable associates a method to an individual field, | |
121 | the second form specifies a method applicable to all fields. | |
122 | Available methods are: | |
9fb87caf | 123 | `list' or nil lets the value of the field be a list of values, |
43a51f78 RS |
124 | `first' keeps the first value and discards the others, |
125 | `concat' concatenates the values into a single multiline string, | |
126 | `duplicate' duplicates the entire entry into as many instances as | |
127 | different values." | |
128 | :type '(choice (const :menu-tag "List" list) | |
129 | (const :menu-tag "First" first) | |
130 | (const :menu-tag "Concat" concat) | |
131 | (const :menu-tag "Duplicate" duplicate) | |
132 | (repeat :menu-tag "Per Field Specification" | |
133 | :tag "Per Field Specification" | |
134 | (cons :tag "Field/Method" | |
135 | :value (nil . list) | |
136 | (symbol :tag "Field name") | |
137 | (choice :tag "Method" | |
138 | :menu-tag "Method" | |
139 | (const :menu-tag "List" list) | |
140 | (const :menu-tag "First" first) | |
141 | (const :menu-tag "Concat" concat) | |
142 | (const :menu-tag "Duplicate" duplicate))))) | |
143 | :group 'ph | |
144 | ) | |
145 | ||
146 | (defcustom ph-inline-query-format-list nil | |
147 | "*Format of an inline expansion query. | |
148 | If the inline query string consists of several words, this list specifies | |
149 | how these individual words are associated to CCSO database field names. | |
150 | If nil all the words will be mapped onto the default CCSO database key." | |
151 | :type '(repeat (symbol :tag "Field name")) | |
152 | :group 'ph) | |
153 | ||
154 | (defcustom ph-expanding-overwrites-query t | |
9fb87caf | 155 | "*If non nil, expanding a query overwrites the query string." |
43a51f78 RS |
156 | :type 'boolean |
157 | :group 'ph) | |
158 | ||
159 | (defcustom ph-inline-expansion-format '("%s" email) | |
160 | "*A list specifying the format of the expansion of inline queries. | |
9fb87caf RS |
161 | This variable controls what `ph-expand-inline' actually inserts in the buffer. |
162 | First element is a string passed to `format'. Remaining elements are symbols | |
43a51f78 | 163 | indicating CCSO database field names, corresponding field values are passed |
9fb87caf | 164 | as additional arguments to `format'." |
43a51f78 RS |
165 | :type '(list (string :tag "Format String") |
166 | (repeat :inline t | |
167 | :tag "Field names" | |
168 | (symbol :tag ""))) | |
169 | :group 'ph) | |
170 | ||
171 | (defcustom ph-form-fields '(name email phone) | |
172 | "*A list of fields presented in the query form." | |
173 | :tag "Default Fields in Query Forms" | |
174 | :type '(repeat (symbol :tag "Field name")) | |
175 | :group 'ph) | |
176 | ||
177 | (defcustom ph-fieldname-formstring-alist '((url . "URL") | |
178 | (callsign . "HAM Call Sign") | |
179 | (id . "ID") | |
180 | (email . "E-Mail") | |
181 | (firstname . "First Name")) | |
9fb87caf RS |
182 | "*Map CCSO database field names into prompt strings for query/response. |
183 | Prompt strings for fields that are not listed here | |
184 | are derived by splitting the field name | |
43a51f78 RS |
185 | at `_' signs and capitalizing the individual words." |
186 | :tag "Mapping of Field Names onto Prompt Strings" | |
187 | :type '(repeat (cons :tag "Field" | |
188 | (symbol :tag "Name") | |
189 | (string :tag "Prompt string"))) | |
190 | :group 'ph) | |
191 | ||
192 | (defcustom ph-bbdb-conversion-alist | |
193 | '((name . name) | |
194 | (net . email) | |
195 | (address . (ph-bbdbify-address address "Address")) | |
196 | (phone . ((ph-bbdbify-phone phone "Phone") | |
197 | (ph-bbdbify-phone office_phone "Office Phone")))) | |
198 | "*A mapping from BBDB to PH/QI fields. | |
199 | This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where | |
200 | BBDB-FIELD is the name of a field that must be defined in your BBDB | |
201 | environment (standard field names are `name', `company', `net', `phone', | |
202 | `address' and `notes'). SPEC-OR-LIST is either a single SPEC or a list | |
9fb87caf | 203 | of SPECs. Lists of specs are valid only for the `phone' and `address' |
43a51f78 | 204 | BBDB fields. SPECs are sexps which are evaluated: |
9fb87caf RS |
205 | a string evaluates to itself, |
206 | a symbol evaluates to the symbol value. Symbols naming PH/QI fields | |
207 | present in the record evaluate to the value of the field in the record, | |
208 | a form is evaluated as a function. The argument list may contain PH/QI | |
43a51f78 | 209 | field names which eval to the corresponding values in the |
9fb87caf RS |
210 | record. The form evaluation should return something appropriate for |
211 | the particular BBDB-FIELD (see `bbdb-create-internal'). | |
212 | `ph-bbdbify-phone' and `ph-bbdbify-address' are provided as convenience | |
43a51f78 RS |
213 | functions to parse phones and addresses." |
214 | :tag "BBDB to CCSO Field Name Mapping" | |
215 | :type '(repeat (cons :tag "Field Name" | |
216 | (symbol :tag "BBDB Field") | |
217 | (sexp :tag "Conversion Spec"))) | |
218 | :group 'ph) | |
219 | ||
220 | (defcustom ph-options-file "~/.ph-options" | |
9fb87caf | 221 | "*A file where the PH `servers' hotlist is stored." |
43a51f78 RS |
222 | :type '(file :Tag "File Name:")) |
223 | ||
224 | (defcustom ph-mode-hook nil | |
9fb87caf | 225 | "*Normal hook run on entry to PH mode." |
43a51f78 RS |
226 | :type '(repeat (sexp :tag "Hook"))) |
227 | ||
228 | ;;}}} | |
229 | ||
230 | ||
231 | ;;{{{ Internal cooking | |
232 | ||
233 | ||
234 | (defconst ph-xemacs-p (string-match "XEmacs" emacs-version)) | |
235 | (defconst ph-emacs-p (not ph-xemacs-p)) | |
236 | (defconst ph-xemacs-mule-p (and ph-xemacs-p | |
237 | (featurep 'mule))) | |
238 | (defconst ph-emacs-mule-p (and ph-emacs-p | |
239 | (featurep 'mule))) | |
240 | ||
241 | (defvar ph-server-hotlist nil) | |
242 | ||
243 | (defconst ph-default-server-port 105 | |
9fb87caf | 244 | "Default TCP port for CCSO directory services.") |
43a51f78 RS |
245 | |
246 | (defvar ph-form-widget-list nil) | |
247 | (defvar ph-process-buffer nil) | |
248 | (defvar ph-read-point) | |
249 | ||
250 | ;;; Load the options file | |
251 | (if (and (and (locate-library ph-options-file) | |
252 | (message "")) ; Remove modeline message | |
253 | (not (featurep 'ph-options-file))) | |
254 | (load ph-options-file)) | |
255 | ||
e865033e RS |
256 | (defun ph-cadr (obj) |
257 | (car (cadr obj))) | |
258 | ||
259 | (defun ph-cdar (obj) | |
260 | (cdr (car obj))) | |
261 | ||
43a51f78 RS |
262 | (defun ph-mode () |
263 | "Major mode used in buffers displaying the results of PH queries. | |
264 | There is no sense in calling this command from a buffer other than | |
265 | one containing the results of a PH query. | |
266 | ||
9fb87caf RS |
267 | These are the special commands of PH mode: |
268 | q -- kill this buffer. | |
269 | f -- Display a form to query the CCSO PH/QI nameserver. | |
270 | n -- Move to next record. | |
271 | p -- Move to previous record." | |
43a51f78 RS |
272 | (interactive) |
273 | (kill-all-local-variables) | |
274 | (setq major-mode 'ph-mode) | |
275 | (setq mode-name "PH") | |
276 | (use-local-map ph-mode-map) | |
277 | (setq mode-popup-menu (ph-menu)) | |
278 | (run-hooks 'ph-mode-hook) | |
279 | ) | |
280 | ||
281 | (defun ph-display-records (records &optional raw-field-names) | |
282 | "Display the record list RECORDS in a formatted buffer. | |
9fb87caf RS |
283 | If RAW-FIELD-NAMES is non-nil, the raw field names are displayed |
284 | otherwise they are formatted according to `ph-fieldname-formstring-alist'." | |
43a51f78 RS |
285 | (let ((buffer (get-buffer-create "*PH Query Results*")) |
286 | inhibit-read-only | |
287 | precords | |
288 | (width 0) | |
289 | beg field-beg | |
290 | field-name) | |
291 | (switch-to-buffer buffer) | |
292 | (setq buffer-read-only t) | |
293 | (setq inhibit-read-only t) | |
294 | (erase-buffer) | |
295 | (insert "PH Query Result\n") | |
296 | (insert "===============\n\n\n") | |
297 | (if (null records) | |
298 | (insert "No match found.\n" | |
299 | (if ph-strict-return-matches | |
300 | "Try setting ph-strict-return-matches to nil or change ph-default-return-fields." | |
301 | "")) | |
302 | ;; Replace field names with prompt strings, compute prompt max width | |
303 | (setq precords | |
304 | (mapcar | |
305 | (function | |
306 | (lambda (record) | |
307 | (mapcar | |
308 | (function | |
309 | (lambda (field) | |
310 | (setq field-name (if raw-field-names | |
311 | (symbol-name (car field)) | |
312 | (or (and (assq (car field) ph-fieldname-formstring-alist) | |
313 | (cdr (assq (car field) ph-fieldname-formstring-alist))) | |
314 | (capitalize (mapconcat '(lambda (char) | |
315 | (if (eq char ?_) | |
316 | " " | |
317 | (char-to-string char))) | |
318 | (symbol-name (car field)) | |
319 | ""))))) | |
320 | (if (> (length field-name) width) | |
321 | (setq width (length field-name))) | |
322 | (cons field-name (cdr field)))) | |
323 | record))) | |
324 | records)) | |
325 | (mapcar (function | |
326 | (lambda (record) | |
327 | (setq beg (point)) | |
328 | ;; Actually insert the field/value pairs | |
329 | (mapcar (function | |
330 | (lambda (field) | |
331 | (setq field-beg (point)) | |
332 | (insert (format (concat "%" width "s: ") (car field))) | |
333 | (put-text-property field-beg (point) 'face 'bold) | |
334 | (mapcar (function | |
335 | (lambda (val) | |
336 | (indent-to (+ 2 width)) | |
337 | (insert val "\n"))) | |
338 | (if (stringp (cdr field)) | |
339 | (split-string (cdr field) "\n") | |
340 | (cdr field))))) | |
341 | record) | |
342 | ;; Store the record internal format in some convenient place | |
343 | (overlay-put (make-overlay beg (point)) | |
344 | 'ph-record | |
345 | (car records)) | |
346 | (setq records (cdr records)) | |
347 | (insert "\n"))) | |
348 | precords)) | |
349 | (insert "\n") | |
350 | (widget-create 'push-button | |
351 | :notify (lambda (&rest ignore) | |
352 | (ph-query-form)) | |
353 | "New query") | |
354 | (widget-insert " ") | |
355 | (widget-create 'push-button | |
356 | :notify (lambda (&rest ignore) | |
357 | (kill-this-buffer)) | |
358 | "Quit") | |
359 | (ph-mode) | |
360 | (widget-setup) | |
361 | ) | |
362 | ) | |
363 | ||
364 | (defun ph-process-form () | |
9fb87caf | 365 | "Process the form in current buffer and display the results." |
43a51f78 RS |
366 | (let (query-alist |
367 | value) | |
368 | (if (not (and (boundp 'ph-form-widget-list) | |
369 | ph-form-widget-list)) | |
370 | (error "Not in a PH query form buffer") | |
371 | (mapcar (function | |
372 | (lambda (wid-field) | |
373 | (setq value (widget-value (cdr wid-field))) | |
374 | (if (not (string= value "")) | |
375 | (setq query-alist (cons (cons (car wid-field) value) | |
376 | query-alist))))) | |
377 | ph-form-widget-list) | |
378 | (kill-buffer (current-buffer)) | |
379 | (ph-display-records (ph-query-internal query-alist)) | |
380 | ))) | |
381 | ||
382 | ||
383 | (defun ph-query-internal (query &optional return-fields) | |
384 | "Query the PH/QI server with QUERY. | |
385 | QUERY can be a string NAME or a list made of strings NAME | |
386 | and/or cons cells (KEY . VALUE) where KEYs should be valid | |
9fb87caf RS |
387 | CCSO database keys. NAME is equivalent to (DEFAULT . NAME), |
388 | where DEFAULT is the default key of the database. | |
389 | RETURN-FIELDS is a list of database fields to return, | |
390 | defaulting to `ph-default-return-fields'." | |
43a51f78 RS |
391 | (let (request) |
392 | (if (null return-fields) | |
393 | (setq return-fields ph-default-return-fields)) | |
394 | (setq request | |
395 | (concat "query " | |
396 | (if (stringp query) | |
397 | query | |
398 | (mapconcat (function (lambda (elt) | |
399 | (if (stringp elt) elt) | |
400 | (format "%s=%s" (car elt) (cdr elt)))) | |
401 | query | |
402 | " ")) | |
403 | (if return-fields | |
404 | (concat " return " (mapconcat 'symbol-name return-fields " "))))) | |
405 | (and (> (length request) 6) | |
406 | (ph-do-request request) | |
407 | (ph-parse-query-result return-fields)))) | |
408 | ||
409 | (defun ph-parse-query-result (&optional fields) | |
9fb87caf | 410 | "Return a list of alists of key/values from in `ph-process-buffer'. |
43a51f78 | 411 | Fields not in FIELDS are discarded." |
9fb87caf RS |
412 | (let (record |
413 | records | |
414 | line-regexp | |
415 | current-key | |
416 | key | |
417 | value | |
418 | ignore) | |
43a51f78 RS |
419 | (save-excursion |
420 | (message "Parsing results...") | |
421 | (set-buffer ph-process-buffer) | |
422 | (goto-char (point-min)) | |
423 | (while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t) | |
424 | (catch 'ignore | |
425 | (setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$")) | |
426 | (beginning-of-line) | |
427 | (setq record nil | |
428 | ignore nil | |
429 | current-key nil) | |
430 | (while (re-search-forward line-regexp nil t) | |
431 | (catch 'skip-line | |
432 | (if (string= "-508" (match-string 1)) | |
9fb87caf | 433 | ;; A field is missing in this entry. Skip it or skip the |
43a51f78 RS |
434 | ;; whole record (see ph-strict-return-matches) |
435 | (if (not ph-strict-return-matches) | |
436 | (throw 'skip-line t) | |
437 | (while (re-search-forward line-regexp nil t)) | |
438 | (setq ignore t) | |
439 | (throw 'ignore t))) | |
440 | (setq key (and (not (string= (match-string 2) "")) | |
441 | (intern (match-string 2))) | |
442 | value (match-string 3)) | |
443 | (if (and current-key | |
444 | (eq key current-key)) | |
445 | (setq key nil) | |
446 | (setq current-key key)) | |
447 | (if (or (null fields) | |
448 | (memq 'all fields) | |
449 | (memq current-key fields)) | |
450 | (if key | |
451 | (setq record (cons (cons key value) record)) ; New key | |
e865033e RS |
452 | (setcdr (car record) (if (listp (ph-cdar record)) |
453 | (append (ph-cdar record) (list value)) | |
454 | (list (ph-cdar record) value)))))))) | |
43a51f78 RS |
455 | (and (not ignore) |
456 | (or (null fields) | |
457 | (memq 'all fields) | |
458 | (setq record (nreverse record))) | |
459 | (setq record (if (not (eq 'list ph-duplicate-fields-handling-method)) | |
460 | (ph-filter-duplicate-fields record) | |
461 | (list record))) | |
462 | (setq records (append record records)))) | |
463 | ) | |
464 | (message "Done") | |
465 | records) | |
466 | ) | |
467 | ||
468 | (defun ph-filter-duplicate-fields (record) | |
9fb87caf | 469 | "Filter RECORD according to `ph-duplicate-fields-handling-method'." |
43a51f78 RS |
470 | (let ((rec record) |
471 | unique | |
472 | duplicates | |
473 | result) | |
474 | ||
475 | ;; Search for multiple records | |
476 | (while (and rec | |
e865033e | 477 | (not (listp (ph-cdar rec)))) |
43a51f78 RS |
478 | (setq rec (cdr rec))) |
479 | ||
e865033e | 480 | (if (null (ph-cdar rec)) |
43a51f78 RS |
481 | (list record) ; No duplicate fields in this record |
482 | (mapcar (function | |
483 | (lambda (field) | |
484 | (if (listp (cdr field)) | |
485 | (setq duplicates (cons field duplicates)) | |
486 | (setq unique (cons field unique))))) | |
487 | record) | |
488 | (setq result (list unique)) | |
489 | (mapcar (function | |
490 | (lambda (field) | |
491 | (let ((method (if (consp ph-duplicate-fields-handling-method) | |
492 | (cdr (assq (car field) ph-duplicate-fields-handling-method)) | |
493 | ph-duplicate-fields-handling-method))) | |
494 | (cond | |
495 | ((or (null method) (eq 'list method)) | |
496 | (setq result | |
497 | (ph-add-field-to-records field result))) | |
498 | ((eq 'first method) | |
499 | (setq result | |
e865033e | 500 | (ph-add-field-to-records (cons (car field) (ph-cadr field)) result))) |
43a51f78 RS |
501 | ((eq 'concat method) |
502 | (setq result | |
503 | (ph-add-field-to-records (cons (car field) | |
504 | (mapconcat | |
505 | 'identity | |
506 | (cdr field) | |
507 | "\n")) result))) | |
508 | ((eq 'duplicate method) | |
509 | (setq result | |
510 | (ph-distribute-field-on-records field result))))))) | |
511 | duplicates) | |
512 | result))) | |
513 | ||
514 | (defun ph-add-field-to-records (field records) | |
515 | "Add FIELD to each individual record in RECORDS and return the resulting list." | |
516 | (mapcar (function | |
517 | (lambda (r) | |
518 | (cons field r))) | |
519 | records)) | |
520 | ||
521 | (defun ph-distribute-field-on-records (field records) | |
522 | "Duplicate each individual record in RECORDS according to value of FIELD. | |
523 | Each copy is added a new field containing one of the values of FIELD." | |
524 | (let (result | |
525 | (values (cdr field))) | |
526 | ;; Uniquify values first | |
527 | (while values | |
528 | (setcdr values (delete (car values) (cdr values))) | |
529 | (setq values (cdr values))) | |
530 | (mapcar (function | |
531 | (lambda (value) | |
532 | (let ((result-list (copy-sequence records))) | |
533 | (setq result-list (ph-add-field-to-records (cons (car field) value) | |
534 | result-list)) | |
535 | (setq result (append result-list result)) | |
536 | ))) | |
537 | (cdr field)) | |
538 | result) | |
539 | ) | |
540 | ||
541 | (defun ph-do-request (request) | |
542 | "Send REQUEST to the server. | |
543 | Wait for response and return the buffer containing it." | |
544 | (let (process | |
545 | buffer) | |
546 | (unwind-protect | |
547 | (progn | |
548 | (message "Contacting server...") | |
549 | (setq process (ph-open-session)) | |
550 | (if process | |
551 | (save-excursion | |
552 | (set-buffer (setq buffer (process-buffer process))) | |
553 | (ph-send-command process request) | |
554 | (message "Request sent, waiting for reply...") | |
555 | (ph-read-response process)))) | |
556 | (if process | |
557 | (ph-close-session process))) | |
558 | buffer)) | |
559 | ||
560 | (defun ph-open-session (&optional server) | |
561 | "Open a connection to the given CCSO SERVER. | |
562 | SERVER is either a string naming the server or a list (NAME PORT)." | |
563 | (let (process | |
564 | host | |
565 | port) | |
566 | (catch 'done | |
567 | (if (null server) | |
568 | (setq server (or ph-server | |
569 | (call-interactively 'ph-set-server)))) | |
570 | (string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server) | |
571 | (setq host (match-string 1 server)) | |
572 | (setq port (or (match-string 3 server) | |
573 | ph-default-server-port)) | |
574 | (setq ph-process-buffer (get-buffer-create (format " *PH-%s*" host))) | |
575 | (save-excursion | |
576 | (set-buffer ph-process-buffer) | |
577 | (erase-buffer) | |
578 | (setq ph-read-point (point)) | |
579 | (and ph-xemacs-mule-p | |
580 | (set-buffer-file-coding-system 'binary t))) | |
581 | (setq process (open-network-stream "ph" ph-process-buffer host port)) | |
582 | (if (null process) | |
583 | (throw 'done nil)) | |
584 | (process-kill-without-query process) | |
585 | process))) | |
586 | ||
587 | ||
588 | (defun ph-close-session (process) | |
589 | (save-excursion | |
590 | (set-buffer (process-buffer process)) | |
591 | (ph-send-command process "quit") | |
592 | (ph-read-response process) | |
593 | (if (fboundp 'add-async-timeout) | |
594 | (add-async-timeout 10 'delete-process process) | |
595 | (run-at-time 2 nil 'delete-process process)))) | |
596 | ||
597 | (defun ph-send-command (process command) | |
598 | (goto-char (point-max)) | |
599 | (process-send-string process command) | |
600 | (process-send-string process "\r\n") | |
601 | ) | |
602 | ||
603 | (defun ph-read-response (process &optional return-response) | |
604 | "Read a response from the PH/QI query process PROCESS. | |
9fb87caf | 605 | Returns nil if response starts with an error code. If the |
43a51f78 | 606 | response is successful the return code or the reponse itself is returned |
9fb87caf | 607 | depending on RETURN-RESPONSE." |
43a51f78 RS |
608 | (let ((case-fold-search nil) |
609 | return-code | |
610 | match-end) | |
611 | (goto-char ph-read-point) | |
612 | ;; CCSO protocol : response complete if status >= 200 | |
613 | (while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t)) | |
614 | (accept-process-output process) | |
615 | (goto-char ph-read-point)) | |
616 | (setq match-end (point)) | |
617 | (goto-char ph-read-point) | |
618 | (if (and (setq return-code (match-string 1)) | |
619 | (setq return-code (string-to-number return-code)) | |
620 | (>= (abs return-code) 300)) | |
621 | (progn (setq ph-read-point match-end) nil) | |
622 | (setq ph-read-point match-end) | |
623 | (if return-response | |
624 | (buffer-substring (point) match-end) | |
625 | return-code)))) | |
626 | ||
627 | (defun ph-create-bbdb-record (record) | |
628 | "Create a BBDB record using the RECORD alist. | |
629 | RECORD is an alist of (KEY . VALUE) where KEY is a symbol naming a field | |
9fb87caf | 630 | of the PH/QI database and VALUE is the corresponding value for the record." |
43a51f78 RS |
631 | ;; This function runs in a special context where lisp symbols corresponding |
632 | ;; to field names in record are bound to the corresponding values | |
633 | (eval | |
634 | `(let* (,@(mapcar '(lambda (c) | |
635 | (list (car c) (if (listp (cdr c)) | |
636 | (list 'quote (cdr c)) | |
637 | (cdr c)))) | |
638 | record) | |
639 | bbdb-name | |
640 | bbdb-company | |
641 | bbdb-net | |
642 | bbdb-address | |
643 | bbdb-phones | |
644 | bbdb-notes | |
645 | spec | |
646 | bbdb-record | |
647 | value) | |
648 | ||
649 | ;; BBDB standard fields | |
650 | (setq bbdb-name (ph-parse-spec (cdr (assq 'name ph-bbdb-conversion-alist)) record nil) | |
651 | bbdb-company (ph-parse-spec (cdr (assq 'company ph-bbdb-conversion-alist)) record nil) | |
652 | bbdb-net (ph-parse-spec (cdr (assq 'net ph-bbdb-conversion-alist)) record nil) | |
653 | bbdb-notes (ph-parse-spec (cdr (assq 'notes ph-bbdb-conversion-alist)) record nil)) | |
654 | (setq spec (cdr (assq 'address ph-bbdb-conversion-alist))) | |
655 | (setq bbdb-address (delq nil (ph-parse-spec (if (listp (car spec)) | |
656 | spec | |
657 | (list spec)) | |
658 | record t))) | |
659 | (setq spec (cdr (assq 'phone ph-bbdb-conversion-alist))) | |
660 | (setq bbdb-phones (delq nil (ph-parse-spec (if (listp (car spec)) | |
661 | spec | |
662 | (list spec)) | |
663 | record t))) | |
664 | ;; BBDB custom fields | |
665 | (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes))) | |
666 | (mapcar (function | |
667 | (lambda (mapping) | |
668 | (if (and (not (memq (car mapping) | |
669 | '(name company net address phone notes))) | |
670 | (setq value (ph-parse-spec (cdr mapping) record nil))) | |
671 | (cons (car mapping) value)))) | |
672 | ph-bbdb-conversion-alist))) | |
673 | (setq bbdb-notes (delq nil bbdb-notes)) | |
674 | (setq bbdb-record (bbdb-create-internal bbdb-name | |
675 | bbdb-company | |
676 | bbdb-net | |
677 | bbdb-address | |
678 | bbdb-phones | |
679 | bbdb-notes)) | |
680 | ||
681 | (bbdb-display-records (list bbdb-record)) | |
682 | ))) | |
683 | ||
684 | (defun ph-parse-spec (spec record recurse) | |
9fb87caf RS |
685 | "Parse the conversion SPEC using RECORD. |
686 | If RECURSE is non-nil then SPEC may be a list of atomic specs." | |
43a51f78 RS |
687 | (cond |
688 | ((or (stringp spec) | |
689 | (symbolp spec) | |
690 | (and (listp spec) | |
691 | (symbolp (car spec)) | |
692 | (fboundp (car spec)))) | |
693 | (condition-case nil | |
694 | (eval spec) | |
695 | (void-variable nil))) | |
696 | ((and recurse | |
697 | (listp spec)) | |
698 | (mapcar '(lambda (spec-elem) | |
699 | (ph-parse-spec spec-elem record nil)) | |
700 | spec)) | |
701 | (t | |
9fb87caf | 702 | (error "Invalid specification for `%s' in `ph-bbdb-conversion-alist'" spec)))) |
43a51f78 RS |
703 | |
704 | (defun ph-bbdbify-address (addr location) | |
9fb87caf | 705 | "Parse ADDR into a vector compatible with BBDB. |
43a51f78 | 706 | ADDR should be an address string of no more than four lines or a |
9fb87caf | 707 | list of lines. |
43a51f78 | 708 | The last line is searched for the zip code, city and state name. |
e865033e | 709 | LOCATION is used as the address location for bbdb." |
43a51f78 RS |
710 | (let* ((addr-components (if (listp addr) |
711 | (reverse addr) | |
712 | (reverse (split-string addr "\n")))) | |
713 | (lastl (pop addr-components)) | |
714 | zip city state) | |
715 | (setq addr-components (nreverse addr-components)) | |
716 | (cond | |
717 | ;; American style | |
718 | ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" lastl) | |
719 | (setq city (match-string 1 lastl) | |
720 | state (match-string 2 lastl) | |
721 | zip (string-to-number (match-string 3 lastl)))) | |
722 | ;; European style | |
723 | ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" lastl) | |
724 | (setq city (match-string 2 lastl) | |
725 | zip (string-to-number (match-string 1 lastl)))) | |
726 | (t | |
9fb87caf | 727 | (error "Cannot parse the address; see `ph-bbdb-conversion-alist'"))) |
43a51f78 RS |
728 | (vector location |
729 | (or (nth 0 addr-components) "") | |
730 | (or (nth 1 addr-components) "") | |
731 | (or (nth 2 addr-components) "") | |
732 | (or city "") | |
733 | (or state "") | |
734 | zip))) | |
735 | ||
736 | (defun ph-bbdbify-phone (phone location) | |
9fb87caf | 737 | "Parse PHONE into a vector compatible with BBDB. |
43a51f78 RS |
738 | PHONE is either a string supposedly containing a phone number or |
739 | a list of such strings which are concatenated. | |
9fb87caf | 740 | LOCATION is used as the phone location for bbdb." |
43a51f78 RS |
741 | (cond |
742 | ((stringp phone) | |
743 | (let (phone-list) | |
744 | (condition-case err | |
745 | (setq phone-list (bbdb-parse-phone-number phone)) | |
746 | (error | |
e865033e | 747 | (if (string= "phone number unparsable." (ph-cadr err)) |
9fb87caf RS |
748 | (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone))) |
749 | (error "Phone number unparsable") | |
43a51f78 RS |
750 | (setq phone-list (list (bbdb-string-trim phone)))) |
751 | (signal (car err) (cdr err))))) | |
752 | (if (= 3 (length phone-list)) | |
753 | (setq phone-list (append phone-list '(nil)))) | |
754 | (apply 'vector location phone-list))) | |
755 | ((listp phone) | |
756 | (vector location (mapconcat 'identity phone ", "))) | |
757 | (t | |
9fb87caf | 758 | (error "Invalid phone specification")))) |
43a51f78 RS |
759 | |
760 | ;;}}} | |
761 | ||
762 | ;;{{{ High-level interfaces (interactive functions) | |
763 | ||
764 | (defun ph-customize () | |
765 | "Customize the PH package." | |
766 | (interactive) | |
767 | (customize-group 'ph)) | |
768 | ||
769 | (defun ph-set-server (server) | |
9fb87caf | 770 | "Set the PH server to SERVER." |
43a51f78 RS |
771 | (interactive "sNew PH/QI Server: ") |
772 | (message "Selected PH/QI server is now %s" server) | |
773 | (setq ph-server server)) | |
774 | ||
775 | ;;;###autoload | |
776 | (defun ph-get-email (name) | |
777 | "Get the email field of NAME from the PH/QI directory server." | |
778 | (interactive "sName: ") | |
779 | (let ((email (cdaar (ph-query-internal name '(email))))) | |
780 | (if (interactive-p) | |
781 | (if email | |
782 | (message "%s" email) | |
783 | (message "No record matching %s" name))) | |
784 | email)) | |
785 | ||
786 | ;;;###autoload | |
787 | (defun ph-get-phone (name) | |
788 | "Get the phone field of NAME from the PH/QI directory server." | |
789 | (interactive "sName: ") | |
790 | (let ((phone (cdaar (ph-query-internal name '(phone))))) | |
791 | (if (interactive-p) | |
792 | (if phone | |
793 | (message "%s" phone) | |
794 | (message "No record matching %s" name))) | |
795 | phone)) | |
796 | ||
797 | (defun ph-get-field-list () | |
798 | "Return a list of valid field names for current server. | |
799 | When called interactively the list is formatted in a dedicated buffer | |
800 | otherwise a list of symbols is returned." | |
801 | (interactive) | |
802 | (ph-do-request "fields") | |
803 | (if (interactive-p) | |
804 | (let ((ph-duplicate-fields-handling-method 'list)) | |
805 | (ph-display-records (ph-parse-query-result) t)) | |
806 | (mapcar 'caar | |
807 | (ph-parse-query-result))) | |
808 | ) | |
809 | ||
810 | ;;;###autoload | |
811 | (defun ph-expand-inline (&optional replace) | |
9fb87caf | 812 | "Query the PH server, and expand the query string before point. |
43a51f78 | 813 | The query string consists of the buffer substring from the point back to |
9fb87caf RS |
814 | the preceding comma, colon or beginning of line. If it contains more than |
815 | one word, the variable `ph-inline-query-format-list' controls to map these | |
43a51f78 RS |
816 | onto CCSO database field names. |
817 | After querying the server for the given string, the expansion specified by | |
9fb87caf RS |
818 | `ph-inline-expansion-format' is inserted in the buffer at point. |
819 | If REPLACE is t, then this expansion replaces the name in the buffer. | |
820 | If `ph-expanding-overwrites-query' is t, that inverts the meaning of REPLACE." | |
43a51f78 RS |
821 | (interactive) |
822 | (let* ((end (point)) | |
823 | (beg (save-excursion | |
824 | (if (re-search-backward "[:,][ \t]*" | |
825 | (save-excursion | |
826 | (beginning-of-line) | |
827 | (point)) | |
828 | 'move) | |
829 | (goto-char (match-end 0))) | |
830 | (point))) | |
831 | (words (buffer-substring beg end)) | |
832 | query | |
833 | query-alist | |
834 | (query-format ph-inline-query-format-list) | |
835 | response | |
836 | response-strings | |
837 | key val cell) | |
838 | ||
839 | ;; Prepare the query | |
840 | (if (or (not query-format) | |
841 | (not (string-match "[ \t]+" words))) | |
842 | (setq query words) | |
843 | (setq words (split-string words "[ \t]+")) | |
844 | (while (and words query-format) | |
845 | (setq query-alist (cons (cons (car query-format) (car words)) query-alist)) | |
846 | (setq words (cdr words) | |
847 | query-format (cdr query-format))) | |
848 | (if words | |
849 | (setcdr (car query-alist) | |
e865033e | 850 | (concat (ph-cdar query-alist) " " |
43a51f78 RS |
851 | (mapconcat 'identity words " ")))) |
852 | ;; Uniquify query-alist | |
853 | (setq query-alist (nreverse query-alist)) | |
854 | (while query-alist | |
855 | (setq key (caar query-alist) | |
e865033e | 856 | val (ph-cdar query-alist) |
43a51f78 RS |
857 | cell (assq key query)) |
858 | (if cell | |
859 | (setcdr cell (concat val " " (cdr cell))) | |
860 | (setq query (cons (car query-alist) query)))) | |
861 | (setq query-alist (cdr query-alist))) | |
862 | ||
863 | (setq response (ph-query-internal query (cdr ph-inline-expansion-format))) | |
864 | ||
865 | (if (null response) | |
866 | (error "No match found") | |
867 | ||
868 | ;; Process response through ph-inline-expansion-format | |
869 | (while response | |
870 | (setq response-strings | |
871 | (cons (apply 'format | |
872 | (car ph-inline-expansion-format) | |
873 | (mapcar (function | |
874 | (lambda (field) | |
875 | (or (cdr (assq field (car response))) | |
876 | ""))) | |
877 | (cdr ph-inline-expansion-format))) | |
878 | response-strings)) | |
879 | (setq response (cdr response))) | |
880 | ||
881 | (if (or | |
882 | (and replace (not ph-expanding-overwrites-query)) | |
883 | (and (not replace) ph-expanding-overwrites-query)) | |
884 | (delete-region beg end)) | |
885 | (cond | |
886 | ((or (= (length response-strings) 1) | |
887 | (null ph-multiple-match-handling-method) | |
888 | (eq ph-multiple-match-handling-method 'first)) | |
889 | (insert (car response-strings))) | |
890 | ((eq ph-multiple-match-handling-method 'select) | |
891 | (with-output-to-temp-buffer "*Completions*" | |
892 | (display-completion-list response-strings))) | |
893 | ((eq ph-multiple-match-handling-method 'all) | |
894 | (insert (mapconcat 'identity response-strings ", "))) | |
895 | ((eq ph-multiple-match-handling-method 'abort) | |
896 | (error "There is more than one match for the query")) | |
897 | )) | |
898 | ) | |
899 | ) | |
900 | ||
901 | ;;;###autoload | |
902 | (defun ph-query-form (&optional get-fields-from-server) | |
9fb87caf | 903 | "Display a form to query the CCSO PH/QI nameserver. |
43a51f78 RS |
904 | If given a non-nil argument the function first queries the server |
905 | for the existing fields and displays a corresponding form." | |
906 | (interactive "P") | |
907 | (let ((fields (or (and get-fields-from-server | |
908 | (ph-get-field-list)) | |
909 | ph-form-fields)) | |
910 | (buffer (get-buffer-create "*PH/QI Query Form*")) | |
911 | field-name | |
912 | widget | |
913 | (width 0) | |
914 | inhibit-read-only | |
915 | pt) | |
916 | (switch-to-buffer buffer) | |
917 | (setq inhibit-read-only t) | |
918 | (erase-buffer) | |
919 | (kill-all-local-variables) | |
920 | (make-local-variable 'ph-form-widget-list) | |
921 | (widget-insert "PH/QI Query Form\n") | |
922 | (widget-insert "================\n\n") | |
923 | (widget-insert "Current server is: " (or ph-server | |
924 | (call-interactively 'ph-set-server)) "\n") | |
925 | ;; Loop over prompt strings to find the biggest one | |
926 | (setq fields | |
927 | (mapcar (function | |
928 | (lambda (field) | |
929 | (setq field-name (or (and (assq field ph-fieldname-formstring-alist) | |
930 | (cdr (assq field ph-fieldname-formstring-alist))) | |
931 | (capitalize (symbol-name field)))) | |
932 | (if (> (length field-name) width) | |
933 | (setq width (length field-name))) | |
934 | (cons field field-name))) | |
935 | fields)) | |
936 | ;; Insert the first widget out of the mapcar to leave the cursor | |
937 | ;; in the first field | |
938 | (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr (car fields)))) | |
939 | (setq pt (point)) | |
940 | (setq widget (widget-create 'editable-field :size 15)) | |
941 | (setq ph-form-widget-list (cons (cons (car (car fields)) widget) | |
942 | ph-form-widget-list)) | |
943 | (setq fields (cdr fields)) | |
944 | (mapcar (function | |
945 | (lambda (field) | |
946 | (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr field))) | |
947 | (setq widget (widget-create 'editable-field | |
948 | :size 15)) | |
949 | (setq ph-form-widget-list (cons (cons (car field) widget) | |
950 | ph-form-widget-list)))) | |
951 | fields) | |
952 | (widget-insert "\n\n") | |
953 | (widget-create 'push-button | |
954 | :notify (lambda (&rest ignore) | |
955 | (ph-process-form)) | |
956 | "Query Server") | |
957 | (widget-insert " ") | |
958 | (widget-create 'push-button | |
959 | :notify (lambda (&rest ignore) | |
960 | (ph-query-form)) | |
961 | "Reset Form") | |
962 | (widget-insert " ") | |
963 | (widget-create 'push-button | |
964 | :notify (lambda (&rest ignore) | |
965 | (kill-this-buffer)) | |
966 | "Quit") | |
967 | (goto-char (1+ pt)) ; 1+ for some extent boundary reason | |
968 | (use-local-map widget-keymap) | |
969 | (widget-setup)) | |
970 | ) | |
971 | ||
972 | (defun ph-bookmark-server (server) | |
9fb87caf RS |
973 | "Add SERVER to the PH `servers' hotlist." |
974 | (interactive "sPH server: ") | |
43a51f78 RS |
975 | (if (member server ph-server-hotlist) |
976 | (error "%s is already in the hotlist" server) | |
977 | (setq ph-server-hotlist (cons server ph-server-hotlist)) | |
978 | (ph-install-menu) | |
979 | (ph-save-options))) | |
980 | ||
981 | (defun ph-bookmark-current-server () | |
9fb87caf | 982 | "Add current server to the PH `servers' hotlist." |
43a51f78 RS |
983 | (interactive) |
984 | (ph-bookmark-server ph-server)) | |
985 | ||
986 | (defun ph-save-options () | |
9fb87caf | 987 | "Save options (essentially the hotlist) to `ph-options-file'." |
43a51f78 RS |
988 | (interactive) |
989 | (save-excursion | |
990 | (set-buffer (find-file-noselect ph-options-file t)) | |
991 | ;; delete the previous setq | |
992 | (let ((standard-output (current-buffer)) | |
993 | provide-p | |
994 | setq-p) | |
995 | (catch 'found | |
996 | (while t | |
997 | (let ((sexp (condition-case nil | |
998 | (read (current-buffer)) | |
999 | (end-of-file (throw 'found nil))))) | |
1000 | (if (listp sexp) | |
1001 | (progn | |
1002 | (if (and (eq (car sexp) 'setq) | |
e865033e | 1003 | (eq (ph-cadr sexp) 'ph-server-hotlist)) |
43a51f78 RS |
1004 | (progn |
1005 | (delete-region (save-excursion | |
1006 | (backward-sexp) | |
1007 | (point)) | |
1008 | (point)) | |
1009 | (setq setq-p t))) | |
1010 | (if (and (eq (car sexp) 'provide) | |
e865033e | 1011 | (equal (ph-cadr sexp) '(quote ph-options-file))) |
43a51f78 RS |
1012 | (setq provide-p t)) |
1013 | (if (and provide-p | |
1014 | setq-p) | |
1015 | (throw 'found t))))))) | |
1016 | (if (eq (point-min) (point-max)) | |
1017 | (princ ";; This file was automatically generated by ph.el\n\n")) | |
1018 | (if (not (bolp)) | |
1019 | (princ "\n")) | |
1020 | (princ "(setq ph-server-hotlist '") | |
1021 | (prin1 ph-server-hotlist) | |
1022 | (princ ")\n") | |
1023 | (if (not provide-p) | |
1024 | (princ "(provide 'ph-options-file)\n")) | |
1025 | (save-buffer))) | |
1026 | ) | |
1027 | ||
1028 | (defun ph-insert-record-at-point-into-bbdb () | |
1029 | "Insert record at point into the BBDB database. | |
1030 | This function can only be called from a PH/QI query result buffer." | |
1031 | (interactive) | |
1032 | (let ((record (and (overlays-at (point)) | |
1033 | (overlay-get (car (overlays-at (point))) 'ph-record)))) | |
1034 | (if (null record) | |
e865033e | 1035 | (error "Point is not over a record") |
43a51f78 RS |
1036 | (ph-create-bbdb-record record)))) |
1037 | ||
1038 | (defun ph-try-bbdb-insert () | |
9fb87caf | 1039 | "Call `ph-insert-record-at-point-into-bbdb' if on a record." |
43a51f78 RS |
1040 | (interactive) |
1041 | (and (or (featurep 'bbdb) | |
1042 | (prog1 (locate-library "bbdb") (message ""))) | |
1043 | (overlays-at (point)) | |
1044 | (overlay-get (car (overlays-at (point))) 'ph-record) | |
1045 | (ph-insert-record-at-point-into-bbdb))) | |
1046 | ||
1047 | (defun ph-move-to-next-record () | |
9fb87caf | 1048 | "Move to next record, in a buffer displaying PH query results." |
43a51f78 RS |
1049 | (interactive) |
1050 | (if (not (eq major-mode 'ph-mode)) | |
1051 | (error "Not in a PH buffer") | |
1052 | (let ((pt (next-overlay-change (point)))) | |
1053 | (if (< pt (point-max)) | |
1054 | (goto-char (1+ pt)) | |
1055 | (error "No more records after point"))))) | |
1056 | ||
1057 | (defun ph-move-to-previous-record () | |
9fb87caf | 1058 | "Move to previous record, in a buffer displaying PH query results." |
43a51f78 RS |
1059 | (interactive) |
1060 | (if (not (eq major-mode 'ph-mode)) | |
1061 | (error "Not in a PH buffer") | |
1062 | (let ((pt (previous-overlay-change (point)))) | |
1063 | (if (> pt (point-min)) | |
1064 | (goto-char pt) | |
1065 | (error "No more records before point"))))) | |
1066 | ||
1067 | ||
1068 | ||
1069 | ;;}}} | |
1070 | ||
1071 | ;;{{{ Menus an keymaps | |
1072 | ||
1073 | (require 'easymenu) | |
1074 | ||
1075 | (defvar ph-mode-map (let ((map (make-sparse-keymap))) | |
1076 | (define-key map "q" 'kill-this-buffer) | |
1077 | (define-key map "x" 'kill-this-buffer) | |
1078 | (define-key map "f" 'ph-query-form) | |
1079 | (define-key map "b" 'ph-try-bbdb-insert) | |
1080 | (define-key map "n" 'ph-move-to-next-record) | |
1081 | (define-key map "p" 'ph-move-to-previous-record) | |
1082 | map)) | |
1083 | (set-keymap-parent ph-mode-map widget-keymap) | |
1084 | ||
1085 | (defconst ph-tail-menu | |
1086 | `(["---" nil nil] | |
1087 | ["Query Form" ph-query-form t] | |
1088 | ["Expand Inline" ph-expand-inline t] | |
43a51f78 RS |
1089 | ["---" nil nil] |
1090 | ["Get Email" ph-get-email t] | |
1091 | ["Get Phone" ph-get-phone t] | |
1092 | ["List Valid Field Names" ph-get-field-list t] | |
1093 | ["---" nil nil] | |
1094 | ,(cons "Customize" (cdr (custom-menu-create 'ph))))) | |
1095 | ||
1096 | (defconst ph-server-menu | |
1097 | '(["---" ph-bookmark-server t] | |
1098 | ["Bookmark Current Server" ph-bookmark-current-server t] | |
1099 | ["New Server" ph-set-server t])) | |
1100 | ||
1101 | ||
1102 | (defun ph-menu () | |
1103 | (let (command) | |
1104 | (append '("Ph") | |
1105 | (list | |
1106 | (append '("Server") | |
1107 | (mapcar (function | |
1108 | (lambda (server) | |
1109 | (setq command (intern (concat "ph-set-server-" server))) | |
1110 | (if (not (fboundp command)) | |
1111 | (fset command `(lambda () | |
1112 | (interactive) | |
1113 | (setq ph-server ,server) | |
1114 | (message "Selected PH/QI server is now %s" ,server)))) | |
1115 | (vector server command t))) | |
1116 | ph-server-hotlist) | |
1117 | ph-server-menu)) | |
1118 | ph-tail-menu))) | |
1119 | ||
1120 | (defun ph-install-menu () | |
1121 | (cond | |
1122 | (ph-xemacs-p | |
1123 | (add-submenu '("Tools") (ph-menu))) | |
1124 | (ph-emacs-p | |
1125 | (easy-menu-define ph-menu-map ph-mode-map "PH Menu" (ph-menu)) | |
1126 | (define-key | |
1127 | global-map | |
1128 | [menu-bar tools ph] | |
1129 | (cons "Ph" | |
b6ceebbc | 1130 | (easy-menu-create-menu "Ph" (cdr (ph-menu)))))) |
43a51f78 RS |
1131 | )) |
1132 | ||
1133 | (ph-install-menu) | |
1134 | ||
1135 | ||
1136 | ;;}}} | |
1137 | ||
1138 | (provide 'ph) | |
1139 | ||
1140 | ;;; ph.el ends here |