Mercurial > emacs

comparison lisp/ph.el @ 18914:f9d2d84a004c

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