[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/mh-e/mh-seq.el
From: |
Bill Wohler |
Subject: |
[Emacs-diffs] Changes to emacs/lisp/mh-e/mh-seq.el |
Date: |
Fri, 25 Apr 2003 01:52:10 -0400 |
Index: emacs/lisp/mh-e/mh-seq.el
diff -c emacs/lisp/mh-e/mh-seq.el:1.2 emacs/lisp/mh-e/mh-seq.el:1.3
*** emacs/lisp/mh-e/mh-seq.el:1.2 Mon Feb 3 15:55:30 2003
--- emacs/lisp/mh-e/mh-seq.el Fri Apr 25 01:52:00 2003
***************
*** 1,6 ****
;;; mh-seq.el --- MH-E sequences support
! ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc.
;; Author: Bill Wohler <address@hidden>
;; Maintainer: Bill Wohler <address@hidden>
--- 1,6 ----
;;; mh-seq.el --- MH-E sequences support
! ;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc.
;; Author: Bill Wohler <address@hidden>
;; Maintainer: Bill Wohler <address@hidden>
***************
*** 68,75 ****
;;; Change Log:
- ;; $Id: mh-seq.el,v 1.2 2003/02/03 20:55:30 wohler Exp $
-
;;; Code:
(require 'cl)
--- 68,73 ----
***************
*** 146,153 ****
(mh-undefine-sequence sequence '("all"))
(mh-delete-seq-locally sequence)
(mh-iterate-on-messages-in-region msg (point-min) (point-max)
! (when (and (member msg msg-list) (not (mh-seq-containing-msg msg nil)))
! (mh-notate nil ? (1+ mh-cmd-note))))))
;; Avoid compiler warnings
(defvar view-exit-action)
--- 144,153 ----
(mh-undefine-sequence sequence '("all"))
(mh-delete-seq-locally sequence)
(mh-iterate-on-messages-in-region msg (point-min) (point-max)
! (cond ((and mh-tick-seq (eq sequence mh-tick-seq))
! (mh-notate-tick msg ()))
! ((and (member msg msg-list) (not (mh-seq-containing-msg msg nil)))
! (mh-notate nil ? (1+ mh-cmd-note)))))))
;; Avoid compiler warnings
(defvar view-exit-action)
***************
*** 195,204 ****
;;;###mh-autoload
(defun mh-msg-is-in-seq (message)
! "Display the sequences that contain MESSAGE (default: current message)."
(interactive (list (mh-get-msg-num t)))
(let* ((dest-folder (loop for seq in mh-refile-list
! when (member message (cdr seq)) return (car seq)))
(deleted-flag (unless dest-folder (member message mh-delete-list))))
(message "Message %d%s is in sequences: %s"
message
--- 195,206 ----
;;;###mh-autoload
(defun mh-msg-is-in-seq (message)
! "Display the sequences that contain MESSAGE.
! Default is the displayed message."
(interactive (list (mh-get-msg-num t)))
(let* ((dest-folder (loop for seq in mh-refile-list
! until (member message (cdr seq))
! finally return (car seq)))
(deleted-flag (unless dest-folder (member message mh-delete-list))))
(message "Message %d%s is in sequences: %s"
message
***************
*** 209,214 ****
--- 211,219 ----
(mh-list-to-string (mh-seq-containing-msg message t))
" "))))
+ ;; Avoid compiler warning
+ (defvar tool-bar-map)
+
;;;###mh-autoload
(defun mh-narrow-to-seq (sequence)
"Restrict display of this folder to just messages in SEQUENCE.
***************
*** 224,229 ****
--- 229,235 ----
(setq mh-thread-scan-line-map (make-hash-table :test #'eql))
(mh-copy-seq-to-eob sequence)
(narrow-to-region eob (point-max))
+ (setq mh-narrowed-to-seq sequence)
(mh-notate-user-sequences)
(mh-notate-deleted-and-refiled)
(mh-notate-cur)
***************
*** 233,276 ****
(setq mh-mode-line-annotation (symbol-name sequence))
(mh-make-folder-mode-line)
(mh-recenter nil)
! (if (and (boundp 'tool-bar-mode) tool-bar-mode)
! (set (make-local-variable 'tool-bar-map)
! mh-folder-seq-tool-bar-map))
! (setq mh-narrowed-to-seq sequence)
(push 'widen mh-view-ops)))
(t
(error "No messages in sequence `%s'" (symbol-name sequence))))))
;;;###mh-autoload
(defun mh-put-msg-in-seq (msg-or-seq sequence)
! "Add MSG-OR-SEQ (default: displayed message) to SEQUENCE.
! If optional prefix argument provided, then prompt for the message sequence.
! If variable `transient-mark-mode' is non-nil and the mark is active, then
! the selected region is added to the sequence."
! (interactive (list (cond
! ((mh-mark-active-p t)
! (cons (region-beginning) (region-end)))
! (current-prefix-arg
! (mh-read-seq-default "Add messages from" t))
! (t
! (cons (line-beginning-position) (line-end-position))))
(mh-read-seq-default "Add to" nil)))
! (let ((internal-seq-flag (mh-internal-seq sequence))
! msg-list)
! (cond ((and (consp msg-or-seq)
! (numberp (car msg-or-seq)) (numberp (cdr msg-or-seq)))
! (mh-iterate-on-messages-in-region m (car msg-or-seq) (cdr
msg-or-seq)
! (push m msg-list)
! (unless internal-seq-flag
! (mh-notate nil mh-note-seq (1+ mh-cmd-note))))
! (mh-add-msgs-to-seq msg-list sequence internal-seq-flag t))
! ((or (numberp msg-or-seq) (listp msg-or-seq))
! (when (numberp msg-or-seq)
! (setq msg-or-seq (list msg-or-seq)))
! (mh-add-msgs-to-seq msg-or-seq sequence internal-seq-flag))
! (t (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) sequence)))
(if (not internal-seq-flag)
! (setq mh-last-seq-used sequence))))
(defun mh-valid-view-change-operation-p (op)
"Check if the view change operation can be performed.
--- 239,280 ----
(setq mh-mode-line-annotation (symbol-name sequence))
(mh-make-folder-mode-line)
(mh-recenter nil)
! (when (and (boundp 'tool-bar-mode) tool-bar-mode)
! (set (make-local-variable 'tool-bar-map)
! mh-folder-seq-tool-bar-map)
! (when (buffer-live-p (get-buffer mh-show-buffer))
! (save-excursion
! (set-buffer (get-buffer mh-show-buffer))
! (set (make-local-variable 'tool-bar-map)
! mh-show-seq-tool-bar-map))))
(push 'widen mh-view-ops)))
(t
(error "No messages in sequence `%s'" (symbol-name sequence))))))
;;;###mh-autoload
(defun mh-put-msg-in-seq (msg-or-seq sequence)
! "Add MSG-OR-SEQ to SEQUENCE.
! Default is the displayed message.
! If optional prefix argument is provided, then prompt for the message sequence.
! If variable `transient-mark-mode' is non-nil and the mark is active, then the
! selected region is added to the sequence.
! In a program, MSG-OR-SEQ can be a message number, a list of message numbers, a
! region in a cons cell, or a sequence."
! (interactive (list (mh-interactive-msg-or-seq "Add messages from")
(mh-read-seq-default "Add to" nil)))
! (when (and (interactive-p) mh-tick-seq (eq sequence mh-tick-seq))
! (error "Use `mh-toggle-tick' to add messages to %s" mh-tick-seq))
! (let* ((internal-seq-flag (mh-internal-seq sequence))
! (note-seq (if internal-seq-flag nil mh-note-seq))
! (msg-list ()))
! (mh-iterate-on-msg-or-seq m msg-or-seq
! (push m msg-list)
! (mh-notate nil note-seq (1+ mh-cmd-note)))
! (mh-add-msgs-to-seq msg-list sequence nil t)
(if (not internal-seq-flag)
! (setq mh-last-seq-used sequence))
! (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
! (mh-speed-flists t mh-current-folder))))
(defun mh-valid-view-change-operation-p (op)
"Check if the view change operation can be performed.
***************
*** 300,312 ****
(mh-make-folder-mode-line))
(if msg
(mh-goto-msg msg t t))
(mh-notate-deleted-and-refiled)
(mh-notate-user-sequences)
(mh-notate-cur)
(mh-recenter nil)))
! (if (and (boundp 'tool-bar-mode) tool-bar-mode)
! (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map))
! (setq mh-narrowed-to-seq nil))
;; FIXME? We may want to clear all notations and add one for current-message
;; and process user sequences.
--- 304,321 ----
(mh-make-folder-mode-line))
(if msg
(mh-goto-msg msg t t))
+ (setq mh-narrowed-to-seq nil)
+ (setq mh-tick-seq-changed-when-narrowed-flag nil)
(mh-notate-deleted-and-refiled)
(mh-notate-user-sequences)
(mh-notate-cur)
(mh-recenter nil)))
! (when (and (boundp 'tool-bar-mode) tool-bar-mode)
! (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
! (when (buffer-live-p (get-buffer mh-show-buffer))
! (save-excursion
! (set-buffer (get-buffer mh-show-buffer))
! (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))))
;; FIXME? We may want to clear all notations and add one for current-message
;; and process user sequences.
***************
*** 408,415 ****
uses `overlay-arrow-position' to put a marker in the fringe."
(let ((cur (car (mh-seq-to-msgs 'cur))))
(when (and cur (mh-goto-msg cur t t))
- (mh-notate nil mh-note-cur mh-cmd-note)
(beginning-of-line)
(setq mh-arrow-marker (set-marker mh-arrow-marker (point)))
(setq overlay-arrow-position mh-arrow-marker))))
--- 417,425 ----
uses `overlay-arrow-position' to put a marker in the fringe."
(let ((cur (car (mh-seq-to-msgs 'cur))))
(when (and cur (mh-goto-msg cur t t))
(beginning-of-line)
+ (when (looking-at mh-scan-good-msg-regexp)
+ (mh-notate nil mh-note-cur mh-cmd-note))
(setq mh-arrow-marker (set-marker mh-arrow-marker (point)))
(setq overlay-arrow-position mh-arrow-marker))))
***************
*** 431,436 ****
--- 441,448 ----
; ;; LOCATION in the current buffer.
; (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location))
+ (defvar mh-thread-last-ancestor)
+
(defun mh-copy-seq-to-eob (seq)
"Copy SEQ to the end of the buffer."
;; It is quite involved to write something which will work at any place in
***************
*** 455,466 ****
(forward-line))
;; Remove scan lines and read results from pre-computed tree
(delete-region (point-min) (point-max))
! (let ((thread-tree (mh-thread-generate mh-current-folder ()))
! (mh-thread-body-width
! (- (window-width) mh-cmd-note
! (1- mh-scan-field-subject-start-offset)))
! (mh-thread-last-ancestor nil))
! (mh-thread-generate-scan-lines thread-tree -2)))
(mh-index-data
(mh-index-insert-folder-headers)))))))
--- 467,474 ----
(forward-line))
;; Remove scan lines and read results from pre-computed tree
(delete-region (point-min) (point-max))
! (mh-thread-print-scan-lines
! (mh-thread-generate mh-current-folder ())))
(mh-index-data
(mh-index-insert-folder-headers)))))))
***************
*** 491,502 ****
--- 499,581 ----
(let ((binding-needed-flag var))
`(save-excursion
(goto-char ,begin)
+ (beginning-of-line)
(while (and (<= (point) ,end) (not (eobp)))
(when (looking-at mh-scan-valid-regexp)
(let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
,@body))
(forward-line 1)))))
+ (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
+
+ ;;;###mh-autoload
+ (defmacro mh-iterate-on-msg-or-seq (var msg-or-seq &rest body)
+ "Iterate an operation over a region or sequence.
+
+ VAR is bound to each message in turn in a loop over MSG-OR-SEQ, which can be a
+ message number, a list of message numbers, a sequence, or a region in a cons
+ cell. In each iteration, BODY is executed.
+
+ The parameter MSG-OR-SEQ is usually created with `mh-interactive-msg-or-seq'
+ in order to provide a uniform interface to MH-E functions."
+ (unless (symbolp var)
+ (error "Can not bind the non-symbol %s" var))
+ (let ((binding-needed-flag var)
+ (msgs (make-symbol "msgs"))
+ (seq-hash-table (make-symbol "seq-hash-table")))
+ `(cond ((numberp ,msg-or-seq)
+ (when (mh-goto-msg ,msg-or-seq t t)
+ (let ,(if binding-needed-flag `((,var ,msg-or-seq)) ())
+ ,@body)))
+ ((and (consp ,msg-or-seq)
+ (numberp (car ,msg-or-seq)) (numberp (cdr ,msg-or-seq)))
+ (mh-iterate-on-messages-in-region ,var
+ (car ,msg-or-seq) (cdr ,msg-or-seq)
+ ,@body))
+ (t (let ((,msgs (if (and ,msg-or-seq (symbolp ,msg-or-seq))
+ (mh-seq-to-msgs ,msg-or-seq)
+ ,msg-or-seq))
+ (,seq-hash-table (make-hash-table)))
+ (dolist (msg ,msgs)
+ (setf (gethash msg ,seq-hash-table) t))
+ (mh-iterate-on-messages-in-region v (point-min) (point-max)
+ (when (gethash v ,seq-hash-table)
+ (let ,(if binding-needed-flag `((,var v)) ())
+ ,@body))))))))
+
+ (put 'mh-iterate-on-msg-or-seq 'lisp-indent-hook 'defun)
+
+ ;;;###mh-autoload
+ (defun mh-msg-or-seq-to-msg-list (msg-or-seq)
+ "Return a list of messages for MSG-OR-SEQ.
+ MSG-OR-SEQ can be a message number, a list of message numbers, a sequence, or
+ a region in a cons cell."
+ (let (msg-list)
+ (mh-iterate-on-msg-or-seq msg msg-or-seq
+ (push msg msg-list))
+ (nreverse msg-list)))
+
+ ;;;###mh-autoload
+ (defun mh-interactive-msg-or-seq (sequence-prompt)
+ "Return interactive specification for message, sequence, or region.
+ By convention, the name of this argument is msg-or-seq.
+
+ If variable `transient-mark-mode' is non-nil and the mark is active, then this
+ function returns a cons-cell of the region.
+ If optional prefix argument provided, then prompt for message sequence with
+ SEQUENCE-PROMPT and return sequence.
+ Otherwise, the message number at point is returned.
+
+ This function is usually used with `mh-iterate-on-msg-or-seq' in order to
+ provide a uniform interface to MH-E functions."
+ (cond
+ ((mh-mark-active-p t)
+ (cons (region-beginning) (region-end)))
+ (current-prefix-arg
+ (mh-read-seq-default sequence-prompt t))
+ (t
+ (mh-get-msg-num t))))
+
;;;###mh-autoload
(defun mh-region-to-msg-list (begin end)
"Return a list of messages within the region between BEGIN and END."
***************
*** 1005,1021 ****
(buffer-read-only nil)
(old-buffer-modified-flag (buffer-modified-p)))
(delete-region (point-min) (point-max))
! (let ((mh-thread-body-width (- (window-width) mh-cmd-note
! (1- mh-scan-field-subject-start-offset)))
! (mh-thread-last-ancestor nil))
! (mh-thread-generate-scan-lines thread-tree -2))
(mh-notate-user-sequences)
(mh-notate-deleted-and-refiled)
(mh-notate-cur)
(set-buffer-modified-p old-buffer-modified-flag))))
- (defvar mh-thread-last-ancestor)
-
(defun mh-thread-generate-scan-lines (tree level)
"Generate scan lines.
TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices
--- 1084,1095 ----
(buffer-read-only nil)
(old-buffer-modified-flag (buffer-modified-p)))
(delete-region (point-min) (point-max))
! (mh-thread-print-scan-lines thread-tree)
(mh-notate-user-sequences)
(mh-notate-deleted-and-refiled)
(mh-notate-cur)
(set-buffer-modified-p old-buffer-modified-flag))))
(defun mh-thread-generate-scan-lines (tree level)
"Generate scan lines.
TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices
***************
*** 1099,1104 ****
--- 1173,1197 ----
(mh-thread-parse-scan-line (format "%s%s" spaces old-line)))))
(forward-line 1))))
+ (defun mh-thread-print-scan-lines (thread-tree)
+ "Print scan lines in THREAD-TREE in threaded mode."
+ (let ((mh-thread-body-width (- (window-width) mh-cmd-note
+ (1- mh-scan-field-subject-start-offset)))
+ (mh-thread-last-ancestor nil))
+ (if (null mh-index-data)
+ (mh-thread-generate-scan-lines thread-tree -2)
+ (loop for x in (mh-index-group-by-folder)
+ do (let* ((old-map mh-thread-scan-line-map)
+ (mh-thread-scan-line-map (make-hash-table)))
+ (setq mh-thread-last-ancestor nil)
+ (loop for msg in (cdr x)
+ do (let ((v (gethash msg old-map)))
+ (when v
+ (setf (gethash msg mh-thread-scan-line-map)
v))))
+ (when (> (hash-table-count mh-thread-scan-line-map) 0)
+ (insert (if (bobp) "" "\n") (car x) "\n")
+ (mh-thread-generate-scan-lines thread-tree -2)))))))
+
(defun mh-thread-folder ()
"Generate thread view of folder."
(message "Threading %s..." (buffer-name))
***************
*** 1115,1124 ****
(let* ((range (mh-coalesce-msg-list msg-list))
(thread-tree (mh-thread-generate (buffer-name) range)))
(delete-region (point-min) (point-max))
! (let ((mh-thread-body-width (- (window-width) mh-cmd-note
! (1- mh-scan-field-subject-start-offset)))
! (mh-thread-last-ancestor nil))
! (mh-thread-generate-scan-lines thread-tree -2))
(mh-notate-user-sequences)
(mh-notate-deleted-and-refiled)
(mh-notate-cur)
--- 1208,1214 ----
(let* ((range (mh-coalesce-msg-list msg-list))
(thread-tree (mh-thread-generate (buffer-name) range)))
(delete-region (point-min) (point-max))
! (mh-thread-print-scan-lines thread-tree)
(mh-notate-user-sequences)
(mh-notate-deleted-and-refiled)
(mh-notate-cur)
***************
*** 1137,1143 ****
(let ((msg-list ()))
(goto-char (point-min))
(while (not (eobp))
! (let ((index (mh-get-msg-num t)))
(when index
(push index msg-list)))
(forward-line))
--- 1227,1233 ----
(let ((msg-list ()))
(goto-char (point-min))
(while (not (eobp))
! (let ((index (mh-get-msg-num nil)))
(when index
(push index msg-list)))
(forward-line))
***************
*** 1161,1166 ****
--- 1251,1257 ----
(id-index (gethash id mh-thread-id-index-map))
(duplicates (gethash id mh-thread-duplicates)))
(remhash index mh-thread-index-id-map)
+ (remhash index mh-thread-scan-line-map)
(cond ((and (eql index id-index) (null duplicates))
(remhash id mh-thread-id-index-map))
((eql index id-index)
***************
*** 1307,1312 ****
--- 1398,1482 ----
(mh-iterate-on-messages-in-region () (car region) (cadr region)
(mh-refile-a-msg nil folder))
(mh-next-msg)))))
+
+
+
+ ;; Tick mark handling
+
+ ;; Functions to highlight and unhighlight ticked messages.
+ (defun mh-tick-add-overlay ()
+ "Add tick overlay to current line."
+ (with-mh-folder-updating (t)
+ (let ((overlay
+ (or (mh-funcall-if-exists make-overlay (point) (line-end-position))
+ (mh-funcall-if-exists make-extent (point)
(line-end-position)))))
+ (or (mh-funcall-if-exists overlay-put overlay 'face
'mh-folder-tick-face)
+ (mh-funcall-if-exists set-extent-face overlay 'mh-folder-tick-face))
+ (mh-funcall-if-exists set-extent-priority overlay 10)
+ (add-text-properties (point) (line-end-position) `(mh-tick ,overlay)))))
+
+ (defun mh-tick-remove-overlay ()
+ "Remove tick overlay from current line."
+ (let ((overlay (get-text-property (point) 'mh-tick)))
+ (when overlay
+ (with-mh-folder-updating (t)
+ (or (mh-funcall-if-exists delete-overlay overlay)
+ (mh-funcall-if-exists delete-extent overlay))
+ (remove-text-properties (point) (line-end-position) `(mh-tick
nil))))))
+
+ ;;;###mh-autoload
+ (defun mh-notate-tick (msg ticked-msgs &optional ignore-narrowing)
+ "Highlight current line if MSG is in TICKED-MSGS.
+ If optional argument IGNORE-NARROWING is non-nil then highlighting is carried
+ out even if folder is narrowed to `mh-tick-seq'."
+ (when mh-tick-seq
+ (let ((narrowed-to-tick (and (not ignore-narrowing)
+ (eq mh-narrowed-to-seq mh-tick-seq)))
+ (overlay (get-text-property (point) 'mh-tick))
+ (in-tick (member msg ticked-msgs)))
+ (cond (narrowed-to-tick (mh-tick-remove-overlay))
+ ((and (not overlay) in-tick) (mh-tick-add-overlay))
+ ((and overlay (not in-tick)) (mh-tick-remove-overlay))))))
+
+ ;; Interactive function to toggle tick.
+ ;;;###mh-autoload
+ (defun mh-toggle-tick (begin end)
+ "Toggle tick mark of all messages in region BEGIN to END."
+ (interactive (cond ((mh-mark-active-p t)
+ (list (region-beginning) (region-end)))
+ (t (list (line-beginning-position)
(line-end-position)))))
+ (unless mh-tick-seq
+ (error "Enable ticking by customizing `mh-tick-seq'"))
+ (let* ((tick-seq (mh-find-seq mh-tick-seq))
+ (tick-seq-msgs (mh-seq-msgs tick-seq)))
+ (mh-iterate-on-messages-in-region msg begin end
+ (cond ((member msg tick-seq-msgs)
+ (mh-undefine-sequence mh-tick-seq (list msg))
+ (setcdr tick-seq (delq msg (cdr tick-seq)))
+ (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
+ (mh-tick-remove-overlay))
+ (t
+ (mh-add-msgs-to-seq (list msg) mh-tick-seq nil t)
+ (setq mh-last-seq-used mh-tick-seq)
+ (mh-tick-add-overlay))))
+ (when (and (eq mh-tick-seq mh-narrowed-to-seq)
+ (not mh-tick-seq-changed-when-narrowed-flag))
+ (setq mh-tick-seq-changed-when-narrowed-flag t)
+ (let ((ticked-msgs (mh-seq-msgs (mh-find-seq mh-tick-seq))))
+ (mh-iterate-on-messages-in-region msg (point-min) (point-max)
+ (mh-notate-tick msg ticked-msgs t))))))
+
+ ;;;###mh-autoload
+ (defun mh-narrow-to-tick ()
+ "Restrict display of this folder to just messages in `mh-tick-seq'.
+ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
+ (interactive)
+ (cond ((not mh-tick-seq)
+ (error "Enable ticking by customizing `mh-tick-seq'"))
+ ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))
+ (message "No messages in tick sequence"))
+ (t (mh-narrow-to-seq mh-tick-seq))))
+
(provide 'mh-seq)