Commit 572e0ef3 authored by waider's avatar waider

sync with Sourceforge CVS

parent 0a098cf166f9
2005-07-24 Waider <waider@waider.ie>
* Sync to SourceForge CVS
2005-07-24 Norbert Koch <viteno@xemacs.org>
* Makefile (VERSION): XEmacs package 1.27 released.
......
This diff is collapsed.
......@@ -21,8 +21,7 @@
;;; This file was written by Ivan Vazquez <ivan@haldane.bu.edu>
;; $Date$ by $Author$
;; $Revision$
;;; $Id$
;;; This file adds the ability to define ftp-sites in a BBDB, much the same
;;; way one adds a regular person's name to the BBDB. It also defines the
......
......@@ -32,7 +32,7 @@
;; Cater for older emacs (19.34) with default Gnus installation.
(eval-and-compile
(condition-case error
(condition-case nil
(progn
(require 'gnus-win)
(require 'gnus-sum)
......@@ -40,17 +40,12 @@
(error nil)))
;;; Compiler hushing
;;; Some of these are probably obsolete variables for older versions
;;; of gnus that should be taken out back and shot.
(eval-when-compile
(defvar gnus-optional-headers)
(defvar gnus-Subject-mode-map)
(defvar gnus-Subject-buffer))
(defvar gnus-optional-headers))
(defun bbdb/gnus-get-message-id ()
"Return the message-id of the current message."
(save-excursion
(set-buffer (get-buffer gnus-article-buffer))
(set-buffer gnus-original-article-buffer)
(goto-char (point-min))
(let ((case-fold-search t))
......@@ -90,7 +85,6 @@ the user confirms the creation."
(records (bbdb/gnus-update-records offer-to-create)))
(if records (car records) nil)))
;;;###autoload
(defun bbdb/gnus-update-records (&optional offer-to-create)
"Return the records corresponding to the current GNUS message, creating
......@@ -113,7 +107,8 @@ C-g again it will stop scanning."
(msg-id (bbdb/gnus-get-message-id))
records cache)
(save-excursion
(set-buffer (get-buffer gnus-article-buffer))
(set-buffer gnus-article-buffer)
(if (and msg-id (not bbdb/gnus-offer-to-create))
(setq cache (bbdb-message-cache-lookup msg-id)))
......@@ -130,7 +125,7 @@ C-g again it will stop scanning."
(or (if (boundp 'gnus-ignored-from-addresses)
gnus-ignored-from-addresses)
bbdb-user-mail-names)
'mail-fetch-field)
'gnus-fetch-field)
bbdb/news-auto-create-p
offer-to-create)))
(if (and bbdb-message-caching-enabled msg-id)
......@@ -184,7 +179,8 @@ This buffer will be in `bbdb-mode', with associated keybindings."
(defun bbdb/gnus-show-all-recipients ()
"Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
(interactive)
(bbdb/gnus-show-records 'recipients))
(let ((bbdb-get-only-first-address-p nil))
(bbdb/gnus-show-records 'recipients)))
(defun bbdb/gnus-show-sender (&optional show-recipients)
"Display the contents of the BBDB for the senders of this message.
......@@ -195,7 +191,8 @@ This buffer will be in `bbdb-mode', with associated keybindings."
(cond ((= 4 show-recipients)
(bbdb/gnus-show-all-recipients))
((= 16 show-recipients)
(bbdb/gnus-show-records))
(let ((bbdb-get-only-first-address-p nil))
(bbdb/gnus-show-records)))
(t
(if (null (bbdb/gnus-show-records 'authors))
(bbdb/gnus-show-all-recipients)))))
......@@ -215,20 +212,14 @@ displaying the record corresponding to the sender of the current message."
(lambda (w)
(let ((b (current-buffer)))
(set-buffer (window-buffer w))
(prog1 (or (eq major-mode 'gnus-Article-mode)
(eq major-mode 'gnus-article-mode))
(prog1 (eq major-mode 'gnus-article-mode)
(set-buffer b)))))
(or bbdb-inside-electric-display
(not (get-buffer-window bbdb-buffer-name))
(let (w)
(delete-other-windows)
(if (assq 'article gnus-buffer-configuration)
(gnus-configure-windows 'article)
(gnus-configure-windows 'SelectArticle))
(if (setq w (get-buffer-window
(if (boundp 'gnus-summary-buffer)
gnus-summary-buffer
gnus-Subject-buffer)))
(gnus-configure-windows 'article)
(if (setq w (get-buffer-window gnus-summary-buffer))
(select-window w)))))
(set-buffer b))
(if records (bbdb-display-records records bbdb-pop-up-display-layout)))
......@@ -340,17 +331,18 @@ documentation for the following variables for more details:
This function is meant to be used with the user function defined in
`bbdb/gnus-summary-user-format-letter'"
(let* ((from (mail-header-from header))
(data (and bbdb/gnus-summary-show-bbdb-names
(condition-case ()
(mail-extract-address-components from)
(error nil))))
(name (car data))
(net (car (cdr data)))
(record (and data
(bbdb-search-simple name
(if (and net bbdb-canonicalize-net-hook)
(bbdb-canonicalize-address net)
net)))))
(data (and bbdb/gnus-summary-show-bbdb-names
(condition-case nil
(mail-extract-address-components from)
(error nil))))
(name (car data))
(net (car (cdr data)))
(record (and data
(bbdb-search-simple
name
(if (and net bbdb-canonicalize-net-hook)
(bbdb-canonicalize-address net)
net)))))
(if (and record name (member (downcase name) (bbdb-record-net record)))
;; bogon!
(setq record nil))
......@@ -402,8 +394,12 @@ This function is meant to be used with the user function defined in
"Snarf signature from the corresponding *Article* buffer."
(interactive)
(save-excursion
;; this is a little bogus, since it will remain set after you've
;; quit Gnus
(or gnus-article-buffer (error "Not in Gnus!"))
(set-buffer gnus-article-buffer)
;; This is wrong for non-ASCII text. Why not use
;; gnus-article-hide-signature?
(set-buffer gnus-original-article-buffer)
(save-restriction
(or (gnus-article-narrow-to-signature) (error "No signature!"))
(bbdb-snarf-region (point-min) (point-max)))))
......@@ -489,19 +485,16 @@ addresses better than the traditionally static global scorefile."
"))"))))
bbdb/gnus-score-alist)
;;; Posted originally by Colin Rafferty on the <bbdb-info> mailing list
;;;###autoload
(defun bbdb/gnus-summary-show-all-recipients (not-elided)
"Display BBDB records for all recipients of the message."
(interactive "P")
(gnus-summary-select-article)
(let ((bbdb-display-layout (or (not not-elided)
bbdb-pop-up-display-layout
bbdb-display-layout))
(bbdb-auto-notes-alist nil))
(bbdb/gnus-pop-up-bbdb-buffer nil)
(set-buffer gnus-article-buffer)
(bbdb-show-all-recipients)
))
(bbdb-get-only-first-address-p nil))
(gnus-summary-select-article)
(bbdb/gnus-show-records 'recipients)))
;;; from Brian Edmonds' gnus-bbdb.el
;;;
......@@ -635,13 +628,19 @@ spooled, using the addresses in the headers and information from the
BBDB."
(let ((prq (list (cons 0 nil) (cons 1 nil) (cons 2 nil) (cons 3 nil))))
;; the From: header is special
(let* ((hdr (or (mail-fetch-field "from") (user-login-name)))
(let* ((hdr (or (mail-fetch-field "resent-from")
(mail-fetch-field "from")
(user-login-name)))
(rv (bbdb/gnus-split-to-group hdr t)))
(setcdr (nth (cdr rv) prq) (cons (car rv) nil)))
;; do the rest of the headers
(let ((hdr (or (concat (mail-fetch-field "to" nil t) ", "
(mail-fetch-field "cc" nil t) ", "
(mail-fetch-field "apparently-to" nil t)) "")))
(let ((hdr (or (concat (or (mail-fetch-field "resent-to" nil t)
(mail-fetch-field "to" nil t))
", "
(mail-fetch-field "cc" nil t)
", "
(mail-fetch-field "apparently-to" nil t))
"")))
(setq hdr (rfc822-addresses hdr))
(while hdr
(let* ((rv (bbdb/gnus-split-to-group (car hdr)))
......@@ -682,7 +681,8 @@ determine the group and spooling priority for a single address."
((and rgx pub
(goto-char (point-min))
(re-search-forward "^From: \\([^ \n]+\\)[ \n]" nil t)
(string-match rgx (buffer-substring (match-beginning 1) (match-end 1))))
(string-match rgx (buffer-substring (match-beginning 1)
(match-end 1))))
(cons pub 3))
(prv
(cons prv
......@@ -702,18 +702,10 @@ determine the group and spooling priority for a single address."
(defun bbdb-insinuate-gnus ()
"Call this function to hook BBDB into GNUS."
(setq gnus-optional-headers 'bbdb/gnus-lines-and-from)
(cond ((boundp 'gnus-Article-prepare-hook) ; 3.14 or lower
(add-hook 'gnus-Article-prepare-hook 'bbdb/gnus-pop-up-bbdb-buffer)
(add-hook 'gnus-Save-newsrc-hook 'bbdb-offer-save)
(define-key gnus-Subject-mode-map ":" 'bbdb/gnus-show-sender)
(define-key gnus-Subject-mode-map [(control :)]
'bbdb/gnus-summary-show-all-recipients)
(define-key gnus-Subject-mode-map ";" 'bbdb/gnus-edit-notes))
(t ; 3.15 or higher
(add-hook 'gnus-article-prepare-hook 'bbdb/gnus-pop-up-bbdb-buffer)
(add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
(define-key gnus-summary-mode-map ":" 'bbdb/gnus-show-sender)
(define-key gnus-summary-mode-map ";" 'bbdb/gnus-edit-notes)))
(add-hook 'gnus-article-prepare-hook 'bbdb/gnus-pop-up-bbdb-buffer)
(add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
(define-key gnus-summary-mode-map ":" 'bbdb/gnus-show-sender)
(define-key gnus-summary-mode-map ";" 'bbdb/gnus-edit-notes)
;; Set up user field for use in gnus-summary-line-format
(let ((get-author-user-fun (intern
......@@ -758,4 +750,65 @@ Redefine `bbdb/gnus-summary-in-bbdb-format-letter' to a different letter."
; 'bbdb/gnus-score))
)
;; Uwe Brauer
(defun bbdb/gnus-nnimap-folder-list-from-bbdb ()
"Return a list of \( \"From\" email-regexp imap-folder-name\) tuples
based on the contents of the bbdb.
The folder-name is the value of the 'imap attribute on the bbdb
record; the email-regexp consists of all the email addresses for the
bbdb record concatenated with with OR. bbdb records without a 'imap
attribute are ignored.
Here is an example of a relevant BBDB entry:
Uwe Brauer
net: oub@mat.ucm.es
imap: testimap
This function uses regexp-opt to generate the email-regexp which
automatically regexp-quotes its arguments. Please note: in oder that
this will work with the nnimap-split-fancy method you have to use
macros, that is your setting will look like:
\(setq
nnimap-split-rule 'nnimap-split-fancy
nnimap-split-inbox \"INBOX\"
nnimap-split-fancy
`\(|
,@\(bbdb/gnus-nnimap-folder-list-from-bbdb\)
...
\)\)
Note that `\( is the backquote NOT the quote '\(. "
;(interactive)
(let ( ;; the raw-notes attribute of a bbdb record
notes-attr
;; the value of the 'imap attribute of a bbdb record
folder-attr
;; strings to put before and after the folder-attr
(folder-prefix "")
(folder-postfix "")
;; a regexp matching all the email addresses from a bbdb record
email-regexp
;; the list of (folder email) tuples to return
new-elmnt-list
)
;; loop over the bbdb-records; if a imap attribute exists on
;; the record, generate a regexp matching all the email addresses
;; and add a tuple (folder email-regexp) to the new-elmnt-list
(dolist (record (bbdb-records))
(setq notes-attr (bbdb-record-raw-notes record))
(when (and (listp notes-attr)
(setq folder-attr (cdr (assq 'imap notes-attr))))
(setq email-regexp (regexp-opt (mapcar 'downcase
(bbdb-record-net record))))
(unless (zerop (length email-regexp))
(setq new-elmnt-list
(cons (list "From" email-regexp (concat folder-prefix
folder-attr folder-postfix))
new-elmnt-list)))))
new-elmnt-list))
(provide 'bbdb-gnus)
......@@ -83,28 +83,35 @@ which is the current time string."
;;; Determining whether to create a record based on the content of the
;;; current message.
(eval-when-compile
(defvar vm-mail-buffer)
(defvar vm-message-pointer)
(autoload 'vm-start-of "vm")
(autoload 'bbdb/vm-pop-up-bbdb-buffer "bbdb-vm"))
;;;###autoload
(defun bbdb-header-start ()
"Returns a marker at the beginning of the header block of the current
message. This will not necessarily be in the current buffer."
(cond ((memq major-mode '(vm-presentation-mode vm-mode vm-summary-mode))
(if vm-mail-buffer (set-buffer vm-mail-buffer))
(vm-start-of (car vm-message-pointer)))
((memq major-mode '(rmail-mode rmail-summary-mode))
(if (and (boundp 'rmail-buffer) rmail-buffer)
(set-buffer rmail-buffer))
(point-min-marker))
((memq major-mode
'(gnus-Group-mode gnus-Subject-mode gnus-Article-mode))
(set-buffer gnus-article-buffer)
(point-min-marker))
;; MH-E clause added by knabe.
((eq major-mode 'mh-folder-mode)
(mh-show)
(set-buffer mh-show-buffer)
(point-min-marker))
(t (point-min-marker))
))
(cond ((memq major-mode
'(gnus-group-mode gnus-summary-mode gnus-article-mode))
(set-buffer (or gnus-original-article-buffer
gnus-article-buffer))
(point-min-marker))
((memq major-mode '(vm-presentation-mode vm-mode vm-summary-mode))
(if vm-mail-buffer (set-buffer vm-mail-buffer))
(vm-start-of (car vm-message-pointer)))
((memq major-mode '(rmail-mode rmail-summary-mode))
(if (and (boundp 'rmail-buffer) rmail-buffer)
(set-buffer rmail-buffer))
(point-min-marker))
;; MH-E clause added by knabe.
((eq major-mode 'mh-folder-mode)
(mh-show)
(set-buffer mh-show-buffer)
(point-min-marker))
(t (point-min-marker))
))
;;;###autoload
......@@ -118,24 +125,29 @@ beginning of the message headers."
;; we can't special-case VM here to use its cache, because the cache has
;; divided real-names from addresses; the actual From: and Subject: fields
;; exist only in the message.
(setq field-name (concat (regexp-quote field-name) "[ \t]*:[ \t]*"))
(let ((case-fold-search t)
done)
(while (not (or done
(looking-at "\n") ; we're at BOL
(eobp)))
(if (looking-at field-name)
(progn
(goto-char (match-end 0))
(setq done (buffer-substring (point)
(progn (end-of-line) (point))))
(while (looking-at "\n[ \t]")
(setq done (concat done " "
(buffer-substring (match-end 0)
(progn (end-of-line 2) (point))))))))
(forward-line 1))
done))
(save-excursion
(if (memq major-mode
'(gnus-summary-mode gnus-article-mode gnus-tree-mode))
(progn
(set-buffer (get-buffer gnus-original-article-buffer))
(goto-char (point-min))))
(setq field-name (concat (regexp-quote field-name) "[ \t]*:[ \t]*"))
(let ((case-fold-search t)
done)
(while (not (or done
(looking-at "\n") ; we're at BOL
(eobp)))
(if (looking-at field-name)
(progn
(goto-char (match-end 0))
(setq done (buffer-substring (point)
(progn (end-of-line) (point))))
(while (looking-at "\n[ \t]")
(setq done (concat done " "
(buffer-substring (match-end 0)
(progn (end-of-line 2) (point))))))))
(forward-line 1))
done)))
(defcustom bbdb-ignore-most-messages-alist '()
"*An alist describing which messages to automatically create BBDB
......@@ -186,31 +198,31 @@ the bbdb-ignore-most-messages-alist (which see) and *no* others."
(let ((rest (if invert-sense
bbdb-ignore-some-messages-alist
bbdb-ignore-most-messages-alist))
(case-fold-search t)
(done nil)
(b (current-buffer))
(marker (bbdb-header-start))
field regexp fieldval)
(case-fold-search t)
(done nil)
(b (current-buffer))
(marker (bbdb-header-start))
field regexp fieldval)
(set-buffer (marker-buffer marker))
(save-restriction
(widen)
(while (and rest (not done))
(goto-char marker)
(setq field (car (car rest))
regexp (cdr (car rest))
fieldval (bbdb-extract-field-value field))
(if (and fieldval (string-match regexp fieldval))
(setq done t))
(setq rest (cdr rest))))
(goto-char marker)
(setq field (car (car rest))
regexp (cdr (car rest))
fieldval (bbdb-extract-field-value field))
(if (and fieldval (string-match regexp fieldval))
(setq done t))
(setq rest (cdr rest))))
(set-buffer b)
(if invert-sense
(not done)
done)))
(not done)
done)))
;;; Provided by Bill Carpenter.
(defvar bbdb-ignore-selected-messages-confirmation nil
"*If bbdb-ignore-selected-messages-hook is used as an auto-create-hook, this
variable governs whether you are prompted for creation of BBDB entries.")
variable governs whether you are prompted for creation of BBDB entries.")
;;;###autoload
(defun bbdb-ignore-selected-messages-hook ()
......@@ -691,8 +703,8 @@ get records added for those people you reply to."
(bbdb/gnus-pop-up-bbdb-buffer))
((member major-mode '(rmail-mode rmail-summary-mode))
(bbdb/rmail-pop-up-bbdb-buffer))
((member major-mode '(mhe-mode mhe-summary-mode))
(bbdb/gnus-pop-up-bbdb-buffer))
((member major-mode '(mhe-mode mhe-summary-mode mh-folder-mode))
(bbdb/mh-pop-up-bbdb-buffer))
))))
(provide 'bbdb-hooks)
......@@ -86,7 +86,7 @@ the user confirms the creation."
(or (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)
offer-to-create)
offer-to-create)))
(bbdb-encache-message msg (list record))
(if (and msg record) (bbdb-encache-message msg (list record)))
;; return one record
record))))))
......
......@@ -24,6 +24,16 @@
;; $Id$
;;
;; $Log$
;; Revision 1.20 2004/03/22 15:55:03 waider
;; * Minor docstring fix (Stefan Monnier)
;; * Catch error if attempting to kill only window in frame (Stefan Monnier)
;;
;; Revision 1.19 2002/08/19 22:49:12 waider
;; Jim Blandy's fix for migrating notes.
;;
;; Revision 1.18 2002/05/12 22:17:03 waider
;; Dave Love's big patch. See ChangeLog for full details.
;;
;; Revision 1.17 2001/05/17 17:15:31 fenk
;; (bbdb-unmigrate-zip-codes-to-strings): Fixed the faulty use of let instead of let*.
;;
......@@ -95,9 +105,9 @@
;;;###autoload
(defun bbdb-migration-query (ondisk)
"Ask if the database is to be migrated. ONDISK is the version
number of the database as currently stored on disk. Returns the
version for the saved database."
"Ask if the database is to be migrated.
ONDISK is the version number of the database as currently stored on
disk. Returns the version for the saved database."
(save-excursion
(let ((wc (current-window-configuration))
(buf (get-buffer-create "*BBDB Migration Info*"))
......@@ -129,7 +139,11 @@ changes introduced after version %d is shown below:\n\n" ondisk ondisk))
(y-or-n-p (concat "Upgrade BBDB to version "
(format "%d" bbdb-file-format)
"? ")))
(delete-window win)
(condition-case nil
(delete-window win)
;; The window might be the only one on its frame. Hopefully, it's
;; a dedicated window and the kill-buffer below will DTRT.
(error nil))
(kill-buffer buf)
(set-window-configuration wc)
(if update bbdb-file-format ondisk))))
......@@ -139,8 +153,8 @@ changes introduced after version %d is shown below:\n\n" ondisk ondisk))
"Migrate the BBDB from the version on disk (the car of
`bbdb-file-format-migration') to the current version (in
`bbdb-file-format')."
(mapc (bbdb-migrate-versions-lambda (car bbdb-file-format-migration))
records)
(bbdb-mapc (bbdb-migrate-versions-lambda (car bbdb-file-format-migration))
records)
records)
;;;###autoload
......@@ -190,7 +204,7 @@ results will be saved with SET."
(byte-compile `(lambda (rec)
,@(mapcar (lambda (ch)
`(,(cadr ch) rec
(,(caddr ch)
(,(car (cddr ch))
(,(car ch) rec))))
changes)
rec)))
......@@ -299,14 +313,16 @@ This uses the code that used to be in bbdb-parse-zip-string."
addrs))
(defun bbdb-migrate-change-dates (rec)
"Change date formats in timestamp and creation-date fields from
"Change date formats.
Formats are changed in timestamp and creation-date fields from
\"dd mmm yy\" to \"yyyy-mm-dd\". Assumes the notes are passed in as an
argument."
(mapc (lambda (rr)
(when (memq (car rr) '(creation-date timestamp))
(bbdb-migrate-change-dates-change-field rr)))
rec)
rec)
(unless (stringp rec)
(bbdb-mapc (lambda (rr)
(when (memq (car rr) '(creation-date timestamp))
(bbdb-migrate-change-dates-change-field rr)))
rec)
rec))
(defun bbdb-migrate-change-dates-change-field (field)
"Migrate the date field (the cdr of FIELD) from \"dd mmm yy\" to
......@@ -367,14 +383,16 @@ argument."
field date)))))
(defun bbdb-unmigrate-change-dates (rec)
"Change date formats is timestamp and creation-date fields from
"Change date formats.
Formats are changed in timestamp and creation-date fields from
\"yyyy-mm-dd\" to \"dd mmm yy\". Assumes the notes list is passed in
as an argument."
(mapc (lambda (rr)
(when (memq (car rr) '(creation-date timestamp))
(bbdb-unmigrate-change-dates-change-field rr)))
rec)
rec)
(unless (stringp rec)
(bbdb-mapc (lambda (rr)
(when (memq (car rr) '(creation-date timestamp))
(bbdb-unmigrate-change-dates-change-field rr)))
rec)
rec))
(defun bbdb-unmigrate-change-dates-change-field (field)
"Unmigrate the date field (the cdr of FIELD) from \"yyyy-mm-dd\" to
......
......@@ -41,7 +41,7 @@
;;; bbdb-print; it is used verbatim.
;;;
;;; Not all fields or records need be printed. To not print a certain
;;; field, add it to `bbdb-print-elide' (which see). If after eliding
;;; field, add it to `bbdb-print-omit-fields' (which see). If after eliding
;;; fields a record contains no interesting information, it will not
;;; be printed at all; the variable `bbdb-print-require' determines
;;; what is meant by "interesting" information. You can also restrict
......@@ -56,6 +56,9 @@
;; $Id$
;;
;; $Log$
;; Revision 1.68 2004/10/13 13:37:06 waider
;; * Correct variable name in comment
;;
;; Revision 1.67 2001/11/19 21:35:08 waider
;; Patch from Alex Schroeder
;;
......
......@@ -53,17 +53,6 @@
;;
;; $Id$
;;
;; $Log$
;; Revision 1.55 2000/07/13 17:07:00 sds
;; minor doc fixes to comply with the standards
;;
;; Revision 1.54 1998/04/11 07:18:55 simmonmt
;; Colin Rafferty's patch adding autoload cookies back
;;
;; Revision 1.53 1998/01/06 06:10:06 simmonmt
;; Changed setup documentation and added RCS ID and Log strings
;;
;;
;;-----------------------------------------------------------------------
......
......@@ -22,13 +22,16 @@
;; $Id$
;;
(eval-and-compile
(eval-when-compile
(require 'bbdb)
(require 'bbdb-com)
(require 'rmail)
;(require 'rmail