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