CVS update by fenk packages/xemacs-packages/bbdb/lisp, bbdb-gnus.el,
bbdb-mhe.el, bbdb-reportmail.el, bbdb-snarf.el, bbdb.el ...
xemacs-cvs at xemacs.org
xemacs-cvs at xemacs.org
Fri Feb 23 15:24:13 EST 2007
User: fenk
Date: 07/02/23 21:24:13
Modified: packages/xemacs-packages/bbdb/lisp bbdb-com.el bbdb-ftp.el
bbdb-gnus.el bbdb-hooks.el bbdb-merge.el
bbdb-mhe.el bbdb-migrate.el bbdb-print.el
bbdb-reportmail.el bbdb-rmail.el bbdb-sc.el
bbdb-snarf.el bbdb-srv.el bbdb-vm.el bbdb-w3.el
bbdb.el
Log:
This is the release version 2.35 of BBDB.
A diff of the SF CVS on '2005/07/24 15:22:58' and the XEmacs CVS shows only
differences in the expanded keywords of the lisp files.
Those evil CVS/RCS keywords will be removed in the next BBDB version.
Revision Changes Path
1.10 +54 -24 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-com.el
Index: bbdb-com.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-com.el,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -p -r1.9 -r1.10
--- bbdb-com.el 2005/07/24 15:22:57 1.9
+++ bbdb-com.el 2007/02/23 20:24:06 1.10
@@ -20,14 +20,12 @@
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
-;; $Id: bbdb-com.el,v 1.9 2005/07/24 15:22:57 waider Exp $
+;; $Id: bbdb-com.el,v 1.10 2007/02/23 20:24:06 fenk Exp $
;;
+(require 'cl)
(require 'bbdb)
-;;(require 'bbdb-snarf) causes recursive compile!
-(eval-when-compile
- (require 'cl)
- (defvar bbdb-extract-address-components-func)) ;; bbdb-snarf
+;;(require 'bbdb-snarf) causes recursive compile, which I should fix.
;; ARGH. fmh, dammit.
(require
@@ -66,6 +64,13 @@
(defvar bbdb-define-all-aliases-needs-rebuilt nil)
+(defcustom bbdb-extract-address-components-func
+ 'bbdb-rfc822-addresses
+ "Function called to parse one or more email addresses.
+See bbdb-extract-address-components for an example."
+:group 'bbdb-noticing-records
+:type 'function)
+
(defcustom bbdb-default-country
'"Emacs";; what do you mean, it's not a country?
"*Default country to use if none is specified."
@@ -1034,9 +1039,12 @@ section, then the entire field is edited
;;
;; delete the old hash entry
(let ((name (bbdb-record-name bbdb-record))
+ (lastname (bbdb-record-lastname bbdb-record))
(company (bbdb-record-company bbdb-record)))
(if (> (length name) 0)
(bbdb-remhash (downcase name) bbdb-record))
+ (if (> (length lastname) 0)
+ (bbdb-remhash (downcase lastname) bbdb-record))
(if (> (length company) 0)
(bbdb-remhash (downcase company) bbdb-record)))
(bbdb-record-set-namecache bbdb-record nil)
@@ -1061,10 +1069,7 @@ section, then the entire field is edited
""))))))
;; delete the old hash entry
- (let ((name (bbdb-record-name bbdb-record))
- (company (bbdb-record-company bbdb-record)))
- (if (> (length name) 0)
- (bbdb-remhash (downcase name) bbdb-record))
+ (let ((company (bbdb-record-company bbdb-record)))
(if (> (length company) 0)
(bbdb-remhash (downcase company) bbdb-record)))
@@ -1942,9 +1947,11 @@ the name is always included. If `bbdb-d
(or (fboundp 'vm-mail-internal)
(load-library "vm-reply")))) ; 5.31 or earlier
(vm-session-initialization)
- (vm-mail-internal nil to subj)
- (run-hooks 'vm-mail-hook)
- (run-hooks 'vm-mail-mode-hook))
+ (if (not subj)
+ (vm-mail to)
+ (vm-mail-internal nil to subj)
+ (run-hooks 'vm-mail-hook)
+ (run-hooks 'vm-mail-mode-hook)))
((eq type 'message)
(or (fboundp 'message-mail) (autoload 'message-mail "message"))
(message-mail to subj))
@@ -2225,22 +2232,35 @@ completion with."
)
(setq bbdb-complete-name-saved-window-config nil))))
+(defvar bbdb-complete-name-callback-data nil
+ "Stores the buffer and region start and end of the completed string.
+This is set in the *Completions* buffer.
+It is set in `bbdb-display-completion-list' and used in the advice
+`choose-completion-string'.")
+
+(make-variable-buffer-local 'bbdb-complete-name-callback-data)
+
(defun bbdb-display-completion-list (list &optional callback data)
"Wrapper for `display-completion-list'.
GNU Emacs requires DATA to be in a specific format, viz. (nth 1 data) should
be a marker for the start of the region being completed."
+ ;; disgusting hack to make GNU Emacs nuke the bit you've typed
+ ;; when it inserts the completion.
+ (setq bbdb-complete-name-callback-data data)
(if (featurep 'xemacs)
(display-completion-list list :activate-callback callback
:user-data data)
- (display-completion-list list)
- ;; disgusting hack to make GNU Emacs nuke the bit you've typed
- ;; when it inserts the completion.
- (if data
- (save-excursion
- (set-buffer standard-output)
- (setq completion-base-size
- (- (marker-position (nth 1 data)) 1))))))
+ (display-completion-list list)))
+(defadvice choose-completion-string (before bbdb-complete-fix activate)
+ "Deletes the completed string before replacing.
+We need to do this as we are abusing completion and it was not meant to work
+in buffer other than the mini buffer."
+ (when bbdb-complete-name-callback-data
+ (save-excursion
+ (set-buffer (car bbdb-complete-name-callback-data))
+ (apply 'delete-region (cdr bbdb-complete-name-callback-data)))))
+
(defun bbdb-complete-clicked-name (event extent user-data)
"Find the record for a name clicked in a completion buffer.
Currently only used by XEmacs."
@@ -2332,7 +2352,7 @@ Completion behaviour can be controlled w
(setq only-one-p nil))
(if (not (memq sym all-the-completions))
(setq all-the-completions (cons sym all-the-completions))))))
- (completion (try-completion pattern ht pred))
+ (completion (progn (all-completions pattern ht pred) (try-completion pattern ht)))
(exact-match (eq completion t)))
(cond
@@ -2418,6 +2438,15 @@ Completion behaviour can be controlled w
(length pattern))))
(setq match-recs (cons (car recs) match-recs)
matched t)))
+
+ ;; Did we match on lastname?
+ (let ((b-r-name (or (bbdb-record-lastname (car recs)) "")))
+ (if (string= pattern
+ (substring (downcase b-r-name) 0
+ (min (length b-r-name)
+ (length pattern))))
+ (setq match-recs (cons (car recs) match-recs)
+ matched t)))
;; Did we match on aka?
(when (not matched)
@@ -2500,7 +2529,7 @@ Completion behaviour can be controlled w
(not (string= completion last))
(setq last completion
pattern (downcase orig)
- completion (try-completion pattern ht pred)))
+ completion (progn (all-completions pattern ht pred) (try-completion pattern ht))))
(if (stringp completion)
(progn (delete-region beg end)
(insert completion))))
@@ -2738,7 +2767,8 @@ of all of those people."
(setq result (cdr result)))
(when (not use-abbrev-p)
- (modify-syntax-entry ?* "w" mail-mode-header-syntax-table)
+ (if (boundp 'mail-mode-header-syntax-table)
+ (modify-syntax-entry ?* "w" mail-mode-header-syntax-table))
(sendmail-pre-abbrev-expand-hook))))
;; We should be cleverer here and instead of rebuilding all aliases we should
@@ -2917,7 +2947,7 @@ try to use internal sound if available."
(condition-case nil
(play-sound (list 'sound
:file (aref bbdb-sound-files
- (string-to-int num))
+ (string-to-number num))
:volume (or volume bbdb-sound-volume)))
(error nil)))
(if (and bbdb-sound-player
1.9 +0 -0 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-ftp.el
Index: bbdb-ftp.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-ftp.el,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -p -r1.8 -r1.9
--- bbdb-ftp.el 2005/07/24 15:22:57 1.8
+++ bbdb-ftp.el 2007/02/23 20:24:07 1.9
@@ -21,7 +21,7 @@
;;; This file was written by Ivan Vazquez <ivan at haldane.bu.edu>
-;;; $Id: bbdb-ftp.el,v 1.8 2005/07/24 15:22:57 waider Exp $
+;;; $Id: bbdb-ftp.el,v 1.9 2007/02/23 20:24:07 fenk Exp $
;;; 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
1.9 +10 -10 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-gnus.el
Index: bbdb-gnus.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-gnus.el,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -p -r1.8 -r1.9
--- bbdb-gnus.el 2005/07/24 15:22:57 1.8
+++ bbdb-gnus.el 2007/02/23 20:24:07 1.9
@@ -2,7 +2,7 @@
;;; This file is part of the Insidious Big Brother Database (aka BBDB),
;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz at netscape.com>.
-;;; Interface to GNUS version 3.12 or greater. See bbdb.texinfo.
+;;; Interface to Gnus. See bbdb.texinfo.
;;; The Insidious Big Brother Database is free software; you can redistribute
;;; it and/or modify it under the terms of the GNU General Public License as
@@ -19,7 +19,7 @@
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
-;; $Id: bbdb-gnus.el,v 1.8 2005/07/24 15:22:57 waider Exp $
+;; $Id: bbdb-gnus.el,v 1.9 2007/02/23 20:24:07 fenk Exp $
;;
(require 'bbdb)
@@ -77,7 +77,7 @@ The default is to annotate only new mess
;;;###autoload
(defun bbdb/gnus-update-record (&optional offer-to-create)
- "Return the record corresponding to the current GNUS message, creating
+ "Return the record corresponding to the current Gnus message, creating
or modifying it as necessary. A record will be created if
bbdb/news-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
the user confirms the creation."
@@ -87,7 +87,7 @@ the user confirms the creation."
;;;###autoload
(defun bbdb/gnus-update-records (&optional offer-to-create)
- "Return the records corresponding to the current GNUS message, creating
+ "Return the records corresponding to the current Gnus message, creating
or modifying it as necessary. A record will be created if
bbdb/news-auto-create-p is non-nil or if OFFER-TO-CREATE is true
and the user confirms the creation.
@@ -198,7 +198,7 @@ This buffer will be in `bbdb-mode', with
(bbdb/gnus-show-all-recipients)))))
(defun bbdb/gnus-pop-up-bbdb-buffer (&optional offer-to-create)
- "Make the *BBDB* buffer be displayed along with the GNUS windows,
+ "Make the *BBDB* buffer be displayed along with the Gnus windows,
displaying the record corresponding to the sender of the current message."
(let ((bbdb-gag-messages t)
(records (bbdb/gnus-update-records offer-to-create))
@@ -237,7 +237,7 @@ set gnus-optional-headers to 'bbdb/gnus-
(defcustom bbdb/gnus-summary-mark-known-posters t
"*If t, mark messages created by people with records in the BBDB.
-In GNUS, this marking will take place in the subject list (assuming
+In Gnus, this marking will take place in the subject list (assuming
`gnus-optional-headers' contains `bbdb/gnus-lines-and-from'). In Gnus, the
marking will take place in the Summary buffer if the format code defined by
`bbdb/gnus-summary-user-format-letter' is used in `gnus-summary-line-format'.
@@ -263,7 +263,7 @@ then for messages from authors who are i
displayed will be the primary name in the database, rather than the
one in the From line of the message. This doesn't affect the names of
people who aren't in the database, of course. (`gnus-optional-headers'
-must be `bbdb/gnus-lines-and-from' for GNUS users.)"
+must be `bbdb/gnus-lines-and-from' for Gnus users.)"
:group 'bbdb-mua-specific-gnus
:type 'boolean)
(defvaralias 'bbdb/gnus-header-show-bbdb-names
@@ -281,7 +281,7 @@ otherwise display his/her primary net ad
is set to the symbol bbdb, then real names will be used from the BBDB
if present, otherwise the net address in the post will be used. If
bbdb/gnus-summary-prefer-bbdb-data is nil, then this has no effect.
-See `bbdb/gnus-lines-and-from' for GNUS users, or
+See `bbdb/gnus-lines-and-from' for Gnus users, or
`bbdb/gnus-summary-user-format-letter' for Gnus users."
:group 'bbdb-mua-specific-gnus
:type '(choice (const :tag "Prefer real names" t)
@@ -445,7 +445,7 @@ record contains a gnus-score field."
;;;###autoload
(defun bbdb/gnus-score (group)
- "This returns a score alist for GNUS. A score pair will be made for
+ "This returns a score alist for Gnus. A score pair will be made for
every member of the net field in records which also have a gnus-score
field. This allows the BBDB to serve as a supplemental global score
file, with the advantage that it can keep up with multiple and changing
@@ -700,7 +700,7 @@ determine the group and spooling priorit
;;;###autoload
(defun bbdb-insinuate-gnus ()
- "Call this function to hook BBDB into GNUS."
+ "Call this function to hook BBDB into Gnus."
(setq gnus-optional-headers 'bbdb/gnus-lines-and-from)
(add-hook 'gnus-article-prepare-hook 'bbdb/gnus-pop-up-bbdb-buffer)
(add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
1.7 +5 -3 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-hooks.el
Index: bbdb-hooks.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-hooks.el,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -p -r1.6 -r1.7
--- bbdb-hooks.el 2005/07/24 15:22:57 1.6
+++ bbdb-hooks.el 2007/02/23 20:24:07 1.7
@@ -32,11 +32,12 @@
;;; Read the docstrings; read the texinfo file.
;;
-;; $Id: bbdb-hooks.el,v 1.6 2005/07/24 15:22:57 waider Exp $
+;; $Id: bbdb-hooks.el,v 1.7 2007/02/23 20:24:07 fenk Exp $
;;
(require 'bbdb)
(require 'bbdb-com)
+(require 'mail-parse)
(eval-when-compile
(condition-case()
@@ -118,7 +119,7 @@ message. This will not necessarily be i
(defun bbdb-extract-field-value (field-name)
"Given the name of a field (like \"Subject\") this returns the value of
that field in the current message, or nil. This works whether you're in
-GNUS, Rmail, or VM. This works on multi-line fields, but if more than
+Gnus, Rmail, or VM. This works on multi-line fields, but if more than
one field of the same name is present, only the last is returned. It is
expected that the current buffer has a message in it, and (point) is at the
beginning of the message headers."
@@ -147,7 +148,8 @@ beginning of the message headers."
(buffer-substring (match-end 0)
(progn (end-of-line 2) (point))))))))
(forward-line 1))
- done)))
+ (and done
+ (mail-decode-encoded-word-string done)))))
(defcustom bbdb-ignore-most-messages-alist '()
"*An alist describing which messages to automatically create BBDB
1.4 +3 -0 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-merge.el
Index: bbdb-merge.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-merge.el,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -p -r1.3 -r1.4
--- bbdb-merge.el 2005/07/23 14:44:51 1.3
+++ bbdb-merge.el 2007/02/23 20:24:07 1.4
@@ -149,9 +149,12 @@ Returns the Grand Unified Record."
;; fix up the in-memory copy.
(bbdb-change-record merge-record t)
(let ((name (bbdb-record-name merge-record))
+ (lastname (bbdb-record-lastname merge-record))
(company (bbdb-record-company merge-record)))
(if (> (length name) 0)
(bbdb-remhash (downcase name) merge-record))
+ (if (> (length lastname) 0)
+ (bbdb-remhash (downcase lastname) merge-record))
(if (> (length company) 0)
(bbdb-remhash (downcase company) merge-record)))
(bbdb-record-set-namecache merge-record nil)
1.6 +6 -4 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-mhe.el
Index: bbdb-mhe.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-mhe.el,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -p -r1.5 -r1.6
--- bbdb-mhe.el 2005/07/24 15:22:57 1.5
+++ bbdb-mhe.el 2007/02/23 20:24:07 1.6
@@ -22,7 +22,7 @@
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
-;; $Id: bbdb-mhe.el,v 1.5 2005/07/24 15:22:57 waider Exp $
+;; $Id: bbdb-mhe.el,v 1.6 2007/02/23 20:24:07 fenk Exp $
;;
(eval-and-compile
@@ -85,9 +85,11 @@ the user confirms the creation."
from t
(or (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)
offer-to-create)
- offer-to-create)))
- (if (and msg record) (bbdb-encache-message msg (list record)))
- ;; return one record
+ ;; ugh. what the hell?
+ (or offer-to-create
+ (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)))))
+ (if (and msg record) (bbdb-encache-message msg (list record)))
+ ;; return one record
record))))))
;;;###autoload
1.9 +11 -77 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-migrate.el
Index: bbdb-migrate.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-migrate.el,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -p -r1.8 -r1.9
--- bbdb-migrate.el 2005/07/24 15:22:58 1.8
+++ bbdb-migrate.el 2007/02/23 20:24:08 1.9
@@ -21,77 +21,8 @@
;;;
;;
-;; $Id: bbdb-migrate.el,v 1.8 2005/07/24 15:22:58 waider Exp $
+;; $Id: bbdb-migrate.el,v 1.9 2007/02/23 20:24:08 fenk Exp $
;;
-;; $Log: bbdb-migrate.el,v $
-;; Revision 1.8 2005/07/24 15:22:58 waider
-;; sync with Sourceforge CVS
-;;
-;; 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*.
-;;
-;; Revision 1.16 2000/11/27 12:59:53 waider
-;; Alex's zipcode changes. WARNING: New database format.
-;;
-;; Revision 1.15 2000/08/05 15:38:04 waider
-;; When converting the streets to a list, delete "nil" as well as "".
-;;
-;; Revision 1.14 2000/07/11 21:28:44 sds
-;; (bbdb-migrate-record-lambda): `mapcar', not `mapc' here!
-;;
-;; Revision 1.13 2000/07/10 17:00:12 sds
-;; revert the last patch (`mapc' is more efficient than `mapcar')
-;;
-;; Revision 1.12 2000/07/09 09:20:11 waider
-;; GNUmacs doesn't have "mapc".
-;;
-;; Revision 1.11 2000/07/05 21:43:35 sds
-;; rewrote migration in a modular way
-;;
-;; Revision 1.10 2000/06/30 19:12:36 sds
-;; (bbdb-migrate): re-wrote using `mapcar' instead of `append'
-;; this is linear instead of quadratic and avoids much consing
-;;
-;; Revision 1.9 2000/05/29 22:47:50 waider
-;; *** empty log message ***
-;;
-;; Revision 1.8 2000/04/17 08:30:47 waider
-;; omitted bracket on unmigrate for v5->v4
-;;
-;; Revision 1.7 2000/04/16 04:00:54 waider
-;; * Added 5->4 unmigration
-;;
-;; Revision 1.6 2000/04/15 14:57:38 waider
-;; * Fixed misplaced bracket in street migration code.
-;;
-;; Revision 1.5 2000/04/12 23:57:16 waider
-;; * Added v5 migration. NB no back-migration yet.
-;;
-;; Revision 1.4 2000/04/05 16:45:07 bbdb-writer
-;; * Added Alex's BBDB v4 format migration (country field)
-;;
-;; Revision 1.3 1998/10/10 18:47:21 simmonmt
-;; From slbaur: Don't pass an integer to concat.
-;; Format dates with number format - not string - so we get leading
-;; zeros.
-;;
-;; Revision 1.2 1998/04/11 07:19:19 simmonmt
-;; Colin Rafferty's patch adding autoload cookies back
-;;
-;; Revision 1.1 1998/01/06 06:06:06 simmonmt
-;; Initial revision
-;;
-;;
(require 'bbdb)
@@ -285,7 +216,7 @@ This uses the code that used to be in bb
(zip (cond ((string-match "^[ \t\n]*$" string) 0)
;; Matches 1 to 6 digits.
((string-match "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$" string)
- (string-to-int string))
+ (string-to-number string))
;; Matches 5 digits and 3 or 4 digits.
((string-match "^[ \t\n]*\\([0-9][0-9][0-9][0-9][0-9]\\)[ \t\n]*-?[ \t\n]*\\([0-9][0-9][0-9][0-9]?\\)[ \t\n]*$" string)
(list (bbdb-subint string 1) (bbdb-subint string 2)))
@@ -339,9 +270,9 @@ argument."
["0" "0" "0" "0" nil])
(cond ((string-match
"^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)" date)
- (setq parsed (vector (string-to-int (match-string 1 date))
- (string-to-int (match-string 2 date))
- (string-to-int (match-string 3 date))))
+ (setq parsed (vector (string-to-number (match-string 1 date))
+ (string-to-number (match-string 2 date))
+ (string-to-number (match-string 3 date))))
;; This should be fairly loud for GNU Emacs users
(bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
(car field) (cdr field)
@@ -351,9 +282,9 @@ argument."
(aref parsed 2) (aref parsed 0)))
((string-match
"^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
- (setq parsed (vector (string-to-int (match-string 3 date))
- (string-to-int (match-string 1 date))
- (string-to-int (match-string 2 date))))
+ (setq parsed (vector (string-to-number (match-string 3 date))
+ (string-to-number (match-string 1 date))
+ (string-to-number (match-string 2 date))))
;; This should be fairly loud for GNU Emacs users
(bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
(car field) (cdr field)
@@ -365,11 +296,11 @@ argument."
;; I like numbers
(and (stringp (aref parsed 0))
- (aset parsed 0 (string-to-int (aref parsed 0))))
+ (aset parsed 0 (string-to-number (aref parsed 0))))
(and (stringp (aref parsed 1))
- (aset parsed 1 (string-to-int (aref parsed 1))))
+ (aset parsed 1 (string-to-number (aref parsed 1))))
(and (stringp (aref parsed 2))
- (aset parsed 2 (string-to-int (aref parsed 2))))
+ (aset parsed 2 (string-to-number (aref parsed 2))))
;; Sanity check
(cond ((and (< 0 (aref parsed 0))
1.7 +1 -56 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-print.el
Index: bbdb-print.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-print.el,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -p -r1.6 -r1.7
--- bbdb-print.el 2005/07/24 15:22:58 1.6
+++ bbdb-print.el 2007/02/23 20:24:08 1.7
@@ -53,65 +53,7 @@
;;; documentation for the allowed options.
;;
-;; $Id: bbdb-print.el,v 1.6 2005/07/24 15:22:58 waider Exp $
-;;
-;; $Log: bbdb-print.el,v $
-;; Revision 1.6 2005/07/24 15:22:58 waider
-;; sync with Sourceforge CVS
-;;
-;; 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
-;;
-;; Revision 1.66 2001/09/11 10:55:31 fenk
-;; Appliend fixed according to change log
-;;
-;; Revision 1.65 2000/11/27 12:59:53 waider
-;; Alex's zipcode changes. WARNING: New database format.
-;;
-;; Revision 1.64 2000/07/13 17:07:00 sds
-;; minor doc fixes to comply with the standards
-;;
-;; Revision 1.63 2000/05/29 22:47:50 waider
-;; *** empty log message ***
-;;
-;; Revision 1.62 2000/04/15 17:11:49 kuepper
-;; Adopt TeX-output of streets to new file-format v5.
-;;
-;; Revision 1.61 2000/04/13 17:19:58 kuepper
-;; Improved TeX output (fonts, breaks).
-;;
-;; Revision 1.60 2000/04/13 00:22:23 waider
-;; * Address layout patch, including Euro addresses and the streets->list thing
-;;
-;; Revision 1.59 1998/11/02 07:08:14 simmonmt
-;; Change mailing list address
-;;
-;; Revision 1.58 1998/10/17 19:43:26 simmonmt
-;; Patch to convert default area code protection from condition-case to
-;; integerp.
-;;
-;; Revision 1.57 1998/04/11 07:19:32 simmonmt
-;; Colin Rafferty's patch adding autoload cookies back
-;;
-;; Revision 1.56 1998/03/10 07:37:42 simmonmt
-;; Protecting bbdb-default-area-code
-;;
-;; Revision 1.55 1998/02/23 07:12:40 simmonmt
-;; Moved key binding to bbdb.el, changed default of bbdb-print-elide,
-;; fixed problem with nil bbdb-default-area-code
-;;
-;; Revision 1.54 1998/01/06 06:08:38 simmonmt
-;; Customized variables and removed autoloads
-;;
-;; Revision 1.53 1997/12/01 05:02:28 simmonmt
-;; Soren Dayton's fix to correct tilde printing
-;;
-;; Revision 1.52 1997/10/06 01:05:28 simmonmt
-;; New version of bbdb-print from Boris Goldowsky <boris at gnu.ai.mit.edu>
-;;
+;; $Id: bbdb-print.el,v 1.7 2007/02/23 20:24:08 fenk Exp $
;;
;;; Installation:
1.7 +0 -0 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-reportmail.el
Index: bbdb-reportmail.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-reportmail.el,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -p -r1.6 -r1.7
--- bbdb-reportmail.el 2005/07/24 15:22:58 1.6
+++ bbdb-reportmail.el 2007/02/23 20:24:08 1.7
@@ -51,7 +51,7 @@
;; Initial release.
;;
-;; $Id: bbdb-reportmail.el,v 1.6 2005/07/24 15:22:58 waider Exp $
+;; $Id: bbdb-reportmail.el,v 1.7 2007/02/23 20:24:08 fenk Exp $
;;
;;-----------------------------------------------------------------------
1.7 +116 -92 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-rmail.el
Index: bbdb-rmail.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-rmail.el,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -p -r1.6 -r1.7
--- bbdb-rmail.el 2005/07/24 15:22:58 1.6
+++ bbdb-rmail.el 2007/02/23 20:24:08 1.7
@@ -17,21 +17,16 @@
;;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
;;
-;; $Id: bbdb-rmail.el,v 1.6 2005/07/24 15:22:58 waider Exp $
+;; $Id: bbdb-rmail.el,v 1.7 2007/02/23 20:24:08 fenk Exp $
;;
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'rmail)
+(require 'rmailsum)
+(require 'mailheader)
-(eval-when-compile
- (require 'bbdb)
- (require 'bbdb-com)
- (require 'rmail)
- ;(require 'rmailsum) ; not provided, dammit!
- (if (not (fboundp 'rmail-make-summary-line))
- (load-library "rmailsum"))
- ;; just to avoid a warning
- (if (not (boundp 'rmail-buffer))
- (defvar rmail-buffer nil)))
;;;###autoload
(defun bbdb/rmail-update-record (&optional offer-to-create)
@@ -39,39 +34,79 @@
(records (bbdb/rmail-update-records offer-to-create)))
(if records (car records) nil)))
+(defun bbdb/rmail-get-header-content( header-field buf )
+ "Pull HEADER-FIELD out of BUF's mail header.
+BUF is actually the rmail buffer from which the current message should
+be extracted."
+ (save-excursion
+ (set-buffer buf)
+ (save-restriction
+ (rmail-narrow-to-non-pruned-header)
+ (let ((headers (mail-header-extract))
+ (header (intern-soft (downcase header-field))))
+ (mail-header header headers)))))
+
+(defun bbdb/rmail-new-flag( buf )
+ "Returns t if the current message in buffer BUF is new."
+ (rmail-message-labels-p rmail-current-message ", ?\\(unseen\\),"))
+
+(defcustom bbdb/rmail-update-records-mode
+ '(if (bbdb/rmail-new-flag rmail-buffer) 'annotating 'searching)
+ "RMAIL-specific version of `bbdb-update-records-mode', which see."
+:group 'bbdb-mua-specific-rmail
+:type '(choice (const :tag "annotating all messages"
+ annotating)
+ (const :tag "annotating no messages"
+ searching)
+ (const :tag "annotating only new messages"
+ (if (bbdb/rmail-new-flag rmail-buffer) 'annotating 'searching))
+ (sexp :tag "user defined")))
+
+;;;###autoload
(defun bbdb/rmail-update-records (&optional offer-to-create)
- "Returns the records corresponding to the current RMAIL message, creating or
-modifying it as necessary. A record will be created if
-bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
-the user confirms the creation."
- (if bbdb-use-pop-up
- (bbdb/rmail-pop-up-bbdb-buffer offer-to-create)
- (if (and (boundp 'rmail-buffer) rmail-buffer)
- (set-buffer rmail-buffer))
- (if rmail-current-message
- (let ((records (bbdb-message-cache-lookup rmail-current-message))
- record)
- (or records
- (save-excursion
- (let ((from (mail-fetch-field "from")))
- (if (or (null from)
- (string-match (bbdb-user-mail-names)
- (mail-strip-quoted-names from)))
- ;; if logged-in user sent this, use recipients.
- (setq from (or (mail-fetch-field "to") from)))
- (if from
- (setq record
- (bbdb-annotate-message-sender
- from t
- (or (bbdb-invoke-hook-for-value
- bbdb/mail-auto-create-p)
- offer-to-create)
- offer-to-create)))
- ;; return a list of records
- (if record
- (bbdb-encache-message
- rmail-current-message
- (list record))))))))))
+ "Returns the records corresponding to the current RMAIL emssage,
+creating or modifying them as necessary. A record will be created if
+bbdb/mail-auto-create-p is non-nil or if OFFER-TO-CREATE is true, and
+the user confirms the creation.
+
+The variable `bbdb/rmail-update-records-mode' controls what actions
+are performed and it might override `bbdb-update-records-mode'.
+
+When hitting C-g once you will not be asked anymore for new people
+listed n this message, but it will search only for existing records.
+When hitting C-g again it will stop scanning."
+ (if (and (boundp 'rmail-buffer) rmail-buffer)
+ (set-buffer rmail-buffer)
+ (error "Not in an rmail buffer"))
+ (if rmail-current-message
+ (let ((bbdb/rmail-offer-to-create offer-to-create)
+ cache records)
+
+ (if (not bbdb/rmail-offer-to-create)
+ (setq cache (bbdb-message-cache-lookup
+ rmail-current-message)))
+
+ (if cache
+ (setq records (if bbdb-get-only-first-address-p
+ (list (car cache))
+ cache))
+
+ (let ((bbdb-update-records-mode (or
+ bbdb/rmail-update-records-mode
+ bbdb-update-records-mode)))
+ (setq records (bbdb-update-records
+ (bbdb-get-addresses
+ bbdb-get-only-first-address-p
+ ;; uninteresting-senders
+ user-mail-address
+ 'bbdb/rmail-get-header-content
+ rmail-buffer)
+ bbdb/mail-auto-create-p
+ offer-to-create))
+
+ (bbdb-encache-message rmail-current-message records)))
+ records))
+ )
;;;###autoload
(defun bbdb/rmail-annotate-sender (string &optional replace)
@@ -108,47 +143,36 @@ This buffer will be in bbdb-mode, with a
(bbdb-display-records (list record))
(error "unperson"))))
+(defun bbdb/rmail-pop-up-bbdb-buffer ( &optional offer-to-create )
+ "Make the *BBDB* buffer be displayed along with the RMAIL window(s).
+Displays the records corresponding to the sender respectively
+recipients of the current message.
+See `bbdb/rmail-get-addresses-headers' and
+'bbdb-get-only-first-address-p' for configuration of what is being
+displayed."
+ (save-excursion
+ (let ((bbdb-gag-messages t)
+ (bbdb-electric-p nil)
+ (records (bbdb/rmail-update-records offer-to-create))
+ (bbdb-buffer-name bbdb-buffer-name))
+
+ (when (and bbdb-use-pop-up records)
+ (bbdb-pop-up-bbdb-buffer
+ (function (lambda (w)
+ (let ((b (current-buffer)))
+ (set-buffer (window-buffer w))
+ (prog1 (eq major-mode 'rmail-mode)
+ (set-buffer b))))))
+
+ ;; Always update the records; if there are no records, empty
+ ;; the BBDB window. This should be generic, not MUA-specific.
+ (bbdb-display-records records bbdb-pop-up-display-layout))
-(defun bbdb/rmail-pop-up-bbdb-buffer (&optional offer-to-create)
- "Make the *BBDB* buffer be displayed along with the RMAIL window(s),
-displaying the record corresponding to the sender of the current message."
- (bbdb-pop-up-bbdb-buffer
- (function (lambda (w)
- (let ((b (current-buffer)))
- (set-buffer (window-buffer w))
- (prog1 (eq major-mode 'rmail-mode)
- (set-buffer b))))))
- (let ((bbdb-gag-messages t)
- (bbdb-use-pop-up nil)
- (bbdb-electric-p nil))
- (let ((records (bbdb/rmail-update-records offer-to-create))
- (b (current-buffer)))
- (if records
- (bbdb-display-records records bbdb-pop-up-display-layout)
+ (when (not records)
(bbdb-undisplay-records)
(if (get-buffer-window bbdb-buffer-name)
- (delete-window (get-buffer-window bbdb-buffer-name))))
- (set-buffer b)
- records)))
-
-(defun bbdb/rmail-only-expunge ()
- "Actually erase all deleted messages in the file."
- (interactive)
- (setq bbdb-message-cache nil)
- (bbdb-orig-rmail-only-expunge))
-
-(defun bbdb/undigestify-rmail-message ()
- "Break up a digest message into its constituent messages.
-Leaves original message, deleted, before the undigestified messages."
- (interactive)
- (setq bbdb-message-cache nil)
- (bbdb-orig-undigestify-rmail-message))
+ (delete-window (get-buffer-window bbdb-buffer-name)))))))
-;(defun bbdb-orig-rmail-expunge ()
-; "This becomes the original rmail-expunge function.")
-;(defun bbdb-orig-undigestify-rmail-message ()
-; "This becomes the original rmail-expunge function.")
-
;;;###autoload
(defun bbdb-insinuate-rmail ()
"Call this function to hook BBDB into RMAIL."
@@ -157,23 +181,23 @@ Leaves original message, deleted, before
(define-key rmail-summary-mode-map ":" 'bbdb/rmail-show-sender)
(define-key rmail-summary-mode-map ";" 'bbdb/rmail-edit-notes)
- (add-hook 'rmail-show-message-hook 'bbdb/rmail-update-records)
+ (add-hook 'rmail-show-message-hook 'bbdb/rmail-pop-up-bbdb-buffer)
- ;; We must patch into rmail-only-expunge to clear the cache, since expunging a
- ;; message invalidates the cache (which is based on message numbers).
- ;; Same for undigestifying.
- (or (fboundp 'bbdb-orig-rmail-only-expunge)
- (defalias 'bbdb-orig-rmail-only-expunge (symbol-function 'rmail-only-expunge)))
- (defalias 'rmail-only-expunge 'bbdb/rmail-only-expunge)
+ ;; We must patch into rmail-only-expunge to clear the cache, since
+ ;; expunging a message invalidates the cache (which is based on
+ ;; message numbers).
+ (defadvice rmail-only-expunge (before bbdb/rmail-only-expunge)
+ "Invalidate BBDB cache before expunging."
+ (setq bbdb-message-cache nil))
+ ;; Same for undigestifying.
(or (fboundp 'undigestify-rmail-message)
(autoload 'undigestify-rmail-message "undigest" nil t))
(if (eq (car-safe (symbol-function 'undigestify-rmail-message)) 'autoload)
(load (nth 1 (symbol-function 'undigestify-rmail-message))))
- (or (fboundp 'bbdb-orig-undigestify-rmail-message)
- (defalias 'bbdb-orig-undigestify-rmail-message
- (symbol-function 'undigestify-rmail-message)))
- (defalias 'undigestify-rmail-message 'bbdb/undigestify-rmail-message)
+ (defadvice undigestify-rmail-message (before bbdb/undigestify-rmail-message)
+ "Invalidate BBDB cache before undigestifying."
+ (setq bbdb-message-cache nil))
)
(provide 'bbdb-rmail)
1.8 +0 -0 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-sc.el
Index: bbdb-sc.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-sc.el,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -p -r1.7 -r1.8
--- bbdb-sc.el 2005/07/24 15:22:58 1.7
+++ bbdb-sc.el 2007/02/23 20:24:08 1.8
@@ -26,7 +26,7 @@
;;; for improvements and to Michael D. Carney <carney at ltx-tr.com>
;;; for testing and feedback.
-;;; $Id: bbdb-sc.el,v 1.7 2005/07/24 15:22:58 waider Exp $
+;;; $Id: bbdb-sc.el,v 1.8 2007/02/23 20:24:08 fenk Exp $
;;; This file adds the ability to define attributions for Supercite in
;;; a BBDB, enables you to retrieve your standard attribution from
1.8 +14 -24 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-snarf.el
Index: bbdb-snarf.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-snarf.el,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -p -r1.7 -r1.8
--- bbdb-snarf.el 2005/07/24 15:22:58 1.7
+++ bbdb-snarf.el 2007/02/23 20:24:08 1.8
@@ -2,7 +2,7 @@
;;;
;;; Copyright (C) 1997 by John Heidemann <johnh at isi.edu>.
-;;; $Id: bbdb-snarf.el,v 1.7 2005/07/24 15:22:58 waider Exp $
+;;; $Id: bbdb-snarf.el,v 1.8 2007/02/23 20:24:08 fenk Exp $
;;;
;;; This file is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
@@ -203,11 +203,12 @@ more details."
;; name
(goto-char (point-min))
;; This check is horribly english-centric (I think)
- (while (/= (char-syntax (char-after (point))) ?w)
+ (while (and (not (eobp)) (/= (char-syntax (char-after (point))) ?w))
(forward-line 1))
- (re-search-forward "\\(\\sw\\|[ -\.,]\\)*\\sw" nil t)
- (setq name (match-string 0))
- (delete-region (match-beginning 0) (match-end 0))
+ (if (re-search-forward "\\(\\sw\\|[ -\.,]\\)*\\sw" nil t)
+ (progn
+ (setq name (match-string 0))
+ (delete-region (match-beginning 0) (match-end 0))))
;; address
(goto-char (point-min))
@@ -281,6 +282,11 @@ more details."
; "city: " city "\n"
; "state: " state "\n"
; "zip: " zip "\n")
+
+ (setq name (or name
+ (and nets (car (car (bbdb-rfc822-addresses (car nets)))))
+ "?"))
+
(bbdb-merge-interactively name
nil
nets
@@ -411,28 +417,12 @@ more details."
(defun bbdb-replace-in-string (string regexp newtext &optional literal)
(bbdb-replace-regexp-in-string regexp newtext string nil literal))))
-(defcustom bbdb-extract-address-components-func
- 'bbdb-rfc822-addresses
- "Function called to parse one or more email addresses.
-See bbdb-extract-address-components for an example."
-:group 'bbdb-noticing-records
-:type 'function)
-
(defcustom bbdb-extract-address-component-regexps
'(
-;; This was part of Dave Love's patch. Alas, it appears to break the
-;; very thing it is supposed to handle, viz. unwrapping "Last, First"
-;; into "First Last". Thusly, commented out for now. The unwrapping
-;; seems to work fine without it?
-;;
-;; "surname, firstname" <address> from Outlookers
-;; ("\"\\([^\"]*\\)\"\\s-*<\\([^>]+\\)>"
-;; (bbdb-clean-username (match-string 1 adstring)) 2)
- ;; "name" <address>
+ ;; "surname, firstname" <address> from Outlookers
("\"\\([^\"]*\\)\"\\s-*<\\([^>]+\\)>"
- (car (mail-extract-address-components
- (concat "\"" (match-string 1 adstring) "\"")))
- 2)
+ (bbdb-clean-username (match-string 1 adstring)) 2)
+
;; name <address>
("\\([^<>,\t][^<>,]+[^<>, \t]\\)\\s-*<\\([^>]+\\)>"
1 2)
1.9 +0 -0 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-srv.el
Index: bbdb-srv.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-srv.el,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -p -r1.8 -r1.9
--- bbdb-srv.el 2005/07/24 15:22:58 1.8
+++ bbdb-srv.el 2007/02/23 20:24:08 1.9
@@ -20,7 +20,7 @@
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
-;; $Id: bbdb-srv.el,v 1.8 2005/07/24 15:22:58 waider Exp $
+;; $Id: bbdb-srv.el,v 1.9 2007/02/23 20:24:08 fenk Exp $
;;; This requires the `gnuserv' and `itimer' packages.
;;;
1.8 +3 -7 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-vm.el
Index: bbdb-vm.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-vm.el,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -p -r1.7 -r1.8
--- bbdb-vm.el 2005/07/24 15:22:58 1.7
+++ bbdb-vm.el 2007/02/23 20:24:08 1.8
@@ -19,7 +19,7 @@
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
-;; $Id: bbdb-vm.el,v 1.7 2005/07/24 15:22:58 waider Exp $
+;; $Id: bbdb-vm.el,v 1.8 2007/02/23 20:24:08 fenk Exp $
;;
(eval-and-compile
@@ -297,12 +297,8 @@ e.g. define you own function `my-folder-
(delete
nil
(mapcar (lambda (r)
- (let ((notes (bbdb-record-raw-notes r)))
- (if (and notes
- (assq bbdb/vm-set-auto-folder-alist-field
- notes))
- r
- nil)))
+ (if (bbdb-record-getprop r bbdb/vm-set-auto-folder-alist-field)
+ r))
(bbdb-records))))
(while headers
1.7 +4 -2 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-w3.el
Index: bbdb-w3.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb-w3.el,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -p -r1.6 -r1.7
--- bbdb-w3.el 2005/07/24 15:22:58 1.6
+++ bbdb-w3.el 2007/02/23 20:24:09 1.7
@@ -17,7 +17,7 @@
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
-;; $Id: bbdb-w3.el,v 1.6 2005/07/24 15:22:58 waider Exp $
+;; $Id: bbdb-w3.el,v 1.7 2007/02/23 20:24:09 fenk Exp $
;;
(require 'bbdb-com)
@@ -35,7 +35,9 @@ means to try all records currently visib
Non-interactively, do all records if arg is nonnil."
(interactive (list (bbdb-get-record "Visit (WWW): ")
(or current-prefix-arg 0)))
- (browse-url (read-string "fetch: " (bbdb-get-field rec 'www which))))
+ (browse-url (read-string "fetch: "
+ (or (bbdb-get-field rec 'www which)
+ (bbdb-get-field rec 'ftp which)))))
;;;###autoload
(defun bbdb-www-grab-homepage (record)
1.10 +83 -61 XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb.el
Index: bbdb.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/bbdb/lisp/bbdb.el,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -p -r1.9 -r1.10
--- bbdb.el 2005/07/24 15:22:58 1.9
+++ bbdb.el 2007/02/23 20:24:09 1.10
@@ -35,7 +35,7 @@
;;; | information plus state information about how you have BBDB set up. |
;;; ------------------------------------------------------------------------
;;;
-;;; $Id: bbdb.el,v 1.9 2005/07/24 15:22:58 waider Exp $
+;;; $Id: bbdb.el,v 1.10 2007/02/23 20:24:09 fenk Exp $
(require 'timezone)
(eval-when-compile (require 'cl))
@@ -49,20 +49,23 @@
(autoload 'bbdb-migrate-rewrite-all "bbdb-migrate")
(autoload 'bbdb-migrate-update-file-version "bbdb-migrate")
(autoload 'bbdb-unmigrate-record "bbdb-migrate")
- (autoload 'bbdb-redisplay-records "bbdb-com")
(autoload 'bbdb-create-internal "bbdb-com")
(autoload 'bbdb-append-records-p "bbdb-com")
+ (autoload 'bbdb-redisplay-records "bbdb-com")
(autoload 'y-or-n-p-with-timeout "timer")
(autoload 'mail-position-on-field "sendmail")
(autoload 'bbdb-fontify-buffer "bbdb-gui")
- ;; autoload doesn't work for these
- (condition-case nil (require 'message)
- (error (message "Warning: message not found. Ensure it is in your `load-path'"))); for message-mode-map
- (require 'sendmail); for mail-mode-map
+ (autoload 'vm-select-folder-buffer "vm-folder")
+
+ ;; can't use autoload for variables...
+ (defvar bbdb-define-all-aliases-needs-rebuilt) ;; bbdb-com
+ (defvar message-mode-map) ;; message.el
+ (defvar mail-mode-map) ;; sendmail.el
+ (defvar gnus-article-buffer) ;; gnus-art.el
)
(defconst bbdb-version "2.35")
-(defconst bbdb-version-date "$Date: 2005/07/24 15:22:58 $")
+(defconst bbdb-version-date "$Date: 2007/02/23 20:24:09 $")
(defcustom bbdb-gui (if (fboundp 'display-color-p) ; Emacs 21
(display-color-p)
@@ -323,11 +326,13 @@ When nil, you will be asked."
(unless (fboundp 'primep)
(defun primep (num)
- (let ((lim (sqrt num)) (nu 2) (prime t))
- (while (and prime (< nu lim))
- (setq prime (/= 0 (mod num nu))
- nu (1+ nu)))
- prime)))
+ "Return t if NUM is a prime number."
+ (and (numberp num) (> num 1) (= num (floor num))
+ (let ((lim (sqrt num)) (nu 2) (prime t))
+ (while (and prime (<= nu lim))
+ (setq prime (/= 0 (mod num nu))
+ nu (1+ nu)))
+ prime))))
(defcustom bbdb-hashtable-size 1021
"*The size of the bbdb hashtable.
@@ -407,13 +412,14 @@ commands be different."
;; these variables both need to be enabled for gnus mailreading to
;; work right. that's probably a bug, or something.
(defcustom bbdb/mail-auto-create-p t
- "*If this is t, then VM, MH, and RMAIL will automatically create new bbdb
-records for people you receive mail from. If this is a function name
-or lambda, then it is called with no arguments to decide whether an
-entry should be automatically created. You can use this to, for example,
-not create records for messages which have reached you through a
-particular mailing list, or to only create records automatically if
-the mail has a particular subject."
+ "*If this is t, then Gnus, MH, RMAIL, and VM will automatically
+create new bbdb records for people you receive mail from. If this
+is a function name or lambda, then it is called with no arguments
+to decide whether an entry should be automatically created. You
+can use this to, for example, not create records for messages
+which have reached you through a particular mailing list, or to
+only create records automatically if the mail has a particular
+subject."
:group 'bbdb-noticing-records
:type '(choice (const :tag "Automatically create" t)
(const :tag "Prompt before creating" prompt)
@@ -421,7 +427,7 @@ the mail has a particular subject."
(function :tag "Create with function" bbdb-)))
(defcustom bbdb/news-auto-create-p nil
- "*If this is t, then GNUS will automatically create new bbdb
+ "*If this is t, then Gnus will automatically create new bbdb
records for people you receive mail from. If this is a function name
or lambda, then it is called with no arguments to decide whether an
entry should be automatically created. You can use this to, for
@@ -491,14 +497,14 @@ newer than the file is was read from, an
(defcustom bbdb-use-pop-up t
"If true, display a continuously-updating bbdb window while in VM, MH,
-RMAIL, or GNUS. If 'horiz, stack the window horizontally if there is room."
+RMAIL, or Gnus. If 'horiz, stack the window horizontally if there is room."
:group 'bbdb-record-display
:type '(choice (const :tag "Automatic BBDB window, stacked vertically" t)
(const :tag "Automatic BBDB window, stacked horizontally" 'horiz)
(const :tag "No Automatic BBDB window" nil)))
(defcustom bbdb-pop-up-target-lines 5
- "*Desired number of lines in a VM/MH/RMAIL/GNUS pop-up bbdb window."
+ "*Desired number of lines in a VM/MH/RMAIL/Gnus pop-up bbdb window."
:group 'bbdb-record-display
:type 'integer)
@@ -697,7 +703,7 @@ one argument, the new record. The recor
this to be called - use `bbdb-change-hook' for that. You can use this to,
for example, add something to the notes field based on the subject of the
current message. It is up to your hook to determine whether it is running
-in GNUS, VM, MH, or RMAIL, and to act appropriately.
+in Gnus, VM, MH, or RMAIL, and to act appropriately.
Also note that `bbdb-change-hook' will NOT be called as a result of any
modifications you may make to the record inside this hook.
@@ -709,7 +715,7 @@ address was extracted from.
Beware that if the variable `bbdb-message-caching-enabled' is true (a good
idea) then when you are using VM, MH, or RMAIL, this hook will be called only
-the first time that message is selected. (The GNUS interface does not use
+the first time that message is selected. (The Gnus interface does not use
caching.) When debugging the value of this hook, it is a good idea to set
caching-enabled to nil."
:group 'bbdb-hooks
@@ -737,20 +743,27 @@ Database initialization function `bbdb-i
:group 'bbdb-hooks
:type 'hook)
+;;;###autoload
+(defcustom bbdb-multiple-buffers nil
+ "When non-nil we create a new buffer of every buffer causing pop-ups.
+You can also set this to a function returning a buffer name."
+:group 'bbdb-record-display
+:type '(choice (const :tag "Disabled" nil)
+ (function :tag "Enabled" bbdb-multiple-buffers-default)
+ (function :tag "User defined function")))
+
(defvar bbdb-mode-map nil
"Keymap for Insidious Big Brother Database listings.")
(defvar bbdb-mode-search-map nil
"Keymap for Insidious Big Brother Database searching")
;; iso-2022-7bit should be OK (but not optimal for Emacs, at least --
-;; emacs-mule would be better) with both Emacs 21 and XEmacs. Emacs
-;; 22 will really need utf-8-emacs.
-(defconst bbdb-file-coding-system (if (fboundp 'coding-system-p)
- (cond ((coding-system-p 'utf-8-emacs)
- 'utf-8-emacs)
- ((coding-system-p 'mule-utf-8)
- 'mule-utf-8)
- (t 'iso-2022-7bit)))
+;; emacs-mule would be better) with both Emacs 21 and XEmacs.
+(defconst bbdb-file-coding-system
+ (if (fboundp 'coding-system-p)
+ (cond ((coding-system-p 'utf-8-emacs)
+ 'utf-8-emacs)
+ (t 'iso-2022-7bit)))
"Coding system used for reading and writing `bbdb-file'.
This should not be changed by users.")
@@ -826,8 +839,7 @@ about.")
(funcall hook arg))))
(defun bbdb-invoke-hook-for-value (hook &rest args)
- "If HOOK is nil, return nil. If it is t, return t. Otherwise,
-return the value of funcalling it with the rest of the arguments."
+ "If HOOK is a function, invoke it with ARGS. Otherwise return it as-is."
(cond ((eq hook nil) nil)
((eq hook t) t)
((functionp hook) (apply hook args))
@@ -853,6 +865,9 @@ that holds the number of slots."
(list 'defmacro readname '(vector)
(list 'list ''aref 'vector i))
(list 'defmacro setname '(vector value)
+ (if (string= setname "bbdb-record-set-net")
+ (list 'setq
+ 'bbdb-define-all-aliases-needs-rebuilt t))
(list 'list ''aset 'vector i 'value))
;(list 'put (list 'quote readname) ''edebug-form-hook ''(form))
;(list 'put (list 'quote setname) ''edebug-form-hook ''(form form))
@@ -879,11 +894,11 @@ that holds the number of slots."
)
;; HACKHACK
-(defmacro bbdb-record-set-net (vector value)
- "We redefine the set-binding for 'net to detect changes"
- (list 'progn
- (list 'aset vector 6 value)
- (list 'setq 'bbdb-define-all-aliases-needs-rebuilt t)))
+;;(defmacro bbdb-record-set-net (vector value)
+;; "We redefine the set-binding for 'net to detect changes"
+;; (list 'progn
+;; (list 'aset vector 6 value)
+;; (list 'setq 'bbdb-define-all-aliases-needs-rebuilt t)))
(put 'company 'field-separator "; ")
(put 'notes 'field-separator "\n")
@@ -1057,7 +1072,7 @@ If the note is absent, returns a zero le
(list 'bbdb-record-sortkey record2)))
(defmacro bbdb-subint (string match-number)
- (list 'string-to-int
+ (list 'string-to-number
(list 'substring string
(list 'match-beginning match-number)
(list 'match-end match-number))))
@@ -1210,9 +1225,9 @@ determined by FORMAT (or `bbdb-time-disp
present). Returns a string containing the date in the new format."
(let ((parts (bbdb-split date "-")))
(format-time-string (or format bbdb-time-display-format)
- (encode-time 0 0 0 (string-to-int (caddr parts))
- (string-to-int (cadr parts))
- (string-to-int (car parts))))))
+ (encode-time 0 0 0 (string-to-number (caddr parts))
+ (string-to-number (cadr parts))
+ (string-to-number (car parts))))))
(defalias 'bbdb-format-record-timestamp 'bbdb-time-convert)
(defalias 'bbdb-format-record-creation-date 'bbdb-time-convert)
@@ -1506,7 +1521,7 @@ formatted and inserted into the current
(put-text-property start (point) 'bbdb-field '(company)))))
(defun bbdb-format-record-one-line-phones (layout record phone)
- "Return a formatted phone number for one-line display."
+ "Insert a formatted phone number for one-line display."
(let ((start (point)))
(insert (format "%s " (aref phone 1)))
(put-text-property start (point) 'bbdb-field
@@ -1517,11 +1532,18 @@ formatted and inserted into the current
(list 'phone phone 'field-name))))
(defun bbdb-format-record-one-line-net (layout record net)
- "Return a formatted list of nets for one-line display."
+ "Insert a formatted list of nets for one-line display."
(let ((start (point)))
(insert net)
(put-text-property start (point) 'bbdb-field (list 'net net))))
+(defun bbdb-format-record-one-line-notes (layout record notes)
+ "Insert formatted notes for one-line display.
+Line breaks will be removed and white space trimmed."
+ (let ((start (point)))
+ (insert (bbdb-replace-in-string notes "[\r\n\t ]+" " "))
+ (put-text-property start (point) 'bbdb-field (list 'notes notes))))
+
(defun bbdb-format-record-layout-one-line (layout record field-list)
"Record formatting function for the one-line layout.
See `bbdb-display-layout-alist' for more."
@@ -2127,11 +2149,14 @@ The inverse function of `bbdb-split'."
"Insert the record in the appropriate hashtables. This must be called
while the .bbdb buffer is selected."
(let ((name (bbdb-record-name-1 record)) ; faster version
+ (lastname (bbdb-record-lastname record))
(company (bbdb-record-company record))
(aka (bbdb-record-aka record))
(net (bbdb-record-net record)))
(if (> (length name) 0)
(bbdb-puthash (downcase name) record bbdb-hashtable))
+ (if (> (length lastname) 0)
+ (bbdb-puthash (downcase lastname) record bbdb-hashtable))
(if (> (length company) 0)
(bbdb-puthash (downcase company) record bbdb-hashtable))
(while aka
@@ -2431,13 +2456,16 @@ optional arg DONT-CHECK-DISK is non-nil
(save-restriction
(widen)
(goto-char (point-min))
- ;; Fixme: probably this should check any existing cookie for
- ;; consistency with bbdb-file-coding-system.
- (unless (looking-at ";; *-\\*-coding:")
- (insert-before-markers (format ";; -*-coding: %s;-*-\n"
- bbdb-file-coding-system))))
+
+ ;; this always rewrites the coding cookie, which is a bit
+ ;; wasteful, but safer than alternatives
+ (if (looking-at ";; *-\\*-coding:")
+ (delete-region (point) (progn (forward-line) (point))))
+ (insert-before-markers (format ";; -*-coding: %s;-*-\n"
+ bbdb-file-coding-system)))
(setq bbdb-modified-p nil
- bbdb-changed-records nil)
+ bbdb-changed-records nil
+ buffer-file-coding-system bbdb-file-coding-system)
(let ((buf (get-buffer bbdb-buffer-name)))
(when buf
(with-current-buffer buf
@@ -2467,6 +2495,7 @@ optional arg DONT-CHECK-DISK is non-nil
(bbdb-record-marker (car (cdr tail)))
bbdb-end-marker))
(let ((name (bbdb-record-name record))
+ (lastname (bbdb-record-lastname record))
(company (bbdb-record-company record))
(aka (bbdb-record-aka record))
(nets (bbdb-record-net record)))
@@ -2474,6 +2503,8 @@ optional arg DONT-CHECK-DISK is non-nil
(bbdb-remhash (downcase name) record bbdb-hashtable))
(if (> (length company) 0)
(bbdb-remhash (downcase company) record bbdb-hashtable))
+ (if (> (length lastname) 0)
+ (bbdb-remhash (downcase lastname) record bbdb-hashtable))
(while nets
(bbdb-remhash (downcase (car nets)) record bbdb-hashtable)
(setq nets (cdr nets)))
@@ -3183,7 +3214,7 @@ before the record is created, otherwise
(if (string-match "^[^@]+" net)
(setq name (bbdb-clean-username (match-string 0 net)))))
(setq record (if (or (null prompt-to-create-p)
- create-p
+ (eq create-p t) ;; don't skip if it's 'prompt!
(if (functionp prompt-to-create-p)
(bbdb-invoke-hook-for-value
prompt-to-create-p)
@@ -3406,15 +3437,6 @@ before the record is created, otherwise
;;; window configuration hackery
-;;;###autoload
-(defcustom bbdb-multiple-buffers nil
- "When non-nil we create a new buffer of every buffer causing pop-ups.
-You can also set this to a function returning a buffer name."
-:group 'bbdb-record-display
-:type '(choice (const :tag "Disabled" nil)
- (function :tag "Enabled" bbdb-multiple-buffers-default)
- (function :tag "User defined function")))
-
(defun bbdb-multiple-buffers-default ()
"Default function for guessing a better name for new *BBDB* buffers."
(cond ((memq major-mode '(vm-mode vm-summary-mode
More information about the XEmacs-CVS
mailing list