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