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