X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e516799970be4553edae8ca46d5f64852befec77..177cd3b9f4881410dcd5ef9e8fc706421e63c109:/lisp/mail/rmailkwd.el diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index 1ac89d3461..6772817637 100644 --- a/lisp/mail/rmailkwd.el +++ b/lisp/mail/rmailkwd.el @@ -1,9 +1,9 @@ -;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs. +;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs -;; Maintainer: FSF -;; Last-Modified: 31 Oct 1989 +;; Copyright (C) 1985, 1988, 1994, 2001 Free Software Foundation, Inc. -;; Copyright (C) 1985, 1988 Free Software Foundation, Inc. +;; Maintainer: FSF +;; Keywords: mail ;; This file is part of GNU Emacs. @@ -18,8 +18,11 @@ ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. + +;;; Commentary: ;;; Code: @@ -33,127 +36,124 @@ (defconst rmail-attributes (cons 'rmail-keywords - (mapcar '(lambda (s) (intern s rmail-label-obarray)) - '("deleted" "answered" "filed" "forwarded" "unseen" "edited")))) + (mapcar (function (lambda (s) (intern s rmail-label-obarray))) + '("deleted" "answered" "filed" "forwarded" "unseen" "edited" + "resent")))) (defconst rmail-deleted-label (intern "deleted" rmail-label-obarray)) ;; Named list of symbols representing valid message keywords in RMAIL. -(defvar rmail-keywords nil) +(defvar rmail-keywords) +;;;###autoload (defun rmail-add-label (string) "Add LABEL to labels associated with current RMAIL message. Completion is performed over known labels when reading." (interactive (list (rmail-read-label "Add label"))) (rmail-set-label string t)) +;;;###autoload (defun rmail-kill-label (string) "Remove LABEL from labels associated with current RMAIL message. Completion is performed over known labels when reading." (interactive (list (rmail-read-label "Remove label"))) (rmail-set-label string nil)) +;;;###autoload (defun rmail-read-label (prompt) - (if (not rmail-keywords) (rmail-parse-file-keywords)) - (let ((result - (completing-read (concat prompt - (if rmail-last-label - (concat " (default " - (symbol-name rmail-last-label) - "): ") - ": ")) - rmail-label-obarray - nil - nil))) - (if (string= result "") - rmail-last-label - (setq rmail-last-label (rmail-make-label result t))))) + (with-current-buffer rmail-buffer + (if (not rmail-keywords) (rmail-parse-file-keywords)) + (let ((result + (completing-read (concat prompt + (if rmail-last-label + (concat " (default " + (symbol-name rmail-last-label) + "): ") + ": ")) + rmail-label-obarray + nil + nil))) + (if (string= result "") + rmail-last-label + (setq rmail-last-label (rmail-make-label result t)))))) (defun rmail-set-label (l state &optional n) - (rmail-maybe-set-message-counters) - (if (not n) (setq n rmail-current-message)) - (aset rmail-summary-vector (1- n) nil) - (let* ((attribute (rmail-attribute-p l)) - (keyword (and (not attribute) - (or (rmail-keyword-p l) - (rmail-install-keyword l)))) - (label (or attribute keyword))) - (if label - (let ((omax (- (buffer-size) (point-max))) - (omin (- (buffer-size) (point-min))) - (buffer-read-only nil) - (case-fold-search t)) - (unwind-protect - (save-excursion - (widen) - (goto-char (rmail-msgbeg n)) - (forward-line 1) - (if (not (looking-at "[01],")) - nil - (let ((start (1+ (point))) - (bound)) - (narrow-to-region (point) (progn (end-of-line) (point))) - (setq bound (point-max)) - (search-backward ",," nil t) - (if attribute - (setq bound (1+ (point))) - (setq start (1+ (point)))) - (goto-char start) -; (while (re-search-forward "[ \t]*,[ \t]*" nil t) -; (replace-match ",")) -; (goto-char start) - (if (re-search-forward + (with-current-buffer rmail-buffer + (rmail-maybe-set-message-counters) + (if (not n) (setq n rmail-current-message)) + (aset rmail-summary-vector (1- n) nil) + (let* ((attribute (rmail-attribute-p l)) + (keyword (and (not attribute) + (or (rmail-keyword-p l) + (rmail-install-keyword l)))) + (label (or attribute keyword))) + (if label + (let ((omax (- (buffer-size) (point-max))) + (omin (- (buffer-size) (point-min))) + (buffer-read-only nil) + (case-fold-search t)) + (unwind-protect + (save-excursion + (widen) + (goto-char (rmail-msgbeg n)) + (forward-line 1) + (if (not (looking-at "[01],")) + nil + (let ((start (1+ (point))) + (bound)) + (narrow-to-region (point) (progn (end-of-line) (point))) + (setq bound (point-max)) + (search-backward ",," nil t) + (if attribute + (setq bound (1+ (point))) + (setq start (1+ (point)))) + (goto-char start) +; (while (re-search-forward "[ \t]*,[ \t]*" nil t) +; (replace-match ",")) +; (goto-char start) + (if (re-search-forward (concat ", " (rmail-quote-label-name label) ",") bound 'move) - (if (not state) (replace-match ",")) - (if state (insert " " (symbol-name label) ","))) - (if (eq label rmail-deleted-label) - (rmail-set-message-deleted-p n state))))) - (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)) - (if (= n rmail-current-message) (rmail-display-labels))))))) + (if (not state) (replace-match ",")) + (if state (insert " " (symbol-name label) ","))) + (if (eq label rmail-deleted-label) + (rmail-set-message-deleted-p n state))))) + (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)) + (if (= n rmail-current-message) (rmail-display-labels)))))))) ;; Commented functions aren't used by RMAIL but might be nice for user ;; packages that do stuff with RMAIL. Note that rmail-message-labels-p ;; is in rmail.el now. -;(defun rmail-message-attribute-p (attribute &optional n) -; "Returns t if ATTRIBUTE on NTH or current message." -; (rmail-message-labels-p (rmail-make-label attribute t) n)) - -;(defun rmail-message-keyword-p (keyword &optional n) -; "Returns t if KEYWORD on NTH or current message." -; (rmail-message-labels-p (rmail-make-label keyword t) n t)) - ;(defun rmail-message-label-p (label &optional n) ; "Returns symbol if LABEL (attribute or keyword) on NTH or current message." -; (rmail-message-labels-p (rmail-make-label label t) n 'all)) - -;; Not used by RMAIL but might be nice for user package. +; (rmail-message-labels-p (or n rmail-current-message) (regexp-quote label))) ;(defun rmail-parse-message-labels (&optional n) ; "Returns labels associated with NTH or current RMAIL message. -;Results is a list of two lists. The first is the message attributes -;and the second is the message keywords. Labels are represented as symbols." -; (let ((omin (- (buffer-size) (point-min))) -; (omax (- (buffer-size) (point-max))) -; (result)) -; (unwind-protect -; (save-excursion -; (let ((beg (rmail-msgbeg (or n rmail-current-message)))) -; (widen) -; (goto-char beg) -; (forward-line 1) -; (if (looking-at "[01],") -; (save-restriction -; (narrow-to-region (point) (save-excursion (end-of-line) (point))) -; (rmail-nuke-whitespace) -; (goto-char (1+ (point-min))) -; (list (mail-parse-comma-list) (mail-parse-comma-list)))))) -; (narrow-to-region (- (buffer-size) omin) -; (- (buffer-size) omax)) -; nil))) +;The result is a list of two lists of strings. The first is the +;message attributes and the second is the message keywords." +; (let (atts keys) +; (save-restriction +; (widen) +; (goto-char (rmail-msgbeg (or n rmail-current-message))) +; (forward-line 1) +; (or (looking-at "[01],") (error "Malformed label line")) +; (forward-char 2) +; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") +; (setq atts (cons (buffer-substring (match-beginning 1) (match-end 1)) +; atts)) +; (goto-char (match-end 0))) +; (or (looking-at ",") (error "Malformed label line")) +; (forward-char 1) +; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") +; (setq keys (cons (buffer-substring (match-beginning 1) (match-end 1)) +; keys)) +; (goto-char (match-end 0))) +; (or (looking-at "[ \t]*$") (error "Malformed label line")) +; (list (nreverse atts) (nreverse keys))))) (defun rmail-attribute-p (s) (let ((symbol (rmail-make-label s))) @@ -176,6 +176,7 @@ Completion is performed over known labels when reading." ;; Motion on messages with keywords. +;;;###autoload (defun rmail-previous-labeled-message (n labels) "Show previous message with one of the labels LABELS. LABELS should be a comma-separated list of label names. @@ -184,6 +185,7 @@ With prefix argument N moves backward N messages with these labels." (interactive "p\nsMove to previous msg with labels: ") (rmail-next-labeled-message (- n) labels)) +;;;###autoload (defun rmail-next-labeled-message (n labels) "Show next message with one of the labels LABELS. LABELS should be a comma-separated list of label names. @@ -194,6 +196,7 @@ With prefix argument N moves forward N messages with these labels." (setq labels rmail-last-multi-labels)) (or labels (error "No labels to find have been specified previously")) + (set-buffer rmail-buffer) (setq rmail-last-multi-labels labels) (rmail-maybe-set-message-counters) (let ((lastwin rmail-current-message) @@ -268,4 +271,5 @@ With prefix argument N moves forward N messages with these labels." (- (buffer-size) omax))))) keyword)) +;;; arch-tag: b26b3392-99ca-4e1d-933a-dab59b04e9a8 ;;; rmailkwd.el ends here