[bpt/emacs.git] / lisp / mail / pmailkwd.el

;;; pmailkwd.el --- part of the "PMAIL" mail reader for Emacs

;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
;;   2007, 2008 Free Software Foundation, Inc.

;; Maintainer: FSF
;; Keywords: mail

;; This file is part of GNU Emacs.

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

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

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This library manages keywords (labels).  Labels are stored in the
;; variable `pmail-keywords'.

;;; Code:

(defvar pmail-buffer)
(defvar pmail-current-message)
(defvar pmail-last-label)
(defvar pmail-last-multi-labels)
(defvar pmail-summary-vector)
(defvar pmail-total-messages)

;; Global to all PMAIL buffers.  It exists primarily for the sake of
;; completion.  It is better to use strings with the label functions
;; and let them worry about making the label.

(eval-when-compile
  (require 'mail-utils))

;; Named list of symbols representing valid message attributes in PMAIL.

(defconst pmail-attributes
  '(deleted answered filed forwarded unseen edited resent)
  "Keywords with defined semantics used to label messages.
These have a well-defined meaning to the PMAIL system.")

(defconst pmail-deleted-label 'deleted)

;; Named list of symbols representing valid message keywords in PMAIL.

(defvar pmail-keywords nil
  "Keywords used to label messages.
These are all user-defined, unlike `pmail-attributes'.")
\f

;; External library declarations.
(declare-function mail-comma-list-regexp "mail-utils" (labels))
(declare-function mail-parse-comma-list "mail-utils" ())
(declare-function pmail-desc-add-keyword "pmaildesc" (keyword n))
(declare-function pmail-desc-get-end "pmaildesc" (n))
(declare-function pmail-desc-get-keywords "pmaildesc" (n))
(declare-function pmail-desc-get-start "pmaildesc" (n))
(declare-function pmail-desc-remove-keyword "pmaildesc" (keyword n))
(declare-function pmail-display-labels "pmail" ())
(declare-function pmail-message-labels-p "pmail" (msg labels))
(declare-function pmail-msgbeg "pmail" (n))
(declare-function pmail-set-attribute "pmail" (attr state &optional msgnum))
(declare-function pmail-show-message "pmail" (&optional n no-summary))
(declare-function pmail-summary-exists "pmail" ())
(declare-function pmail-summary-update "pmailsum" (n))

;;;; Low-level functions.

