xemacs-beta: lisp/utils/ph.el comparison

comparison lisp/utils/ph.el @ 165:5a88923fcbfe r20-3b9

Import from CVS: tag r20-3b9

author	cvs
date	Mon, 13 Aug 2007 09:44:42 +0200
parents	28f395d8dc7a
children	8eaf7971accc

comparison

equal deleted inserted replaced

-:4e0740e5aab2
+:5a88923fcbfe
 ;;; ph.el --- Client for the CCSO directory system (aka PH/QI)
-;; Copyright (C) 1997 Oscar Figueiredo
+;; Copyright (C) 1997 Free Software Foundation, Inc.
 ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
 ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
 ;; Created: May 1997
-;; Version: $Revision: 1.2 $
+;; Version: 2.1
 ;; Keywords: help
 ;; This file is part of XEmacs
 ;; XEmacs is free software; you can redistribute it and/or modify it
 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to
 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 ;;; Commentary:
+;;    This package provides functions to query CCSO PH/QI nameservers
-;; LCD Archive Entry (not registered yet):
+;;    through an interactive form or replace inline query strings in
-;; ph|Oscar Figueiredo|Oscar.Figueiredo@di.epfl.ch|
+;;    buffers with appropriately formatted query results (especially
-;; Client for the CCSO directory system (aka PH/QI)|
+;;    used to expand email addresses in message buffers). It also
-;; 27-May-1997|Version $Revision: 1.2 $|ftp://(Not Available)
+;;    interfaces with the BBDB package to let you register entries of
+;;    the CCSO PH/QI directory into your own database.  The CCSO PH/QI
-;;    This package provides functions to query CCSO nameservers through an
+;;    white pages system was developped at UIUC and is in use in more
-;;    interactive form or replace inline query strings in buffers with
-;;    appropriately formatted query results (especially used to expand email
-;;    addresses in message buffers). It also interfaces with the BBDB package
-;;    to let you register entries of the CCSO directory into your own database.
-;;    The CCSO white pages system was developped at UIUC and is in use in more
 ;;    than 300 sites in the world. The distribution can be found at
