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