Commits

Anonymous committed c46a2b5

EUDC Release 1.29

  • Participants
  • Parent commits 48031a0
  • Tags r1-29

Comments (0)

Files changed (14)

+TODO
 _pkg.el
-package-info
 auto-autoloads.el
 custom-load.el
+eudc.aux
+eudc.cp
+eudc.dvi
+eudc.fn
+eudc.ky
+eudc.log
+eudc.pg
+eudc.ps
+eudc.toc
+eudc.tp
+eudc.vr
+package-info
+1999-07-21  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc: EUDC 1.29 is released
+	
+	* eudc-custom-vars.el (eudc-external-viewers): New variable
+
+1999-07-19  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc-custom-vars.el (eudc-attribute-display-method-alist):
+	Changed syntax to use strings instead of symbols as keys
+
+	* eudc.el (eudc-print-attribute-value): Use `assoc' on
+	`eudc-attribute-display-method-alist'
+
+	* eudc-bob.el : New file
+
+	* eudc : Renamed backend files to eudc-bck-*.el
+
+1999-06-19  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc.el : Moved various parts to new files: eudc-hotlist.el,
+	eudc-export.el and eudc-image.el
+	
+	* eudc-custom-vars.el : 
+	(eudc-attribute-display-method-alist): New variable
+
+1999-06-14  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc-ldap.el (eudc-filter-$): Simplified the implementation
+	(eudc-ldap-cleanup-record-simple): New function
+	(eudc-ldap-cleanup-record-filtering-addresses): New function
+	(eudc-ldap-simple-query-internal): Use them
+
+1999-06-02  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc.el (split-string): Synched with XEmacs 21.2 to avoid an
+	infinite loop in some situations
+
+1999-05-30  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc-ldap.el (eudc-ldap-cleanup-record): Removed
+	(eudc-cleanup-record-field): Removed
+	(eudc-ldap-simple-query-internal): Take it into account
+	(toplevel): Set `eudc-attribute-decoding-alist' to decode
+	jpegPhoto
+
+	* eudc.el (eudc-format-attribute-name-for-display): New function
+	(eudc-print-attribute-value): New function
+	(eudc-print-record-field): New function
+	(eudc-display-records): Use them
+
+1999-05-15  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc.el (eudc-batch-import-records-into-bbdb): New function
+	suggested by "Tom Roth" <godfather@pixelpark.com> 
+	(eudc-create-bbdb-record): New parameter `silent' for batch record 
+	creation
+
+	* eudc.texi: Fixes by "James R. Van Zandt" <jrv@vanzandt.mv.com>
+
+	* eudc-custom-vars.el: Bug fixes in custom definitions by "Mark
+ 	Flacy" <flacy@nortelnetworks.com>
+
+1999-04-10  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
+
+	* eudc-ldap.el (eudc-ldap-simple-query-internal): Fixed error when 
+	`return-attrs' is 'all
+
+	* eudc.el (eudc-query): Ditto
+	Fixed problem with hostnames containg `-' in the hotlist editor.
+
 1999-02-13  Oscar Figueiredo  <Oscar.Figueiredo@di.epfl.ch>
 
 	* eudc: Released 1.28
 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 # Boston, MA 02111-1307, USA.
 
-VERSION = 1.28
-AUTHOR_VERSION = 1.28
-MAINTAINER = Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
+VERSION = 1.29
+AUTHOR_VERSION = 1.29
+MAINTAINER = Oscar Figueiredo <oscar@xemacs.org>
 PACKAGE = eudc
 PKG_TYPE = regular
 REQUIRES = fsf-compat xemacs-base bbdb
 CATEGORY = comm
 
-ELCS = eudc.elc eudc-ph.elc eudc-ldap.elc eudc-bbdb.elc eudc-custom-vars.elc
+ELCS =  eudc.elc eudc-hotlist.elc eudc-export.elc eudc-bob.elc \
+	eudc-bck-ph.elc eudc-bck-ldap.elc eudc-bck-bbdb.elc \
+	eudc-custom-vars.elc
 
 INFO_FILES = $(PACKAGE).info*
 TEXI_FILES = $(PACKAGE).texi
