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