From xemacs-m  Thu May  8 23:47:07 1997
Received: from jagor.srce.hr (hniksic@jagor.srce.hr [161.53.2.130])
	by xemacs.org (8.8.5/8.8.5) with ESMTP id XAA17148
	for <xemacs-beta@xemacs.org>; Thu, 8 May 1997 23:47:05 -0500 (CDT)
Received: (from hniksic@localhost)
          by jagor.srce.hr (8.8.5/8.8.4)
	  id GAA01121; Fri, 9 May 1997 06:46:55 +0200 (MET DST)
To: xemacs-beta@xemacs.org, emacs-custom@sunsite.auc.dk
Subject: blackbook.el, v0.2
X-Save-Project-Gutenberg: <URL:http://www.promo.net/pg/nl/pgny_nov96.html>
X-Attribution: Hrv
X-Face: Mie8:rOV<\c/~z{s.X4A{!?vY7{drJ([U]0O=W/<W*SMo/Mv:58:*_y~ki>xDi&N7XG
        KV^$k0m3Oe/)'e%3=$PCR&3ITUXH,cK>]bci&<qQ>Ff%x_>1`T(+M2Gg/fgndU%k*ft
        [(7._6e0n-V%|%'[c|q:;}td$#INd+;?!-V=c8Pqf}3J
From: Hrvoje Niksic <hniksic@srce.hr>
Date: 09 May 1997 06:46:54 +0200
Message-ID: <kigohalp801.fsf@jagor.srce.hr>
Lines: 554
X-Mailer: Gnus v5.4.50/XEmacs 19.15

Here is the new version of blackbook.el, the Emacs addressbook.  With
this package, you can edit your mail aliases in a user-friendly way.
You can also use it to import your old pine, elm or mutt aliases.  It
uses the Per Abrahamsen's widget library.  It should run on both
Emacsen.

Before using, don't forget to backup your ~/.mailrc, as it's not yet
stable.

;;; blackbook.el -- edit aliases file in an user-friendly way

;; Copyright (c) 1997 Free Software Foundation

;; Author: Hrvoje Niksic <hniksic@srce.hr>
;; Keywords: mail, abbrev, extenstions
;; Version: 0.2

;; This file is not yet part of any Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Synched up with: not in FSF

;;; Commentary:

;; Although the format of the mailrc file (that Emacs packages use to
;; read mail aliases from) is very simple, the question "How do I add
;; an alias to Emacs?" has popped up one time too many on comp.emacs.
;;
;; Blackbook package will parse the `~/.mailrc' file, and present the
;; aliases in a user-friendly way, using the facilities provided by
;; the widget library written by Per Abrahamsen.  In a way, this is
;; similar to Pine's and Netscape's `addressbook' features, hence the
;; name.

;;; Code:

(require 'cl)

(require 'widget)
(eval-when-compile
  (require 'wid-edit))

(defvar blackbook-mailrc-file
  (or (and (boundp 'mail-abbrev-mailrc-file)
	   mail-abbrev-mailrc-file)
      (getenv "MAILRC")
      (expand-file-name "~/.mailrc")))

(defvar blackbook-aliases-widget nil)
(defvar blackbook-file-widget nil)
(defvar blackbook-file-type nil)

;; Create the blackbook buffer with the appropriate widgets.
(defun blackbook-setup-buffer ()
  (message "Creating blackbook buffer...")
  (kill-buffer (get-buffer-create "*Blackbook*"))
  (switch-to-buffer (get-buffer-create "*Blackbook*"))
  ;; Short documentation.
  (widget-insert "This is the Blackbook buffer.
Push RET or click mouse-2 on the word ")
  (widget-create 'info-link 
		 :tag "help"
		 :help-echo "Read the online help."
		 "(blackbook)Editing Mail Aliases")
  (widget-insert " for more information.\n\n")
  ;; File choices.
  (setq blackbook-file-type nil)
  (widget-create 'choice
		 :tag "Aliases Type"
		 :format "%[%v%]"
		 :value 'mail
		 :notify 'blackbook-import-choice-callback
		 '(const :tag "Emacs" :format "%t" mail)
		 '(const :tag "Mutt" :format "%t" mutt)
		 '(const :tag "Elm" :format "%t" elm)
		 '(const :tag "Pine" :format "%t" pine))
  (widget-insert " aliases ")
  (setq
   blackbook-file-widget
   (widget-create 'file
		  :tag "file"
		  :format "%[%t%]: %v"
		  :value blackbook-mailrc-file))
  (widget-insert "\n")
  (widget-create 'file
		 :tag "Save To"
		 :format "%[%t%]: %v"
		 :notify (lambda (widget &rest ignore)
			   (setq blackbook-mailrc-file
				 (widget-value widget)))
		 :value blackbook-mailrc-file)
  (widget-insert "\n")
  ;; Buttons.
  (widget-create 'push-button
		 :tag "Import"
		 :help-echo "Import settings from file"
		 :action 'blackbook-import-callback)
  (widget-insert " ")
  (widget-create 'push-button
		 :tag "Merge & Save"
		 :help-echo "Merge with alises file and save"
		 :action 'blackbook-merge-callback)
  (widget-insert " ")
  (widget-create 'push-button
		 :tag "Save"
		 :help-echo "Save aliases, replacing previous ones"
		 :action 'blackbook-save-callback)
  (widget-insert " ")
  (widget-create 'push-button
		 :tag "Clear"
		 :help-echo "Clear alias list"
		 :action 'blackbook-clear-callback)
  (widget-insert " ")
  (widget-create 'push-button
		 :tag "Activate"
		 :help-echo "Parse saved aliases for use in mail"
		 :action 'blackbook-activate-callback)
  (widget-insert " ")
  (widget-create 'push-button
		 :tag "Done"
		 :help-echo "Exit Blackbook"
		 :action 'blackbook-done-callback)
  (widget-insert "\n\n")
  ;; Main widget with all the aliases.
  (setq
   blackbook-aliases-widget
   (widget-create
    'editable-list
    :offset 3
    :entry-format "%i %d\n%v"
    :value nil
    :value-to-internal 'blackbook-to-internal
    :value-to-external 'blackbook-from-internal
    :notify (lambda (widget &rest ignore)
	      (widget-put widget 'dirty-flag t))
    '(choice
      :tag "Address Type"
      :value (alias "" "")
      (group :tag "Mail Alias"
	     :value (alias "" "")
	     :format "%t\n%v\n"
	     (const :format "" alias)
	     (editable-field :tag "Alias Name"
			     :format "%[%t%]: %v"
			     :validate blackbook-validate-alias)
	     (editable-field :tag "Personal Address"
			     :format "%[%t%]: %v"
			     :validate blackbook-validate-address))
      (group :tag "Group of Users"
	     :value (group "")
	     :format "%t\n%v\n"
	     :validate blackbook-validate-group
	     (const :format "" group)
	     (editable-field :tag "Group Name"
			     :format "%[%t%]: %v"
			     :validate blackbook-validate-alias)
	     (editable-list :tag "Members"
			    :format "%t:\n%v%i\n"
			    :inline t
			    :extra-offset 3
			    :value ("")
			    (editable-field
			     :tag "Address"
			     :format "%[%t%]: %v"
			     :validate blackbook-validate-address))))))
  ;; keyboard
  (use-local-map widget-keymap)
  (local-set-key "q" 'blackbook-done-callback)
  (local-set-key "\C-x\C-s" 'blackbook-save-callback)
  ;; & the rest...
  (widget-setup)
  (widget-put blackbook-aliases-widget 'dirty-flag nil)
  (set-buffer-modified-p nil)
  (goto-char (point-min))
  (forward-line 2)
  (message "Creating blackbook buffer... done"))

;;; Functions used by widgets

;; we need an internal value, to be able to distinguish between group
;; and alias.
(defun blackbook-to-internal (ignore l)
  (let (res)
    (while l
      (push (cons (if (cddar l) 'group 'alias) (car l)) res)
      (pop l))
    (nreverse res)))

(defun blackbook-from-internal (ignore l)
  (let (res)
    (while l
      (push (cdar l) res)
      (pop l))
    (nreverse res)))

(defun blackbook-import-choice-callback (widget &rest ignore)
  (let ((val (widget-value widget)))
    (widget-value-set
     blackbook-file-widget
     (expand-file-name
      (cdr (assq val '((mail . "~/.mailrc")
		       (mutt . "~/.muttrc")
		       (elm . "~/.elm/aliases.text")
		       (pine . "~/.addressbook"))))))
    (setq blackbook-file-type val))
  (widget-setup))

(defun blackbook-merge-callback (&rest ignore)
  (interactive)
  (if (null (widget-get blackbook-aliases-widget 'dirty-flag))
      (message "(No aliases need to be saved)")
    (let ((invalid (widget-apply blackbook-aliases-widget
				 :validate)))
      (when invalid
	(error (widget-get invalid :error))))
    (blackbook-save-mailrc blackbook-mailrc-file
			      (widget-value blackbook-aliases-widget)
			      (blackbook-read blackbook-mailrc-file))
    (widget-put blackbook-aliases-widget 'dirty-flag nil)))

(defun blackbook-save-callback (&rest ignore)
  (interactive)
  (if (null (widget-get blackbook-aliases-widget 'dirty-flag))
      (message "(No aliases need to be saved)")
    (let ((invalid (widget-apply blackbook-aliases-widget
				 :validate)))
      (when invalid
	(error (widget-get invalid :error))))
    (blackbook-save-mailrc blackbook-mailrc-file
			      (widget-value blackbook-aliases-widget))
    (widget-put blackbook-aliases-widget 'dirty-flag nil)))

(defun blackbook-import-callback (&rest ignore)
  (when (or (not (widget-get blackbook-aliases-widget 'dirty-flag))
	    (yes-or-no-p
	     "Are you sure you want to discard changes? "))
    (let ((file (widget-value blackbook-file-widget))
	  aliases)
      (message "Parsing %s..." file)
      (setq aliases (blackbook-read file blackbook-file-type))
      (message "Refreshing widget...")
      (widget-value-set blackbook-aliases-widget aliases))
    (message "Refreshing buffer...")
    (widget-setup)
    (message "")
    (widget-put blackbook-aliases-widget 'dirty-flag t)))

(defun blackbook-clear-callback (&rest ignore)
  (when (or (not (widget-get blackbook-aliases-widget 'dirty-flag))
	    (yes-or-no-p
	     "Are you sure you want to clear the aliases? "))
    (widget-value-set blackbook-aliases-widget nil)
    (widget-setup)
    (widget-put blackbook-aliases-widget 'dirty-flag t)))

(defun blackbook-activate-callback (&rest ignore)
  (if (not (widget-get blackbook-aliases-widget 'dirty-flag))
      ;; argh!
      (if (fboundp 'build-mail-aliases)
	  (build-mail-aliases)
	(build-mail-abbrevs))
    (error "You must save options first")))
 
(defun blackbook-done-callback (&rest ignore)
  (interactive)
  (if (or (null (widget-value blackbook-aliases-widget))
	  (not (widget-get blackbook-aliases-widget 'dirty-flag))
	  (yes-or-no-p
	   "There are unsaved changes.  Are you sure you want to exit? "))
      (kill-buffer (current-buffer))))

;; group must contain at least one member
(defun blackbook-validate-group (widget)
  (or (widget-children-validate widget)
      (if (null (cdr (widget-value widget)))
	  (prog1 widget
	    (widget-put widget
			:error "Empty groups not allowed"))
	nil)))

;; allow nothing but word and symbols constituents in alias/group names
(defun blackbook-validate-alias (widget)
  (let ((val (widget-value widget)))
    (if (or (zerop (length val))
	    (string-match "[^0-9a-zA-Z._-]" val))
      (prog1 widget
	(widget-put widget
		    :error (format "%s: invalid alias/group name" val)))
    nil)))

;; on the other hand, addresses can contain anything but newlines
(defun blackbook-validate-address (widget)
  (let ((val (widget-value widget)))
    (if (or (zerop (length val))
	    (string-match "\n" (widget-value widget)))
	(prog1 widget
	  (widget-put widget :error "Invalid email address"))
      nil)))

;; Add LIST to ALIASES
(defmacro blackbook-add-to-aliases (list aliases sorted-list)
  `(let ((found (gethash (car ,list) ,aliases)))
     (setf (gethash (car ,list) ,aliases) ,list)
     (unless found
       (push (car ,list) ,sorted-list))))

;; Parse STR into pieces, where separate pieces can be delimited using
;; quotes.  Uses the Lisp reader to read the quoted parts.
(defsubst blackbook-parse-string (str)
  (let ((beg 0) (end 0)
	word res)
    (while (string-match ",?[ \t]*\\([^ ,\t\n\]+\\)" str end)
      (setq beg (match-beginning 1)
	    end (match-end 1)
	    word (substring str beg end))
      (when (eq ?\" (aref word 0))
	(let ((sexp (condition-case nil
			(read-from-string str beg)
		      (error (error)))))
	  (setq word (car sexp)
		end (cdr sexp))))
      (push word res))
    (nreverse res)))

;;; The parser for aliases.  The parser should return a cons whose CAR
;;; is a hashtable, and whose CDR is a sorted list of entries (in the
;;; order they appear in .mailrc).

;; The mailrc-parsing stuff was originally from mail-abbrevs, but has
;; been rewritten by me.
(defun blackbook-parse-mailrc ()
  (let ((case-fold-search nil)
	(aliases (make-hash-table :test 'equal))
	sorted)
    ;; Don't lose if no final newline.
    (goto-char (point-max))
    (or (eq (char-after (1- (point-max))) ?\n) (newline))
    ;; handle \LFD continuation lines
    (goto-char (point-min))
    (while (not (eobp))
      (end-of-line)
      (cond ((eq (char-after (1- (point))) ?\\)
	     (progn (delete-char -1) (delete-char 1) (insert ?\ )))
	    (t
	     (forward-char 1))))
    ;; Look for aliases
    (goto-char (point-min))
    (while (re-search-forward
	    "^[ \t]*\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+[^ \t\n]+"
	    nil t)
      (beginning-of-line)
      (cond ((looking-at "source[ \t]+\\([^ \t\n]+\\).*$")
	     (let ((file (substitute-in-file-name (match-string 1))))
	       ;; insert the new stuff
	       (delete-region (point) (match-end 0))
	       (insert-file-contents file)))
	    (t
	     (re-search-forward "[ \t]+\\([^ \t\n]+\\)")
	     (let* ((name (buffer-substring
			   (match-beginning 1) (match-end 1)))
		    (expn (buffer-substring
			   (progn (skip-chars-forward " \t") (point))
			   (progn (end-of-line) (point))))
		    (list (condition-case nil
			      (blackbook-parse-string expn)
			    (error (error "Parse error near alias `%s'"
					  name)))))
	       (if list
		   (blackbook-add-to-aliases (cons name list)
						aliases sorted)
		 (error "Empty alias `%s'" name))))))
    (cons aliases (nreverse sorted))))

;; Emacs 19.34 doesn't have split-string, which makes this kludge
;; necessary.
(if (fboundp 'split-string)
    (fset 'blackbook-split-string 'split-string)
  (defun blackbook-split-string (str pattern)
    (let ((l nil) (old 0) (new 0))
      (while (setq new (string-match pattern str old))
	(push (substring str old new) l)
	(setq old (1+ new)))
      (push (substring str old) l)
      (nreverse l))))

;; Parse elm's aliases.text
(defun blackbook-parse-elm ()
  (let ((case-fold-search nil)
	(aliases (make-hash-table :test 'equal))
	(sorted nil))
    (goto-char (point-min))
    (while (not (eobp))
      (if (looking-at
	   "^[ \t]*\\([^ \t\n]+\\)[ \t]*=[^=\n]*=[ \t]*\\([^ \t\n]*\\)[ \t]*$")
	  (let ((name (match-string 1))
		(l (blackbook-split-string (match-string 2) ",")))
	    (blackbook-add-to-aliases (cons name l) aliases sorted)))
      (forward-line 1))
    (cons aliases (nreverse sorted))))

;; Parse pine's .addressbook
(defun blackbook-parse-pine ()
  (let ((case-fold-search nil)
	(aliases (make-hash-table :test 'equal))
	(sorted nil))
    (goto-char (point-min))
    (while (not (eobp))
      (if (looking-at "^\\([^\t\n]+\\)\t[^\t\n]+\t\\([^\t\n]+\\)")
	  (let ((name (match-string 1))
		(addrs (match-string 2)))
	    (blackbook-add-to-aliases
	     (cons name
		   (if (eq (aref addrs 0) ?\()
		       (blackbook-split-string
			(substring addrs 1 (1- (length addrs)))
			",")
		     (list addrs)))
	     aliases sorted)))
      (forward-line 1))
    (cons aliases (nreverse sorted))))

(defun blackbook-read (file &optional type)
  "Read the mail aliases from FILE.
The optional argument TYPE can be a symbol `mail', `mutt', `elm',
or `pine'."
  (let (aliases)
    (when (file-exists-p file)
      (save-excursion
	(unwind-protect
	    (let ((buffer (generate-new-buffer " *aliases*")))
	      (buffer-disable-undo buffer)
	      (set-buffer buffer)
	      (insert-file-contents file)
	      (setq aliases
		    (cond ((or (null type)
			       (eq type 'mail)
			       ;; mutt knows mail aliases
			       (eq type 'mutt))
			   (blackbook-parse-mailrc))
			  ((eq type 'elm)
			   (blackbook-parse-elm))
			  ((eq type 'pine)
			   (blackbook-parse-pine))
			  (t
			   (error "Unknown type %s" type)))))
	  (kill-buffer " *aliases*"))))
    (let ((hash (car aliases))
	  (lst (cdr aliases))
	  (res nil))
      (while lst
	(push (gethash (car lst) hash) res)
	(pop lst))
      (nreverse res))))

;; Quote the string if it contains spaces or stuff.
(defun blackbook-quote-maybe (str)
  (if (not (string-match "[ \t\"]" str))
      str
    (prin1-to-string str)))

;;; Merge two sets of aliases
(defun blackbook-merge-aliases (old new)
  (let ((hsh (make-hash-table :test 'equal))
	sorted)
    (while old
      (blackbook-add-to-aliases (car old) hsh sorted)
      (pop old))
    (while new
      (blackbook-add-to-aliases (car new) hsh sorted)
      (pop new))
    (let (new)
      (while sorted
	(push (gethash (car sorted) hsh) new)
	(pop sorted))
      new)))

;;; The function to save mailrc

(defun blackbook-save-mailrc (file aliases &optional merge)
  ;; if the aliases are to be merged, we must first read the existing
  ;; ones.
  (when merge
    (setq aliases (blackbook-merge-aliases merge aliases)))
  (save-excursion
    (unwind-protect
	(let ((buf (get-buffer-create " *saving aliases*")))
	  (buffer-disable-undo buf)
	  (set-buffer buf)
	  (erase-buffer)
	  (condition-case nil
	      (insert-file-contents file)
	    (error nil))
	  ;; Insert final newline, if none.
	  (unless (or (zerop (buffer-size))
		      (eq (char-after (1- (point-max))) ?\n))
	    (goto-char (point-max))
	    (insert ?\n))
	  ;; handle \LFD continuation lines
	  (goto-char (point-min))
	  (while (not (eobp))
	    (end-of-line)
	    (cond ((eq (char-after (1- (point))) ?\\)
		   (progn (delete-char -1) (delete-char 1) (insert ?\ )))
		  (t
		   (forward-char 1))))
	  ;; Kill all the alias/group/source entries.
	  (goto-char (point-min))
	  (let ((case-fold-search nil))
	    (while (re-search-forward
		    "^[ \t]*\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+[^ \t\n]+"
		    nil t)
	      (delete-region (match-beginning 0)
			     (progn (forward-line 1) (point)))))
	  (goto-char (point-max))
	  (while aliases
	    (if (cddar aliases)
		;; alias/group names needn't be quoted, but -- just in case!
		(let ((l (cdar aliases)))
		  (insert "group " (blackbook-quote-maybe (caar aliases)))
		  (while l
		    (insert " " (blackbook-quote-maybe (car l)))
		    (pop l)))
	      (insert "alias " (blackbook-quote-maybe (caar aliases))
		      " " (blackbook-quote-maybe (cadar aliases))))
	    (insert ?\n)
	    (pop aliases))
	  (write-region (point-min) (point-max) file))
      (kill-buffer " *saving aliases*"))))

;;;###autoload
(defun blackbook ()
  "Edit the mail aliases."
  (interactive)
  (blackbook-setup-buffer))


-- 
Hrvoje Niksic <hniksic@srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
Ask not for whom the <CONTROL-G> tolls.