(defun pmail-attribute-p (s)
  "Non-nil if S is a known attribute.
See `pmail-attributes'."
  (let ((symbol (pmail-make-label s)))
    (memq symbol pmail-attributes)))

(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)))
    (memq symbol pmail-keywords)))

(defun pmail-make-label (s &optional forcep)
  (cond ((symbolp s) s)
	(forcep (intern (downcase s)))
	(t  (intern-soft (downcase s)))))

(defun pmail-quote-label-name (label)
  (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)))))
\f
;;;; 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)))
\f
;; Motion on messages with keywords.

;;;###autoload
(defun pmail-previous-labeled-message (n labels)
  "Show previous message with one of the labels LABELS.
LABELS should be a comma-separated list of label names.
If LABELS is empty, the last set of labels specified is used.
With prefix argument N moves backward N messages with these labels."
  (interactive "p\nsMove to previous msg with labels: ")
  (pmail-next-labeled-message (- n) labels))

;;;###autoload
(defun pmail-next-labeled-message (n labels)
  "Show next message with one of the labels LABELS.
LABELS should be a comma-separated list of label names.
If LABELS is empty, the last set of labels specified is used.
With prefix argument N moves forward N messages with these labels."
  (interactive "p\nsMove to next msg with labels: ")
  (when (string= labels "")
    (setq labels pmail-last-multi-labels))
  (unless labels
    (error "No labels to find have been specified previously"))
  (with-current-buffer pmail-buffer
    (setq pmail-last-multi-labels labels)
    (let ((lastwin pmail-current-message)
	  (current pmail-current-message)
	  (regexp (concat ", ?\\("
			  (mail-comma-list-regexp labels)
			  "\\),")))
      (save-restriction
	(widen)
	(while (and (> n 0) (< current pmail-total-messages))
	  (setq current (1+ current))
	  (when (pmail-message-labels-p current regexp)
	    (setq lastwin current n (1- n))))
	(while (and (< n 0) (> current 1))
	  (setq current (1- current))
	  (when (pmail-message-labels-p current regexp)
	    (setq lastwin current n (1+ n)))))
      (pmail-show-message lastwin)
      (when (< n 0)
	(message "No previous message with labels %s" labels))
      (when (> n 0)
	(message "No following message with labels %s" labels)))))

(provide 'pmailkwd)

;; arch-tag: 1149979c-8e47-4333-9629-cf3dc887a6a7
;;; pmailkwd.el ends here
Commit	Line	Data
e131541f PR	1	;;; pmailkwd.el --- part of the "PMAIL" mail reader for Emacs
e131541f PR	2
8c1ded96 GM	3	;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
8c1ded96 GM	4	;; 2007, 2008 Free Software Foundation, Inc.
e131541f PR	5
	6	;; Maintainer: FSF
	7	;; Keywords: mail
	8
	9	;; This file is part of GNU Emacs.
	10
8c1ded96	11	;; GNU Emacs is free software: you can redistribute it and/or modify
e131541f	12	;; it under the terms of the GNU General Public License as published by
8c1ded96 GM	13	;; the Free Software Foundation, either version 3 of the License, or
8c1ded96 GM	14	;; (at your option) any later version.
e131541f PR	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
8c1ded96	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
e131541f PR	23
	24	;;; Commentary:
	25
	26	;; This library manages keywords (labels). Labels are stored in the
	27	;; variable `pmail-keywords'.
	28
	29	;;; Code:
	30
	31	(defvar pmail-buffer)
	32	(defvar pmail-current-message)
	33	(defvar pmail-last-label)
	34	(defvar pmail-last-multi-labels)
	35	(defvar pmail-summary-vector)
	36	(defvar pmail-total-messages)
	37
	38	;; Global to all PMAIL buffers. It exists primarily for the sake of
	39	;; completion. It is better to use strings with the label functions
	40	;; and let them worry about making the label.
	41
e131541f PR	42	(eval-when-compile
	43	(require 'mail-utils))
	44
	45	;; Named list of symbols representing valid message attributes in PMAIL.
	46
	47	(defconst pmail-attributes
	48	'(deleted answered filed forwarded unseen edited resent)
	49	"Keywords with defined semantics used to label messages.
	50	These have a well-defined meaning to the PMAIL system.")
	51
	52	(defconst pmail-deleted-label 'deleted)
	53
	54	;; Named list of symbols representing valid message keywords in PMAIL.
	55
	56	(defvar pmail-keywords nil
	57	"Keywords used to label messages.
	58	These are all user-defined, unlike `pmail-attributes'.")
	59	\f
acdc2006 PR	60
	61	;; External library declarations.
	62	(declare-function mail-comma-list-regexp "mail-utils" (labels))
	63	(declare-function mail-parse-comma-list "mail-utils" ())
	64	(declare-function pmail-desc-add-keyword "pmaildesc" (keyword n))
	65	(declare-function pmail-desc-get-end "pmaildesc" (n))
	66	(declare-function pmail-desc-get-keywords "pmaildesc" (n))
	67	(declare-function pmail-desc-get-start "pmaildesc" (n))
	68	(declare-function pmail-desc-remove-keyword "pmaildesc" (keyword n))
	69	(declare-function pmail-display-labels "pmail" ())
acdc2006 PR	70	(declare-function pmail-message-labels-p "pmail" (msg labels))
	71	(declare-function pmail-msgbeg "pmail" (n))
	72	(declare-function pmail-set-attribute "pmail" (attr state &optional msgnum))
acdc2006 PR	73	(declare-function pmail-show-message "pmail" (&optional n no-summary))
	74	(declare-function pmail-summary-exists "pmail" ())
	75	(declare-function pmail-summary-update "pmailsum" (n))
	76
e131541f PR	77	;;;; Low-level functions.
	78
	79	(defun pmail-attribute-p (s)
	80	"Non-nil if S is a known attribute.
	81	See `pmail-attributes'."
	82	(let ((symbol (pmail-make-label s)))
	83	(memq symbol pmail-attributes)))
	84
	85	(defun pmail-keyword-p (s)
	86	"Non-nil if S is a known keyword for this Pmail file.
	87	See `pmail-keywords'."
	88	(let ((symbol (pmail-make-label s)))
	89	(memq symbol pmail-keywords)))
	90
	91	(defun pmail-make-label (s &optional forcep)
	92	(cond ((symbolp s) s)
	93	(forcep (intern (downcase s)))
	94	(t (intern-soft (downcase s)))))
	95
	96	(defun pmail-quote-label-name (label)
	97	(regexp-quote (symbol-name (pmail-make-label label t))))
	98
	99	;;;###autoload
	100	(defun pmail-register-keywords (words)
	101	"Add the strings in WORDS to `pmail-keywords'."
	102	(dolist (word words)
	103	(pmail-register-keyword word)))
	104
	105	(defun pmail-register-keyword (word)
	106	"Append the string WORD to `pmail-keywords',
	107	unless it already is a keyword or an attribute."
	108	(let ((keyword (pmail-make-label word t)))
	109	(unless (or (pmail-attribute-p keyword)
	110	(pmail-keyword-p keyword))
	111	(setq pmail-keywords (cons keyword pmail-keywords)))))
	112	\f
	113	;;;; Adding and removing message keywords.
	114
	115	;;;###autoload
	116	(defun pmail-add-label (string)
	117	"Add LABEL to labels associated with current PMAIL message."
	118	(interactive (list (pmail-read-label "Add label")))
	119	(pmail-set-label (pmail-make-label string) t)
	120	(pmail-display-labels))
	121
	122	;;;###autoload
	123	(defun pmail-kill-label (string)
	124	"Remove LABEL from labels associated with current PMAIL message."
	125	(interactive (list (pmail-read-label "Remove label" t)))
	126	(pmail-set-label (pmail-make-label string) nil))
	127
	128	;;;###autoload
	129	(defun pmail-read-label (prompt &optional existing)
	130	"Ask for a label using PROMPT.
	131	If EXISTING is non-nil, ask for one of the labels of the current
	132	message."
	133	(when (= pmail-total-messages 0)
	134	(error "No messages in this file"))
	135	(with-current-buffer pmail-buffer
	136	(let ((result (if existing
	137	(let* ((keywords (pmail-desc-get-keywords
	138	pmail-current-message))
	139	(last (symbol-name pmail-last-label))
	140	(default (if (member last keywords)
141	last
142	(car keywords))))
143	(unless keywords
144	(error "No labels for the current message"))
145	(completing-read
146	(concat prompt " (default " default "): ")
147	keywords nil t nil nil default))
148	(let ((default (symbol-name pmail-last-label)))
149	(completing-read
150	(concat prompt (if pmail-last-label
151	(concat " (default " default "): ")
152	": "))
153	(mapcar 'list pmail-keywords)
154	nil nil nil nil default)))))
155	(setq pmail-last-label (pmail-make-label result t))
156	;; return the string, not the symbol
157	result)))
158
e131541f PR	159	(defun pmail-set-label (l state &optional n)
	160	"Add or remove label L in message N.
	161	The label L is added when STATE is non-nil, otherwise it is
	162	removed. If N is nil then use the current Pmail message. The
	163	current buffer, possibly narrowed, displays a message."
	164	(if (= pmail-total-messages 0)
	165	(error "No messages in this file"))
	166	(with-current-buffer pmail-buffer
	167	(if (not n) (setq n pmail-current-message))
	168	(save-restriction
	169	(widen)
	170	(narrow-to-region (pmail-desc-get-start n) (pmail-desc-get-end n))
	171	;; FIXME: we should move all string-using functions to symbols!
	172	(let ((str (symbol-name l)))
	173	(if (pmail-attribute-p l)
	174	(pmail-set-attribute str state n)
	175	;; Make sure the keyword is registered.
	176	(pmail-register-keyword l)
	177	(if state
	178	(pmail-desc-add-keyword str n)
	179	(pmail-desc-remove-keyword str n))))))
	180	(pmail-display-labels)
	181	;; Deal with the summary buffer.
acdc2006	182	(when (pmail-summary-exists)
e131541f PR	183	(pmail-summary-update n)))
	184	\f
	185	;; Motion on messages with keywords.
	186
	187	;;;###autoload
	188	(defun pmail-previous-labeled-message (n labels)
	189	"Show previous message with one of the labels LABELS.
	190	LABELS should be a comma-separated list of label names.
	191	If LABELS is empty, the last set of labels specified is used.
	192	With prefix argument N moves backward N messages with these labels."
	193	(interactive "p\nsMove to previous msg with labels: ")
	194	(pmail-next-labeled-message (- n) labels))
	195
	196	;;;###autoload
	197	(defun pmail-next-labeled-message (n labels)
	198	"Show next message with one of the labels LABELS.
	199	LABELS should be a comma-separated list of label names.
	200	If LABELS is empty, the last set of labels specified is used.
	201	With prefix argument N moves forward N messages with these labels."
	202	(interactive "p\nsMove to next msg with labels: ")
	203	(when (string= labels "")
	204	(setq labels pmail-last-multi-labels))
	205	(unless labels
	206	(error "No labels to find have been specified previously"))
	207	(with-current-buffer pmail-buffer
	208	(setq pmail-last-multi-labels labels)
	209	(let ((lastwin pmail-current-message)
	210	(current pmail-current-message)
	211	(regexp (concat ", ?\\("
	212	(mail-comma-list-regexp labels)
	213	"\\),")))
	214	(save-restriction
	215	(widen)
	216	(while (and (> n 0) (< current pmail-total-messages))
	217	(setq current (1+ current))
	218	(when (pmail-message-labels-p current regexp)
	219	(setq lastwin current n (1- n))))
	220	(while (and (< n 0) (> current 1))
	221	(setq current (1- current))
	222	(when (pmail-message-labels-p current regexp)
	223	(setq lastwin current n (1+ n)))))
	224	(pmail-show-message lastwin)
	225	(when (< n 0)
	226	(message "No previous message with labels %s" labels))
	227	(when (> n 0)
	228	(message "No following message with labels %s" labels)))))
	229
acdc2006 PR	230	(provide 'pmailkwd)
acdc2006 PR	231
0faeefbb	232	;; arch-tag: 1149979c-8e47-4333-9629-cf3dc887a6a7
e131541f	233	;;; pmailkwd.el ends here