+-*- mode:outline -*-
+
+             Emacs Unified Directory Client (EUDC)
+             =====================================
+
+
+This file presents an history of user visible changes in EUDC.  See the
+ChangeLog file for source-level changes.
+
+
+
+
+* Release 1.29
+  ------------
+
+** Support for non-textual values 
+   Right mouse button pops-up a contextual menu of functions to handle those
+   values.
+   Note: internal support for LDAP binary values in XEmacs 21.1 is corrupted
+*** Images can be displayed inline or as buttons (jpegPhoto LDAP attribute)
+*** Sound can be played (audio LDAP attribute)
+*** URLs are clickable (needs browse-url)
+
+** Code has been splitted across several files to make loading faster
+
+** Selecting an LDAP server with an empty search base asks for configuration
+
+** You can import a batch of directory entries into BBDB in a single operation
+   See `eudc-batch-export-records-to-bbdb'
+
+** Miscellaneous bug fixes

File eudc-bck-bbdb.el

+;;; eudc-bck-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Created: Feb 1998
+;; Version: $Revision$
+;; Keywords: help
+
+;; This file is part of XEmacs
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with 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 library provides an interface to use BBDB as a backend of 
+;;    the Emacs Unified Directory Client.
+
+;;; Installation:
+;;    Install EUDC first. See EUDC documentation.
+
+;;    This library runs under XEmacs 20 and under Emacs 19.34 and above
+
+;;; Usage:
+
+;;; Code:
+
+(require 'eudc)
+(require 'bbdb)
+(require 'bbdb-com)
+
+;;{{{      Internal cooking
+
+;; I don't like this but mapcar does not accept a parameter to the function and
+;; I don't want to use mapcar*
+(defvar eudc-bbdb-current-query nil)
+(defvar eudc-bbdb-current-return-attributes nil)
+
+(defvar eudc-bbdb-attributes-translation-alist
+  '((name . lastname)
+    (email . net)
+    (phone . phones))
+  "Alist mapping EUDC attribute names to BBDB names.")
+
+(eudc-protocol-set 'eudc-query-function 'eudc-bbdb-query-internal 'bbdb)
+(eudc-protocol-set 'eudc-list-attributes-function nil 'bbdb)
+(eudc-protocol-set 'eudc-protocol-attributes-translation-alist 
+		   'eudc-bbdb-attributes-translation-alist 'bbdb)
+(eudc-protocol-set 'eudc-bbdb-conversion-alist nil 'bbdb)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'bbdb)
+
+(defun eudc-bbdb-format-query (query)
+  "Format a EUDC query alist into a list suitable to `bbdb-search'."
+  (let* ((firstname (cdr (assq 'firstname query)))
+	 (lastname (cdr (assq 'lastname query)))
+	 (name (or (and firstname lastname
+			(concat firstname " " lastname))
+		   firstname
+		   lastname))
+	(company (cdr (assq 'company query)))
+	(net (cdr (assq 'net query)))
+	(notes (cdr (assq 'notes query)))
+	(phone (cdr (assq 'phone query))))
+    (list name company net notes phone)))
+	
+
+(defun eudc-bbdb-filter-non-matching-record (record)
+  "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
+  (catch 'unmatch
+    (progn
+      (mapcar 
+       (function 
+	(lambda (condition)
+	  (let ((attr (car condition))
+		(val (cdr condition))
+		(case-fold-search t)
+		bbdb-val)
+	    (or (and (memq attr '(firstname lastname aka company phones addresses net))
+		     (progn 
+		       (setq bbdb-val 
+			     (eval (list (intern (concat "bbdb-record-" 
+							 (symbol-name attr)))
+					 'record)))
+		       (if (listp bbdb-val)
+			   (if eudc-bbdb-enable-substring-matches
+			       (eval `(or ,@(mapcar '(lambda (subval)
+						       (string-match val
+								     subval))
+						  bbdb-val)))
+			     (member (downcase val)
+				     (mapcar 'downcase bbdb-val)))
+			 (if eudc-bbdb-enable-substring-matches
+			     (string-match val bbdb-val)
+			   (string-equal (downcase val) (downcase bbdb-val))))))
+		(throw 'unmatch nil)))))
+       eudc-bbdb-current-query)
+      record)))
+
+(defun eudc-bbdb-extract-phones (record)
+  (mapcar (function
+	   (lambda (phone)
+	     (if eudc-bbdb-use-locations-as-attribute-names
+		 (cons (intern (bbdb-phone-location phone))
+		       (bbdb-phone-string phone))
+	       (cons 'phones (format "%s: %s" 
+				     (bbdb-phone-location phone)
+				     (bbdb-phone-string phone))))))
+	  (bbdb-record-phones record)))
+
+(defun eudc-bbdb-extract-addresses (record)
+  (let (s c val)
+    (mapcar (function
+	     (lambda (address)
+	       (setq val (concat (unless (= 0 (length (setq s (bbdb-address-street1 address))))
+				   (concat s "\n"))
+				 (unless (= 0 (length (setq s (bbdb-address-street2 address))))
+				   (concat s "\n"))
+				 (unless (= 0 (length (setq s (bbdb-address-street3 address))))
+				   (concat s "\n"))
+				 (progn 
+				   (setq c (bbdb-address-city address))
+				   (setq s (bbdb-address-state address))
+				   (if (and (> (length c) 0) (> (length s) 0))
+				       (concat c ", " s " ")
+				     (concat c " ")))
+				 (bbdb-address-zip-string address)))
+	       (if eudc-bbdb-use-locations-as-attribute-names
+		   (cons (intern (bbdb-address-location address)) val)
+		 (cons 'addresses (concat (bbdb-address-location address) "\n" val)))))
+	    (bbdb-record-addresses record))))
+
+(defun eudc-bbdb-format-record-as-result (record)
+  "Format the BBDB RECORD as a EUDC query result record.
+The record is filtered according to `eudc-bbdb-current-return-attributes'"
+  (let ((attrs (or eudc-bbdb-current-return-attributes
+		   '(firstname lastname aka company phones addresses net notes)))
+	attr
+	eudc-rec
+	val)
+    (while (prog1 
+	       (setq attr (car attrs))
+	     (setq attrs (cdr attrs)))
+      (cond
+       ((eq attr 'phones)
+	(setq val (eudc-bbdb-extract-phones record)))
+       ((eq attr 'addresses)
+	(setq val (eudc-bbdb-extract-addresses record)))
+       ((memq attr '(firstname lastname aka company net notes))
+	(setq val (eval 
+		   (list (intern 
+			  (concat "bbdb-record-" 
+				  (symbol-name attr)))
+			 'record))))
+       (t
+	(setq val "Unknown BBDB attribute")))
+      (if val
+	(cond 
+	 ((memq attr '(phones addresses))
+	  (setq eudc-rec (append val eudc-rec)))
+	 ((and (listp val)
+	  (= 1 (length val)))
+	  (setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
+	 ((> (length val) 0)
+	  (setq eudc-rec (cons (cons attr val) eudc-rec)))
+	 (t
+	  (error "Unexpected attribute value")))))
+    (nreverse eudc-rec)))
+	
+
+
+(defun eudc-bbdb-query-internal (query &optional return-attrs)
+  "Query BBDB  with QUERY.
+QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid 
+BBDB attribute names.  
+RETURN-ATTRS is a list of attributes to return, defaulting to 
+`eudc-default-return-attributes'."
+
+  (let ((eudc-bbdb-current-query query)
+	(eudc-bbdb-current-return-attributes return-attrs)
+	(query-attrs (eudc-bbdb-format-query query))
+	bbdb-attrs
+	(records (bbdb-records))
+	result
+	filtered)
+    ;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
+    ;; call bbdb-search iteratively on the returned records for each of the
+    ;; requested attributes
+    (while (and records (> (length query-attrs) 0))
+      (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
+      (if (car query-attrs)
+	  (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
+      (setq query-attrs (cdr query-attrs)))
+    (mapcar (function
+	     (lambda (record)
+	       (setq filtered (eudc-filter-duplicate-attributes record))
+	       ;; If there were duplicate attributes reverse the order of the
+	       ;; record so the unique attributes appear first
+	       (if (> (length filtered) 1)
+		   (setq filtered (mapcar (function 
+					   (lambda (rec)
+					     (reverse rec)))
+					  filtered)))
+	       (setq result (append result filtered))))
+	    (delq nil
+		  (mapcar 'eudc-bbdb-format-record-as-result 
+			  (delq nil 
+				(mapcar 'eudc-bbdb-filter-non-matching-record 
+					records)))))
+    result))
+
+;;}}}        
+
+;;{{{      High-level interfaces (interactive functions)
+
+(defun eudc-bbdb-set-server (dummy)
+  "Set the EUDC server to BBDB."
+  (interactive)
+  (eudc-set-server dummy 'bbdb)
+  (message "BBDB server selected"))
+
+;;;}}}
+
+
+(eudc-register-protocol 'bbdb)
+
+(provide 'eudc-bck-bbdb)
+
+;;; eudc-bck-bbdb.el ends here

File eudc-bck-ldap.el

+;;; eudc-bck-ldap.el --- Emacs Unified Directory Client - LDAP Backend
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Created: Feb 1998
+;; Version: $Revision$
+;; Keywords: help
+
+;; This file is part of XEmacs
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with 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 library provides specific LDAP protocol support for the 
+;;    Emacs Unified Directory Client library.
+
+;;; Installation:
+;;    Install EUDC first. See EUDC documentation.
+
+;;; Code:
+
+(require 'eudc)
+(require 'ldap)
+
+
+;;{{{      Internal cooking
+
+(if (fboundp 'ldap-get-host-parameter)
+    (fset 'eudc-ldap-get-host-parameter 'ldap-get-host-parameter)
+  (defun eudc-ldap-get-host-parameter (host parameter)
+    "Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
+    (plist-get (cdr (assoc host ldap-host-parameters-alist))
+	       parameter)))
+
+(defvar eudc-ldap-attributes-translation-alist
+  '((name . sn)
+    (firstname . givenname)
+    (email . mail)
+    (phone . telephonenumber))
+  "Alist mapping EUDC attribute names to LDAP names.")
+
+(eudc-protocol-set 'eudc-query-function 'eudc-ldap-simple-query-internal 
+		   'ldap)
+(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ldap-get-field-list
+		   'ldap)
+(eudc-protocol-set 'eudc-protocol-attributes-translation-alist 
+		   'eudc-ldap-attributes-translation-alist 'ldap)
+(eudc-protocol-set 'eudc-bbdb-conversion-alist 
+		   'eudc-ldap-bbdb-conversion-alist 
+		   'ldap)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'ldap)
+(eudc-protocol-set 'eudc-attribute-display-method-alist 
+		   '(("jpegphoto" . eudc-display-jpeg-inline)
+		     ("labeledurl" . eudc-display-url)
+		     ("audio" . eudc-display-sound)
+		     ("labeledurl" . eudc-display-url)
+		     ("url" . eudc-display-url)) 
+		   'ldap)
+(eudc-protocol-set 'eudc-switch-to-server-hook 
+		   '(eudc-ldap-check-base) 
+		   'ldap)
+
+(defun eudc-ldap-cleanup-record-simple (record)
+  "Do some cleanup in a record to make it suitable for EUDC."
+  (mapcar 
+   (function 
+    (lambda (field)
+      (cons (intern (car field))
+	    (if (cdr (cdr field))
+		(cdr field)
+	      (car (cdr field))))))
+   record))
+
+(defun eudc-filter-$ (string)
+  (mapconcat 'identity (split-string string "\\$") "\n"))
+
+;; Cleanup a LDAP record to make it suitable for EUDC:
+;;   Make the record a cons-cell instead of a list if the it's single-valued
+;;   Filter the $ character in addresses into \n if not done by the LDAP lib
+(defun eudc-ldap-cleanup-record-filtering-addresses (record)
+  (mapcar 
+   (function 
+    (lambda (field)
+      (let ((name (intern (car field)))
+	    (value (cdr field)))
+	(if (memq name '(postaladdress registeredaddress))
+	    (setq value (mapcar 'eudc-filter-$ value)))
+	(cons name
+	      (if (cdr value)
+		  value
+		(car value))))))
+   record))
+
+(defun eudc-ldap-simple-query-internal (query &optional return-attrs)
+  "Query the LDAP server with QUERY.
+QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid 
+LDAP attribute names.  
+RETURN-ATTRS is a list of attributes to return, defaulting to 
+`eudc-default-return-attributes'."
+  (let ((result (ldap-search (eudc-ldap-format-query-as-rfc1558 query)
+			     eudc-server
+			     (if (listp return-attrs)
+				 (mapcar 'symbol-name return-attrs))))
+	final-result)
+    (if (or (not (boundp 'ldap-ignore-attribude-codings))
+	    ldap-ignore-attribude-codings)
+	(setq result 
+	      (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result))
+      (setq result (mapcar 'eudc-ldap-cleanup-record-simple result)))
+
+    (if (and eudc-strict-return-matches
+	     return-attrs
+	     (not (eq 'all return-attrs)))
+	(setq result (eudc-filter-partial-records result return-attrs)))
+    ;; Apply eudc-duplicate-attribute-handling-method
+    (if (not (eq 'list eudc-duplicate-attribute-handling-method))
+	(mapcar 
+	 (function (lambda (record)
+		     (setq final-result 
+			   (append (eudc-filter-duplicate-attributes record)
+				   final-result))))
+	 result))
+    final-result))
+
+(defun eudc-ldap-get-field-list (dummy &optional objectclass)
+  "Return a list of valid attribute names for the current server.
+OBJECTCLASS is the LDAP object class for which the valid
+attribute names are returned. Default to `person'"
+  (interactive)
+  (or eudc-server
+      (call-interactively 'eudc-set-server))
+  (let ((ldap-host-parameters-alist 
+	 (list (cons eudc-server
+		     '(scope subtree sizelimit 1)))))
+    (mapcar 'eudc-ldap-cleanup-record
+	    (ldap-search 
+	     (eudc-ldap-format-query-as-rfc1558 
+	      (list (cons "objectclass"
+			  (or objectclass
+			      "person"))))
+	     eudc-server nil t))))
+
+(defun eudc-ldap-format-query-as-rfc1558 (query)
+  "Format the EUDC QUERY list as a RFC1558 LDAP search filter."
+  (format "(&%s)" (apply 'concat (mapcar '(lambda (item)
+					    (format "(%s=%s)" (car item) (cdr item)))
+					 query))))
+
+
+;;}}}        
+
+;;{{{      High-level interfaces (interactive functions)
+
+(defun eudc-ldap-customize ()
+  "Customize the EUDC LDAP support."
+  (interactive)
+  (customize-group 'eudc-ldap))
+
+(defun eudc-ldap-check-base ()
+  "Check if the current LDAP server has a configured search base."
+  (unless (or (eudc-ldap-get-host-parameter eudc-server 'base)
+	      ldap-default-base
+	      (null (y-or-n-p "No search base defined. Configure it now ?")))
+    ;; If the server is not in ldap-host-parameters-alist we add it for the
+    ;; user
+    (if (null (assoc eudc-server ldap-host-parameters-alist))
+	(setq ldap-host-parameters-alist 
+	      (cons (list eudc-server) ldap-host-parameters-alist)))
+    (customize-variable 'ldap-host-parameters-alist)))
+
+;;;}}}
+
+
+(eudc-register-protocol 'ldap)
+
+(provide 'eudc-bck-ldap)
+
+;;; eudc-bck-ldap.el ends here

File eudc-bck-ph.el

+;;; eudc-bck-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Created: Feb 1998
+;; Version: $Revision$
+;; Keywords: help
+
+;; This file is part of XEmacs
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with 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 library provides specific CCSO PH/QI protocol support for the 
+;;    Emacs Unified Directory Client library.
+
+;;; Installation:
+;;    Install EUDC first. See EUDC documentation.
+
+;;    This library runs under XEmacs 20 and under Emacs 19.34 and above
+
+;;; Usage:
+
+;;; Code:
+
+(require 'eudc)
+
+
+;;{{{      Internal cooking
+
+(eudc-protocol-set 'eudc-bbdb-conversion-alist 'eudc-ph-bbdb-conversion-alist 'ph)
+(eudc-protocol-set 'eudc-query-function 'eudc-ph-query-internal 'ph)
+(eudc-protocol-set 'eudc-list-attributes-function 'eudc-ph-get-field-list 'ph)
+(eudc-protocol-set 'eudc-protocol-has-default-query-attributes t 'ph)
+
+(defvar eudc-ph-process-buffer nil)
+(defvar eudc-ph-read-point)
+
+(defconst eudc-ph-default-server-port 105
+  "Default TCP port for CCSO PH/QI directory services.")
+
+
+
+
+(defun eudc-ph-query-internal (query &optional return-fields)
+  "Query the PH/QI server with QUERY.
+QUERY can be a string NAME or a list made of strings NAME 
+and/or cons cells (KEY . VALUE) where KEYs should be valid 
+CCSO database keys.  NAME is equivalent to (DEFAULT . NAME),
+where DEFAULT is the default key of the database.
+RETURN-FIELDS is a list of database fields to return,
+defaulting to `eudc-default-return-attributes'."
+  (let (request)
+    (if (null return-fields)
+	(setq return-fields eudc-default-return-attributes))
+    (if (eq 'all return-fields)
+	(setq return-fields '(all)))
+    (setq request 
+	  (concat "query "
+		  (if (stringp query)
+		      query
+		    (mapconcat (function (lambda (elt)
+					   (if (stringp elt) elt)
+					   (format "%s=%s" (car elt) (cdr elt))))
+			       query
+			       " "))
+		  (if return-fields
+		      (concat " return " (mapconcat 'symbol-name return-fields " ")))))
+    (and (> (length request) 6)
+	 (eudc-ph-do-request request)
+	 (eudc-ph-parse-query-result return-fields))))
+
+(defun eudc-ph-get-field-list (full-records)
+  "Return a list of valid field names for the current server.
+If FULL-RECORDS is non-nil, full records including field description
+are returned"
+  (interactive)
+  (eudc-ph-do-request "fields")
+  (if full-records
+      (eudc-ph-parse-query-result)
+    (mapcar 'eudc-caar (eudc-ph-parse-query-result))))
+
+
+(defun eudc-ph-parse-query-result (&optional fields)
+  "Return a list of alists of key/values from in `eudc-ph-process-buffer'. 
+Fields not in FIELDS are discarded."
+  (let (record 
+	records
+	line-regexp
+	current-key
+	key
+	value
+	ignore)
+    (save-excursion
+      (message "Parsing results...")
+      (set-buffer eudc-ph-process-buffer)
+      (goto-char (point-min))
+      (while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t)
+	(catch 'ignore
+	  (setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))
+	  (beginning-of-line)
+	  (setq record nil
+		ignore nil
+		current-key nil)
+	  (while (re-search-forward line-regexp nil t)
+	    (catch 'skip-line
+	      (if (string= "-508" (match-string 1))
+		  ;; A field is missing in this entry.  Skip it or skip the
+		  ;; whole record (see `eudc-strict-return-matches')
+		  (if (not eudc-strict-return-matches)
+		      (throw 'skip-line t)
+		    (while (re-search-forward line-regexp nil t))
+		    (setq ignore t)
+		    (throw 'ignore t)))
+	      (setq key   (and (not (string= (match-string 2) ""))
+			       (intern (match-string 2)))
+		    value (match-string 3))
+	      (if (and current-key
+		       (eq key current-key)) 
+		  (setq key nil)
+		(setq current-key key))
+	      (if (or (null fields)
+		      (eq 'all fields)
+		      (memq current-key fields))
+		  (if key
+		      (setq record (cons (cons key value) record)) ; New key
+		    (setcdr (car record) (if (listp (eudc-cdar record))
+					     (append (eudc-cdar record) (list value))
+					   (list (eudc-cdar record) value))))))))
+	(and (not ignore)
+	     (or (null fields)
+		 (eq 'all fields)
+		 (setq record (nreverse record)))
+	     (setq record (if (not (eq 'list eudc-duplicate-attribute-handling-method))
+			      (eudc-filter-duplicate-attributes record)
+			    (list record)))
+	     (setq records (append record records))))
+      )
+    (message "Done")
+    records)
+  )
+
+(defun eudc-ph-do-request (request)
+  "Send REQUEST to the server.
+Wait for response and return the buffer containing it."
+  (let (process
+	buffer)
+    (unwind-protect
+	(progn
+	  (message "Contacting server...")
+	  (setq process (eudc-ph-open-session))
+	  (if process
+	      (save-excursion 
+		(set-buffer (setq buffer (process-buffer process)))
+		(eudc-ph-send-command process request)
+		(message "Request sent, waiting for reply...")
+		(eudc-ph-read-response process))))
+      (if process
+	  (eudc-ph-close-session process)))
+    buffer))
+        
+(defun eudc-ph-open-session (&optional server)
+  "Open a connection to the given CCSO/QI SERVER.
+SERVER is either a string naming the server or a list (NAME PORT)."
+  (let (process
+	host
+	port)
+    (catch 'done
+      (if (null server)
+	  (setq server (or eudc-server
+			   (call-interactively 'eudc-ph-set-server))))
+      (string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server)
+      (setq host (match-string 1 server))
+      (setq port (or (match-string 3 server)
+		     eudc-ph-default-server-port))
+      (setq eudc-ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
+      (save-excursion
+	(set-buffer eudc-ph-process-buffer)
+	(erase-buffer)
+	(setq eudc-ph-read-point (point))
+	(and eudc-xemacs-mule-p
+	     (set-buffer-file-coding-system 'binary t)))
+      (setq process (open-network-stream "ph" eudc-ph-process-buffer host port))
+      (if (null process)
+	  (throw 'done nil))
+      (process-kill-without-query process)
+      process)))
+
+
+(defun eudc-ph-close-session (process)
+  (save-excursion
+    (set-buffer (process-buffer process))
+    (eudc-ph-send-command process "quit")
+    (eudc-ph-read-response process)
+    (if (fboundp 'add-async-timeout)
+	(add-async-timeout 10 'delete-process process)
+      (run-at-time 2 nil 'delete-process process))))
+
+(defun eudc-ph-send-command (process command)
+  (goto-char (point-max))
+  (process-send-string process command)
+  (process-send-string process "\r\n")
+  )
+
+(defun eudc-ph-read-response (process &optional return-response)
+  "Read a response from the PH/QI query process PROCESS.
+Returns nil if response starts with an error code.  If the
+response is successful the return code or the reponse itself is returned
+depending on RETURN-RESPONSE."
+  (let ((case-fold-search nil)
+	return-code
+	match-end)
+    (goto-char eudc-ph-read-point)
+    ;; CCSO protocol : response complete if status >= 200
+    (while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t))
+      (accept-process-output process)
+      (goto-char eudc-ph-read-point))
+    (setq match-end (point))
+    (goto-char eudc-ph-read-point)
+    (if (and (setq return-code (match-string 1))
+	     (setq return-code (string-to-number return-code))
+	     (>= (abs return-code) 300))
+	(progn (setq eudc-ph-read-point match-end) nil)
+      (setq eudc-ph-read-point match-end)
+      (if return-response
+	  (buffer-substring (point) match-end)
+	return-code))))
+
+;;}}}        
+
+;;{{{      High-level interfaces (interactive functions)
+
+(defun eudc-ph-customize ()
+  "Customize the EUDC PH support."
+  (interactive)
+  (customize-group 'eudc-ph))
+
+(defun eudc-ph-set-server (server)
+  "Set the PH server to SERVER."
+  (interactive "sNew PH/QI Server: ")
+  (message "Selected PH/QI server is now %s" server)
+  (eudc-set-server server 'ph))
+
+;;}}}
+
+
+(eudc-register-protocol 'ph)
+
+(provide 'eudc-bck-ph)
+
+;;; eudc-bck-ph.el ends here
+;;; eudc-bob.el --- Binary Objects Support for EUDC
+
+;; Copyright (C) 1999 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Created: Jun 1999
+;; Version: $Revision$
+;; Keywords: help
+
+;; This file is part of XEmacs
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to 
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Usage:
+;;    See the corresponding info file
+
+;;; Code:
+
+(require 'eudc)
+
+(defvar eudc-bob-generic-keymap nil
+  "Keymap for multimedia objects")
+
+(defvar eudc-bob-image-keymap nil
+  "Keymap for inline images")
+
+(defvar eudc-bob-sound-keymap nil
+  "Keymap for inline images")
+
+(defvar eudc-bob-url-keymap nil
+  "Keymap for inline images")
+
+(defconst eudc-bob-generic-menu
+  '("EUDC Binary Object Menu"
+    ["---" nil nil]
+    ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
+    ["Save object" eudc-bob-save-object t]))
+
+(defconst eudc-bob-image-menu
+  `("EUDC Image Menu"
+    ["---" nil nil]
+    ["Toggle inline display" eudc-bob-toggle-inline-display
+     (eudc-bob-can-display-inline-images)]
+    ,@(cdr (cdr eudc-bob-generic-menu))))
+ 
+(defconst eudc-bob-sound-menu
+  `("EUDC Sound Menu"
+    ["---" nil nil]
+    ["Play sound" eudc-bob-play-sound-at-point 
+     (fboundp 'play-sound)]
+    ,@(cdr (cdr eudc-bob-generic-menu))))
+ 
+(defun eudc-jump-to-event (event)
+  "Jump to the window and point where EVENT occurred."
+  (if eudc-xemacs-p
+      (goto-char (event-closest-point event))
+    (set-buffer (window-buffer (posn-window (event-start event))))
+    (goto-char (posn-point (event-start event)))))
+
+(defun eudc-bob-get-overlay-prop (prop)
+  "Get property PROP from one of the overlays around."
+  (let ((overlays (append (overlays-at (1- (point)))
+			  (overlays-at (point))))
+	overlay value
+	(notfound t))
+    (while (and notfound
+		(setq overlay (car overlays)))
+      (if (setq value (overlay-get overlay prop))
+	  (setq notfound nil))
+      (setq overlays (cdr overlays)))
+    value))
+
+(defun eudc-bob-can-display-inline-images ()
+  "Return non-nil if we can display images inline."
+  (and eudc-xemacs-p
+       (memq (console-type) 
+	     '(x mswindows))
+       (fboundp 'make-glyph)))
+
+(defun eudc-bob-make-button (label keymap &optional menu plist)
+  "Create a button with LABEL.
+Attach KEYMAP, MENU and properties from PLIST to a new overlay covering 
+LABEL."
+  (let (overlay
+	(p (point))
+	prop val)
+    (insert label)
+    (put-text-property p (point) 'face 'bold)    
+    (setq overlay (make-overlay p (point)))
+    (overlay-put overlay 'mouse-face 'highlight)
+    (overlay-put overlay 'keymap keymap)
+    (overlay-put overlay 'local-map keymap)
+    (overlay-put overlay 'menu menu)
+    (while plist
+      (setq prop (car plist)
+	    plist (cdr plist)
+	    val (car plist)
+	    plist (cdr plist))
+      (overlay-put overlay prop val))))
+
+(defun eudc-bob-display-jpeg (data inline)
+  "Display the JPEG DATA at point.
+if INLINE is non-nil then try to inline the image otherwise simply 
+display a button."
+  (let ((glyph (if (eudc-bob-can-display-inline-images)
+		   (make-glyph (list (vector 'jpeg :data data) 
+				     [string :data "[JPEG Picture]"])))))
+    (eudc-bob-make-button "[JPEG Picture]"
+			  eudc-bob-image-keymap
+			  eudc-bob-image-menu
+			  (list 'glyph glyph
+				'end-glyph (if inline glyph)
+				'duplicable t
+				'invisible inline
+				'start-open t
+				'end-open t
+				'object-data data))))
+
+(defun eudc-bob-toggle-inline-display ()
+  "Toggle inline display of an image"
+  (interactive)
+  (if (eudc-bob-can-display-inline-images)
+      (let ((overlays (append (overlays-at (1- (point)))
+			      (overlays-at (point))))
+	    overlay glyph)
+	(setq overlay (car overlays))
+	(while (and overlay
+		    (not (setq glyph (overlay-get overlay 'glyph))))
+	  (setq overlays (cdr overlays))
+	  (setq overlay (car overlays)))
+	(if overlay
+	    (if (overlay-get overlay 'end-glyph)
+		(progn
+		  (overlay-put overlay 'end-glyph nil)
+		  (overlay-put overlay 'invisible nil))
+	      (overlay-put overlay 'end-glyph glyph)
+	      (overlay-put overlay 'invisible t))))))
+
+(defun eudc-bob-display-audio (data)
+  "Display a button for audio DATA"
+  (eudc-bob-make-button "[Audio Sound]"
+			eudc-bob-sound-keymap
+			eudc-bob-sound-menu
+			(list 'duplicable t
+			      'start-open t
+			      'end-open t
+			      'object-data data)))
+
+
+(defun eudc-bob-display-generic-binary (data)
+  "Display a button for unidentified binary DATA"
+  (eudc-bob-make-button "[Binary Data]"
+			eudc-bob-generic-keymap
+			eudc-bob-generic-menu
+			(list 'duplicable t
+			      'start-open t
+			      'end-open t
+			      'object-data data)))
+
+(defun eudc-bob-play-sound-at-point ()
+  "Play the sound data contained in the button at point."
+  (interactive)
+  (let (sound)
+    (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
+	(error "No sound data available here")
+      (if (not (and (boundp 'sound-alist)
+		    sound-alist))
+	  (error "Don't know how to play sound on this Emacs version")
+	(setq sound-alist 
+	      (cons (list 'eudc-sound 
+			  :sound sound)
+		    sound-alist))
+	(condition-case nil
+	    (play-sound 'eudc-sound)
+	  (t 
+	   (setq sound-alist (cdr sound-alist))))))))
+  
+
+(defun eudc-bob-play-sound-at-mouse (event)
+  "Play the sound data contained in the button where EVENT occurred."
+  (interactive "e")
+  (save-excursion
+    (eudc-jump-to-event event)
+    (eudc-bob-play-sound-at-point)))
+  
+
+(defun eudc-bob-save-object ()
+  "Save the object data of the button at point."
+  (interactive)
+  (let ((data (eudc-bob-get-overlay-prop 'object-data))
+	(buffer (generate-new-buffer "*eudc-tmp*")))
+    (save-excursion
+      (if (fboundp 'set-buffer-file-coding-system)
+	  (set-buffer-file-coding-system 'binary))
+      (set-buffer buffer)
+      (insert data)
+      (save-buffer))
+    (kill-buffer buffer)))
+
+(defun eudc-bob-pipe-object-to-external-program ()
+  "Pipe the object data of the button at point to an external program."
+  (interactive)
+  (let ((data (eudc-bob-get-overlay-prop 'object-data))
+	(buffer (generate-new-buffer "*eudc-tmp*"))
+	program)
+    (condition-case nil
+	(save-excursion
+	  (if (fboundp 'set-buffer-file-coding-system)
+	      (set-buffer-file-coding-system 'binary))
+	  (set-buffer buffer)
+	  (insert data)
+	  (setq program (completing-read "Viewer: " eudc-external-viewers))
+	  (if (setq viewer (assoc program eudc-external-viewers))
+	      (call-process-region (point-min) (point-max) 
+				   (car (cdr viewer)) 
+				   (cdr (cdr viewer)))
+	    (call-process-region (point-min) (point-max) program)))
+      (t
+       (kill-buffer buffer)))))
+
+(defun eudc-bob-menu ()
+  "Retrieve the menu attached to a binary object"
+  (eudc-bob-get-overlay-prop 'menu))
+  
+(defun eudc-bob-popup-menu (event)
+  "Pop-up a menu of EUDC multimedia commands"
+  (interactive "@e")
+  (run-hooks 'activate-menubar-hook)
+  (eudc-jump-to-event event)
+  (if eudc-xemacs-p
+      (progn 
+	(run-hooks 'activate-popup-menu-hook)
+	(popup-menu (eudc-bob-menu)))
+    (let ((result (x-popup-menu t (eudc-bob-menu)))
+	  command)
+      (if result
+	  (progn
+	    (setq command (lookup-key (eudc-bob-menu)
+				      (apply 'vector result)))
+	    (command-execute command))))))
+
+(setq eudc-bob-generic-keymap
+      (let ((map (make-sparse-keymap)))
+	(define-key map "s" 'eudc-bob-save-object)
+	(define-key map (if eudc-xemacs-p
+			    [button3]
+			  [down-mouse-3]) 'eudc-bob-popup-menu)
+	map))
+
+(setq eudc-bob-image-keymap
+      (let ((map (make-sparse-keymap)))
+	(define-key map "t" 'eudc-bob-toggle-inline-display)
+	map))
+
+(setq eudc-bob-sound-keymap
+      (let ((map (make-sparse-keymap)))
+	(define-key map [return] 'eudc-bob-play-sound-at-point)
+	(define-key map (if eudc-xemacs-p
+			    [button2]
+			  [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
+	map))
+
+(setq eudc-bob-url-keymap
+      (let ((map (make-sparse-keymap)))
+	(define-key map [return] 'browse-url-at-point)
+	(define-key map (if eudc-xemacs-p
+			    [button2]
+			  [down-mouse-2]) 'browse-url-at-mouse)
+	map))
+
+(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
+(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
+
+    
+(if eudc-emacs-p
+    (progn
+      (easy-menu-define eudc-bob-generic-menu 
+			eudc-bob-generic-keymap
+			""
+			eudc-bob-generic-menu)
+      (easy-menu-define eudc-bob-image-menu 
+			eudc-bob-image-keymap
+			""
+			eudc-bob-image-menu)
+      (easy-menu-define eudc-bob-sound-menu 
+			eudc-bob-sound-keymap
+			""
+			eudc-bob-sound-menu)))
+
+;;;###autoload
+(defun eudc-display-generic-binary (data)
+  "Display a button for unidentified binary DATA."
+  (eudc-bob-display-generic-binary data))
+
+;;;###autoload
+(defun eudc-display-url (url)
+  "Display URL and make it clickable."
+  (require 'browse-url)
+  (eudc-bob-make-button url eudc-bob-url-keymap))
+
+;;;###autoload
+(defun eudc-display-sound (data)
+  "Display a button to play the sound DATA."
+  (eudc-bob-display-audio data))
+
+;;;###autoload
+(defun eudc-display-jpeg-inline (data)
+  "Display the JPEG DATA inline at point if possible."
+  (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
+
+;;;###autoload
+(defun eudc-display-jpeg-as-button (data)
+  "Display a button for the JPEG DATA."
+  (eudc-bob-display-jpeg data nil))
+    
+;;; eudc-bob.el ends here

File eudc-custom-vars.el

 
 ;; Copyright (C) 1998 Free Software Foundation, Inc.
 
-;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
-;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
 ;; Created: Feb 1998
 ;; Version: $Revision$
 ;; Keywords: help
 Supported protocols are specified by `eudc-supported-protocols'."
   :type  `(choice :menu-tag "Protocol"
 		  ,@(mapcar (lambda (s) 
-			      (list 'string ':tag (symbol-name s)))
+			      (list 'const ':tag (symbol-name s) s))
 			    eudc-known-protocols))
   :group 'eudc)
 
 If set to the symbol `all' return all attributes.
 nil means return the default attributes as configured in the server."
   :type  '(choice :menu-tag "Return Attributes"
-		  (const :menu-tag "Server Defaults (nil)" nil)
+		  (const :menu-tag "Server defaults (nil)" nil)
 		  (const :menu-tag "All" all)
-		  (repeat :menu-tag "Edit List" (symbol :tag "Field name")))
+		  (repeat :menu-tag "Attribute list" 
+			  :tag "Attribute name"
+			  :value (nil)
+			  (symbol :tag "Attribute name")))
   :group 'eudc)
 
 (defcustom eudc-multiple-match-handling-method 'select
   :type  'boolean
   :group 'eudc)
 
+(defcustom eudc-attribute-display-method-alist nil
+  "*An alist specifying methods to display attribute values.  Each member 
+of the list is of the form (NAME . FUNC) where NAME is a lowercased
+string naming a directory attribute (translated according to 
+`eudc-user-attribute-names-alist' if `eudc-use-raw-directory-names' is 
+non-nil) and FUNC a function that will be passed the corresponding 
+attribute values for display."
+  :tag "Attribute Decoding Functions"
+  :type '(repeat (cons :tag "Attribute"
+		       (symbol :tag "Name")
+		       (symbol :tag "Display Function")))
+  :group 'eudc)
+
+(defcustom eudc-external-viewers '(("XV" "xv" "-") 
+				   ("ImageMagick" "display" "-")
+				   ("ShowAudio" "showaudio"))
+  "*A list of viewer program specifications.
+Viewers are programs which can be piped a directory attribute value for
+display or arbitrary processing. Each specification is a list whose 
+first element is a string naming the viewer, the second element is the 
+executable program which should be invoked and following elements are
+arguments that should be passed to the program."
+  :tag "External Viewer Programs"
+  :type '(repeat (list :tag "Viewer"
+		       (string :tag "Name")
+		       (string :tag "Executable program")
+		       (repeat
+			:tag "Arguments"
+			:inline t
+			(string :tag "Argument"))))
+  :group 'eudc)
+
 (defcustom eudc-options-file "~/.eudc-options"
   "*A file where the `servers' hotlist is stored."
-  :type '(file :Tag "File Name:"))
+  :type '(file :Tag "File Name:")
+  :group 'eudc)
 
 (defcustom eudc-mode-hook nil
   "*Normal hook run on entry to EUDC mode."
-  :type '(repeat (sexp :tag "Hook definition")))
+  :type '(repeat (sexp :tag "Hook definition"))
+  :group 'eudc)
 
 ;;}}}
 

File eudc-export.el

+;;; eudc-export.el --- Functions to export EUDC qeuery results
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Created: Jun 1999
+;; Version: $Revision$
+;; Keywords: help
+
+;; This file is part of XEmacs
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with 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:
+
+;;; Usage:
+;;    See the corresponding info file
+
+;;; Code:
+
+(require 'eudc)
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+(defun eudc-create-bbdb-record (record &optional silent)
+  "Create a BBDB record using the RECORD alist.
+RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
+symbol and VALUE is the corresponding value for the record.
+If SILENT is non-nil then the created BBDB record is not displayed."
+  ;; This function runs in a special context where lisp symbols corresponding
+  ;; to field names in record are bound to the corresponding values
+  (eval 
+   `(let* (,@(mapcar '(lambda (c)
+			(list (car c) (if (listp (cdr c))
+					  (list 'quote (cdr c))
+					(cdr c))))
+		     record)
+	     bbdb-name
+	     bbdb-company
+	     bbdb-net
+	     bbdb-address
+	     bbdb-phones
+	     bbdb-notes
+	     spec
+	     bbdb-record
+	     value
+	     (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
+
+      ;; BBDB standard fields
+      (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
+	    bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
+	    bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
+	    bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
+      (setq spec (cdr (assq 'address conversion-alist)))
+      (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
+						      spec
+						    (list spec))
+						  record t)))
+      (setq spec (cdr (assq 'phone conversion-alist)))
+      (setq bbdb-phones (delq nil (eudc-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 (eudc-parse-spec (cdr mapping) record nil)))
+					      (cons (car mapping) value))))
+				       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))
+      (or silent
+	  (bbdb-display-records (list bbdb-record))))))
+
+(defun eudc-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)
+	       (eudc-parse-spec spec-elem record nil))
+	    spec))
+   (t
+    (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
+
+(defun eudc-bbdbify-address (addr location)
+  "Parse ADDR into a vector compatible with BBDB.
+ADDR should be an address string of no more than four lines or a
+list of lines.
+The last two lines are 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"))))
+	 (last1 (pop addr-components))
+	 (last2 (pop addr-components))
+	 zip city state)
+    (setq addr-components (nreverse addr-components))
+    ;; If not containing the zip code the last line is supposed to contain a
+    ;; country name and the addres is supposed to be in european style
+    (if (not (string-match "[0-9][0-9][0-9]" last1))
+	(progn
+	  (setq state last1)
+	  (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
+	      (setq city (match-string 2 last2)
+		    zip (string-to-number (match-string 1 last2)))
+	    (error "Cannot parse the address")))
+      (cond
+       ;; American style
+       ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
+	(setq city (match-string 1 last1)
+	      state (match-string 2 last1)
+	      zip (string-to-number (match-string 3 last1))))
+       ;; European style
+       ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
+	(setq city (match-string 2 last1)
+	      zip (string-to-number (match-string 1 last1))))
+       (t
+	(error "Cannot parse the address"))))
+    (vector location 
+	    (or (nth 0 addr-components) "")
+	    (or (nth 1 addr-components) "")
+	    (or (nth 2 addr-components) "")
+	    (or city "")
+	    (or state "")
+	    zip)))
+
+(defun eudc-bbdbify-phone (phone location)
+  "Parse PHONE into a vector compatible with BBDB.
+PHONE is either a string supposedly containing a phone number or
+a list of such strings which are concatenated.
+LOCATION is used as the phone location for BBDB."
+  (cond 
+   ((stringp phone)
+    (let (phone-list)
+      (condition-case err
+	  (setq phone-list (bbdb-parse-phone-number phone))
+	(error
+	 (if (string= "phone number unparsable." (eudc-cadr err))
+	     (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
+		 (error "Phone number unparsable")
+	       (setq phone-list (list (bbdb-string-trim phone))))
+	   (signal (car err) (cdr err)))))
+      (if (= 3 (length phone-list))
+	  (setq phone-list (append phone-list '(nil))))
+      (apply 'vector location phone-list)))
+   ((listp phone)
+    (vector location (mapconcat 'identity phone ", ")))
+   (t
+    (error "Invalid phone specification"))))
+      
+(defun eudc-batch-export-records-to-bbdb ()
+  "Insert all the records returned by a directory query into BBDB."
+  (interactive)
+  (goto-char (point-min))
+  (let ((nbrec 0)
+	record)
+    (while (eudc-move-to-next-record)
+      (and (overlays-at (point))
+	   (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
+	   (1+ nbrec)
+	   (eudc-create-bbdb-record record t)))
+    (message "%d records imported into BBDB" nbrec)))
+
+;;;### autoload
+(defun eudc-insert-record-at-point-into-bbdb ()
+  "Insert record at point into the BBDB database.
+This function can only be called from a directory query result buffer."
+  (interactive)
+  (let ((record (and (overlays-at (point))
+		     (overlay-get (car (overlays-at (point))) 'eudc-record))))
+    (if (null record)
+	(error "Point is not over a record")
+      (eudc-create-bbdb-record record))))
+
+;;;### autoload
+(defun eudc-try-bbdb-insert ()
+  "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
+  (interactive)
+  (and (or (featurep 'bbdb)
+	   (prog1 (locate-library "bbdb") (message "")))
+       (overlays-at (point))
+       (overlay-get (car (overlays-at (point))) 'eudc-record)
+       (eudc-insert-record-at-point-into-bbdb)))
+
+;;; eudc-export.el ends here

File eudc-hotlist.el

+;;; eudc-hotlist.el --- Hotlist Management for EUDC
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
+;; Created: Jun 1999
+;; Version: $Revision$
+;; Keywords: help
+
+;; This file is part of XEmacs
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with 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:
+
+;;; Usage:
+;;    See the corresponding info file
+
+;;; Code:
+
+(require 'eudc)
+
+(defvar eudc-hotlist-menu nil)
+(defvar eudc-hotlist-mode-map nil)
+(defvar eudc-hotlist-list-beginning nil)
+
+(defun eudc-hotlist-mode ()
+  "Major mode used to edit the hotlist of servers.
+
+These are the special commands of this mode:
+    a -- Add a new server to the list.
+    d -- Delete the server at point from the list.
+    s -- Select the server at point.
+    t -- Transpose the server at point and the previous one
+    q -- Commit the changes and quit.
+    x -- Quit without commiting the changes."
+  (interactive)
+  (kill-all-local-variables)
+  (setq major-mode 'eudc-hotlist-mode)
+  (setq mode-name "EUDC-Servers")
+  (use-local-map eudc-hotlist-mode-map)
+  (setq mode-popup-menu eudc-hotlist-menu)
+  (when (and eudc-xemacs-p
+	     (featurep 'menubar))
+    (set-buffer-menubar current-menubar)
+    (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))
+  (setq buffer-read-only t))
+
+;;;###autoload
+(defun eudc-edit-hotlist ()
+  "Edit the hotlist of directory servers in a specialized buffer"
+  (interactive)
+  (switch-to-buffer (get-buffer-create "*EUDC Servers*"))
+  (setq buffer-read-only nil)
+  (erase-buffer)
+  (insert "              EUDC Servers\n"
+	  "              ============\n"
+	  "\n"
+	  "Server                        Protocol\n"
+	  "------                        --------\n"
+	  "\n")
+  (setq eudc-hotlist-list-beginning (point))
+  (mapcar '(lambda (entry)
+	     (insert (car entry))
+	     (indent-to 30)
+	     (insert (symbol-name (cdr entry)) "\n"))
+	  eudc-server-hotlist)
+  (eudc-hotlist-mode))
+
+(defun eudc-hotlist-add-server ()
+  "Add a new server to the list after current one"
+  (interactive)
+  (if (not (eq major-mode 'eudc-hotlist-mode))
+      (error "Not in a EUDC hotlist edit buffer"))
+  (let ((server (read-from-minibuffer "Server: "))
+	(protocol (completing-read "Protocol: "
+				   (mapcar '(lambda (elt)
+					      (cons (symbol-name elt)
+						    elt))
+					   eudc-known-protocols)))
+	(buffer-read-only nil))
+    (if (not (eobp))
+	(forward-line 1))
+    (insert server)
+    (indent-to 30)
+    (insert protocol "\n")))
+
+(defun eudc-hotlist-delete-server ()
+  "Delete the server at point from the list"
+  (interactive)
+  (if (not (eq major-mode 'eudc-hotlist-mode))
+      (error "Not in a EUDC hotlist edit buffer"))
+  (let ((buffer-read-only nil))
+    (save-excursion
+      (beginning-of-line)
+      (if (and (>= (point) eudc-hotlist-list-beginning)     
+	       (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)"))
+	  (kill-line 1)
+	(error "No server on this line")))))
+
+(defun eudc-hotlist-quit-edit ()
+  "Quit the hotlist editing mode and save changes to the hotlist"
+  (interactive)
+  (if (not (eq major-mode 'eudc-hotlist-mode))
+      (error "Not in a EUDC hotlist edit buffer"))
+  (let (hotlist)
+    (goto-char eudc-hotlist-list-beginning)
+    (while (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")
+      (setq hotlist (cons (cons (match-string 1)
+				(intern (match-string 2)))
+			  hotlist))
+      (forward-line 1))
+    (if (not (looking-at "^[ \t]*$"))
+	(error "Malformed entry in hotlist, discarding edits")) 
+    (setq eudc-server-hotlist (nreverse hotlist))
+    (eudc-install-menu)
+    (eudc-save-options)
+    (kill-this-buffer)))
+
+(defun eudc-hotlist-select-server ()
+  "Select the server at point as the current server"
+  (interactive)
+  (if (not (eq major-mode 'eudc-hotlist-mode))
+      (error "Not in a EUDC hotlist edit buffer"))
+  (save-excursion
+    (beginning-of-line)
+    (if (and (>= (point) eudc-hotlist-list-beginning)
+	     (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)"))
+	(progn
+	  (eudc-set-server (match-string 1) (intern (match-string 2)))
+	  (message "Current directory server is %s (%s)" eudc-server eudc-protocol))
+      (error "No server on this line"))))
+      
+(defun eudc-hotlist-transpose-servers ()
+  "Swap the order of the server with the previous one in the list"
+  (interactive)
+  (if (not (eq major-mode 'eudc-hotlist-mode))
+      (error "Not in a EUDC hotlist edit buffer"))
+  (let ((buffer-read-only nil))
+    (save-excursion
+      (beginning-of-line)
+      (if (and (>= (point) eudc-hotlist-list-beginning)
+	       (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")
+	       (progn 
+		 (forward-line -1)
+		 (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")))
+	  (progn
+	    (forward-line 1)
+	    (transpose-lines 1))))))
+  
+(setq eudc-hotlist-mode-map
+      (let ((map (make-sparse-keymap)))
+	(define-key map "a" 'eudc-hotlist-add-server)
+	(define-key map "d" 'eudc-hotlist-delete-server)
+	(define-key map "s" 'eudc-hotlist-select-server)
+	(define-key map "t" 'eudc-hotlist-transpose-servers)
+	(define-key map "q" 'eudc-hotlist-quit-edit)
+	(define-key map "x" 'kill-this-buffer)
+	map))
+
+(defconst eudc-hotlist-menu
+  '("EUDC Hotlist Edit"
+    ["---" nil nil]
+    ["Add New Server" eudc-hotlist-add-server t]
+    ["Delete Server" eudc-hotlist-delete-server t]
+    ["Select Server" eudc-hotlist-select-server t]
+    ["Transpose Servers" eudc-hotlist-transpose-servers t]
+    ["Save and Quit" eudc-hotlist-quit-edit t]
+    ["Exit without Saving" kill-this-buffer t]))
+
+(if eudc-emacs-p
+    (easy-menu-define eudc-hotlist-emacs-menu 
+		      eudc-hotlist-mode-map
+		      ""
+		      eudc-hotlist-menu))
+
+;;; eudc-hotlist.el ends here
 
 ;; Copyright (C) 1998 Free Software Foundation, Inc.
 
-;; Author: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
-;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@epfl.ch>
+;; Author: Oscar Figueiredo <oscar@xemacs.org>
+;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
 ;; Created: Feb 1998
 ;; Version: $Revision$
 ;; Keywords: help
       (require 'cl)))
 
 (autoload 'custom-menu-create "cus-edit")
-(autoload 'bbdb-create-internal "bbdb-com")
-(autoload 'bbdb-parse-phone-number "bbdb-com")
-(autoload 'bbdb-display-records "bbdb")
 
 (require 'eudc-custom-vars)
 
 
 (defvar eudc-form-widget-list nil)
 (defvar eudc-mode-map nil)
-(defvar eudc-hotlist-menu nil)
-(defvar eudc-hotlist-mode-map nil)
-(defvar eudc-hotlist-list-beginning nil)
-
 ;; Used by the selection insertion mechanism
 (defvar eudc-pre-select-window-configuration nil)
 (defvar eudc-insertion-marker nil)
   (or pattern
       (setq pattern "[ \f\t\n\r\v]+"))
   (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)))))
+    (when (string-match pattern string 0)
+      (if (> (match-beginning 0) 0)
+	  (setq parts (cons (substring string 0 (match-beginning 0)) nil)))
+      (setq start (match-end 0))
+      (while (and (string-match pattern string start)
+		  (> (match-end 0) start))
+	(setq parts (cons (substring string start (match-beginning 0)) parts)
+	      start (match-end 0))))
+    (nreverse (if (< start (length string))
+		  (cons (substring string start) parts)
+		parts)))))
 
 (if eudc-xemacs-p
     (defalias 'eudc-plist-get 'plist-get)
       (set var val)))))
 
 (defun eudc-update-local-variables ()
-  "Update all declared local EUDC variables according to theire local settings."
+  "Update all EUDC variables according to their local settings."
+  (interactive)
   (mapcar 'eudc-update-variable eudc-local-vars))
 
 (eudc-default-set 'eudc-query-function nil)
 (eudc-default-set 'eudc-switch-to-server-hook nil)
 (eudc-default-set 'eudc-switch-from-server-hook nil)
 (eudc-default-set 'eudc-protocol-has-default-query-attributes nil)
+(eudc-default-set 'eudc-attribute-display-method-alist nil)
 
 ;;}}}
 
 
 (defun eudc-query (query &optional return-attributes no-translation)
    "Query the directory server with QUERY.
-QUERY is a list of cons cells (ATTR . VALUE) where 
-ATTR is an attribute name and VALUE the corresponding
-value.  
-ATTR is translated according to `eudc-protocol-attributes-translation-alist' 
-unless NO-TRANSLATION is non nil.
-RETURN-ATTRIBUTES is a list of attributes to return,
-defaulting to `eudc-default-return-attributes'."
+QUERY is a list of cons cells (ATTR . VALUE) where ATTR is an attribute
+name and VALUE the corresponding value.  
+If NO-TRANSLATION is non nil, ATTR is translated according to 
+`eudc-protocol-attributes-translation-alist'.
+RETURN-ATTRIBUTES is a list of attributes to return defaulting to 
+`eudc-default-return-attributes'."
    (unless eudc-query-function
      (error "Don't know how to perform the query"))
    (if no-translation
 		
      (funcall eudc-query-function 
 	      (eudc-translate-query query)
-	      (eudc-translate-attribute-list (or return-attributes
-						 eudc-default-return-attributes)))))
+	      (cond 
+	       (return-attributes
+		(eudc-translate-attribute-list return-attributes))
+	       ((listp eudc-default-return-attributes)
+		(eudc-translate-attribute-list eudc-default-return-attributes))
+	       (t
+		eudc-default-return-attributes)))))
 
- 
+(defun eudc-format-attribute-name-for-display (attribute)
+  "Format a directory attribute name for display.
+ATTRIBUTE is looked up in `eudc-user-attribute-names-alist' and replaced 
+by the corresponding user name if any.  Otherwise it is capitalized and
+underscore characters are replaced by spaces."
+  (let ((match (assq attribute eudc-user-attribute-names-alist)))
+    (if match
+	(cdr match)
+      (capitalize 
+       (mapconcat 'identity 
+		  (split-string (symbol-name attribute) "_")
+		  " ")))))
+
+(defun eudc-print-attribute-value (field)
+  "Insert the value of the directory FIELD at point.
+The directory attribute name in car of FIELD is looked up in 
+`eudc-attribute-display-method-alist' and the corresponding method, 
+if any, is called to print the value in cdr of FIELD."
+  (let ((match (assoc (downcase (car field))
+		      eudc-attribute-display-method-alist))
+	(col (current-column))
+	(val (cdr field)))
+    (if match
+	(progn
+	  (eval (list (cdr match) val))
+	  (insert "\n"))
+      (mapcar
+       (function
+	(lambda (val-elem)
+	  (indent-to col)
+	  (insert val-elem "\n")))
+       (cond
+	((listp val) val)
+	((stringp val) (split-string val "\n"))
+	((null val) '(""))
+	(t (list val)))))))
+
+(defun eudc-print-record-field (field column-width)
+  "Print the record field FIELD.
+FIELD is a list (ATTR VALUE1 VALUE2 ...) or cons-cell (ATTR . VAL)
+COLUMN-WIDTH is the width of the first display column containing the 
+attribute name ATTR."
+  (let ((field-beg (point)))
+;; The record field that is passed to this function has already been processed
+;; by `eudc-format-attribute-name-for-display' so we don't need to call it
+;; again to display the attribute name
+    (insert (format (concat "%" (int-to-string column-width) "s: ") 
+		    (car field)))
+    (put-text-property field-beg (point) 'face 'bold)
+    (indent-to (+ 2 column-width))
+    (eudc-print-attribute-value field)))
+
 (defun eudc-display-records (records &optional raw-attr-names)
   "Display the record list RECORDS in a formatted buffer. 
 If RAW-ATTR-NAMES is non-nil, the raw attribute names are displayed
 	inhibit-read-only
 	precords
 	(width 0)
-	beg field-beg
-	attribute)
+	beg
+	first-record
+	attribute-name)
     (switch-to-buffer buffer)    
     (setq buffer-read-only t)
     (setq inhibit-read-only t)
 		(mapcar 
 		 (function
 		  (lambda (field)
-		    (setq attribute (if raw-attr-names
-					 (symbol-name (car field))
-				      (or (and (assq (car field) eudc-user-attribute-names-alist)
-					       (cdr (assq (car field) eudc-user-attribute-names-alist)))
-					   (capitalize (mapconcat '(lambda (char)
-								     (if (eq char ?_)
-									 " "
-								       (char-to-string char)))
-								  (symbol-name (car field))
-								  "")))))
-		    (if (> (length attribute) width)
-			(setq width (length attribute)))
-		    (cons attribute (cdr field))))
+		    (setq attribute-name 
+			  (if raw-attr-names
+			      (symbol-name (car field))
+			    (eudc-format-attribute-name-for-display (car field))))
+		    (if (> (length attribute-name) width)
+			(setq width (length attribute-name)))
+		    (cons attribute-name (cdr field))))
 		 record)))
 	     records))
-      (mapcar (function
-	       (lambda (record)
-		 (setq beg (point))
-		 ;; Actually insert the attribute/value pairs
-		 (mapcar (function
-			  (lambda (field)
-			    (setq field-beg (point))
-			    (insert (format (concat "%" (int-to-string width) "s: ") (car field)))
-			    (put-text-property field-beg (point) 'face 'bold)
-			    (mapcar (function 
-				     (lambda (val)
-				       (indent-to (+ 2 width))
-				       (insert val "\n")))
-				    (cond 
-				     ((stringp (cdr field))
-				      (split-string (cdr field) "\n"))
-				     ((null (cdr field))
-				      '(""))
-				     (t
-				      (cdr field))))))
-			 record)
-		 ;; Store the record internal format in some convenient place
-		 (overlay-put (make-overlay beg (point))
-			      'eudc-record
-			      (car records))
-		 (setq records (cdr records))
-		 (insert "\n")))
-	      precords))
+      ;; Display the records
+      (setq first-record (point))
+      (mapcar 
+       (function
+	(lambda (record)
+	  (setq beg (point))
+	  ;; Map over the record fields to print the attribute/value pairs
+	  (mapcar (function 
+		   (lambda (field)
+		     (eudc-print-record-field field width))) 
+		  record)
+	  ;; Store the record internal format in some convenient place
+	  (overlay-put (make-overlay beg (point))
+		       'eudc-record
+		       (car records))
+	  (setq records (cdr records))
+	  (insert "\n")))
+       precords))
     (insert "\n")
     (widget-create 'push-button
 		   :notify (lambda (&rest ignore)
 			     (kill-this-buffer))
 		   "Quit")
     (eudc-mode)
-    (widget-setup)      
-    )
-  )
+    (widget-setup)
+    (goto-char first-record)))
 
 (defun eudc-process-form ()
   "Process the query form in current buffer and display the results."
 		   (setq unique (cons field unique)))))
 	      record)
       (setq result (list unique))
-      (mapcar (function
-	       (lambda (field)
-		 (let ((method (if (consp eudc-duplicate-attribute-handling-method)
-				   (cdr (assq (or (car (rassq (car field)
-							      (symbol-value eudc-protocol-attributes-translation-alist)))
-						  (car field))
-					      eudc-duplicate-attribute-handling-method))
-				 eudc-duplicate-attribute-handling-method)))
-		   (cond
-		    ((or (null method) (eq 'list method))
-		     (setq result 
-			   (eudc-add-field-to-records field result)))
-		    ((eq 'first method)
-		     (setq result 
-			   (eudc-add-field-to-records (cons (car field) (eudc-cadr field)) result)))
-		    ((eq 'concat method)
-		     (setq result 
-			   (eudc-add-field-to-records (cons (car field)
-							  (mapconcat 
-							   'identity
-							   (cdr field)
-							   "\n")) result)))
-		    ((eq 'duplicate method)
-		     (setq result
-			   (eudc-distribute-field-on-records field result)))))))
-	      duplicates)
+      ;; Map over the record fields that have multiple values
+      (mapcar 
+       (function
+	(lambda (field)
+	  (let ((method (if (consp eudc-duplicate-attribute-handling-method)
+			    (cdr 
+			     (assq 
+			      (or 
+			       (car 
+				(rassq 
+				 (car field)
+				 (symbol-value 
+				  eudc-protocol-attributes-translation-alist)))
+			       (car field))
+			      eudc-duplicate-attribute-handling-method))
+			  eudc-duplicate-attribute-handling-method)))
+	    (cond
+	     ((or (null method) (eq 'list method))
+	      (setq result 
+		    (eudc-add-field-to-records field result)))
+	     ((eq 'first method)
+	      (setq result 
+		    (eudc-add-field-to-records (cons (car field) 
+						     (eudc-cadr field)) 
+					       result)))
+	     ((eq 'concat method)
+	      (setq result 
+		    (eudc-add-field-to-records (cons (car field)
+						     (mapconcat 
+						      'identity
+						      (cdr field)
+						      "\n")) result)))
+	     ((eq 'duplicate method)
+	      (setq result
+		    (eudc-distribute-field-on-records field result)))))))
+       duplicates)
       result)))
-          
+
 (defun eudc-filter-partial-records (records attrs)
   "Eliminate records that do not caontain all ATTRS from RECORDS."
   (delq nil 
     (while values
       (setcdr values (delete (car values) (cdr values)))
       (setq values (cdr values)))
-    (mapcar (function
-	     (lambda (value)
-	       (let ((result-list (copy-sequence records)))
-		 (setq result-list (eudc-add-field-to-records (cons (car field) value)
-							      result-list))
-		 (setq result (append result-list result))
+    (mapcar 
+     (function
+      (lambda (value)
+	(let ((result-list (copy-sequence records)))
+	  (setq result-list (eudc-add-field-to-records 
+			     (cons (car field) value)
+			     result-list))
+	  (setq result (append result-list result))
 		 )))
 	    (cdr field))
-    result)
-  )
+    result))
 
 
-(defun eudc-create-bbdb-record (record)
-  "Create a BBDB record using the RECORD alist.
-RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
-symbol and VALUE is the corresponding value for the record."
-  ;; This function runs in a special context where lisp symbols corresponding
-  ;; to field names in record are bound to the corresponding values
-  (eval 
-   `(let* (,@(mapcar '(lambda (c)
-			(list (car c) (if (listp (cdr c))
-					  (list 'quote (cdr c))
-					(cdr c))))
-		     record)
-	     bbdb-name
-	     bbdb-company
-	     bbdb-net
-	     bbdb-address
-	     bbdb-phones
-	     bbdb-notes
-	     spec
-	     bbdb-record
-	     value
-	     (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
-
-      ;; BBDB standard fields
-      (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
-	    bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
-	    bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
-	    bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
-      (setq spec (cdr (assq 'address conversion-alist)))
-      (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
-						      spec
-						    (list spec))
-						  record t)))
-      (setq spec (cdr (assq 'phone conversion-alist)))
-      (setq bbdb-phones (delq nil (eudc-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 (eudc-parse-spec (cdr mapping) record nil)))
-					      (cons (car mapping) value))))
-				       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 eudc-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)
-	       (eudc-parse-spec spec-elem record nil))
-	    spec))
-   (t
-    (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
-
-(defun eudc-bbdbify-address (addr location)
-  "Parse ADDR into a vector compatible with BBDB.
-ADDR should be an address string of no more than four lines or a
-list of lines.
-The last two lines are 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"))))
-	 (last1 (pop addr-components))
-	 (last2 (pop addr-components))
-	 zip city state)
-    (setq addr-components (nreverse addr-components))
-    ;; If not containing the zip code the last line is supposed to contain a
-    ;; country name and the addres is supposed to be in european style
-    (if (not (string-match "[0-9][0-9][0-9]" last1))
-	(progn
-	  (setq state last1)
-	  (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
-	      (setq city (match-string 2 last2)
-		    zip (string-to-number (match-string 1 last2)))
-	    (error "Cannot parse the address")))
-      (cond
-       ;; American style
-       ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
-	(setq city (match-string 1 last1)
-	      state (match-string 2 last1)
-	      zip (string-to-number (match-string 3 last1))))
-       ;; European style
-       ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
-	(setq city (match-string 2 last1)
-	      zip (string-to-number (match-string 1 last1))))
-       (t
-	(error "Cannot parse the address"))))
-    (vector location 
-	    (or (nth 0 addr-components) "")
-	    (or (nth 1 addr-components) "")
-	    (or (nth 2 addr-components) "")
-	    (or city "")
-	    (or state "")
-	    zip)))
-
-(defun eudc-bbdbify-phone (phone location)
-  "Parse PHONE into a vector compatible with BBDB.
-PHONE is either a string supposedly containing a phone number or
-a list of such strings which are concatenated.
-LOCATION is used as the phone location for BBDB."
-  (cond 
-   ((stringp phone)
-    (let (phone-list)
-      (condition-case err
-	  (setq phone-list (bbdb-parse-phone-number phone))
-	(error
-	 (if (string= "phone number unparsable." (eudc-cadr err))
-	     (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
-		 (error "Phone number unparsable")
-	       (setq phone-list (list (bbdb-string-trim phone))))
-	   (signal (car err) (cdr err)))))
-      (if (= 3 (length phone-list))
-	  (setq phone-list (append phone-list '(nil))))
-      (apply 'vector location phone-list)))
-   ((listp phone)
-    (vector location (mapconcat 'identity phone ", ")))
-   (t
-    (error "Invalid phone specification"))))
-      
 (defun eudc-mode ()
   "Major mode used in buffers displaying the results of directory queries.
 There is no sense in calling this command from a buffer other than
   (run-hooks 'eudc-mode-hook)
   )
 
-(defun eudc-hotlist-mode ()
-  "Major mode used to edit the hotlist of servers.
-
-These are the special commands of this mode:
-    a -- Add a new server to the list.
-    d -- Delete the server at point from the list.
-    s -- Select the server at point.
-    t -- Transpose the server at point and the previous one
-    q -- Commit the changes and quit.
-    x -- Quit without commiting the changes."
-  (interactive)
-  (kill-all-local-variables)
-  (setq major-mode 'eudc-hotlist-mode)