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