home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / rmailkwd.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  9KB  |  263 lines
  1. ;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs.
  2.  
  3. ;; Copyright (C) 1985, 1988, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Code:
  25.  
  26. ;; Global to all RMAIL buffers.  It exists primarily for the sake of
  27. ;; completion.  It is better to use strings with the label functions
  28. ;; and let them worry about making the label.
  29.  
  30. (defvar rmail-label-obarray (make-vector 47 0))
  31.  
  32. ;; Named list of symbols representing valid message attributes in RMAIL.
  33.  
  34. (defconst rmail-attributes
  35.   (cons 'rmail-keywords
  36.     (mapcar '(lambda (s) (intern s rmail-label-obarray))
  37.         '("deleted" "answered" "filed" "forwarded" "unseen" "edited"))))
  38.  
  39. (defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
  40.  
  41. ;; Named list of symbols representing valid message keywords in RMAIL.
  42.  
  43. (defvar rmail-keywords nil)
  44.  
  45. (defun rmail-add-label (string)
  46.   "Add LABEL to labels associated with current RMAIL message.
  47. Completion is performed over known labels when reading."
  48.   (interactive (list (rmail-read-label "Add label")))
  49.   (rmail-set-label string t))
  50.  
  51. (defun rmail-kill-label (string)
  52.   "Remove LABEL from labels associated with current RMAIL message.
  53. Completion is performed over known labels when reading."
  54.   (interactive (list (rmail-read-label "Remove label")))
  55.   (rmail-set-label string nil))
  56.  
  57. (defun rmail-read-label (prompt)
  58.   (if (not rmail-keywords) (rmail-parse-file-keywords))
  59.   (let ((result
  60.      (completing-read (concat prompt
  61.                   (if rmail-last-label
  62.                       (concat " (default "
  63.                           (symbol-name rmail-last-label)
  64.                           "): ")
  65.                     ": "))
  66.               rmail-label-obarray
  67.               nil
  68.               nil)))
  69.     (if (string= result "")
  70.     rmail-last-label
  71.       (setq rmail-last-label (rmail-make-label result t)))))
  72.  
  73. (defun rmail-set-label (l state &optional n)
  74.   (rmail-maybe-set-message-counters)
  75.   (if (not n) (setq n rmail-current-message))
  76.   (aset rmail-summary-vector (1- n) nil)
  77.   (let* ((attribute (rmail-attribute-p l))
  78.      (keyword (and (not attribute)
  79.                (or (rmail-keyword-p l)
  80.                (rmail-install-keyword l))))
  81.      (label (or attribute keyword)))
  82.     (if label
  83.     (let ((omax (- (buffer-size) (point-max)))
  84.           (omin (- (buffer-size) (point-min)))
  85.           (buffer-read-only nil)
  86.           (case-fold-search t))
  87.       (unwind-protect
  88.           (save-excursion
  89.         (widen)
  90.         (goto-char (rmail-msgbeg n))
  91.         (forward-line 1)
  92.         (if (not (looking-at "[01],"))
  93.             nil
  94.           (let ((start (1+ (point)))
  95.             (bound))
  96.             (narrow-to-region (point) (progn (end-of-line) (point)))
  97.             (setq bound (point-max))
  98.             (search-backward ",," nil t)
  99.             (if attribute
  100.             (setq bound (1+ (point)))
  101.               (setq start (1+ (point))))
  102.             (goto-char start)
  103. ;            (while (re-search-forward "[ \t]*,[ \t]*" nil t)
  104. ;              (replace-match ","))
  105. ;            (goto-char start)
  106.             (if (re-search-forward
  107.                (concat ", " (rmail-quote-label-name label) ",")
  108.                bound
  109.                'move)
  110.             (if (not state) (replace-match ","))
  111.               (if state (insert " " (symbol-name label) ",")))
  112.             (if (eq label rmail-deleted-label)
  113.             (rmail-set-message-deleted-p n state)))))
  114.         (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
  115.         (if (= n rmail-current-message) (rmail-display-labels)))))))
  116.  
  117. ;; Commented functions aren't used by RMAIL but might be nice for user
  118. ;; packages that do stuff with RMAIL.  Note that rmail-message-labels-p
  119. ;; is in rmail.el now.
  120.  
  121. ;(defun rmail-message-label-p (label &optional n)
  122. ;  "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
  123. ;  (rmail-message-labels-p (or n rmail-current-message) (regexp-quote label)))
  124.  
  125. ;(defun rmail-parse-message-labels (&optional n)
  126. ;  "Returns labels associated with NTH or current RMAIL message.
  127. ;The result is a list of two lists of strings.  The first is the
  128. ;message attributes and the second is the message keywords."
  129. ;  (let (atts keys)
  130. ;    (save-restriction
  131. ;      (widen)
  132. ;      (goto-char (rmail-msgbeg (or n rmail-current-message)))
  133. ;      (forward-line 1)
  134. ;      (or (looking-at "[01],") (error "Malformed label line"))
  135. ;      (forward-char 2)
  136. ;      (while (looking-at "[ \t]*\\([^ \t\n,]+\\),")
  137. ;    (setq atts (cons (buffer-substring (match-beginning 1) (match-end 1))
  138. ;              atts))
  139. ;    (goto-char (match-end 0)))
  140. ;      (or (looking-at ",") (error "Malformed label line"))
  141. ;      (forward-char 1)
  142. ;      (while (looking-at "[ \t]*\\([^ \t\n,]+\\),")
  143. ;    (setq keys (cons (buffer-substring (match-beginning 1) (match-end 1))
  144. ;             keys))
  145. ;    (goto-char (match-end 0)))
  146. ;      (or (looking-at "[ \t]*$") (error "Malformed label line"))
  147. ;      (list (nreverse atts) (nreverse keys)))))
  148.  
  149. (defun rmail-attribute-p (s)
  150.   (let ((symbol (rmail-make-label s)))
  151.     (if (memq symbol (cdr rmail-attributes)) symbol)))
  152.  
  153. (defun rmail-keyword-p (s)
  154.   (let ((symbol (rmail-make-label s)))
  155.     (if (memq symbol (cdr (rmail-keywords))) symbol)))
  156.  
  157. (defun rmail-make-label (s &optional forcep)
  158.   (cond ((symbolp s) s)
  159.     (forcep (intern (downcase s) rmail-label-obarray))
  160.     (t  (intern-soft (downcase s) rmail-label-obarray))))
  161.  
  162. (defun rmail-force-make-label (s)
  163.   (intern (downcase s) rmail-label-obarray))
  164.  
  165. (defun rmail-quote-label-name (label)
  166.   (regexp-quote (symbol-name (rmail-make-label label t))))
  167.  
  168. ;; Motion on messages with keywords.
  169.  
  170. (defun rmail-previous-labeled-message (n labels)
  171.   "Show previous message with one of the labels LABELS.
  172. LABELS should be a comma-separated list of label names.
  173. If LABELS is empty, the last set of labels specified is used.
  174. With prefix argument N moves backward N messages with these labels."
  175.   (interactive "p\nsMove to previous msg with labels: ")
  176.   (rmail-next-labeled-message (- n) labels))
  177.  
  178. (defun rmail-next-labeled-message (n labels)
  179.   "Show next message with one of the labels LABELS.
  180. LABELS should be a comma-separated list of label names.
  181. If LABELS is empty, the last set of labels specified is used.
  182. With prefix argument N moves forward N messages with these labels."
  183.   (interactive "p\nsMove to next msg with labels: ")
  184.   (if (string= labels "")
  185.       (setq labels rmail-last-multi-labels))
  186.   (or labels
  187.       (error "No labels to find have been specified previously"))
  188.   (setq rmail-last-multi-labels labels)
  189.   (rmail-maybe-set-message-counters)
  190.   (let ((lastwin rmail-current-message)
  191.     (current rmail-current-message)
  192.     (regexp (concat ", ?\\("
  193.             (mail-comma-list-regexp labels)
  194.             "\\),")))
  195.     (save-restriction
  196.       (widen)
  197.       (while (and (> n 0) (< current rmail-total-messages))
  198.     (setq current (1+ current))
  199.     (if (rmail-message-labels-p current regexp)
  200.         (setq lastwin current n (1- n))))
  201.       (while (and (< n 0) (> current 1))
  202.     (setq current (1- current))
  203.     (if (rmail-message-labels-p current regexp)
  204.         (setq lastwin current n (1+ n)))))
  205.     (rmail-show-message lastwin)
  206.     (if (< n 0)
  207.     (message "No previous message with labels %s" labels))
  208.     (if (> n 0)
  209.     (message "No following message with labels %s" labels))))
  210.  
  211. ;;; Manipulate the file's Labels option.
  212.  
  213. ;; Return a list of symbols for all
  214. ;; the keywords (labels) recorded in this file's Labels option.
  215. (defun rmail-keywords ()
  216.   (or rmail-keywords (rmail-parse-file-keywords)))
  217.  
  218. ;; Set rmail-keywords to a list of symbols for all
  219. ;; the keywords (labels) recorded in this file's Labels option.
  220. (defun rmail-parse-file-keywords ()
  221.   (save-restriction
  222.     (save-excursion
  223.       (widen)
  224.       (goto-char 1)
  225.       (setq rmail-keywords
  226.         (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
  227.         (progn
  228.           (narrow-to-region (point) (progn (end-of-line) (point)))
  229.           (goto-char (point-min))
  230.           (cons 'rmail-keywords
  231.             (mapcar 'rmail-force-make-label
  232.                 (mail-parse-comma-list)))))))))
  233.  
  234. ;; Add WORD to the list in the file's Labels option.
  235. ;; Any keyword used for the first time needs this done.
  236. (defun rmail-install-keyword (word)
  237.   (let ((keyword (rmail-make-label word t))
  238.     (keywords (rmail-keywords)))
  239.     (if (not (or (rmail-attribute-p keyword)
  240.          (rmail-keyword-p keyword)))
  241.     (let ((omin (- (buffer-size) (point-min)))
  242.           (omax (- (buffer-size) (point-max))))
  243.       (unwind-protect
  244.           (save-excursion
  245.         (widen)
  246.         (goto-char 1)
  247.         (let ((case-fold-search t)
  248.               (buffer-read-only nil))
  249.           (or (search-forward "\nLabels:" nil t)
  250.               (progn
  251.             (end-of-line)
  252.             (insert "\nLabels:")))
  253.           (delete-region (point) (progn (end-of-line) (point)))
  254.           (setcdr keywords (cons keyword (cdr keywords)))
  255.           (while (setq keywords (cdr keywords))
  256.             (insert (symbol-name (car keywords)) ","))
  257.           (delete-char -1)))
  258.         (narrow-to-region (- (buffer-size) omin)
  259.                   (- (buffer-size) omax)))))
  260.     keyword))
  261.  
  262. ;;; rmailkwd.el ends here
  263.