lisp/ph.el

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