Commit bc6cdadc authored by Chong Yidong's avatar Chong Yidong
Browse files

Sync with rmailkwd.el.

parent 0efcb0dc
;;; pmailkwd.el --- part of the "PMAIL" mail reader for Emacs ;;; pmailkwd.el --- part of the "PMAIL" mail reader for Emacs
;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006, ;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004,
;; 2007, 2008 Free Software Foundation, Inc. ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Maintainer: FSF ;; Maintainer: FSF
;; Keywords: mail ;; Keywords: mail
...@@ -23,9 +23,6 @@ ...@@ -23,9 +23,6 @@
;;; Commentary: ;;; Commentary:
;; This library manages keywords (labels). Labels are stored in the
;; variable `pmail-keywords'.
;;; Code: ;;; Code:
(defvar pmail-buffer) (defvar pmail-buffer)
...@@ -39,148 +36,158 @@ ...@@ -39,148 +36,158 @@
;; completion. It is better to use strings with the label functions ;; completion. It is better to use strings with the label functions
;; and let them worry about making the label. ;; and let them worry about making the label.
(eval-when-compile (defvar pmail-label-obarray (make-vector 47 0))
(require 'mail-utils))
;; Named list of symbols representing valid message attributes in PMAIL. ;; Named list of symbols representing valid message attributes in PMAIL.
(defconst pmail-attributes (defconst pmail-attributes
'(deleted answered filed forwarded unseen edited resent) (cons 'pmail-keywords
"Keywords with defined semantics used to label messages. (mapcar (function (lambda (s) (intern s pmail-label-obarray)))
These have a well-defined meaning to the PMAIL system.") '("deleted" "answered" "filed" "forwarded" "unseen" "edited"
"resent"))))
(defconst pmail-deleted-label 'deleted) (defconst pmail-deleted-label (intern "deleted" pmail-label-obarray))
;; Named list of symbols representing valid message keywords in PMAIL. ;; Named list of symbols representing valid message keywords in PMAIL.
(defvar pmail-keywords nil (defvar pmail-keywords)
"Keywords used to label messages.
These are all user-defined, unlike `pmail-attributes'.")
;;;###autoload
(defun pmail-add-label (string)
"Add LABEL to labels associated with current PMAIL message.
Completion is performed over known labels when reading."
(interactive (list (pmail-read-label "Add label")))
(pmail-set-label string t))
;; External library declarations. ;;;###autoload
(declare-function mail-comma-list-regexp "mail-utils" (labels)) (defun pmail-kill-label (string)
(declare-function mail-parse-comma-list "mail-utils" ()) "Remove LABEL from labels associated with current PMAIL message.
(declare-function pmail-desc-add-keyword "pmaildesc" (keyword n)) Completion is performed over known labels when reading."
(declare-function pmail-desc-get-end "pmaildesc" (n)) (interactive (list (pmail-read-label "Remove label")))
(declare-function pmail-desc-get-keywords "pmaildesc" (n)) (pmail-set-label string nil))
(declare-function pmail-desc-get-start "pmaildesc" (n))
(declare-function pmail-desc-remove-keyword "pmaildesc" (keyword n)) ;;;###autoload
(defun pmail-read-label (prompt)
(with-current-buffer pmail-buffer
(if (not pmail-keywords) (pmail-parse-file-keywords))
(let ((result
(completing-read (concat prompt
(if pmail-last-label
(concat " (default "
(symbol-name pmail-last-label)
"): ")
": "))
pmail-label-obarray
nil
nil)))
(if (string= result "")
pmail-last-label
(setq pmail-last-label (pmail-make-label result t))))))
(declare-function pmail-maybe-set-message-counters "pmail" ())
(declare-function pmail-display-labels "pmail" ()) (declare-function pmail-display-labels "pmail" ())
(declare-function pmail-message-labels-p "pmail" (msg labels))
(declare-function pmail-msgbeg "pmail" (n)) (declare-function pmail-msgbeg "pmail" (n))
(declare-function pmail-set-attribute "pmail" (attr state &optional msgnum)) (declare-function pmail-set-message-deleted-p "pmail" (n state))
(declare-function pmail-message-labels-p "pmail" (msg labels))
(declare-function pmail-show-message "pmail" (&optional n no-summary)) (declare-function pmail-show-message "pmail" (&optional n no-summary))
(declare-function pmail-summary-exists "pmail" ()) (declare-function mail-comma-list-regexp "mail-utils" (labels))
(declare-function pmail-summary-update "pmailsum" (n)) (declare-function mail-parse-comma-list "mail-utils.el" ())
;;;; Low-level functions. (defun pmail-set-label (l state &optional n)
(with-current-buffer pmail-buffer
(pmail-maybe-set-message-counters)
(if (not n) (setq n pmail-current-message))
(aset pmail-summary-vector (1- n) nil)
(let* ((attribute (pmail-attribute-p l))
(keyword (and (not attribute)
(or (pmail-keyword-p l)
(pmail-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 (pmail-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 ", " (pmail-quote-label-name label) ",")
bound
'move)
(if (not state) (replace-match ","))
(if state (insert " " (symbol-name label) ",")))
(if (eq label pmail-deleted-label)
(pmail-set-message-deleted-p n state)))))
(narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
(if (= n pmail-current-message) (pmail-display-labels))))))))
;; Commented functions aren't used by PMAIL but might be nice for user
;; packages that do stuff with PMAIL. Note that pmail-message-labels-p
;; is in pmail.el now.
;(defun pmail-message-label-p (label &optional n)
; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
; (pmail-message-labels-p (or n pmail-current-message) (regexp-quote label)))
;(defun pmail-parse-message-labels (&optional n)
; "Returns labels associated with NTH or current PMAIL message.
;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 (pmail-msgbeg (or n pmail-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 pmail-attribute-p (s) (defun pmail-attribute-p (s)
"Non-nil if S is a known attribute.
See `pmail-attributes'."
(let ((symbol (pmail-make-label s))) (let ((symbol (pmail-make-label s)))
(memq symbol pmail-attributes))) (if (memq symbol (cdr pmail-attributes)) symbol)))
(defun pmail-keyword-p (s) (defun pmail-keyword-p (s)
"Non-nil if S is a known keyword for this Pmail file.
See `pmail-keywords'."
(let ((symbol (pmail-make-label s))) (let ((symbol (pmail-make-label s)))
(memq symbol pmail-keywords))) (if (memq symbol (cdr (pmail-keywords))) symbol)))
(defun pmail-make-label (s &optional forcep) (defun pmail-make-label (s &optional forcep)
(cond ((symbolp s) s) (cond ((symbolp s) s)
(forcep (intern (downcase s))) (forcep (intern (downcase s) pmail-label-obarray))
(t (intern-soft (downcase s))))) (t (intern-soft (downcase s) pmail-label-obarray))))
(defun pmail-force-make-label (s)
(intern (downcase s) pmail-label-obarray))
(defun pmail-quote-label-name (label) (defun pmail-quote-label-name (label)
(regexp-quote (symbol-name (pmail-make-label label t)))) (regexp-quote (symbol-name (pmail-make-label label t))))
;;;###autoload
(defun pmail-register-keywords (words)
"Add the strings in WORDS to `pmail-keywords'."
(dolist (word words)
(pmail-register-keyword word)))
(defun pmail-register-keyword (word)
"Append the string WORD to `pmail-keywords',
unless it already is a keyword or an attribute."
(let ((keyword (pmail-make-label word t)))
(unless (or (pmail-attribute-p keyword)
(pmail-keyword-p keyword))
(setq pmail-keywords (cons keyword pmail-keywords)))))
;;;; Adding and removing message keywords.
;;;###autoload
(defun pmail-add-label (string)
"Add LABEL to labels associated with current PMAIL message."
(interactive (list (pmail-read-label "Add label")))
(pmail-set-label (pmail-make-label string) t)
(pmail-display-labels))
;;;###autoload
(defun pmail-kill-label (string)
"Remove LABEL from labels associated with current PMAIL message."
(interactive (list (pmail-read-label "Remove label" t)))
(pmail-set-label (pmail-make-label string) nil))
;;;###autoload
(defun pmail-read-label (prompt &optional existing)
"Ask for a label using PROMPT.
If EXISTING is non-nil, ask for one of the labels of the current
message."
(when (= pmail-total-messages 0)
(error "No messages in this file"))
(with-current-buffer pmail-buffer
(let ((result (if existing
(let* ((keywords (pmail-desc-get-keywords
pmail-current-message))
(last (symbol-name pmail-last-label))
(default (if (member last keywords)
last
(car keywords))))
(unless keywords
(error "No labels for the current message"))
(completing-read
(concat prompt " (default " default "): ")
keywords nil t nil nil default))
(let ((default (symbol-name pmail-last-label)))
(completing-read
(concat prompt (if pmail-last-label
(concat " (default " default "): ")
": "))
(mapcar 'list pmail-keywords)
nil nil nil nil default)))))
(setq pmail-last-label (pmail-make-label result t))
;; return the string, not the symbol
result)))
(defun pmail-set-label (l state &optional n)
"Add or remove label L in message N.
The label L is added when STATE is non-nil, otherwise it is
removed. If N is nil then use the current Pmail message. The
current buffer, possibly narrowed, displays a message."
(if (= pmail-total-messages 0)
(error "No messages in this file"))
(with-current-buffer pmail-buffer
(if (not n) (setq n pmail-current-message))
(save-restriction
(widen)
(narrow-to-region (pmail-desc-get-start n) (pmail-desc-get-end n))
;; FIXME: we should move all string-using functions to symbols!
(let ((str (symbol-name l)))
(if (pmail-attribute-p l)
(pmail-set-attribute str state n)
;; Make sure the keyword is registered.
(pmail-register-keyword l)
(if state
(pmail-desc-add-keyword str n)
(pmail-desc-remove-keyword str n))))))
(pmail-display-labels)
;; Deal with the summary buffer.
(when (pmail-summary-exists)
(pmail-summary-update n)))
;; Motion on messages with keywords. ;; Motion on messages with keywords.
...@@ -200,32 +207,84 @@ LABELS should be a comma-separated list of label names. ...@@ -200,32 +207,84 @@ LABELS should be a comma-separated list of label names.
If LABELS is empty, the last set of labels specified is used. If LABELS is empty, the last set of labels specified is used.
With prefix argument N moves forward N messages with these labels." With prefix argument N moves forward N messages with these labels."
(interactive "p\nsMove to next msg with labels: ") (interactive "p\nsMove to next msg with labels: ")
(when (string= labels "") (if (string= labels "")
(setq labels pmail-last-multi-labels)) (setq labels pmail-last-multi-labels))
(unless labels (or labels
(error "No labels to find have been specified previously")) (error "No labels to find have been specified previously"))
(with-current-buffer pmail-buffer (set-buffer pmail-buffer)
(setq pmail-last-multi-labels labels) (setq pmail-last-multi-labels labels)
(let ((lastwin pmail-current-message) (pmail-maybe-set-message-counters)
(current pmail-current-message) (let ((lastwin pmail-current-message)
(regexp (concat ", ?\\(" (current pmail-current-message)
(mail-comma-list-regexp labels) (regexp (concat ", ?\\("
"\\),"))) (mail-comma-list-regexp labels)
(save-restriction "\\),")))
(widen) (save-restriction
(while (and (> n 0) (< current pmail-total-messages)) (widen)
(setq current (1+ current)) (while (and (> n 0) (< current pmail-total-messages))
(when (pmail-message-labels-p current regexp) (setq current (1+ current))
(if (pmail-message-labels-p current regexp)
(setq lastwin current n (1- n)))) (setq lastwin current n (1- n))))
(while (and (< n 0) (> current 1)) (while (and (< n 0) (> current 1))
(setq current (1- current)) (setq current (1- current))
(when (pmail-message-labels-p current regexp) (if (pmail-message-labels-p current regexp)
(setq lastwin current n (1+ n))))) (setq lastwin current n (1+ n)))))
(pmail-show-message lastwin) (pmail-show-message lastwin)
(when (< n 0) (if (< n 0)
(message "No previous message with labels %s" labels)) (message "No previous message with labels %s" labels))
(when (> n 0) (if (> n 0)
(message "No following message with labels %s" labels))))) (message "No following message with labels %s" labels))))
;;; Manipulate the file's Labels option.
;; Return a list of symbols for all
;; the keywords (labels) recorded in this file's Labels option.
(defun pmail-keywords ()
(or pmail-keywords (pmail-parse-file-keywords)))
;; Set pmail-keywords to a list of symbols for all
;; the keywords (labels) recorded in this file's Labels option.
(defun pmail-parse-file-keywords ()
(save-restriction
(save-excursion
(widen)
(goto-char 1)
(setq pmail-keywords
(if (search-forward "\nLabels:" (pmail-msgbeg 1) t)
(progn
(narrow-to-region (point) (progn (end-of-line) (point)))
(goto-char (point-min))
(cons 'pmail-keywords
(mapcar 'pmail-force-make-label
(mail-parse-comma-list)))))))))
;; Add WORD to the list in the file's Labels option.
;; Any keyword used for the first time needs this done.
(defun pmail-install-keyword (word)
(let ((keyword (pmail-make-label word t))
(keywords (pmail-keywords)))
(if (not (or (pmail-attribute-p keyword)
(pmail-keyword-p keyword)))
(let ((omin (- (buffer-size) (point-min)))
(omax (- (buffer-size) (point-max))))
(unwind-protect
(save-excursion
(widen)
(goto-char 1)
(let ((case-fold-search t)
(buffer-read-only nil))
(or (search-forward "\nLabels:" nil t)
(progn
(end-of-line)
(insert "\nLabels:")))
(delete-region (point) (progn (end-of-line) (point)))
(setcdr keywords (cons keyword (cdr keywords)))
(while (setq keywords (cdr keywords))
(insert (symbol-name (car keywords)) ","))
(delete-char -1)))
(narrow-to-region (- (buffer-size) omin)
(- (buffer-size) omax)))))
keyword))
(provide 'pmailkwd) (provide 'pmailkwd)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment