/[emacs]/emacs/lisp/mh-e/mh-seq.el
ViewVC logotype

Diff of /emacs/lisp/mh-e/mh-seq.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.4.3 by miles, Sat Jul 17 02:51:49 2004 UTC revision 1.2.4.4 by miles, Sat Sep 4 09:22:56 2004 UTC
# Line 70  Line 70 
70    
71  ;;; Code:  ;;; Code:
72    
73  (require 'mh-utils)  (eval-when-compile (require 'mh-acros))
74  (mh-require-cl)  (mh-require-cl)
75  (require 'mh-e)  (require 'mh-e)
76    
# Line 78  Line 78 
78  (defvar tool-bar-mode)  (defvar tool-bar-mode)
79    
80  ;;; Data structures (used in message threading)...  ;;; Data structures (used in message threading)...
81  (defstruct (mh-thread-message (:conc-name mh-message-)  (mh-defstruct (mh-thread-message (:conc-name mh-message-)
82                                (:constructor mh-thread-make-message))                                   (:constructor mh-thread-make-message))
83    (id nil)    (id nil)
84    (references ())    (references ())
85    (subject "")    (subject "")
86    (subject-re-p nil))    (subject-re-p nil))
87    
88  (defstruct (mh-thread-container (:conc-name mh-container-)  (mh-defstruct (mh-thread-container (:conc-name mh-container-)
89                                  (:constructor mh-thread-make-container))                                     (:constructor mh-thread-make-container))
90    message parent children    message parent children
91    (real-child-p t))    (real-child-p t))
92    
# Line 201  redone to get the new thread tree. This Line 201  redone to get the new thread tree. This
201    
202  ;;;###mh-autoload  ;;;###mh-autoload
203  (defun mh-msg-is-in-seq (message)  (defun mh-msg-is-in-seq (message)
204    "Display the sequences that contain MESSAGE.    "Display the sequences in which the current message appears.
205  Default is the displayed message."  Use a prefix argument to display the sequences in which another MESSAGE
206    (interactive (list (mh-get-msg-num t)))  appears."
207      (interactive "P")
208      (if (not message)
209          (setq message (mh-get-msg-num t)))
210    (let* ((dest-folder (loop for seq in mh-refile-list    (let* ((dest-folder (loop for seq in mh-refile-list
211                              until (member message (cdr seq))                              when (member message (cdr seq)) return (car seq)
212                              finally return (car seq)))                              finally return nil))
213           (deleted-flag (unless dest-folder (member message mh-delete-list))))           (deleted-flag (unless dest-folder (member message mh-delete-list))))
214      (message "Message %d%s is in sequences: %s"      (message "Message %d%s is in sequences: %s"
215               message               message
# Line 269  interactive use." Line 272  interactive use."
272    (let* ((internal-seq-flag (mh-internal-seq sequence))    (let* ((internal-seq-flag (mh-internal-seq sequence))
273           (original-msgs (mh-seq-msgs (mh-find-seq sequence)))           (original-msgs (mh-seq-msgs (mh-find-seq sequence)))
274           (folders (list mh-current-folder))           (folders (list mh-current-folder))
275           (msg-list ()))           (msg-list (mh-range-to-msg-list range)))
276        (mh-add-msgs-to-seq msg-list sequence nil t)
277      (mh-iterate-on-range m range      (mh-iterate-on-range m range
       (push m msg-list)  
278        (unless (memq m original-msgs)        (unless (memq m original-msgs)
279          (mh-add-sequence-notation m internal-seq-flag)))          (mh-add-sequence-notation m internal-seq-flag)))
     (mh-add-msgs-to-seq msg-list sequence nil t)  
280      (if (not internal-seq-flag)      (if (not internal-seq-flag)
281          (setq mh-last-seq-used sequence))          (setq mh-last-seq-used sequence))
282      (when mh-index-data      (when mh-index-data
# Line 292  OP is one of 'widen and 'unthread." Line 294  OP is one of 'widen and 'unthread."
294    
295  ;;;###mh-autoload  ;;;###mh-autoload
296  (defun mh-widen (&optional all-flag)  (defun mh-widen (&optional all-flag)
297    "Remove last restriction from current folder.    "Restore the previous limit.
298  If optional prefix argument ALL-FLAG is non-nil, then unwind to the beginning  If optional prefix argument ALL-FLAG is non-nil, remove all limits."
 of the view stack thereby showing all messages that the buffer originally  
 contained."  
299    (interactive "P")    (interactive "P")
300    (let ((msg (mh-get-msg-num nil)))    (let ((msg (mh-get-msg-num nil)))
301      (when mh-folder-view-stack      (when mh-folder-view-stack
# Line 533  should be replaced with: Line 533  should be replaced with:
533      (rplaca old-seq new-name)))      (rplaca old-seq new-name)))
534    
535  ;;;###mh-autoload  ;;;###mh-autoload
 (defun mh-map-to-seq-msgs (func seq &rest args)  
   "Invoke the FUNC at each message in the SEQ.  
 SEQ can either be a list of messages or a MH sequence. The remaining ARGS are  
 passed as arguments to FUNC."  
   (save-excursion  
     (let ((msgs (if (listp seq) seq (mh-seq-to-msgs seq))))  
       (while msgs  
         (if (mh-goto-msg (car msgs) t t)  
             (apply func (car msgs) args))  
         (setq msgs (cdr msgs))))))  
   
 ;;;###mh-autoload  
 (defun mh-notate-seq (seq notation offset)  
   "Mark the scan listing.  
 All messages in SEQ are marked with NOTATION at OFFSET from the beginning of  
 the line."  
   (let ((msg-list (mh-seq-to-msgs seq)))  
     (mh-iterate-on-messages-in-region msg (point-min) (point-max)  
       (when (member msg msg-list)  
         (mh-notate nil notation offset)))))  
   
 ;;;###mh-autoload  
536  (defun mh-notate-cur ()  (defun mh-notate-cur ()
537    "Mark the MH sequence cur.    "Mark the MH sequence cur.
538  In addition to notating the current message with `mh-note-cur' the function  In addition to notating the current message with `mh-note-cur' the function
# Line 577  uses `overlay-arrow-position' to put a m Line 555  uses `overlay-arrow-position' to put a m
555                   "-sequence" (symbol-name seq)                   "-sequence" (symbol-name seq)
556                   (mh-coalesce-msg-list msgs)))))                   (mh-coalesce-msg-list msgs)))))
557    
 ;; This has a tricky bug. mh-map-to-seq-msgs uses mh-goto-msg, which assumes  
 ;; that the folder buffer is sorted. However in this case that assumption  
 ;; doesn't hold. So we will do this the dumb way.  
 ;(defun mh-copy-seq-to-point (seq location)  
 ;  ;; Copy the scan listing of the messages in SEQUENCE to after the point  
 ;  ;; LOCATION in the current buffer.  
 ;  (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location))  
   
558  (defvar mh-thread-last-ancestor)  (defvar mh-thread-last-ancestor)
559    
560  (defun mh-copy-seq-to-eob (seq)  (defun mh-copy-seq-to-eob (seq)
# Line 614  uses `overlay-arrow-position' to put a m Line 584  uses `overlay-arrow-position' to put a m
584                (mh-index-data                (mh-index-data
585                 (mh-index-insert-folder-headers)))))))                 (mh-index-insert-folder-headers)))))))
586    
 (defun mh-copy-line-to-point (msg location)  
   "Copy current message line to a specific location.  
 The argument MSG is not used. The message in the current line is copied to  
 LOCATION."  
   ;; msg is not used?  
   ;; Copy the current line to the LOCATION in the current buffer.  
   (beginning-of-line)  
   (save-excursion  
     (let ((beginning-of-line (point))  
           end)  
       (forward-line 1)  
       (setq end (point))  
       (goto-char location)  
       (insert-buffer-substring (current-buffer) beginning-of-line end))))  
   
587  ;;;###mh-autoload  ;;;###mh-autoload
588  (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)  (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
589    "Iterate over region.    "Iterate over region.
# Line 702  a region in a cons cell." Line 657  a region in a cons cell."
657      (nreverse msg-list)))      (nreverse msg-list)))
658    
659  ;;;###mh-autoload  ;;;###mh-autoload
660  (defun mh-interactive-range (range-prompt)  (defun mh-interactive-range (range-prompt &optional default)
661    "Return interactive specification for message, sequence, range or region.    "Return interactive specification for message, sequence, range or region.
662  By convention, the name of this argument is RANGE.  By convention, the name of this argument is RANGE.
663    
# Line 715  RANGE-PROMPT. A list of messages in that Line 670  RANGE-PROMPT. A list of messages in that
670  If a MH range is given, say something like last:20, then a list containing  If a MH range is given, say something like last:20, then a list containing
671  the messages in that range is returned.  the messages in that range is returned.
672    
673    If DEFAULT non-nil then it is returned.
674    
675  Otherwise, the message number at point is returned.  Otherwise, the message number at point is returned.
676    
677  This function is usually used with `mh-iterate-on-range' in order to provide  This function is usually used with `mh-iterate-on-range' in order to provide
678  a uniform interface to MH-E functions."  a uniform interface to MH-E functions."
679    (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))    (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
680          (current-prefix-arg (mh-read-range range-prompt nil nil t t))          (current-prefix-arg (mh-read-range range-prompt nil nil t t))
681            (default default)
682          (t (mh-get-msg-num t))))          (t (mh-get-msg-num t))))
683    
 ;;;###mh-autoload  
 (defun mh-region-to-msg-list (begin end)  
   "Return a list of messages within the region between BEGIN and END."  
   ;; If end is end of buffer back up one position  
   (setq end (if (equal end (point-max)) (1- end) end))  
   (let ((result))  
     (mh-iterate-on-messages-in-region index begin end  
       (when (numberp index) (push index result)))  
     result))  
   
684    
685    
686  ;;; Commands to handle new 'subject sequence.  ;;; Commands to handle new 'subject sequence.
# Line 772  Return number of messages put in the seq Line 720  Return number of messages put in the seq
720      (if (or (not (looking-at mh-scan-subject-regexp))      (if (or (not (looking-at mh-scan-subject-regexp))
721              (not (match-string 3))              (not (match-string 3))
722              (string-equal "" (match-string 3)))              (string-equal "" (match-string 3)))
723          (progn (message "No subject line.")          (progn (message "No subject line")
724                 nil)                 nil)
725        (let ((subject (match-string-no-properties 3))        (let ((subject (match-string-no-properties 3))
726              (list))              (list))
# Line 835  This function can only be used the folde Line 783  This function can only be used the folde
783       (mh-container-message (gethash (gethash msg mh-thread-index-id-map)       (mh-container-message (gethash (gethash msg mh-thread-index-id-map)
784                                      mh-thread-id-table)))))                                      mh-thread-id-table)))))
785    
786  ;;;###mh-autoload  (defun mh-edit-pick-expr (default)
787  (defun mh-narrow-to-subject ()    "With prefix arg edit a pick expression.
   "Narrow to a sequence containing all following messages with same subject."  
   (interactive)  
   (let ((num (mh-get-msg-num nil))  
         (count (mh-subject-to-sequence t)))  
     (cond  
      ((not count)                       ; No subject line, delete msg anyway  
       nil)  
      ((= 0 count)                       ; No other msgs, delete msg anyway.  
       (message "No other messages with same Subject following this one.")  
       nil)  
      (t                                 ; We have a subject sequence.  
       (message "Found %d messages for subject sequence." count)  
       (mh-narrow-to-seq 'subject)  
       (if (numberp num)  
           (mh-goto-msg num t t))))))  
   
 (defun mh-read-pick-regexp (default)  
   "With prefix arg read a pick regexp.  
788  If no prefix arg is given, then return DEFAULT."  If no prefix arg is given, then return DEFAULT."
789    (let ((default-string (loop for x in default concat (format " %s" x))))    (let ((default-string (loop for x in default concat (format " %s" x))))
790      (if (or current-prefix-arg (equal default-string ""))      (if (or current-prefix-arg (equal default-string ""))
791          (delete "" (split-string (read-string "Pick regexp: " default-string)))          (delete "" (split-string (read-string "Pick expression: "
792                                                  default-string)))
793        default)))        default)))
794    
795  ;;;###mh-autoload  ;;;###mh-autoload
796  (defun mh-narrow-to-from (&optional regexp)  (defun mh-narrow-to-subject (&optional pick-expr)
797    "Limit to messages with the same From header field as the message at point.    "Limit to messages with same subject.
798  With a prefix argument, prompt for the regular expression, REGEXP given to  With a prefix argument, edit PICK-EXPR.
799  pick."  
800    Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
801    (interactive    (interactive
802     (list (mh-read-pick-regexp (mh-current-message-header-field 'from))))     (list (mh-edit-pick-expr (mh-current-message-header-field 'subject))))
803    (mh-narrow-to-header-field 'from regexp))    (mh-narrow-to-header-field 'subject pick-expr))
804    
805  ;;;###mh-autoload  ;;;###mh-autoload
806  (defun mh-narrow-to-cc (&optional regexp)  (defun mh-narrow-to-from (&optional pick-expr)
807    "Limit to messages with the same Cc header field as the message at point.    "Limit to messages with the same `From:' field.
808  With a prefix argument, prompt for the regular expression, REGEXP given to  With a prefix argument, edit PICK-EXPR.
809  pick."  
810    Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
811    (interactive    (interactive
812     (list (mh-read-pick-regexp (mh-current-message-header-field 'cc))))     (list (mh-edit-pick-expr (mh-current-message-header-field 'from))))
813    (mh-narrow-to-header-field 'cc regexp))    (mh-narrow-to-header-field 'from pick-expr))
814    
815  ;;;###mh-autoload  ;;;###mh-autoload
816  (defun mh-narrow-to-to (&optional regexp)  (defun mh-narrow-to-cc (&optional pick-expr)
817    "Limit to messages with the same To header field as the message at point.    "Limit to messages with the same `Cc:' field.
818  With a prefix argument, prompt for the regular expression, REGEXP given to  With a prefix argument, edit PICK-EXPR.
819  pick."  
820    Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
821    (interactive    (interactive
822     (list (mh-read-pick-regexp (mh-current-message-header-field 'to))))     (list (mh-edit-pick-expr (mh-current-message-header-field 'cc))))
823    (mh-narrow-to-header-field 'to regexp))    (mh-narrow-to-header-field 'cc pick-expr))
824    
825  (defun mh-narrow-to-header-field (header-field regexp)  ;;;###mh-autoload
826    "Limit to messages whose HEADER-FIELD match REGEXP.  (defun mh-narrow-to-to (&optional pick-expr)
827      "Limit to messages with the same `To:' field.
828    With a prefix argument, edit PICK-EXPR.
829    
830    Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
831      (interactive
832       (list (mh-edit-pick-expr (mh-current-message-header-field 'to))))
833      (mh-narrow-to-header-field 'to pick-expr))
834    
835    (defun mh-narrow-to-header-field (header-field pick-expr)
836      "Limit to messages whose HEADER-FIELD match PICK-EXPR.
837  The MH command pick is used to do the match."  The MH command pick is used to do the match."
838    (let ((folder mh-current-folder)    (let ((folder mh-current-folder)
839          (original (mh-coalesce-msg-list          (original (mh-coalesce-msg-list
# Line 897  The MH command pick is used to do the ma Line 841  The MH command pick is used to do the ma
841          (msg-list ()))          (msg-list ()))
842      (with-temp-buffer      (with-temp-buffer
843        (apply #'mh-exec-cmd-output "pick" nil folder        (apply #'mh-exec-cmd-output "pick" nil folder
844               (append original (list "-list") regexp))               (append original (list "-list") pick-expr))
845        (goto-char (point-min))        (goto-char (point-min))
846        (while (not (eobp))        (while (not (eobp))
847          (let ((num (read-from-string          (let ((num (read-from-string
# Line 939  The MH command pick is used to do the ma Line 883  The MH command pick is used to do the ma
883    "Limit to messages in RANGE.    "Limit to messages in RANGE.
884    
885  Check the documentation of `mh-interactive-range' to see how RANGE is read in  Check the documentation of `mh-interactive-range' to see how RANGE is read in
886  interactive use."  interactive use.
887    
888    Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
889    (interactive (list (mh-interactive-range "Narrow to")))    (interactive (list (mh-interactive-range "Narrow to")))
890    (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))    (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))
891    (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)    (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)
# Line 958  subject sequence." Line 904  subject sequence."
904       ((not count)                       ; No subject line, delete msg anyway       ((not count)                       ; No subject line, delete msg anyway
905        (mh-delete-msg (mh-get-msg-num t)))        (mh-delete-msg (mh-get-msg-num t)))
906       ((= 0 count)                       ; No other msgs, delete msg anyway.       ((= 0 count)                       ; No other msgs, delete msg anyway.
907        (message "No other messages with same Subject following this one.")        (message "No other messages with same Subject following this one")
908        (mh-delete-msg (mh-get-msg-num t)))        (mh-delete-msg (mh-get-msg-num t)))
909       (t                                 ; We have a subject sequence.       (t                                 ; We have a subject sequence.
910        (message "Marked %d messages for deletion" count)        (message "Marked %d messages for deletion" count)
# Line 1078  SUBJECT and REFS fields." Line 1024  SUBJECT and REFS fields."
1024             message)             message)
1025            (container            (container
1026             (setf (mh-container-message container)             (setf (mh-container-message container)
1027                   (mh-thread-make-message :subject subject                   (mh-thread-make-message :id id :references refs
1028                                           :subject-re-p subject-re-p                                           :subject subject
1029                                           :id id :references refs)))                                           :subject-re-p subject-re-p)))
1030            (t (let ((message (mh-thread-make-message            (t (let ((message (mh-thread-make-message :id id :references refs
1031                               :subject subject                                                      :subject-re-p subject-re-p
1032                               :subject-re-p subject-re-p                                                      :subject subject)))
                              :id id :references refs)))  
1033                 (prog1 message                 (prog1 message
1034                   (mh-thread-get-message-container message)))))))                   (mh-thread-get-message-container message)))))))
1035    
# Line 1450  MSG is the message being notated with NO Line 1395  MSG is the message being notated with NO
1395           (cur-scan-line (and mh-thread-scan-line-map           (cur-scan-line (and mh-thread-scan-line-map
1396                               (gethash msg mh-thread-scan-line-map)))                               (gethash msg mh-thread-scan-line-map)))
1397           (old-scan-lines (loop for map in mh-thread-scan-line-map-stack           (old-scan-lines (loop for map in mh-thread-scan-line-map-stack
1398                                 collect (and map (gethash msg map))))                                 collect (and map (gethash msg map)))))
          (notation (if (stringp notation) (aref notation 0) notation)))  
1399      (when cur-scan-line      (when cur-scan-line
1400        (setf (aref (car cur-scan-line) offset) notation))        (setf (aref (car cur-scan-line) offset) notation))
1401      (dolist (line old-scan-lines)      (dolist (line old-scan-lines)
# Line 1486  MSG is the message being notated with NO Line 1430  MSG is the message being notated with NO
1430                                (setf (gethash msg mh-thread-scan-line-map) v))))                                (setf (gethash msg mh-thread-scan-line-map) v))))
1431                   (when (> (hash-table-count mh-thread-scan-line-map) 0)                   (when (> (hash-table-count mh-thread-scan-line-map) 0)
1432                     (insert (if (bobp) "" "\n") (car x) "\n")                     (insert (if (bobp) "" "\n") (car x) "\n")
1433                     (mh-thread-generate-scan-lines thread-tree -2)))))))                     (mh-thread-generate-scan-lines thread-tree -2))))
1434          (mh-index-create-imenu-index))))
1435    
1436  (defun mh-thread-folder ()  (defun mh-thread-folder ()
1437    "Generate thread view of folder."    "Generate thread view of folder."
# Line 1711  start of the region and the second is th Line 1656  start of the region and the second is th
1656               (push msg unticked)               (push msg unticked)
1657               (setcdr tick-seq (delq msg (cdr tick-seq)))               (setcdr tick-seq (delq msg (cdr tick-seq)))
1658               (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))               (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
1659               (mh-remove-sequence-notation msg t))               (mh-remove-sequence-notation msg (mh-colors-in-use-p)))
1660              (t              (t
1661               (push msg ticked)               (push msg ticked)
1662               (setq mh-last-seq-used mh-tick-seq)               (setq mh-last-seq-used mh-tick-seq)
1663               (mh-add-sequence-notation msg t))))               (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list)))
1664                   (mh-add-sequence-notation msg (mh-colors-in-use-p))))))
1665      (mh-add-msgs-to-seq ticked mh-tick-seq nil t)      (mh-add-msgs-to-seq ticked mh-tick-seq nil t)
1666      (mh-undefine-sequence mh-tick-seq unticked)      (mh-undefine-sequence mh-tick-seq unticked)
1667      (when mh-index-data      (when mh-index-data
# Line 1724  start of the region and the second is th Line 1670  start of the region and the second is th
1670    
1671  ;;;###mh-autoload  ;;;###mh-autoload
1672  (defun mh-narrow-to-tick ()  (defun mh-narrow-to-tick ()
1673    "Restrict display of this folder to just messages in `mh-tick-seq'.    "Limit to messages in `mh-tick-seq'.
1674    
1675  Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."  Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
1676    (interactive)    (interactive)
1677    (cond ((not mh-tick-seq)    (cond ((not mh-tick-seq)
1678           (error "Enable ticking by customizing `mh-tick-seq'"))           (error "Enable ticking by customizing `mh-tick-seq'"))
1679          ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))          ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))
1680           (message "No messages in tick sequence"))           (message "No messages in %s sequence" mh-tick-seq))
1681          (t (mh-narrow-to-seq mh-tick-seq))))          (t (mh-narrow-to-seq mh-tick-seq))))
1682    
   
1683  (provide 'mh-seq)  (provide 'mh-seq)
1684    
1685  ;;; Local Variables:  ;;; Local Variables:

Legend:
Removed from v.1.2.4.3  
changed lines
  Added in v.1.2.4.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26