-;;    ftp://uiarchive.cso.uiuc.edu/pub/packages/ph
+;;    ftp://uiarchive.cso.uiuc.edu/pub/packages/ph Traditionally the
-;;    Traditionally the server is called QI while the client is called PH.
+;;    server is called QI while the client is called PH.
 ;;; Installation:
 ;;    This package uses the custom and widget libraries. If they are not already
 ;;    installed on your system get them from http://www.dina.kvl.dk/~abraham/custom/
 ;;    Then uncomment and add the following to your .emacs file:
 ;;      (require 'ph)
 ;;      (eval-after-load "message"
-;;                       (define-key message-mode-map [(control ?c) (tab)] 'ph-expand-inline))
+;;                       '(define-key message-mode-map [(control ?c) (tab)] 'ph-expand-inline))
 ;;      (eval-after-load "mail"
-;;                       (define-key mail-mode-map [(control ?c) (tab)] 'ph-expand-inline))
+;;                       '(define-key mail-mode-map [(control ?c) (tab)] 'ph-expand-inline))
-;;    This package should run under XEmacs 19.15 or 20 as well as under Emacs 19.34 and above
 ;;; Usage:
-;;    * Provided you did the installation as proposed in the above section,
+;;    - Provided you did the installation as proposed in the above section,
 ;;      inline expansion will be available when you compose an email
 ;;      message. Type the name of somebody recorded in your PH/QI server and hit
 ;;      C-c TAB, this will overwrite the name with the corresponding email
 ;;      address
-;;    * M-x ph-customize to customize inline expansion and other features to
+;;    - M-x ph-customize to customize inline expansion and other features to
 ;;      your needs.
-;;    * Look for the Ph submenu in the tools menu for more.
+;;    - Look for the Ph submenu in the Tools menu for more.
 ;;; Code:
 (eval-when-compile
 (require 'wid-edit))
 (require 'custom)
 (if (not (fboundp 'make-overlay))
 (require 'overlay))
 (if (locate-library "timer")
 (require 'timer))
 (autoload 'custom-menu-create "cus-edit")
+(autoload 'bbdb-create-internal "bbdb-com")
+(autoload 'bbdb-display-records "bbdb")
 ;;{{{      Package customization variables
 (defgroup ph nil
 "CCSO (PH/QI) directory system client"
 		  (const :menu-tag "All"    all)
 		  (const :menu-tag "Abort"  abort)
 		  (const :menu-tag "None" nil))
 :group 'ph)
-(defcustom ph-duplicate-fields-handling-method 'list
+(defcustom ph-duplicate-fields-handling-method '((email . duplicate))
 "*A method to handle entries containing duplicate fields.
 This is either an alist (FIELD . METHOD) or a symbol METHOD.
 The alist form of the variable associates a method to an individual field,
 the second form specifies a method applicable to all fields.
 Available methods are:
 		(repeat :inline t
 			:tag "Field names"
 			(symbol :tag "")))
 :group 'ph)
-(defcustom ph-form-fields '(name firstname email phone)
+(defcustom ph-form-fields '(name email phone)
 "*A list of fields presented in the query form."
 :tag   "Default Fields in Query Forms"
 :type  '(repeat (symbol :tag "Field name"))
 :group 'ph)
 (defcustom ph-fieldname-formstring-alist '((url . "URL")
-					    (unix_gid . "Unix GID")
+					   (unix_gid . "Unix GID")
-					    (unix_uid . "Unix UID")
+					   (unix_uid . "Unix UID")
-					    (unit_code . "Unit Code")
+					   (unit_code . "Unit Code")
-					    (department_code . "Department Code")
+					   (department_code . "Department Code")
-					    (high_school . "High School")
+					   (high_school . "High School")
-					    (home_phone . "Home Phone")
+					   (home_phone . "Home Phone")
-					    (office_phone . "Office Phone")
+					   (office_phone . "Office Phone")
-					    (callsign . "HAM Call Sign")
+					   (callsign . "HAM Call Sign")
-					    (office_address . "Office Address")
+					   (office_address . "Office Address")
-					    (office_location . "Office Location")
+					   (office_location . "Office Location")
-					    (id . "ID")
+					   (id . "ID")
-					    (email . "E-Mail")
+					   (email . "E-Mail")
-					    (firstname . "First Name"))
+					   (firstname . "First Name"))
 "*A mapping of CCSO database field names onto prompt strings used in query/response forms.
 Prompt strings for fields that are not in this are derived by capitalizing
 the field name."
 :tag   "Mapping of Field Names onto Prompt Strings"
 :type  '(repeat (cons :tag "Field"
 			(symbol :tag "Name")
 		        (string :tag "Prompt string")))
 :group 'ph)
-(defcustom ph-bbdb-mapping-alist '((name . (firstname name))
+(defcustom ph-bbdb-conversion-alist '((name . name)
-				    (email . net))
+				      (net . email)
-"*A mapping of CCSO database field names onto BBDB field names"
+				      (address . (ph-bbdbify-address address "Address"))
-:tag "CCSO to BBDB Field Name Mapping"
+				      (phone . ((ph-bbdbify-phone phone "Phone")
+						(ph-bbdbify-phone office_phone "Office Phone"))))
+"*A mapping from BBDB to PH/QI fields.
+This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where BBDB-FIELD
+is the name of a field that must be defined in your BBDB (standard field
+names are `name', `company', `net', `phone', `address' and `notes').
+SPEC-OR-LIST is either a single SPEC or a list of SPECs. Lists of specs are
+valid only for the `phone' and `address' BBDB fields.
+SPECs are sexps which are evaluated:
+-a string evaluates to itself
+-a symbol evaluates to the symbol value. Symbols naming PH/QI fields
+present in the record evaluate to the value of the field in the record
+-a form is evaluated as a function. The argument list may contain PH/QI
+field names which eval to the corresponding values in the record. The form
+evaluation should return something appropriate for the particular
+BBDB-FIELD (see bbdb-create-internal). ph-bbdbify-phone and
+ph-bbdbify-address are provided as convenience functions to parse phones
+and addresses."
+:tag "BBDB to CCSO Field Name Mapping"
 :type '(repeat (cons :tag "Field Name"
-		       (symbol :tag "CCSO")
+		       (symbol :tag "BBDB Field")
-		       (sexp :tag "BBDB")))
+		       (sexp :tag "Conversion Spec")))
 :group 'ph)
 (defcustom ph-options-file "~/.emacs"
 "*A file where the servers hotlist is stored.
 It should be loaded automatically at startup so ~/.emacs is a reasonable
 "Default TCP port for CCSO directory services")
 (defvar ph-form-widget-list nil)
 (defvar ph-process-buffer nil)
 (defvar ph-read-point)
+;;; FSF Emacs does not provide that one
+(if (not (fboundp 'split-string))
+(defun split-string (string pattern)
+"Return a list of substrings of STRING which are separated by PATTERN."
+(let (parts (start 0))
+	(while (string-match pattern string start)
+	  (setq parts (cons (substring string start (match-beginning 0)) parts)
+		start (match-end 0)))
+	(nreverse (cons (substring string start) parts))
+	)))
 (defun ph-display-records (records &optional raw-field-names)
 "Display the record list RECORDS in a formatted buffer.
 If RAW-FIELD-NAMES is non nil, no translation to form strings or
 capitalization is done on field names."
 		(setq current-key key))
 	      (if (or (null fields)
 		      (memq 'all fields)
 		      (memq current-key fields))
 		  (if key
-		      (setq record (cons (cons key value) record))
+		      (setq record (cons (cons key value) record)) ; New key
-		    (setcdr (car record) (cons value (if (listp (cdar record))
+		    (setcdr (car record) (if (listp (cdar record))
-							 (cdar record)
+					     (append (cdar record) (list value))
-						       (cons (cdar record) nil)))))))))
+					   (list (cdar record) value))))))))
 	(and (not ignore)
 	     (or (null fields)
 		 (memq 'all fields)
 		 (setq record (nreverse record)))
 	     (setq record (if (not (eq 'list ph-duplicate-fields-handling-method))
 (setq ph-read-point match-end)
 (if return-response
 	  (buffer-substring (point) match-end)
 	return-code))))
-;;; FSF Emacs does not provide that one
+(defun ph-create-bbdb-record (record)
-(if (not (fboundp 'split-string))
+"Create a BBDB record using the RECORD alist.
-(defun split-string (string pattern)
+RECORD is an alist of (KEY . VALUE) where KEY is a symbol naming a field
-"Return a list of substrings of STRING which are separated by PATTERN."
+of the PH/QI database and VALUE is the corresponding value for the record"
-(let (parts (start 0))
+;; This function runs in a special context where lisp symbols corresponding
-	(while (string-match pattern string start)
+;; to field names in record are bound to the corresponding values
-	  (setq parts (cons (substring string start (match-beginning 0)) parts)
+(eval
-		start (match-end 0)))
+`(let* (,@(mapcar '(lambda (c)
-	(nreverse (cons (substring string start) parts))
+			(list (car c) (if (listp (cdr c))
-	)))
+					  (list 'quote (cdr c))
+					(cdr c))))
+		     record)
+	     bbdb-name
+	     bbdb-company
+	     bbdb-net
+	     bbdb-address
+	     bbdb-phones
+	     bbdb-notes
+	     spec
+	     bbdb-record
+	     value)
+;; BBDB standard fields
+(setq bbdb-name (ph-parse-spec (cdr (assq 'name ph-bbdb-conversion-alist)) record nil)
+	    bbdb-company (ph-parse-spec (cdr (assq 'company ph-bbdb-conversion-alist)) record nil)
+	    bbdb-net (ph-parse-spec (cdr (assq 'net ph-bbdb-conversion-alist)) record nil)
+	    bbdb-notes (ph-parse-spec (cdr (assq 'notes ph-bbdb-conversion-alist)) record nil))
+(setq spec (cdr (assq 'address ph-bbdb-conversion-alist)))
+(setq bbdb-address (delq nil (ph-parse-spec (if (listp (car spec))
+						      spec
+						    (list spec))
+						  record t)))
+(setq spec (cdr (assq 'phone ph-bbdb-conversion-alist)))
+(setq bbdb-phones (delq nil (ph-parse-spec (if (listp (car spec))
+						     spec
+						   (list spec))
+						 record t)))
+;; BBDB custom fields
+(setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
+			       (mapcar (function
+					(lambda (mapping)
+					  (if (and (not (memq (car mapping)
+							      '(name company net address phone notes)))
+						   (setq value (ph-parse-spec (cdr mapping) record nil)))
+					      (cons (car mapping) value))))
+				       ph-bbdb-conversion-alist)))
+(setq bbdb-notes (delq nil bbdb-notes))
+(setq bbdb-record (bbdb-create-internal bbdb-name
+					      bbdb-company
+					      bbdb-net
+					      bbdb-address
+					      bbdb-phones
+					      bbdb-notes))
+(bbdb-display-records (list bbdb-record))
+)))
+(defun ph-parse-spec (spec record recurse)
+"Parse the conversion SPEC using RECORD.
+If RECURSE is non-nil then SPEC may be a list of atomic specs"
+(cond
+((or (stringp spec)
+	(symbolp spec)
+	(and (listp spec)
+	     (symbolp (car spec))
+	     (fboundp (car spec))))
+(condition-case nil
+	(eval spec)
+(void-variable nil)))
+((and recurse
+	 (listp spec))
+(mapcar '(lambda (spec-elem)
+	       (ph-parse-spec spec-elem record nil))
+	    spec))
+(t
+(error "Invalid mapping specification for `%s'. Fix ph-bbdb-conversion-alist" spec))))
+(defun ph-bbdbify-address (addr location)
+"Parse ADDR into a vector compatible with bbdb-create-internal.
+ADR should be an address string of no more than four lines or a
+list of lines.
+The last line is searched for the zip code, city and state name.
+LOCATION is used as the address location for bbdb"
+(let* ((addr-components (if (listp addr)
+			      (reverse addr)
+			    (reverse (split-string addr "\n"))))
+	 (lastl (pop addr-components))
+	 zip city state)
+(setq addr-components (nreverse addr-components))
+(cond
+;; American style
+((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" lastl)
+(setq city (match-string 1 lastl)
+	    state (match-string 2 lastl)
+	    zip (string-to-number (match-string 3 lastl))))
+;; European style
+((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" lastl)
+(setq city (match-string 2 lastl)
+	    zip (string-to-number (match-string 1 lastl))))
+(t
+(error "ph-bbdbify-address was unable to parse the address. Customize ph-bbdb-conversion-alist")))
+(vector location
+	    (or (nth 0 addr-components) "")
+	    (or (nth 1 addr-components) "")
+	    (or (nth 2 addr-components) "")
+	    (or city "")
+	    (or state "")
+	    zip)))
+(defun ph-bbdbify-phone (phone location)
+"Parse PHONE into a vector compatible with bbdb-create-internal.
+PHONE is either a string supposedly containing a phone number or
+a list of such strings which are concatenated.
+LOCATION is used as the phone location for bbdb"
+(let ((phone-string (cond
+		       ((stringp phone)
+			phone)
+		       ((listp phone)
+			(mapconcat 'identity phone ", "))
+		       (t
+			(error "Invalid phone specification. Cannot create bbdb record")))))
+(vector location phone-string)))
 ;;}}}
 ;;{{{      High-level interfaces (interactive functions)
 (defun ph-customize ()
 (customize 'ph))
 (defun ph-set-server (server)
 "Set the server to SERVER."
 (interactive "sNew PH/QI Server: ")
-(setq ph-server server)
+(message "Selected PH/QI server is now %s" server)
-(message "Selected PH/QI server is now %s" server))
+(setq ph-server server))
 (defun ph-get-email (name)
 "Get the email field of NAME from the PH/QI directory server."
 (interactive "sName: ")
 (let ((email (cdaar (ph-query-internal name '(email)))))
 (prin1 ph-server-hotlist)
 (princ ")\n"))
 (save-buffer))
 )
+(defun ph-insert-record-at-point-into-bbdb ()
+"Insert record at point into the BBDB database.
+This function can only be called from a PH/QI query result buffer."
+(interactive)
+(let ((record (and (overlays-at (point))
+		     (overlay-get (car (overlays-at (point))) 'ph-record))))
+(if (null record)
+	(error "Point is not over a record.")
+(ph-create-bbdb-record record))))
 ;;}}}
 ;;{{{      Menu interface
 (require 'easymenu)
 (defconst ph-tail-menu
 `(["---" nil nil]
 ["Query Form" ph-query-form t]
 ["Expand Inline" ph-expand-inline t]
+["Insert Record into BBDB" ph-insert-record-at-point-into-bbdb
+(and (or (featurep 'bbdb)
+	      (locate-library 'bbdb))
+	  (overlays-at (point))
+	  (overlay-get (car (overlays-at (point))) 'ph-record))]
 ["---" nil nil]
 ["Get Email" ph-get-email t]
 ["Get Phone" ph-get-phone t]
 ["List Valid Field Names" ph-get-field-list t]
 ["---" nil nil]

Mercurial > hg > xemacs-beta

comparison lisp/utils/ph.el @ 165:5a88923fcbfe r20-3b9