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 / MH-SEQ.EL < prev    next >
Lisp/Scheme  |  1996-02-17  |  8KB  |  238 lines
  1. ;;; mh-seq --- mh-e sequences support
  2. ;; Time-stamp: <95/08/19 16:45:15 gildea>
  3.  
  4. ;; Copyright (C) 1993, 1995 Free Software Foundation, Inc.
  5.  
  6. ;; This file is part of mh-e, part of GNU Emacs.
  7.  
  8. ;; GNU Emacs is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; GNU Emacs is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21. ;; Boston, MA 02111-1307, USA.
  22.  
  23. ;;; Commentary:
  24.  
  25. ;; Internal support for mh-e package.
  26.  
  27. ;;; Change Log:
  28.  
  29. ;; $Id: mh-seq.el,v 1.6 1996/01/29 23:16:57 kwzh Exp $
  30.  
  31. ;;; Code:
  32.  
  33. (provide 'mh-seq)
  34. (require 'mh-e)
  35.  
  36. ;;; Internal variables:
  37.  
  38. (defvar mh-last-seq-used nil)        ;Name of seq to which a msg was last added.
  39.  
  40. (defvar mh-non-seq-mode-line-annotation nil) ;Saved value of mh-mode-line-annotation when narrowed to a seq.
  41.  
  42.  
  43. (defun mh-delete-seq (sequence)
  44.   "Delete the SEQUENCE."
  45.   (interactive (list (mh-read-seq-default "Delete" t)))
  46.   (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq sequence ?  (1+ mh-cmd-note)
  47.               sequence)
  48.   (mh-undefine-sequence sequence '("all"))
  49.   (mh-delete-seq-locally sequence))
  50.  
  51.  
  52. (defun mh-list-sequences (folder)
  53.   "List the sequences defined in FOLDER."
  54.   (interactive (list (mh-prompt-for-folder "List sequences in"
  55.                        mh-current-folder t)))
  56.   (let ((temp-buffer mh-temp-buffer)
  57.     (seq-list mh-seq-list))
  58.     (with-output-to-temp-buffer temp-buffer
  59.       (save-excursion
  60.     (set-buffer temp-buffer)
  61.     (erase-buffer)
  62.     (message "Listing sequences ...")
  63.     (insert "Sequences in folder " folder ":\n")
  64.     (while seq-list
  65.       (let ((name (mh-seq-name (car seq-list)))
  66.         (sorted-seq-msgs
  67.          (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<))
  68.         (last-col (- (window-width) 4))
  69.         name-spec)
  70.         (insert (setq name-spec (format "%20s:" name)))
  71.         (while sorted-seq-msgs
  72.           (if (> (current-column) last-col)
  73.           (progn
  74.             (insert "\n")
  75.             (move-to-column (length name-spec))))
  76.           (insert (format " %s" (car sorted-seq-msgs)))
  77.           (setq sorted-seq-msgs (cdr sorted-seq-msgs)))
  78.         (insert "\n"))
  79.       (setq seq-list (cdr seq-list)))
  80.     (goto-char (point-min))
  81.     (message "Listing sequences...done")))))
  82.  
  83.  
  84. (defun mh-msg-is-in-seq (message)
  85.   "Display the sequences that contain MESSAGE (default: current message)."
  86.   (interactive (list (mh-get-msg-num t)))
  87.   (message "Message %d is in sequences: %s"
  88.        message
  89.        (mapconcat 'concat
  90.               (mh-list-to-string (mh-seq-containing-msg message t))
  91.               " ")))
  92.  
  93.  
  94. (defun mh-narrow-to-seq (sequence)
  95.   "Restrict display of this folder to just messages in SEQUENCE.
  96. Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
  97.   (interactive (list (mh-read-seq "Narrow to" t)))
  98.   (with-mh-folder-updating (t)
  99.     (cond ((mh-seq-to-msgs sequence)
  100.        (mh-widen)
  101.        (let ((eob (point-max)))
  102.          (mh-copy-seq-to-point sequence eob)
  103.          (narrow-to-region eob (point-max))
  104.          (make-variable-buffer-local 'mh-non-seq-mode-line-annotation)
  105.          (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation)
  106.          (setq mh-mode-line-annotation (symbol-name sequence))
  107.          (mh-make-folder-mode-line)
  108.          (mh-recenter nil)
  109.          (setq mh-narrowed-to-seq sequence)))
  110.       (t
  111.        (error "No messages in sequence `%s'" (symbol-name sequence))))))
  112.  
  113.  
  114. (defun mh-put-msg-in-seq (msg-or-seq sequence)
  115.   "Add MESSAGE(s) (default: displayed message) to SEQUENCE.
  116. If optional prefix argument provided, then prompt for the message sequence."
  117.   (interactive (list (if current-prefix-arg
  118.              (mh-read-seq-default "Add messages from" t)
  119.                  (mh-get-msg-num t))
  120.              (mh-read-seq-default "Add to" nil)))
  121.   (if (not (mh-internal-seq sequence))
  122.       (setq mh-last-seq-used sequence))
  123.   (mh-add-msgs-to-seq (if (numberp msg-or-seq)
  124.               msg-or-seq
  125.               (mh-seq-to-msgs msg-or-seq))
  126.               sequence))
  127.  
  128.  
  129. (defun mh-widen ()
  130.   "Remove restrictions from current folder, thereby showing all messages."
  131.   (interactive)
  132.   (if mh-narrowed-to-seq
  133.       (with-mh-folder-updating (t)
  134.     (delete-region (point-min) (point-max))
  135.     (widen)
  136.     (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
  137.     (mh-make-folder-mode-line)))
  138.   (setq mh-narrowed-to-seq nil))
  139.  
  140.  
  141.  
  142. ;;; Commands to manipulate sequences.  Sequences are stored in an alist
  143. ;;; of the form:
  144. ;;;    ((seq-name msgs ...) (seq-name msgs ...) ...)
  145.  
  146.  
  147. (defun mh-read-seq-default (prompt not-empty)
  148.   ;; Read and return sequence name with default narrowed or previous sequence.
  149.   (mh-read-seq prompt not-empty
  150.            (or mh-narrowed-to-seq
  151.            mh-last-seq-used
  152.            (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
  153.  
  154.  
  155. (defun mh-read-seq (prompt not-empty &optional default)
  156.   ;; Read and return a sequence name.  Prompt with PROMPT, raise an error
  157.   ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply
  158.   ;; an optional DEFAULT sequence.
  159.   ;; A reply of '%' defaults to the first sequence containing the current
  160.   ;; message.
  161.   (let* ((input (completing-read (format "%s %s %s" prompt "sequence:"
  162.                      (if default
  163.                          (format "[%s] " default)
  164.                          ""))
  165.                  (mh-seq-names mh-seq-list)))
  166.      (seq (cond ((equal input "%")
  167.              (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
  168.             ((equal input "") default)
  169.             (t (intern input))))
  170.      (msgs (mh-seq-to-msgs seq)))
  171.     (if (and (null msgs) not-empty)
  172.     (error "No messages in sequence `%s'" seq))
  173.     seq))
  174.  
  175.  
  176. (defun mh-seq-names (seq-list)
  177.   ;; Return an alist containing the names of the SEQUENCES.
  178.   (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry)))))
  179.       seq-list))
  180.  
  181.  
  182. (defun mh-rename-seq (sequence new-name)
  183.   "Rename SEQUENCE to have NEW-NAME."
  184.   (interactive (list (mh-read-seq "Old" t)
  185.              (intern (read-string "New sequence name: "))))
  186.   (let ((old-seq (mh-find-seq sequence)))
  187.     (or old-seq
  188.     (error "Sequence %s does not exist" sequence))
  189.     ;; create new sequence first, since it might raise an error.
  190.     (mh-define-sequence new-name (mh-seq-msgs old-seq))
  191.     (mh-undefine-sequence sequence (mh-seq-msgs old-seq))
  192.     (rplaca old-seq new-name)))
  193.  
  194.  
  195. (defun mh-map-to-seq-msgs (func seq &rest args)
  196.   ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the
  197.   ;; remaining ARGS as arguments.
  198.   (save-excursion
  199.     (let ((msgs (mh-seq-to-msgs seq)))
  200.       (while msgs
  201.     (if (mh-goto-msg (car msgs) t t)
  202.         (apply func (car msgs) args))
  203.     (setq msgs (cdr msgs))))))
  204.  
  205.  
  206. (defun mh-notate-seq (seq notation offset)
  207.   ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER
  208.   ;; at the given OFFSET from the beginning of the listing line.
  209.   (mh-map-to-seq-msgs 'mh-notate seq notation offset))
  210.  
  211.  
  212. (defun mh-add-to-sequence (seq msgs)
  213.   ;; Add to a SEQUENCE each message the list of MSGS.
  214.   (if (not (mh-folder-name-p seq))
  215.       (if msgs
  216.       (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
  217.          "-sequence" (symbol-name seq)
  218.          (mh-coalesce-msg-list msgs)))))
  219.  
  220.  
  221. (defun mh-copy-seq-to-point (seq location)
  222.   ;; Copy the scan listing of the messages in SEQUENCE to after the point
  223.   ;; LOCATION in the current buffer.
  224.   (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location))
  225.  
  226.  
  227. (defun mh-copy-line-to-point (msg location)
  228.   ;; Copy the current line to the LOCATION in the current buffer.
  229.   (beginning-of-line)
  230.   (save-excursion
  231.     (let ((beginning-of-line (point))
  232.       end)
  233.       (forward-line 1)
  234.       (setq end (point))
  235.       (goto-char location)
  236.       (insert-buffer-substring (current-buffer) beginning-of-line end))))
  237.  
  238.