|
161
|
1 ;;; ph.el --- Client for the CCSO directory system (aka PH/QI)
|
|
|
2
|
|
|
3 ;; Copyright (C) 1997 Oscar Figueiredo
|
|
|
4
|
|
|
5 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
|
|
|
6 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
|
|
|
7 ;; Created: May 1997
|
|
|
8 ;; Version: $Revision: 1.2 $
|
|
|
9 ;; Keywords: help
|
|
|
10
|
|
|
11 ;; This file is part of XEmacs
|
|
|
12
|
|
|
13 ;; XEmacs 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 ;; XEmacs 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 XEmacs; 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
|
|
|
30 ;; LCD Archive Entry (not registered yet):
|
|
|
31 ;; ph|Oscar Figueiredo|Oscar.Figueiredo@di.epfl.ch|
|
|
|
32 ;; Client for the CCSO directory system (aka PH/QI)|
|
|
|
33 ;; 27-May-1997|Version $Revision: 1.2 $|ftp://(Not Available)
|
|
|
34
|
|
|
35 ;; This package provides functions to query CCSO nameservers through an
|
|
|
36 ;; interactive form or replace inline query strings in buffers with
|
|
|
37 ;; appropriately formatted query results (especially used to expand email
|
|
|
38 ;; addresses in message buffers). It also interfaces with the BBDB package
|
|
|
39 ;; to let you register entries of the CCSO directory into your own database.
|
|
|
40 ;; The CCSO white pages system was developped at UIUC and is in use in more
|
|
|
41 ;; than 300 sites in the world. The distribution can be found at
|
|
|
42 ;; ftp://uiarchive.cso.uiuc.edu/pub/packages/ph
|
|
|
43 ;; Traditionally the server is called QI while the client is called PH.
|
|
|
44
|
|
|
45 ;;; Installation:
|
|
|
46 ;; This package uses the custom and widget libraries. If they are not already
|
|
|
47 ;; installed on your system get them from http://www.dina.kvl.dk/~abraham/custom/
|
|
|
48 ;; Then uncomment and add the following to your .emacs file:
|
|
|
49 ;; (require 'ph)
|
|
|
50 ;; (eval-after-load "message"
|
|
|
51 ;; (define-key message-mode-map [(control ?c) (tab)] 'ph-expand-inline))
|
|
|
52 ;; (eval-after-load "mail"
|
|
|
53 ;; (define-key mail-mode-map [(control ?c) (tab)] 'ph-expand-inline))
|
|
|
54
|
|
|
55 ;; This package should run under XEmacs 19.15 or 20 as well as under Emacs 19.34 and above
|
|
|
56
|
|
|
57 ;;; Usage:
|
|
|
58 ;; * Provided you did the installation as proposed in the above section,
|
|
|
59 ;; inline expansion will be available when you compose an email
|
|
|
60 ;; message. Type the name of somebody recorded in your PH/QI server and hit
|
|
|
61 ;; C-c TAB, this will overwrite the name with the corresponding email
|
|
|
62 ;; address
|
|
|
63 ;; * M-x ph-customize to customize inline expansion and other features to
|
|
|
64 ;; your needs.
|
|
|
65 ;; * Look for the Ph submenu in the tools menu for more.
|
|
|
66
|
|
|
67 ;;; Code:
|
|
|
68
|
|
|
69 (eval-when-compile
|
|
|
70 (require 'wid-edit))
|
|
|
71 (require 'custom)
|
|
|
72 (if (not (fboundp 'make-overlay))
|
|
|
73 (require 'overlay))
|
|
|
74 (if (locate-library "timer")
|
|
|
75 (require 'timer))
|
|
|
76 (autoload 'custom-menu-create "cus-edit")
|
|
|
77
|
|
|
78 ;;{{{ Package customization variables
|
|
|
79
|
|
|
80 (defgroup ph nil
|
|
|
81 "CCSO (PH/QI) directory system client"
|
|
|
82 :group 'mail
|
|
|
83 :group 'comm)
|
|
|
84
|
|
|
85 (defcustom ph-server nil
|
|
|
86 "*The name or IP address of the CCSO (PH/QI) server.
|
|
|
87 A port number may be specified by appending a colon and a
|
|
|
88 number to the name of the server."
|
|
|
89 :type '(string :tag "Server")
|
|
|
90 :group 'ph)
|
|
|
91
|
|
|
92 (defcustom ph-strict-return-matches t
|
|
|
93 "*If non-nil, entries that do not contain all the requested return fields are ignored."
|
|
|
94 :type 'boolean
|
|
|
95 :group 'ph)
|
|
|
96
|
|
|
97 (defcustom ph-default-return-fields nil
|
|
|
98 "*A list of the default fields to extract from CCSO entries.
|
|
|
99 If it contains `all' then all available fields are returned.
|
|
|
100 nil means return the default fields as configured in the server."
|
|
|
101 :type '(repeat (symbol :tag "Field name"))
|
|
|
102 :group 'ph)
|
|
|
103
|
|
|
104 (defcustom ph-multiple-match-handling-method 'select
|
|
|
105 "*What to do when multiple entries match a query for an inline expansion.
|
|
|
106 Possible values are:
|
|
|
107 `first' (equivalent to nil) which means consider the first match.
|
|
|
108 `select' pop-up a selection buffer
|
|
|
109 `all' use all matches
|
|
|
110 `abort' the operation is aborted, an error is signaled"
|
|
|
111 :type '(choice :menu-tag "Method"
|
|
|
112 (const :menu-tag "First" first)
|
|
|
113 (const :menu-tag "Select" select)
|
|
|
114 (const :menu-tag "All" all)
|
|
|
115 (const :menu-tag "Abort" abort)
|
|
|
116 (const :menu-tag "None" nil))
|
|
|
117 :group 'ph)
|
|
|
118
|
|
|
119 (defcustom ph-duplicate-fields-handling-method 'list
|
|
|
120 "*A method to handle entries containing duplicate fields.
|
|
|
121 This is either an alist (FIELD . METHOD) or a symbol METHOD.
|
|
|
122 The alist form of the variable associates a method to an individual field,
|
|
|
123 the second form specifies a method applicable to all fields.
|
|
|
124 Available methods are:
|
|
|
125 `list' or nil lets the value of the field be a list of values
|
|
|
126 `first' keeps the first value and discards the others,
|
|
|
127 `concat' concatenates the values into a single multiline string,
|
|
|
128 `duplicate' duplicates the entire entry into as many instances as
|
|
|
129 different values."
|
|
|
130 :type '(choice (const :menu-tag "List" list)
|
|
|
131 (const :menu-tag "First" first)
|
|
|
132 (const :menu-tag "Concat" concat)
|
|
|
133 (const :menu-tag "Duplicate" duplicate)
|
|
|
134 (repeat :menu-tag "Per Field Specification"
|
|
|
135 :tag "Per Field Specification"
|
|
|
136 (cons :tag "Field/Method"
|
|
|
137 :value (nil . list)
|
|
|
138 (symbol :tag "Field name")
|
|
|
139 (choice :tag "Method"
|
|
|
140 :menu-tag "Method"
|
|
|
141 (const :menu-tag "List" list)
|
|
|
142 (const :menu-tag "First" first)
|
|
|
143 (const :menu-tag "Concat" concat)
|
|
|
144 (const :menu-tag "Duplicate" duplicate)))))
|
|
|
145 :group 'ph
|
|
|
146 )
|
|
|
147
|
|
|
148 (defcustom ph-inline-query-format-list nil
|
|
|
149 "*Format of an inline expansion query.
|
|
|
150 If the inline query string consists of several words, this list specifies
|
|
|
151 how these individual words are associated to CCSO database field names.
|
|
|
152 If nil all the words will be mapped onto the default CCSO database key."
|
|
|
153 :type '(repeat (symbol :tag "Field name"))
|
|
|
154 :group 'ph)
|
|
|
155
|
|
|
156 (defcustom ph-expanding-overwrites-query t
|
|
|
157 "*If non nil, expanding a query overwrites the query string"
|
|
|
158 :type 'boolean
|
|
|
159 :group 'ph)
|
|
|
160
|
|
|
161 (defcustom ph-inline-expansion-format '("%s" email)
|
|
|
162 "*A list specifying the format of the expansion of inline queries.
|
|
|
163 This variable controls what ph-expand-inline actually inserts in the buffer.
|
|
|
164 First element is a string passed to format. Remaining elements are symbols
|
|
|
165 indicating CCSO database field names, corresponding field values are passed
|
|
|
166 as additional arguments to format."
|
|
|
167 :type '(list (string :tag "Format String")
|
|
|
168 (repeat :inline t
|
|
|
169 :tag "Field names"
|
|
|
170 (symbol :tag "")))
|
|
|
171 :group 'ph)
|
|
|
172
|
|
|
173 (defcustom ph-form-fields '(name firstname email phone)
|
|
|
174 "*A list of fields presented in the query form."
|
|
|
175 :tag "Default Fields in Query Forms"
|
|
|
176 :type '(repeat (symbol :tag "Field name"))
|
|
|
177 :group 'ph)
|
|
|
178
|
|
|
179 (defcustom ph-fieldname-formstring-alist '((url . "URL")
|
|
|
180 (unix_gid . "Unix GID")
|
|
|
181 (unix_uid . "Unix UID")
|
|
|
182 (unit_code . "Unit Code")
|
|
|
183 (department_code . "Department Code")
|
|
|
184 (high_school . "High School")
|
|
|
185 (home_phone . "Home Phone")
|
|
|
186 (office_phone . "Office Phone")
|
|
|
187 (callsign . "HAM Call Sign")
|
|
|
188 (office_address . "Office Address")
|
|
|
189 (office_location . "Office Location")
|
|
|
190 (id . "ID")
|
|
|
191 (email . "E-Mail")
|
|
|
192 (firstname . "First Name"))
|
|
|
193 "*A mapping of CCSO database field names onto prompt strings used in query/response forms.
|
|
|
194 Prompt strings for fields that are not in this are derived by capitalizing
|
|
|
195 the field name."
|
|
|
196 :tag "Mapping of Field Names onto Prompt Strings"
|
|
|
197 :type '(repeat (cons :tag "Field"
|
|
|
198 (symbol :tag "Name")
|
|
|
199 (string :tag "Prompt string")))
|
|
|
200 :group 'ph)
|
|
|
201
|
|
|
202 (defcustom ph-bbdb-mapping-alist '((name . (firstname name))
|
|
|
203 (email . net))
|
|
|
204 "*A mapping of CCSO database field names onto BBDB field names"
|
|
|
205 :tag "CCSO to BBDB Field Name Mapping"
|
|
|
206 :type '(repeat (cons :tag "Field Name"
|
|
|
207 (symbol :tag "CCSO")
|
|
|
208 (sexp :tag "BBDB")))
|
|
|
209 :group 'ph)
|
|
|
210
|
|
|
211 (defcustom ph-options-file "~/.emacs"
|
|
|
212 "*A file where the servers hotlist is stored.
|
|
|
213 It should be loaded automatically at startup so ~/.emacs is a reasonable
|
|
|
214 choice."
|
|
|
215 :type '(file :Tag "File Name:"))
|
|
|
216
|
|
|
217 ;;}}}
|
|
|
218
|
|
|
219
|
|
|
220 ;;{{{ Internal cooking
|
|
|
221
|
|
|
222 (defconst ph-xemacs-p (string-match "XEmacs" emacs-version))
|
|
|
223 (defconst ph-fsfemacs-p (not ph-xemacs-p))
|
|
|
224 (defconst ph-xemacs-mule-p (and ph-xemacs-p
|
|
|
225 (featurep 'mule)))
|
|
|
226 (defconst ph-fsfemacs-mule-p (and ph-fsfemacs-p
|
|
|
227 (featurep 'mule)))
|
|
|
228
|
|
|
229 (defvar ph-server-hotlist nil)
|
|
|
230
|
|
|
231 (defconst ph-default-server-port 105
|
|
|
232 "Default TCP port for CCSO directory services")
|
|
|
233
|
|
|
234 (defvar ph-form-widget-list nil)
|
|
|
235 (defvar ph-process-buffer nil)
|
|
|
236 (defvar ph-read-point)
|
|
|
237
|
|
|
238 (defun ph-display-records (records &optional raw-field-names)
|
|
|
239 "Display the record list RECORDS in a formatted buffer.
|
|
|
240 If RAW-FIELD-NAMES is non nil, no translation to form strings or
|
|
|
241 capitalization is done on field names."
|
|
|
242 (let ((buffer (get-buffer-create "*PH Query Results*"))
|
|
|
243 inhibit-read-only
|
|
|
244 precords
|
|
|
245 (width 0)
|
|
|
246 beg field-beg
|
|
|
247 field-name)
|
|
|
248 (switch-to-buffer buffer)
|
|
|
249 (setq buffer-read-only t)
|
|
|
250 (setq inhibit-read-only t)
|
|
|
251 (erase-buffer)
|
|
|
252 (kill-all-local-variables)
|
|
|
253 (insert "PH Query Result\n")
|
|
|
254 (insert "===============\n\n\n")
|
|
|
255 (if (null records)
|
|
|
256 (insert "No match found.\n"
|
|
|
257 (if ph-strict-return-matches
|
|
|
258 "Try setting ph-strict-return-matches to nil or change ph-default-return-fields."
|
|
|
259 ""))
|
|
|
260 ;; Replace field names with prompt strings, compute prompt max width
|
|
|
261 (setq precords
|
|
|
262 (mapcar
|
|
|
263 (function
|
|
|
264 (lambda (record)
|
|
|
265 (mapcar
|
|
|
266 (function
|
|
|
267 (lambda (field)
|
|
|
268 (setq field-name (if raw-field-names
|
|
|
269 (symbol-name (car field))
|
|
|
270 (or (and (assq (car field) ph-fieldname-formstring-alist)
|
|
|
271 (cdr (assq (car field) ph-fieldname-formstring-alist)))
|
|
|
272 (capitalize (symbol-name (car field))))))
|
|
|
273 (if (> (length field-name) width)
|
|
|
274 (setq width (length field-name)))
|
|
|
275 (cons field-name (cdr field))))
|
|
|
276 record)))
|
|
|
277 records))
|
|
|
278 (mapcar (function
|
|
|
279 (lambda (record)
|
|
|
280 (setq beg (point))
|
|
|
281 ;; Actually insert the field/value pairs
|
|
|
282 (mapcar (function
|
|
|
283 (lambda (field)
|
|
|
284 (setq field-beg (point))
|
|
|
285 (insert (format (concat "%" width "s: ") (car field)))
|
|
|
286 (put-text-property field-beg (point) 'face 'bold)
|
|
|
287 (mapcar (function
|
|
|
288 (lambda (val)
|
|
|
289 (indent-to (+ 2 width))
|
|
|
290 (insert val "\n")))
|
|
|
291 (if (stringp (cdr field))
|
|
|
292 (split-string (cdr field) "\n")
|
|
|
293 (cdr field)))))
|
|
|
294 record)
|
|
|
295 ;; Store the record internal format in some convenient place
|
|
|
296 (overlay-put (make-overlay beg (point))
|
|
|
297 'ph-record
|
|
|
298 (car records))
|
|
|
299 (setq records (cdr records))
|
|
|
300 (insert "\n")))
|
|
|
301 precords))
|
|
|
302 (insert "\n")
|
|
|
303 (widget-create 'push-button
|
|
|
304 :notify (lambda (&rest ignore)
|
|
|
305 (ph-query-form))
|
|
|
306 "New query")
|
|
|
307 (widget-insert " ")
|
|
|
308 (widget-create 'push-button
|
|
|
309 :notify (lambda (&rest ignore)
|
|
|
310 (kill-this-buffer))
|
|
|
311 "Quit")
|
|
|
312 (use-local-map widget-keymap)
|
|
|
313 (widget-setup)
|
|
|
314 )
|
|
|
315 )
|
|
|
316
|
|
|
317 (defun ph-process-form ()
|
|
|
318 "Process the form in current buffer and display the results"
|
|
|
319 (let (query-alist
|
|
|
320 value)
|
|
|
321 (if (not (and (boundp 'ph-form-widget-list)
|
|
|
322 ph-form-widget-list))
|
|
|
323 (error "Not in a PH query form buffer")
|
|
|
324 (mapcar (function
|
|
|
325 (lambda (wid-field)
|
|
|
326 (setq value (widget-value (cdr wid-field)))
|
|
|
327 (if (not (string= value ""))
|
|
|
328 (setq query-alist (cons (cons (car wid-field) value)
|
|
|
329 query-alist)))))
|
|
|
330 ph-form-widget-list)
|
|
|
331 (kill-buffer (current-buffer))
|
|
|
332 (ph-display-records (ph-query-internal query-alist))
|
|
|
333 )))
|
|
|
334
|
|
|
335
|
|
|
336 (defun ph-query-internal (query &optional return-fields)
|
|
|
337 "Query the PH/QI server with QUERY.
|
|
|
338 QUERY can be a string NAME or a list made of strings NAME
|
|
|
339 and/or cons cells (KEY . VALUE) where KEYs should be valid
|
|
|
340 CCSO database keys. NAME is equivalent to (DEFAULT . NAME) where
|
|
|
341 DEFAULT is the default key of the database)
|
|
|
342 RETURN-FIELDS is a list of database fields to return defaulting to
|
|
|
343 ph-default-return-fields."
|
|
|
344 (let (request)
|
|
|
345 (if (null return-fields)
|
|
|
346 (setq return-fields ph-default-return-fields))
|
|
|
347 (setq request
|
|
|
348 (concat "query "
|
|
|
349 (if (stringp query)
|
|
|
350 query
|
|
|
351 (mapconcat (function (lambda (elt)
|
|
|
352 (if (stringp elt) elt)
|
|
|
353 (format "%s=%s" (car elt) (cdr elt))))
|
|
|
354 query
|
|
|
355 " "))
|
|
|
356 (if return-fields
|
|
|
357 (concat " return " (mapconcat 'symbol-name return-fields " ")))))
|
|
|
358 (and (> (length request) 6)
|
|
|
359 (ph-do-request request)
|
|
|
360 (ph-parse-query-result return-fields))))
|
|
|
361
|
|
|
362 (defun ph-parse-query-result (&optional fields)
|
|
|
363 "Return a list of alists of key/values from the record in ph-process-buffer.
|
|
|
364 Fields not in FIELDS are discarded."
|
|
|
365 (let (record records
|
|
|
366 line-regexp
|
|
|
367 current-key key value
|
|
|
368 ignore)
|
|
|
369 (save-excursion
|
|
|
370 (message "Parsing results...")
|
|
|
371 (set-buffer ph-process-buffer)
|
|
|
372 (goto-char (point-min))
|
|
|
373 (while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t)
|
|
|
374 (catch 'ignore
|
|
|
375 (setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))
|
|
|
376 (beginning-of-line)
|
|
|
377 (setq record nil
|
|
|
378 ignore nil
|
|
|
379 current-key nil)
|
|
|
380 (while (re-search-forward line-regexp nil t)
|
|
|
381 (catch 'skip-line
|
|
|
382 (if (string= "-508" (match-string 1))
|
|
|
383 ;; A field is missing in this entry. Skip it or skip the
|
|
|
384 ;; whole record (see ph-strict-return-matches)
|
|
|
385 (if (not ph-strict-return-matches)
|
|
|
386 (throw 'skip-line t)
|
|
|
387 (while (re-search-forward line-regexp nil t))
|
|
|
388 (setq ignore t)
|
|
|
389 (throw 'ignore t)))
|
|
|
390 (setq key (and (not (string= (match-string 2) ""))
|
|
|
391 (intern (match-string 2)))
|
|
|
392 value (match-string 3))
|
|
|
393 (if (and current-key
|
|
|
394 (eq key current-key))
|
|
|
395 (setq key nil)
|
|
|
396 (setq current-key key))
|
|
|
397 (if (or (null fields)
|
|
|
398 (memq 'all fields)
|
|
|
399 (memq current-key fields))
|
|
|
400 (if key
|
|
|
401 (setq record (cons (cons key value) record))
|
|
|
402 (setcdr (car record) (cons value (if (listp (cdar record))
|
|
|
403 (cdar record)
|
|
|
404 (cons (cdar record) nil)))))))))
|
|
|
405 (and (not ignore)
|
|
|
406 (or (null fields)
|
|
|
407 (memq 'all fields)
|
|
|
408 (setq record (nreverse record)))
|
|
|
409 (setq record (if (not (eq 'list ph-duplicate-fields-handling-method))
|
|
|
410 (ph-filter-duplicate-fields record)
|
|
|
411 (list record)))
|
|
|
412 (setq records (append record records))))
|
|
|
413 )
|
|
|
414 (message "Done")
|
|
|
415 records)
|
|
|
416 )
|
|
|
417
|
|
|
418 (defun ph-filter-duplicate-fields (record)
|
|
|
419 "Filter RECORD according to ph-duplicate-fields-handling-method."
|
|
|
420 (let ((rec record)
|
|
|
421 unique
|
|
|
422 duplicates
|
|
|
423 result)
|
|
|
424
|
|
|
425 ;; Search for multiple records
|
|
|
426 (while (and rec
|
|
|
427 (not (listp (cdar rec))))
|
|
|
428 (setq rec (cdr rec)))
|
|
|
429
|
|
|
430 (if (null (cdar rec))
|
|
|
431 (list record) ; No duplicate fields in this record
|
|
|
432 (mapcar (function
|
|
|
433 (lambda (field)
|
|
|
434 (if (listp (cdr field))
|
|
|
435 (setq duplicates (cons field duplicates))
|
|
|
436 (setq unique (cons field unique)))))
|
|
|
437 record)
|
|
|
438 (setq result (list unique))
|
|
|
439 (mapcar (function
|
|
|
440 (lambda (field)
|
|
|
441 (let ((method (if (consp ph-duplicate-fields-handling-method)
|
|
|
442 (cdr (assq (car field) ph-duplicate-fields-handling-method))
|
|
|
443 ph-duplicate-fields-handling-method)))
|
|
|
444 (cond
|
|
|
445 ((or (null method) (eq 'list method))
|
|
|
446 (setq result
|
|
|
447 (ph-add-field-to-records field result)))
|
|
|
448 ((eq 'first method)
|
|
|
449 (setq result
|
|
|
450 (ph-add-field-to-records (cons (car field) (cadr field)) result)))
|
|
|
451 ((eq 'concat method)
|
|
|
452 (setq result
|
|
|
453 (ph-add-field-to-records (cons (car field)
|
|
|
454 (mapconcat
|
|
|
455 'identity
|
|
|
456 (cdr field)
|
|
|
457 "\n")) result)))
|
|
|
458 ((eq 'duplicate method)
|
|
|
459 (setq result
|
|
|
460 (ph-distribute-field-on-records field result)))))))
|
|
|
461 duplicates)
|
|
|
462 result)))
|
|
|
463
|
|
|
464 (defun ph-add-field-to-records (field records)
|
|
|
465 "Add FIELD to each individual record in RECORDS and return the resulting list."
|
|
|
466 (mapcar (function
|
|
|
467 (lambda (r)
|
|
|
468 (cons field r)))
|
|
|
469 records))
|
|
|
470
|
|
|
471 (defun ph-distribute-field-on-records (field records)
|
|
|
472 "Duplicate each individual record in RECORDS according to value of FIELD.
|
|
|
473 Each copy is added a new field containing one of the values of FIELD."
|
|
|
474 (let (result
|
|
|
475 (values (cdr field)))
|
|
|
476 ;; Uniquify values first
|
|
|
477 (while values
|
|
|
478 (setcdr values (delete (car values) (cdr values)))
|
|
|
479 (setq values (cdr values)))
|
|
|
480 (mapcar (function
|
|
|
481 (lambda (value)
|
|
|
482 (let ((result-list (copy-sequence records)))
|
|
|
483 (setq result-list (ph-add-field-to-records (cons (car field) value)
|
|
|
484 result-list))
|
|
|
485 (setq result (append result-list result))
|
|
|
486 )))
|
|
|
487 (cdr field))
|
|
|
488 result)
|
|
|
489 )
|
|
|
490
|
|
|
491 (defun ph-do-request (request)
|
|
|
492 "Send REQUEST to the server. Wait for response and return the buffer containing it."
|
|
|
493 (let (process
|
|
|
494 buffer)
|
|
|
495 (unwind-protect
|
|
|
496 (progn
|
|
|
497 (message "Contacting server...")
|
|
|
498 (setq process (ph-open-session))
|
|
|
499 (if process
|
|
|
500 (save-excursion
|
|
|
501 (set-buffer (setq buffer (process-buffer process)))
|
|
|
502 (ph-send-command process request)
|
|
|
503 (message "Request sent, waiting for reply...")
|
|
|
504 (ph-read-response process))))
|
|
|
505 (if process
|
|
|
506 (ph-close-session process)))
|
|
|
507 buffer))
|
|
|
508
|
|
|
509 (defun ph-open-session (&optional server)
|
|
|
510 "Open a connection to the given CCSO SERVER.
|
|
|
511 SERVER is either a string naming the server or a list (NAME PORT)."
|
|
|
512 (let (process
|
|
|
513 host
|
|
|
514 port)
|
|
|
515 (catch 'done
|
|
|
516 (if (null server)
|
|
|
517 (setq server (or ph-server
|
|
|
518 (call-interactively 'ph-set-server))))
|
|
|
519 (string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server)
|
|
|
520 (setq host (match-string 1 server))
|
|
|
521 (setq port (or (match-string 3 server)
|
|
|
522 ph-default-server-port))
|
|
|
523 (setq ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
|
|
|
524 (save-excursion
|
|
|
525 (set-buffer ph-process-buffer)
|
|
|
526 (erase-buffer)
|
|
|
527 (setq ph-read-point (point))
|
|
|
528 (and ph-xemacs-mule-p
|
|
|
529 (set-buffer-file-coding-system 'binary t)))
|
|
|
530 (setq process (open-network-stream "ph" ph-process-buffer host port))
|
|
|
531 (if (null process)
|
|
|
532 (throw 'done nil))
|
|
|
533 (process-kill-without-query process)
|
|
|
534 process)))
|
|
|
535
|
|
|
536
|
|
|
537 (defun ph-close-session (process)
|
|
|
538 (save-excursion
|
|
|
539 (set-buffer (process-buffer process))
|
|
|
540 (ph-send-command process "quit")
|
|
|
541 (ph-read-response process)
|
|
|
542 (if (fboundp 'add-async-timeout)
|
|
|
543 (add-async-timeout 10 'delete-process process)
|
|
|
544 (run-at-time 2 nil 'delete-process process))))
|
|
|
545
|
|
|
546 (defun ph-send-command (process command)
|
|
|
547 (goto-char (point-max))
|
|
|
548 (process-send-string process command)
|
|
|
549 (process-send-string process "\r\n")
|
|
|
550 )
|
|
|
551
|
|
|
552 (defun ph-read-response (process &optional return-response)
|
|
|
553 "Read a response from the PH/QI query process PROCESS.
|
|
|
554 Returns nil if response starts with an error code. If the
|
|
|
555 response is successful the return code or the reponse itself is returned
|
|
|
556 depending on RETURN-RESPONSE"
|
|
|
557 (let ((case-fold-search nil)
|
|
|
558 return-code
|
|
|
559 match-end)
|
|
|
560 (goto-char ph-read-point)
|
|
|
561 ;; CCSO protocol : response complete if status >= 200
|
|
|
562 (while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t))
|
|
|
563 (accept-process-output process)
|
|
|
564 (goto-char ph-read-point))
|
|
|
565 (setq match-end (point))
|
|
|
566 (goto-char ph-read-point)
|
|
|
567 (if (and (setq return-code (match-string 1))
|
|
|
568 (setq return-code (string-to-number return-code))
|
|
|
569 (>= (abs return-code) 300))
|
|
|
570 (progn (setq ph-read-point match-end) nil)
|
|
|
571 (setq ph-read-point match-end)
|
|
|
572 (if return-response
|
|
|
573 (buffer-substring (point) match-end)
|
|
|
574 return-code))))
|
|
|
575
|
|
|
576 ;;; FSF Emacs does not provide that one
|
|
|
577 (if (not (fboundp 'split-string))
|
|
|
578 (defun split-string (string pattern)
|
|
|
579 "Return a list of substrings of STRING which are separated by PATTERN."
|
|
|
580 (let (parts (start 0))
|
|
|
581 (while (string-match pattern string start)
|
|
|
582 (setq parts (cons (substring string start (match-beginning 0)) parts)
|
|
|
583 start (match-end 0)))
|
|
|
584 (nreverse (cons (substring string start) parts))
|
|
|
585 )))
|
|
|
586
|
|
|
587 ;;}}}
|
|
|
588
|
|
|
589 ;;{{{ High-level interfaces (interactive functions)
|
|
|
590
|
|
|
591 (defun ph-customize ()
|
|
|
592 "Customize the PH package."
|
|
|
593 (interactive)
|
|
|
594 (customize 'ph))
|
|
|
595
|
|
|
596 (defun ph-set-server (server)
|
|
|
597 "Set the server to SERVER."
|
|
|
598 (interactive "sNew PH/QI Server: ")
|
|
|
599 (setq ph-server server)
|
|
|
600 (message "Selected PH/QI server is now %s" server))
|
|
|
601
|
|
|
602 (defun ph-get-email (name)
|
|
|
603 "Get the email field of NAME from the PH/QI directory server."
|
|
|
604 (interactive "sName: ")
|
|
|
605 (let ((email (cdaar (ph-query-internal name '(email)))))
|
|
|
606 (if (interactive-p)
|
|
|
607 (if email
|
|
|
608 (message "%s" email)
|
|
|
609 (message "No record matching %s" name)))
|
|
|
610 email))
|
|
|
611
|
|
|
612 (defun ph-get-phone (name)
|
|
|
613 "Get the phone field of NAME from the PH/QI directory server."
|
|
|
614 (interactive "sName: ")
|
|
|
615 (let ((phone (cdaar (ph-query-internal name '(phone)))))
|
|
|
616 (if (interactive-p)
|
|
|
617 (if phone
|
|
|
618 (message "%s" phone)
|
|
|
619 (message "No record matching %s" name)))
|
|
|
620 phone))
|
|
|
621
|
|
|
622 (defun ph-get-field-list ()
|
|
|
623 "Return a list of valid field names for current server.
|
|
|
624 When called interactively the list is formatted in a dedicated buffer
|
|
|
625 otherwise a list of symbols is returned."
|
|
|
626 (interactive)
|
|
|
627 (ph-do-request "fields")
|
|
|
628 (if (interactive-p)
|
|
|
629 (let ((ph-duplicate-fields-handling-method 'list))
|
|
|
630 (ph-display-records (ph-parse-query-result) t))
|
|
|
631 (mapcar 'caar
|
|
|
632 (ph-parse-query-result)))
|
|
|
633 )
|
|
|
634
|
|
|
635 (defun ph-expand-inline (&optional replace)
|
|
|
636 "Query the server and expand the query string before point.
|
|
|
637 The query string consists of the buffer substring from the point back to
|
|
|
638 the preceding comma, colon or beginning of line. If it consists of more than
|
|
|
639 one word the variable ph-inline-query-format-list controls how these are mapped
|
|
|
640 onto CCSO database field names.
|
|
|
641 After querying the server for the given string, the expansion specified by
|
|
|
642 ph-inline-expansion-format is inserted in the buffer at point. If REPLACE is t
|
|
|
643 then this expansion replaces the name in the buffer.
|
|
|
644 If ph-expanding-overwrites-query is t then the meaning of REPLACE is inverted."
|
|
|
645 (interactive)
|
|
|
646 (let* ((end (point))
|
|
|
647 (beg (save-excursion
|
|
|
648 (if (re-search-backward "[:,][ \t]*"
|
|
|
649 (save-excursion
|
|
|
650 (beginning-of-line)
|
|
|
651 (point))
|
|
|
652 'move)
|
|
|
653 (goto-char (match-end 0)))
|
|
|
654 (point)))
|
|
|
655 (words (buffer-substring beg end))
|
|
|
656 query
|
|
|
657 query-alist
|
|
|
658 (query-format ph-inline-query-format-list)
|
|
|
659 response
|
|
|
660 response-strings
|
|
|
661 key val cell)
|
|
|
662
|
|
|
663 ;; Prepare the query
|
|
|
664 (if (or (not query-format)
|
|
|
665 (not (string-match "[ \t]+" words)))
|
|
|
666 (setq query words)
|
|
|
667 (setq words (split-string words "[ \t]+"))
|
|
|
668 (while (and words query-format)
|
|
|
669 (setq query-alist (cons (cons (car query-format) (car words)) query-alist))
|
|
|
670 (setq words (cdr words)
|
|
|
671 query-format (cdr query-format)))
|
|
|
672 (if words
|
|
|
673 (setcdr (car query-alist)
|
|
|
674 (concat (cdar query-alist) " "
|
|
|
675 (mapconcat 'identity words " "))))
|
|
|
676 ;; Uniquify query-alist
|
|
|
677 (setq query-alist (nreverse query-alist))
|
|
|
678 (while query-alist
|
|
|
679 (setq key (caar query-alist)
|
|
|
680 val (cdar query-alist)
|
|
|
681 cell (assq key query))
|
|
|
682 (if cell
|
|
|
683 (setcdr cell (concat val " " (cdr cell)))
|
|
|
684 (setq query (cons (car query-alist) query))))
|
|
|
685 (setq query-alist (cdr query-alist)))
|
|
|
686
|
|
|
687 (setq response (ph-query-internal query (cdr ph-inline-expansion-format)))
|
|
|
688
|
|
|
689 (if (null response)
|
|
|
690 (error "No match found")
|
|
|
691
|
|
|
692 ;; Process response through ph-inline-expansion-format
|
|
|
693 (while response
|
|
|
694 (setq response-strings
|
|
|
695 (cons (apply 'format
|
|
|
696 (car ph-inline-expansion-format)
|
|
|
697 (mapcar (function
|
|
|
698 (lambda (field)
|
|
|
699 (or (cdr (assq field (car response)))
|
|
|
700 "")))
|
|
|
701 (cdr ph-inline-expansion-format)))
|
|
|
702 response-strings))
|
|
|
703 (setq response (cdr response)))
|
|
|
704
|
|
|
705 (if (or
|
|
|
706 (and replace (not ph-expanding-overwrites-query))
|
|
|
707 (and (not replace) ph-expanding-overwrites-query))
|
|
|
708 (delete-region beg end))
|
|
|
709 (cond
|
|
|
710 ((or (= (length response-strings) 1)
|
|
|
711 (null ph-multiple-match-handling-method)
|
|
|
712 (eq ph-multiple-match-handling-method 'first))
|
|
|
713 (insert (car response-strings)))
|
|
|
714 ((eq ph-multiple-match-handling-method 'select)
|
|
|
715 (with-output-to-temp-buffer "*Completions*"
|
|
|
716 (display-completion-list response-strings)))
|
|
|
717 ((eq ph-multiple-match-handling-method 'all)
|
|
|
718 (insert (mapconcat 'identity response-strings ", ")))
|
|
|
719 ((eq ph-multiple-match-handling-method 'abort)
|
|
|
720 (error "There is more than one match for the query"))
|
|
|
721 ))
|
|
|
722 )
|
|
|
723 )
|
|
|
724
|
|
|
725 (defun ph-query-form (&optional get-fields-from-server)
|
|
|
726 "*Display a form to query the CCSO PH/QI nameserver.
|
|
|
727 If given a non-nil argument the function first queries the server
|
|
|
728 for the existing fields and displays a corresponding form."
|
|
|
729 (interactive "P")
|
|
|
730 (let ((fields (or (and get-fields-from-server
|
|
|
731 (ph-get-field-list))
|
|
|
732 ph-form-fields))
|
|
|
733 (buffer (get-buffer-create "*PH/QI Query Form*"))
|
|
|
734 field-name
|
|
|
735 widget
|
|
|
736 (width 0)
|
|
|
737 inhibit-read-only
|
|
|
738 pt)
|
|
|
739 (switch-to-buffer buffer)
|
|
|
740 (setq inhibit-read-only t)
|
|
|
741 (erase-buffer)
|
|
|
742 (kill-all-local-variables)
|
|
|
743 (make-local-variable 'ph-form-widget-list)
|
|
|
744 (widget-insert "PH/QI Query Form\n")
|
|
|
745 (widget-insert "================\n\n")
|
|
|
746 (widget-insert "Current server is: " (or ph-server
|
|
|
747 (call-interactively 'ph-set-server)) "\n")
|
|
|
748 ;; Loop over prompt strings to find the biggest one
|
|
|
749 (setq fields
|
|
|
750 (mapcar (function
|
|
|
751 (lambda (field)
|
|
|
752 (setq field-name (or (and (assq field ph-fieldname-formstring-alist)
|
|
|
753 (cdr (assq field ph-fieldname-formstring-alist)))
|
|
|
754 (capitalize (symbol-name field))))
|
|
|
755 (if (> (length field-name) width)
|
|
|
756 (setq width (length field-name)))
|
|
|
757 (cons field field-name)))
|
|
|
758 fields))
|
|
|
759 ;; Insert the first widget out of the mapcar to leave the cursor
|
|
|
760 ;; in the first field
|
|
|
761 (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr (car fields))))
|
|
|
762 (setq pt (point))
|
|
|
763 (setq widget (widget-create 'editable-field :size 15))
|
|
|
764 (setq ph-form-widget-list (cons (cons (car (car fields)) widget)
|
|
|
765 ph-form-widget-list))
|
|
|
766 (setq fields (cdr fields))
|
|
|
767 (mapcar (function
|
|
|
768 (lambda (field)
|
|
|
769 (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr field)))
|
|
|
770 (setq widget (widget-create 'editable-field
|
|
|
771 :size 15))
|
|
|
772 (setq ph-form-widget-list (cons (cons (car field) widget)
|
|
|
773 ph-form-widget-list))))
|
|
|
774 fields)
|
|
|
775 (widget-insert "\n\n")
|
|
|
776 (widget-create 'push-button
|
|
|
777 :notify (lambda (&rest ignore)
|
|
|
778 (ph-process-form))
|
|
|
779 "Query Server")
|
|
|
780 (widget-insert " ")
|
|
|
781 (widget-create 'push-button
|
|
|
782 :notify (lambda (&rest ignore)
|
|
|
783 (ph-query-form))
|
|
|
784 "Reset Form")
|
|
|
785 (widget-insert " ")
|
|
|
786 (widget-create 'push-button
|
|
|
787 :notify (lambda (&rest ignore)
|
|
|
788 (kill-this-buffer))
|
|
|
789 "Quit")
|
|
|
790 (goto-char (1+ pt)) ; 1+ for some extent boundary reason
|
|
|
791 (use-local-map widget-keymap)
|
|
|
792 (widget-setup))
|
|
|
793 )
|
|
|
794
|
|
|
795 (defun ph-bookmark-server (server)
|
|
|
796 "Add SERVER to the servers' hotlist."
|
|
|
797 (interactive "sServer: ")
|
|
|
798 (if (member server ph-server-hotlist)
|
|
|
799 (error "%s is already in the hotlist" server)
|
|
|
800 (setq ph-server-hotlist (cons server ph-server-hotlist))
|
|
|
801 (ph-install-menu)
|
|
|
802 (ph-save-hotlist)))
|
|
|
803
|
|
|
804 (defun ph-bookmark-current-server ()
|
|
|
805 "Add current server to the servers' hotlist."
|
|
|
806 (interactive)
|
|
|
807 (ph-bookmark-server ph-server))
|
|
|
808
|
|
|
809 (defun ph-save-hotlist ()
|
|
|
810 "Save the servers hotlist to ph-options-file"
|
|
|
811 (save-excursion
|
|
|
812 (set-buffer (find-file-noselect ph-options-file))
|
|
|
813 ;; delete the previous setq
|
|
|
814 (catch 'found
|
|
|
815 (while t
|
|
|
816 (let ((sexp (condition-case nil
|
|
|
817 (read (current-buffer))
|
|
|
818 (end-of-file (throw 'found nil)))))
|
|
|
819 (if (and (listp sexp)
|
|
|
820 (eq (car sexp) 'setq)
|
|
|
821 (eq (cadr sexp) 'ph-server-hotlist))
|
|
|
822 (progn
|
|
|
823 (delete-region (save-excursion
|
|
|
824 (backward-sexp)
|
|
|
825 (point))
|
|
|
826 (point))
|
|
|
827 (throw 'found t))))))
|
|
|
828 (let ((standard-output (current-buffer)))
|
|
|
829 (if (not (bolp))
|
|
|
830 (princ "\n"))
|
|
|
831 (princ "(setq ph-server-hotlist '")
|
|
|
832 (prin1 ph-server-hotlist)
|
|
|
833 (princ ")\n"))
|
|
|
834 (save-buffer))
|
|
|
835 )
|
|
|
836
|
|
|
837 ;;}}}
|
|
|
838
|
|
|
839 ;;{{{ Menu interface
|
|
|
840
|
|
|
841 (require 'easymenu)
|
|
|
842
|
|
|
843 (defconst ph-tail-menu
|
|
|
844 `(["---" nil nil]
|
|
|
845 ["Query Form" ph-query-form t]
|
|
|
846 ["Expand Inline" ph-expand-inline t]
|
|
|
847 ["---" nil nil]
|
|
|
848 ["Get Email" ph-get-email t]
|
|
|
849 ["Get Phone" ph-get-phone t]
|
|
|
850 ["List Valid Field Names" ph-get-field-list t]
|
|
|
851 ["---" nil nil]
|
|
|
852 ,(cons "Customize" (cdr (custom-menu-create 'ph)))))
|
|
|
853
|
|
|
854 (defconst ph-server-menu
|
|
|
855 '(["---" ph-bookmark-server t]
|
|
|
856 ["Bookmark Current Server" ph-bookmark-current-server t]
|
|
|
857 ["New Server" ph-set-server t]))
|
|
|
858
|
|
|
859
|
|
|
860 (defun ph-menu ()
|
|
|
861 (let (command)
|
|
|
862 (append '("Ph")
|
|
|
863 (list
|
|
|
864 (append '("Server")
|
|
|
865 (mapcar (function
|
|
|
866 (lambda (server)
|
|
|
867 (setq command (intern (concat "ph-set-server-" server)))
|
|
|
868 (if (not (fboundp command))
|
|
|
869 (fset command `(lambda ()
|
|
|
870 (interactive)
|
|
|
871 (setq ph-server ,server)
|
|
|
872 (message "Selected PH/QI server is now %s" ,server))))
|
|
|
873 (vector server command t)))
|
|
|
874 ph-server-hotlist)
|
|
|
875 ph-server-menu))
|
|
|
876 ph-tail-menu)))
|
|
|
877
|
|
|
878 (defun ph-install-menu ()
|
|
|
879 (cond
|
|
|
880 (ph-xemacs-p
|
|
|
881 (add-submenu '("Tools") (ph-menu)))
|
|
|
882 (ph-fsfemacs-p
|
|
|
883 (define-key
|
|
|
884 global-map
|
|
|
885 [menu-bar tools ph]
|
|
|
886 (cons "Ph"
|
|
|
887 (easy-menu-create-keymaps "Ph" (cdr (ph-menu))))))
|
|
|
888 ))
|
|
|
889
|
|
|
890 (ph-install-menu)
|
|
|
891
|
|
|
892
|
|
|
893 ;;}}}
|
|
|
894
|
|
|
895 (provide 'ph)
|
|
|
896
|
|
|
897 ;;; ph.el ends here
|
