mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-28 10:56:36 +00:00
1141 lines
37 KiB
EmacsLisp
1141 lines
37 KiB
EmacsLisp
;;; ph.el --- Client for the CCSO directory system (aka PH/QI)
|
|
|
|
;; Copyright (C) 1997 Free Software Foundation, Inc.
|
|
|
|
;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
|
|
;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
|
|
;; Created: May 1997
|
|
;; Version: 2.8
|
|
;; Keywords: help
|
|
|
|
;; This file is part of GNU Emacs
|
|
|
|
;; GNU Emacs is free software; you can redistribute it and/or modify it
|
|
;; under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful, but
|
|
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
;; Boston, MA 02111-1307, USA.
|
|
|
|
;;; Commentary:
|
|
;; This package provides functions to query CCSO PH/QI nameservers
|
|
;; through an interactive form or replace inline query strings in
|
|
;; buffers with appropriately formatted query results (especially
|
|
;; used to expand email addresses in message buffers). It also
|
|
;; interfaces with the BBDB package to let you register entries of
|
|
;; the CCSO PH/QI directory into your own database. The CCSO PH/QI
|
|
;; white pages system was developped at UIUC and is in use in more
|
|
;; than 300 sites in the world. The distribution can be found at
|
|
;; ftp://uiarchive.cso.uiuc.edu/pub/packages/ph Traditionally the
|
|
;; server is called QI while the client is called PH.
|
|
|
|
;;; Installation:
|
|
;; This package uses the custom and widget libraries. If they are not already
|
|
;; installed on your system get them from http://www.dina.kvl.dk/~abraham/custom/
|
|
;; Then uncomment and add the following to your .emacs file:
|
|
;; (require 'ph)
|
|
;; (eval-after-load "message"
|
|
;; '(define-key message-mode-map [(control ?c) (tab)] 'ph-expand-inline))
|
|
;; (eval-after-load "mail"
|
|
;; '(define-key mail-mode-map [(control ?c) (tab)] 'ph-expand-inline))
|
|
;; See the info file for details
|
|
|
|
;; This package runs under XEmacs 19.15 or 20 and under Emacs 19.34 and above
|
|
|
|
;;; Usage:
|
|
;; - Provided you did the installation as proposed in the above section,
|
|
;; inline expansion will be available when you compose an email
|
|
;; message. Type the name of somebody recorded in your PH/QI server and hit
|
|
;; C-c TAB, this will overwrite the name with the corresponding email
|
|
;; address
|
|
;; - M-x ph-customize to customize inline expansion and other features to
|
|
;; your needs.
|
|
;; - Look for the Ph submenu in the Tools menu for more.
|
|
;; See the info file for details.
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'cl))
|
|
|
|
(require 'wid-edit)
|
|
|
|
(if (not (fboundp 'make-overlay))
|
|
(require 'overlay))
|
|
|
|
(autoload 'custom-menu-create "cus-edit")
|
|
|
|
;;{{{ Package customization variables
|
|
|
|
(defgroup ph nil
|
|
"CCSO (PH/QI) directory system client"
|
|
:group 'mail
|
|
:group 'comm)
|
|
|
|
(defcustom ph-server nil
|
|
"*The name or IP address of the CCSO (PH/QI) server.
|
|
A port number may be specified by appending a colon and a
|
|
number to the name of the server."
|
|
:type '(choice (string :tag "Server")
|
|
(const nil))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-strict-return-matches t
|
|
"*If non-nil, entries not containing all requested return fields are ignored."
|
|
:type 'boolean
|
|
:group 'ph)
|
|
|
|
(defcustom ph-default-return-fields nil
|
|
"*A list of the default fields to extract from CCSO entries.
|
|
If it contains `all' then all available fields are returned.
|
|
nil means return the default fields as configured in the server."
|
|
:type '(repeat (symbol :tag "Field name"))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-multiple-match-handling-method 'select
|
|
"*What to do when multiple entries match an inline expansion query.
|
|
Possible values are:
|
|
`first' (equivalent to nil) which means consider the first match,
|
|
`select' pop-up a selection buffer,
|
|
`all' use all matches,
|
|
`abort' the operation is aborted, an error is signaled."
|
|
:type '(choice :menu-tag "Method"
|
|
(const :menu-tag "First" first)
|
|
(const :menu-tag "Select" select)
|
|
(const :menu-tag "All" all)
|
|
(const :menu-tag "Abort" abort)
|
|
(const :menu-tag "None" nil))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-duplicate-fields-handling-method '((email . duplicate))
|
|
"*A method to handle entries containing duplicate fields.
|
|
This is either an alist (FIELD . METHOD) or a symbol METHOD.
|
|
The alist form of the variable associates a method to an individual field,
|
|
the second form specifies a method applicable to all fields.
|
|
Available methods are:
|
|
`list' or nil lets the value of the field be a list of values,
|
|
`first' keeps the first value and discards the others,
|
|
`concat' concatenates the values into a single multiline string,
|
|
`duplicate' duplicates the entire entry into as many instances as
|
|
different values."
|
|
:type '(choice (const :menu-tag "List" list)
|
|
(const :menu-tag "First" first)
|
|
(const :menu-tag "Concat" concat)
|
|
(const :menu-tag "Duplicate" duplicate)
|
|
(repeat :menu-tag "Per Field Specification"
|
|
:tag "Per Field Specification"
|
|
(cons :tag "Field/Method"
|
|
:value (nil . list)
|
|
(symbol :tag "Field name")
|
|
(choice :tag "Method"
|
|
:menu-tag "Method"
|
|
(const :menu-tag "List" list)
|
|
(const :menu-tag "First" first)
|
|
(const :menu-tag "Concat" concat)
|
|
(const :menu-tag "Duplicate" duplicate)))))
|
|
:group 'ph
|
|
)
|
|
|
|
(defcustom ph-inline-query-format-list nil
|
|
"*Format of an inline expansion query.
|
|
If the inline query string consists of several words, this list specifies
|
|
how these individual words are associated to CCSO database field names.
|
|
If nil all the words will be mapped onto the default CCSO database key."
|
|
:type '(repeat (symbol :tag "Field name"))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-expanding-overwrites-query t
|
|
"*If non nil, expanding a query overwrites the query string."
|
|
:type 'boolean
|
|
:group 'ph)
|
|
|
|
(defcustom ph-inline-expansion-format '("%s" email)
|
|
"*A list specifying the format of the expansion of inline queries.
|
|
This variable controls what `ph-expand-inline' actually inserts in the buffer.
|
|
First element is a string passed to `format'. Remaining elements are symbols
|
|
indicating CCSO database field names, corresponding field values are passed
|
|
as additional arguments to `format'."
|
|
:type '(list (string :tag "Format String")
|
|
(repeat :inline t
|
|
:tag "Field names"
|
|
(symbol :tag "")))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-form-fields '(name email phone)
|
|
"*A list of fields presented in the query form."
|
|
:tag "Default Fields in Query Forms"
|
|
:type '(repeat (symbol :tag "Field name"))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-fieldname-formstring-alist '((url . "URL")
|
|
(callsign . "HAM Call Sign")
|
|
(id . "ID")
|
|
(email . "E-Mail")
|
|
(firstname . "First Name"))
|
|
"*Map CCSO database field names into prompt strings for query/response.
|
|
Prompt strings for fields that are not listed here
|
|
are derived by splitting the field name
|
|
at `_' signs and capitalizing the individual words."
|
|
:tag "Mapping of Field Names onto Prompt Strings"
|
|
:type '(repeat (cons :tag "Field"
|
|
(symbol :tag "Name")
|
|
(string :tag "Prompt string")))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-bbdb-conversion-alist
|
|
'((name . name)
|
|
(net . email)
|
|
(address . (ph-bbdbify-address address "Address"))
|
|
(phone . ((ph-bbdbify-phone phone "Phone")
|
|
(ph-bbdbify-phone office_phone "Office Phone"))))
|
|
"*A mapping from BBDB to PH/QI fields.
|
|
This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
|
|
BBDB-FIELD is the name of a field that must be defined in your BBDB
|
|
environment (standard field names are `name', `company', `net', `phone',
|
|
`address' and `notes'). SPEC-OR-LIST is either a single SPEC or a list
|
|
of SPECs. Lists of specs are valid only for the `phone' and `address'
|
|
BBDB fields. SPECs are sexps which are evaluated:
|
|
a string evaluates to itself,
|
|
a symbol evaluates to the symbol value. Symbols naming PH/QI fields
|
|
present in the record evaluate to the value of the field in the record,
|
|
a form is evaluated as a function. The argument list may contain PH/QI
|
|
field names which eval to the corresponding values in the
|
|
record. The form evaluation should return something appropriate for
|
|
the particular BBDB-FIELD (see `bbdb-create-internal').
|
|
`ph-bbdbify-phone' and `ph-bbdbify-address' are provided as convenience
|
|
functions to parse phones and addresses."
|
|
:tag "BBDB to CCSO Field Name Mapping"
|
|
:type '(repeat (cons :tag "Field Name"
|
|
(symbol :tag "BBDB Field")
|
|
(sexp :tag "Conversion Spec")))
|
|
:group 'ph)
|
|
|
|
(defcustom ph-options-file "~/.ph-options"
|
|
"*A file where the PH `servers' hotlist is stored."
|
|
:type '(file :Tag "File Name:"))
|
|
|
|
(defcustom ph-mode-hook nil
|
|
"*Normal hook run on entry to PH mode."
|
|
:type '(repeat (sexp :tag "Hook")))
|
|
|
|
;;}}}
|
|
|
|
|
|
;;{{{ Internal cooking
|
|
|
|
|
|
(defconst ph-xemacs-p (string-match "XEmacs" emacs-version))
|
|
(defconst ph-emacs-p (not ph-xemacs-p))
|
|
(defconst ph-xemacs-mule-p (and ph-xemacs-p
|
|
(featurep 'mule)))
|
|
(defconst ph-emacs-mule-p (and ph-emacs-p
|
|
(featurep 'mule)))
|
|
|
|
(defvar ph-server-hotlist nil)
|
|
|
|
(defconst ph-default-server-port 105
|
|
"Default TCP port for CCSO directory services.")
|
|
|
|
(defvar ph-form-widget-list nil)
|
|
(defvar ph-process-buffer nil)
|
|
(defvar ph-read-point)
|
|
|
|
;;; Load the options file
|
|
(if (and (and (locate-library ph-options-file)
|
|
(message "")) ; Remove modeline message
|
|
(not (featurep 'ph-options-file)))
|
|
(load ph-options-file))
|
|
|
|
(defun ph-cadr (obj)
|
|
(car (cadr obj)))
|
|
|
|
(defun ph-cdar (obj)
|
|
(cdr (car obj)))
|
|
|
|
(defun ph-mode ()
|
|
"Major mode used in buffers displaying the results of PH queries.
|
|
There is no sense in calling this command from a buffer other than
|
|
one containing the results of a PH query.
|
|
|
|
These are the special commands of PH mode:
|
|
q -- kill this buffer.
|
|
f -- Display a form to query the CCSO PH/QI nameserver.
|
|
n -- Move to next record.
|
|
p -- Move to previous record."
|
|
(interactive)
|
|
(kill-all-local-variables)
|
|
(setq major-mode 'ph-mode)
|
|
(setq mode-name "PH")
|
|
(use-local-map ph-mode-map)
|
|
(setq mode-popup-menu (ph-menu))
|
|
(run-hooks 'ph-mode-hook)
|
|
)
|
|
|
|
(defun ph-display-records (records &optional raw-field-names)
|
|
"Display the record list RECORDS in a formatted buffer.
|
|
If RAW-FIELD-NAMES is non-nil, the raw field names are displayed
|
|
otherwise they are formatted according to `ph-fieldname-formstring-alist'."
|
|
(let ((buffer (get-buffer-create "*PH Query Results*"))
|
|
inhibit-read-only
|
|
precords
|
|
(width 0)
|
|
beg field-beg
|
|
field-name)
|
|
(switch-to-buffer buffer)
|
|
(setq buffer-read-only t)
|
|
(setq inhibit-read-only t)
|
|
(erase-buffer)
|
|
(insert "PH Query Result\n")
|
|
(insert "===============\n\n\n")
|
|
(if (null records)
|
|
(insert "No match found.\n"
|
|
(if ph-strict-return-matches
|
|
"Try setting ph-strict-return-matches to nil or change ph-default-return-fields."
|
|
""))
|
|
;; Replace field names with prompt strings, compute prompt max width
|
|
(setq precords
|
|
(mapcar
|
|
(function
|
|
(lambda (record)
|
|
(mapcar
|
|
(function
|
|
(lambda (field)
|
|
(setq field-name (if raw-field-names
|
|
(symbol-name (car field))
|
|
(or (and (assq (car field) ph-fieldname-formstring-alist)
|
|
(cdr (assq (car field) ph-fieldname-formstring-alist)))
|
|
(capitalize (mapconcat '(lambda (char)
|
|
(if (eq char ?_)
|
|
" "
|
|
(char-to-string char)))
|
|
(symbol-name (car field))
|
|
"")))))
|
|
(if (> (length field-name) width)
|
|
(setq width (length field-name)))
|
|
(cons field-name (cdr field))))
|
|
record)))
|
|
records))
|
|
(mapcar (function
|
|
(lambda (record)
|
|
(setq beg (point))
|
|
;; Actually insert the field/value pairs
|
|
(mapcar (function
|
|
(lambda (field)
|
|
(setq field-beg (point))
|
|
(insert (format (concat "%" width "s: ") (car field)))
|
|
(put-text-property field-beg (point) 'face 'bold)
|
|
(mapcar (function
|
|
(lambda (val)
|
|
(indent-to (+ 2 width))
|
|
(insert val "\n")))
|
|
(if (stringp (cdr field))
|
|
(split-string (cdr field) "\n")
|
|
(cdr field)))))
|
|
record)
|
|
;; Store the record internal format in some convenient place
|
|
(overlay-put (make-overlay beg (point))
|
|
'ph-record
|
|
(car records))
|
|
(setq records (cdr records))
|
|
(insert "\n")))
|
|
precords))
|
|
(insert "\n")
|
|
(widget-create 'push-button
|
|
:notify (lambda (&rest ignore)
|
|
(ph-query-form))
|
|
"New query")
|
|
(widget-insert " ")
|
|
(widget-create 'push-button
|
|
:notify (lambda (&rest ignore)
|
|
(kill-this-buffer))
|
|
"Quit")
|
|
(ph-mode)
|
|
(widget-setup)
|
|
)
|
|
)
|
|
|
|
(defun ph-process-form ()
|
|
"Process the form in current buffer and display the results."
|
|
(let (query-alist
|
|
value)
|
|
(if (not (and (boundp 'ph-form-widget-list)
|
|
ph-form-widget-list))
|
|
(error "Not in a PH query form buffer")
|
|
(mapcar (function
|
|
(lambda (wid-field)
|
|
(setq value (widget-value (cdr wid-field)))
|
|
(if (not (string= value ""))
|
|
(setq query-alist (cons (cons (car wid-field) value)
|
|
query-alist)))))
|
|
ph-form-widget-list)
|
|
(kill-buffer (current-buffer))
|
|
(ph-display-records (ph-query-internal query-alist))
|
|
)))
|
|
|
|
|
|
(defun ph-query-internal (query &optional return-fields)
|
|
"Query the PH/QI server with QUERY.
|
|
QUERY can be a string NAME or a list made of strings NAME
|
|
and/or cons cells (KEY . VALUE) where KEYs should be valid
|
|
CCSO database keys. NAME is equivalent to (DEFAULT . NAME),
|
|
where DEFAULT is the default key of the database.
|
|
RETURN-FIELDS is a list of database fields to return,
|
|
defaulting to `ph-default-return-fields'."
|
|
(let (request)
|
|
(if (null return-fields)
|
|
(setq return-fields ph-default-return-fields))
|
|
(setq request
|
|
(concat "query "
|
|
(if (stringp query)
|
|
query
|
|
(mapconcat (function (lambda (elt)
|
|
(if (stringp elt) elt)
|
|
(format "%s=%s" (car elt) (cdr elt))))
|
|
query
|
|
" "))
|
|
(if return-fields
|
|
(concat " return " (mapconcat 'symbol-name return-fields " ")))))
|
|
(and (> (length request) 6)
|
|
(ph-do-request request)
|
|
(ph-parse-query-result return-fields))))
|
|
|
|
(defun ph-parse-query-result (&optional fields)
|
|
"Return a list of alists of key/values from in `ph-process-buffer'.
|
|
Fields not in FIELDS are discarded."
|
|
(let (record
|
|
records
|
|
line-regexp
|
|
current-key
|
|
key
|
|
value
|
|
ignore)
|
|
(save-excursion
|
|
(message "Parsing results...")
|
|
(set-buffer ph-process-buffer)
|
|
(goto-char (point-min))
|
|
(while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t)
|
|
(catch 'ignore
|
|
(setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))
|
|
(beginning-of-line)
|
|
(setq record nil
|
|
ignore nil
|
|
current-key nil)
|
|
(while (re-search-forward line-regexp nil t)
|
|
(catch 'skip-line
|
|
(if (string= "-508" (match-string 1))
|
|
;; A field is missing in this entry. Skip it or skip the
|
|
;; whole record (see ph-strict-return-matches)
|
|
(if (not ph-strict-return-matches)
|
|
(throw 'skip-line t)
|
|
(while (re-search-forward line-regexp nil t))
|
|
(setq ignore t)
|
|
(throw 'ignore t)))
|
|
(setq key (and (not (string= (match-string 2) ""))
|
|
(intern (match-string 2)))
|
|
value (match-string 3))
|
|
(if (and current-key
|
|
(eq key current-key))
|
|
(setq key nil)
|
|
(setq current-key key))
|
|
(if (or (null fields)
|
|
(memq 'all fields)
|
|
(memq current-key fields))
|
|
(if key
|
|
(setq record (cons (cons key value) record)) ; New key
|
|
(setcdr (car record) (if (listp (ph-cdar record))
|
|
(append (ph-cdar record) (list value))
|
|
(list (ph-cdar record) value))))))))
|
|
(and (not ignore)
|
|
(or (null fields)
|
|
(memq 'all fields)
|
|
(setq record (nreverse record)))
|
|
(setq record (if (not (eq 'list ph-duplicate-fields-handling-method))
|
|
(ph-filter-duplicate-fields record)
|
|
(list record)))
|
|
(setq records (append record records))))
|
|
)
|
|
(message "Done")
|
|
records)
|
|
)
|
|
|
|
(defun ph-filter-duplicate-fields (record)
|
|
"Filter RECORD according to `ph-duplicate-fields-handling-method'."
|
|
(let ((rec record)
|
|
unique
|
|
duplicates
|
|
result)
|
|
|
|
;; Search for multiple records
|
|
(while (and rec
|
|
(not (listp (ph-cdar rec))))
|
|
(setq rec (cdr rec)))
|
|
|
|
(if (null (ph-cdar rec))
|
|
(list record) ; No duplicate fields in this record
|
|
(mapcar (function
|
|
(lambda (field)
|
|
(if (listp (cdr field))
|
|
(setq duplicates (cons field duplicates))
|
|
(setq unique (cons field unique)))))
|
|
record)
|
|
(setq result (list unique))
|
|
(mapcar (function
|
|
(lambda (field)
|
|
(let ((method (if (consp ph-duplicate-fields-handling-method)
|
|
(cdr (assq (car field) ph-duplicate-fields-handling-method))
|
|
ph-duplicate-fields-handling-method)))
|
|
(cond
|
|
((or (null method) (eq 'list method))
|
|
(setq result
|
|
(ph-add-field-to-records field result)))
|
|
((eq 'first method)
|
|
(setq result
|
|
(ph-add-field-to-records (cons (car field) (ph-cadr field)) result)))
|
|
((eq 'concat method)
|
|
(setq result
|
|
(ph-add-field-to-records (cons (car field)
|
|
(mapconcat
|
|
'identity
|
|
(cdr field)
|
|
"\n")) result)))
|
|
((eq 'duplicate method)
|
|
(setq result
|
|
(ph-distribute-field-on-records field result)))))))
|
|
duplicates)
|
|
result)))
|
|
|
|
(defun ph-add-field-to-records (field records)
|
|
"Add FIELD to each individual record in RECORDS and return the resulting list."
|
|
(mapcar (function
|
|
(lambda (r)
|
|
(cons field r)))
|
|
records))
|
|
|
|
(defun ph-distribute-field-on-records (field records)
|
|
"Duplicate each individual record in RECORDS according to value of FIELD.
|
|
Each copy is added a new field containing one of the values of FIELD."
|
|
(let (result
|
|
(values (cdr field)))
|
|
;; Uniquify values first
|
|
(while values
|
|
(setcdr values (delete (car values) (cdr values)))
|
|
(setq values (cdr values)))
|
|
(mapcar (function
|
|
(lambda (value)
|
|
(let ((result-list (copy-sequence records)))
|
|
(setq result-list (ph-add-field-to-records (cons (car field) value)
|
|
result-list))
|
|
(setq result (append result-list result))
|
|
)))
|
|
(cdr field))
|
|
result)
|
|
)
|
|
|
|
(defun ph-do-request (request)
|
|
"Send REQUEST to the server.
|
|
Wait for response and return the buffer containing it."
|
|
(let (process
|
|
buffer)
|
|
(unwind-protect
|
|
(progn
|
|
(message "Contacting server...")
|
|
(setq process (ph-open-session))
|
|
(if process
|
|
(save-excursion
|
|
(set-buffer (setq buffer (process-buffer process)))
|
|
(ph-send-command process request)
|
|
(message "Request sent, waiting for reply...")
|
|
(ph-read-response process))))
|
|
(if process
|
|
(ph-close-session process)))
|
|
buffer))
|
|
|
|
(defun ph-open-session (&optional server)
|
|
"Open a connection to the given CCSO SERVER.
|
|
SERVER is either a string naming the server or a list (NAME PORT)."
|
|
(let (process
|
|
host
|
|
port)
|
|
(catch 'done
|
|
(if (null server)
|
|
(setq server (or ph-server
|
|
(call-interactively 'ph-set-server))))
|
|
(string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server)
|
|
(setq host (match-string 1 server))
|
|
(setq port (or (match-string 3 server)
|
|
ph-default-server-port))
|
|
(setq ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
|
|
(save-excursion
|
|
(set-buffer ph-process-buffer)
|
|
(erase-buffer)
|
|
(setq ph-read-point (point))
|
|
(and ph-xemacs-mule-p
|
|
(set-buffer-file-coding-system 'binary t)))
|
|
(setq process (open-network-stream "ph" ph-process-buffer host port))
|
|
(if (null process)
|
|
(throw 'done nil))
|
|
(process-kill-without-query process)
|
|
process)))
|
|
|
|
|
|
(defun ph-close-session (process)
|
|
(save-excursion
|
|
(set-buffer (process-buffer process))
|
|
(ph-send-command process "quit")
|
|
(ph-read-response process)
|
|
(if (fboundp 'add-async-timeout)
|
|
(add-async-timeout 10 'delete-process process)
|
|
(run-at-time 2 nil 'delete-process process))))
|
|
|
|
(defun ph-send-command (process command)
|
|
(goto-char (point-max))
|
|
(process-send-string process command)
|
|
(process-send-string process "\r\n")
|
|
)
|
|
|
|
(defun ph-read-response (process &optional return-response)
|
|
"Read a response from the PH/QI query process PROCESS.
|
|
Returns nil if response starts with an error code. If the
|
|
response is successful the return code or the reponse itself is returned
|
|
depending on RETURN-RESPONSE."
|
|
(let ((case-fold-search nil)
|
|
return-code
|
|
match-end)
|
|
(goto-char ph-read-point)
|
|
;; CCSO protocol : response complete if status >= 200
|
|
(while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t))
|
|
(accept-process-output process)
|
|
(goto-char ph-read-point))
|
|
(setq match-end (point))
|
|
(goto-char ph-read-point)
|
|
(if (and (setq return-code (match-string 1))
|
|
(setq return-code (string-to-number return-code))
|
|
(>= (abs return-code) 300))
|
|
(progn (setq ph-read-point match-end) nil)
|
|
(setq ph-read-point match-end)
|
|
(if return-response
|
|
(buffer-substring (point) match-end)
|
|
return-code))))
|
|
|
|
(defun ph-create-bbdb-record (record)
|
|
"Create a BBDB record using the RECORD alist.
|
|
RECORD is an alist of (KEY . VALUE) where KEY is a symbol naming a field
|
|
of the PH/QI database and VALUE is the corresponding value for the record."
|
|
;; This function runs in a special context where lisp symbols corresponding
|
|
;; to field names in record are bound to the corresponding values
|
|
(eval
|
|
`(let* (,@(mapcar '(lambda (c)
|
|
(list (car c) (if (listp (cdr c))
|
|
(list 'quote (cdr c))
|
|
(cdr c))))
|
|
record)
|
|
bbdb-name
|
|
bbdb-company
|
|
bbdb-net
|
|
bbdb-address
|
|
bbdb-phones
|
|
bbdb-notes
|
|
spec
|
|
bbdb-record
|
|
value)
|
|
|
|
;; BBDB standard fields
|
|
(setq bbdb-name (ph-parse-spec (cdr (assq 'name ph-bbdb-conversion-alist)) record nil)
|
|
bbdb-company (ph-parse-spec (cdr (assq 'company ph-bbdb-conversion-alist)) record nil)
|
|
bbdb-net (ph-parse-spec (cdr (assq 'net ph-bbdb-conversion-alist)) record nil)
|
|
bbdb-notes (ph-parse-spec (cdr (assq 'notes ph-bbdb-conversion-alist)) record nil))
|
|
(setq spec (cdr (assq 'address ph-bbdb-conversion-alist)))
|
|
(setq bbdb-address (delq nil (ph-parse-spec (if (listp (car spec))
|
|
spec
|
|
(list spec))
|
|
record t)))
|
|
(setq spec (cdr (assq 'phone ph-bbdb-conversion-alist)))
|
|
(setq bbdb-phones (delq nil (ph-parse-spec (if (listp (car spec))
|
|
spec
|
|
(list spec))
|
|
record t)))
|
|
;; BBDB custom fields
|
|
(setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
|
|
(mapcar (function
|
|
(lambda (mapping)
|
|
(if (and (not (memq (car mapping)
|
|
'(name company net address phone notes)))
|
|
(setq value (ph-parse-spec (cdr mapping) record nil)))
|
|
(cons (car mapping) value))))
|
|
ph-bbdb-conversion-alist)))
|
|
(setq bbdb-notes (delq nil bbdb-notes))
|
|
(setq bbdb-record (bbdb-create-internal bbdb-name
|
|
bbdb-company
|
|
bbdb-net
|
|
bbdb-address
|
|
bbdb-phones
|
|
bbdb-notes))
|
|
|
|
(bbdb-display-records (list bbdb-record))
|
|
)))
|
|
|
|
(defun ph-parse-spec (spec record recurse)
|
|
"Parse the conversion SPEC using RECORD.
|
|
If RECURSE is non-nil then SPEC may be a list of atomic specs."
|
|
(cond
|
|
((or (stringp spec)
|
|
(symbolp spec)
|
|
(and (listp spec)
|
|
(symbolp (car spec))
|
|
(fboundp (car spec))))
|
|
(condition-case nil
|
|
(eval spec)
|
|
(void-variable nil)))
|
|
((and recurse
|
|
(listp spec))
|
|
(mapcar '(lambda (spec-elem)
|
|
(ph-parse-spec spec-elem record nil))
|
|
spec))
|
|
(t
|
|
(error "Invalid specification for `%s' in `ph-bbdb-conversion-alist'" spec))))
|
|
|
|
(defun ph-bbdbify-address (addr location)
|
|
"Parse ADDR into a vector compatible with BBDB.
|
|
ADDR should be an address string of no more than four lines or a
|
|
list of lines.
|
|
The last line is searched for the zip code, city and state name.
|
|
LOCATION is used as the address location for bbdb."
|
|
(let* ((addr-components (if (listp addr)
|
|
(reverse addr)
|
|
(reverse (split-string addr "\n"))))
|
|
(lastl (pop addr-components))
|
|
zip city state)
|
|
(setq addr-components (nreverse addr-components))
|
|
(cond
|
|
;; American style
|
|
((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" lastl)
|
|
(setq city (match-string 1 lastl)
|
|
state (match-string 2 lastl)
|
|
zip (string-to-number (match-string 3 lastl))))
|
|
;; European style
|
|
((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" lastl)
|
|
(setq city (match-string 2 lastl)
|
|
zip (string-to-number (match-string 1 lastl))))
|
|
(t
|
|
(error "Cannot parse the address; see `ph-bbdb-conversion-alist'")))
|
|
(vector location
|
|
(or (nth 0 addr-components) "")
|
|
(or (nth 1 addr-components) "")
|
|
(or (nth 2 addr-components) "")
|
|
(or city "")
|
|
(or state "")
|
|
zip)))
|
|
|
|
(defun ph-bbdbify-phone (phone location)
|
|
"Parse PHONE into a vector compatible with BBDB.
|
|
PHONE is either a string supposedly containing a phone number or
|
|
a list of such strings which are concatenated.
|
|
LOCATION is used as the phone location for bbdb."
|
|
(cond
|
|
((stringp phone)
|
|
(let (phone-list)
|
|
(condition-case err
|
|
(setq phone-list (bbdb-parse-phone-number phone))
|
|
(error
|
|
(if (string= "phone number unparsable." (ph-cadr err))
|
|
(if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
|
|
(error "Phone number unparsable")
|
|
(setq phone-list (list (bbdb-string-trim phone))))
|
|
(signal (car err) (cdr err)))))
|
|
(if (= 3 (length phone-list))
|
|
(setq phone-list (append phone-list '(nil))))
|
|
(apply 'vector location phone-list)))
|
|
((listp phone)
|
|
(vector location (mapconcat 'identity phone ", ")))
|
|
(t
|
|
(error "Invalid phone specification"))))
|
|
|
|
;;}}}
|
|
|
|
;;{{{ High-level interfaces (interactive functions)
|
|
|
|
(defun ph-customize ()
|
|
"Customize the PH package."
|
|
(interactive)
|
|
(customize-group 'ph))
|
|
|
|
(defun ph-set-server (server)
|
|
"Set the PH server to SERVER."
|
|
(interactive "sNew PH/QI Server: ")
|
|
(message "Selected PH/QI server is now %s" server)
|
|
(setq ph-server server))
|
|
|
|
;;;###autoload
|
|
(defun ph-get-email (name)
|
|
"Get the email field of NAME from the PH/QI directory server."
|
|
(interactive "sName: ")
|
|
(let ((email (cdaar (ph-query-internal name '(email)))))
|
|
(if (interactive-p)
|
|
(if email
|
|
(message "%s" email)
|
|
(message "No record matching %s" name)))
|
|
email))
|
|
|
|
;;;###autoload
|
|
(defun ph-get-phone (name)
|
|
"Get the phone field of NAME from the PH/QI directory server."
|
|
(interactive "sName: ")
|
|
(let ((phone (cdaar (ph-query-internal name '(phone)))))
|
|
(if (interactive-p)
|
|
(if phone
|
|
(message "%s" phone)
|
|
(message "No record matching %s" name)))
|
|
phone))
|
|
|
|
(defun ph-get-field-list ()
|
|
"Return a list of valid field names for current server.
|
|
When called interactively the list is formatted in a dedicated buffer
|
|
otherwise a list of symbols is returned."
|
|
(interactive)
|
|
(ph-do-request "fields")
|
|
(if (interactive-p)
|
|
(let ((ph-duplicate-fields-handling-method 'list))
|
|
(ph-display-records (ph-parse-query-result) t))
|
|
(mapcar 'caar
|
|
(ph-parse-query-result)))
|
|
)
|
|
|
|
;;;###autoload
|
|
(defun ph-expand-inline (&optional replace)
|
|
"Query the PH server, and expand the query string before point.
|
|
The query string consists of the buffer substring from the point back to
|
|
the preceding comma, colon or beginning of line. If it contains more than
|
|
one word, the variable `ph-inline-query-format-list' controls to map these
|
|
onto CCSO database field names.
|
|
After querying the server for the given string, the expansion specified by
|
|
`ph-inline-expansion-format' is inserted in the buffer at point.
|
|
If REPLACE is t, then this expansion replaces the name in the buffer.
|
|
If `ph-expanding-overwrites-query' is t, that inverts the meaning of REPLACE."
|
|
(interactive)
|
|
(let* ((end (point))
|
|
(beg (save-excursion
|
|
(if (re-search-backward "[:,][ \t]*"
|
|
(save-excursion
|
|
(beginning-of-line)
|
|
(point))
|
|
'move)
|
|
(goto-char (match-end 0)))
|
|
(point)))
|
|
(words (buffer-substring beg end))
|
|
query
|
|
query-alist
|
|
(query-format ph-inline-query-format-list)
|
|
response
|
|
response-strings
|
|
key val cell)
|
|
|
|
;; Prepare the query
|
|
(if (or (not query-format)
|
|
(not (string-match "[ \t]+" words)))
|
|
(setq query words)
|
|
(setq words (split-string words "[ \t]+"))
|
|
(while (and words query-format)
|
|
(setq query-alist (cons (cons (car query-format) (car words)) query-alist))
|
|
(setq words (cdr words)
|
|
query-format (cdr query-format)))
|
|
(if words
|
|
(setcdr (car query-alist)
|
|
(concat (ph-cdar query-alist) " "
|
|
(mapconcat 'identity words " "))))
|
|
;; Uniquify query-alist
|
|
(setq query-alist (nreverse query-alist))
|
|
(while query-alist
|
|
(setq key (caar query-alist)
|
|
val (ph-cdar query-alist)
|
|
cell (assq key query))
|
|
(if cell
|
|
(setcdr cell (concat val " " (cdr cell)))
|
|
(setq query (cons (car query-alist) query))))
|
|
(setq query-alist (cdr query-alist)))
|
|
|
|
(setq response (ph-query-internal query (cdr ph-inline-expansion-format)))
|
|
|
|
(if (null response)
|
|
(error "No match found")
|
|
|
|
;; Process response through ph-inline-expansion-format
|
|
(while response
|
|
(setq response-strings
|
|
(cons (apply 'format
|
|
(car ph-inline-expansion-format)
|
|
(mapcar (function
|
|
(lambda (field)
|
|
(or (cdr (assq field (car response)))
|
|
"")))
|
|
(cdr ph-inline-expansion-format)))
|
|
response-strings))
|
|
(setq response (cdr response)))
|
|
|
|
(if (or
|
|
(and replace (not ph-expanding-overwrites-query))
|
|
(and (not replace) ph-expanding-overwrites-query))
|
|
(delete-region beg end))
|
|
(cond
|
|
((or (= (length response-strings) 1)
|
|
(null ph-multiple-match-handling-method)
|
|
(eq ph-multiple-match-handling-method 'first))
|
|
(insert (car response-strings)))
|
|
((eq ph-multiple-match-handling-method 'select)
|
|
(with-output-to-temp-buffer "*Completions*"
|
|
(display-completion-list response-strings)))
|
|
((eq ph-multiple-match-handling-method 'all)
|
|
(insert (mapconcat 'identity response-strings ", ")))
|
|
((eq ph-multiple-match-handling-method 'abort)
|
|
(error "There is more than one match for the query"))
|
|
))
|
|
)
|
|
)
|
|
|
|
;;;###autoload
|
|
(defun ph-query-form (&optional get-fields-from-server)
|
|
"Display a form to query the CCSO PH/QI nameserver.
|
|
If given a non-nil argument the function first queries the server
|
|
for the existing fields and displays a corresponding form."
|
|
(interactive "P")
|
|
(let ((fields (or (and get-fields-from-server
|
|
(ph-get-field-list))
|
|
ph-form-fields))
|
|
(buffer (get-buffer-create "*PH/QI Query Form*"))
|
|
field-name
|
|
widget
|
|
(width 0)
|
|
inhibit-read-only
|
|
pt)
|
|
(switch-to-buffer buffer)
|
|
(setq inhibit-read-only t)
|
|
(erase-buffer)
|
|
(kill-all-local-variables)
|
|
(make-local-variable 'ph-form-widget-list)
|
|
(widget-insert "PH/QI Query Form\n")
|
|
(widget-insert "================\n\n")
|
|
(widget-insert "Current server is: " (or ph-server
|
|
(call-interactively 'ph-set-server)) "\n")
|
|
;; Loop over prompt strings to find the biggest one
|
|
(setq fields
|
|
(mapcar (function
|
|
(lambda (field)
|
|
(setq field-name (or (and (assq field ph-fieldname-formstring-alist)
|
|
(cdr (assq field ph-fieldname-formstring-alist)))
|
|
(capitalize (symbol-name field))))
|
|
(if (> (length field-name) width)
|
|
(setq width (length field-name)))
|
|
(cons field field-name)))
|
|
fields))
|
|
;; Insert the first widget out of the mapcar to leave the cursor
|
|
;; in the first field
|
|
(widget-insert "\n\n" (format (concat "%" width "s: ") (cdr (car fields))))
|
|
(setq pt (point))
|
|
(setq widget (widget-create 'editable-field :size 15))
|
|
(setq ph-form-widget-list (cons (cons (car (car fields)) widget)
|
|
ph-form-widget-list))
|
|
(setq fields (cdr fields))
|
|
(mapcar (function
|
|
(lambda (field)
|
|
(widget-insert "\n\n" (format (concat "%" width "s: ") (cdr field)))
|
|
(setq widget (widget-create 'editable-field
|
|
:size 15))
|
|
(setq ph-form-widget-list (cons (cons (car field) widget)
|
|
ph-form-widget-list))))
|
|
fields)
|
|
(widget-insert "\n\n")
|
|
(widget-create 'push-button
|
|
:notify (lambda (&rest ignore)
|
|
(ph-process-form))
|
|
"Query Server")
|
|
(widget-insert " ")
|
|
(widget-create 'push-button
|
|
:notify (lambda (&rest ignore)
|
|
(ph-query-form))
|
|
"Reset Form")
|
|
(widget-insert " ")
|
|
(widget-create 'push-button
|
|
:notify (lambda (&rest ignore)
|
|
(kill-this-buffer))
|
|
"Quit")
|
|
(goto-char (1+ pt)) ; 1+ for some extent boundary reason
|
|
(use-local-map widget-keymap)
|
|
(widget-setup))
|
|
)
|
|
|
|
(defun ph-bookmark-server (server)
|
|
"Add SERVER to the PH `servers' hotlist."
|
|
(interactive "sPH server: ")
|
|
(if (member server ph-server-hotlist)
|
|
(error "%s is already in the hotlist" server)
|
|
(setq ph-server-hotlist (cons server ph-server-hotlist))
|
|
(ph-install-menu)
|
|
(ph-save-options)))
|
|
|
|
(defun ph-bookmark-current-server ()
|
|
"Add current server to the PH `servers' hotlist."
|
|
(interactive)
|
|
(ph-bookmark-server ph-server))
|
|
|
|
(defun ph-save-options ()
|
|
"Save options (essentially the hotlist) to `ph-options-file'."
|
|
(interactive)
|
|
(save-excursion
|
|
(set-buffer (find-file-noselect ph-options-file t))
|
|
;; delete the previous setq
|
|
(let ((standard-output (current-buffer))
|
|
provide-p
|
|
setq-p)
|
|
(catch 'found
|
|
(while t
|
|
(let ((sexp (condition-case nil
|
|
(read (current-buffer))
|
|
(end-of-file (throw 'found nil)))))
|
|
(if (listp sexp)
|
|
(progn
|
|
(if (and (eq (car sexp) 'setq)
|
|
(eq (ph-cadr sexp) 'ph-server-hotlist))
|
|
(progn
|
|
(delete-region (save-excursion
|
|
(backward-sexp)
|
|
(point))
|
|
(point))
|
|
(setq setq-p t)))
|
|
(if (and (eq (car sexp) 'provide)
|
|
(equal (ph-cadr sexp) '(quote ph-options-file)))
|
|
(setq provide-p t))
|
|
(if (and provide-p
|
|
setq-p)
|
|
(throw 'found t)))))))
|
|
(if (eq (point-min) (point-max))
|
|
(princ ";; This file was automatically generated by ph.el\n\n"))
|
|
(if (not (bolp))
|
|
(princ "\n"))
|
|
(princ "(setq ph-server-hotlist '")
|
|
(prin1 ph-server-hotlist)
|
|
(princ ")\n")
|
|
(if (not provide-p)
|
|
(princ "(provide 'ph-options-file)\n"))
|
|
(save-buffer)))
|
|
)
|
|
|
|
(defun ph-insert-record-at-point-into-bbdb ()
|
|
"Insert record at point into the BBDB database.
|
|
This function can only be called from a PH/QI query result buffer."
|
|
(interactive)
|
|
(let ((record (and (overlays-at (point))
|
|
(overlay-get (car (overlays-at (point))) 'ph-record))))
|
|
(if (null record)
|
|
(error "Point is not over a record")
|
|
(ph-create-bbdb-record record))))
|
|
|
|
(defun ph-try-bbdb-insert ()
|
|
"Call `ph-insert-record-at-point-into-bbdb' if on a record."
|
|
(interactive)
|
|
(and (or (featurep 'bbdb)
|
|
(prog1 (locate-library "bbdb") (message "")))
|
|
(overlays-at (point))
|
|
(overlay-get (car (overlays-at (point))) 'ph-record)
|
|
(ph-insert-record-at-point-into-bbdb)))
|
|
|
|
(defun ph-move-to-next-record ()
|
|
"Move to next record, in a buffer displaying PH query results."
|
|
(interactive)
|
|
(if (not (eq major-mode 'ph-mode))
|
|
(error "Not in a PH buffer")
|
|
(let ((pt (next-overlay-change (point))))
|
|
(if (< pt (point-max))
|
|
(goto-char (1+ pt))
|
|
(error "No more records after point")))))
|
|
|
|
(defun ph-move-to-previous-record ()
|
|
"Move to previous record, in a buffer displaying PH query results."
|
|
(interactive)
|
|
(if (not (eq major-mode 'ph-mode))
|
|
(error "Not in a PH buffer")
|
|
(let ((pt (previous-overlay-change (point))))
|
|
(if (> pt (point-min))
|
|
(goto-char pt)
|
|
(error "No more records before point")))))
|
|
|
|
|
|
|
|
;;}}}
|
|
|
|
;;{{{ Menus an keymaps
|
|
|
|
(require 'easymenu)
|
|
|
|
(defvar ph-mode-map (let ((map (make-sparse-keymap)))
|
|
(define-key map "q" 'kill-this-buffer)
|
|
(define-key map "x" 'kill-this-buffer)
|
|
(define-key map "f" 'ph-query-form)
|
|
(define-key map "b" 'ph-try-bbdb-insert)
|
|
(define-key map "n" 'ph-move-to-next-record)
|
|
(define-key map "p" 'ph-move-to-previous-record)
|
|
map))
|
|
(set-keymap-parent ph-mode-map widget-keymap)
|
|
|
|
(defconst ph-tail-menu
|
|
`(["---" nil nil]
|
|
["Query Form" ph-query-form t]
|
|
["Expand Inline" ph-expand-inline t]
|
|
["---" nil nil]
|
|
["Get Email" ph-get-email t]
|
|
["Get Phone" ph-get-phone t]
|
|
["List Valid Field Names" ph-get-field-list t]
|
|
["---" nil nil]
|
|
,(cons "Customize" (cdr (custom-menu-create 'ph)))))
|
|
|
|
(defconst ph-server-menu
|
|
'(["---" ph-bookmark-server t]
|
|
["Bookmark Current Server" ph-bookmark-current-server t]
|
|
["New Server" ph-set-server t]))
|
|
|
|
|
|
(defun ph-menu ()
|
|
(let (command)
|
|
(append '("Ph")
|
|
(list
|
|
(append '("Server")
|
|
(mapcar (function
|
|
(lambda (server)
|
|
(setq command (intern (concat "ph-set-server-" server)))
|
|
(if (not (fboundp command))
|
|
(fset command `(lambda ()
|
|
(interactive)
|
|
(setq ph-server ,server)
|
|
(message "Selected PH/QI server is now %s" ,server))))
|
|
(vector server command t)))
|
|
ph-server-hotlist)
|
|
ph-server-menu))
|
|
ph-tail-menu)))
|
|
|
|
(defun ph-install-menu ()
|
|
(cond
|
|
(ph-xemacs-p
|
|
(add-submenu '("Tools") (ph-menu)))
|
|
(ph-emacs-p
|
|
(easy-menu-define ph-menu-map ph-mode-map "PH Menu" (ph-menu))
|
|
(define-key
|
|
global-map
|
|
[menu-bar tools ph]
|
|
(cons "Ph"
|
|
(easy-menu-create-menu "Ph" (cdr (ph-menu))))))
|
|
))
|
|
|
|
(ph-install-menu)
|
|
|
|
|
|
;;}}}
|
|
|
|
(provide 'ph)
|
|
|
|
;;; ph.el ends here
|