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

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

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

revision 1.3.4.2 by miles, Tue Oct 14 23:39:26 2003 UTC revision 1.3.4.3 by miles, Sat Jul 17 02:51:49 2004 UTC
# Line 1  Line 1 
1  ;;; mh-utils.el --- MH-E code needed for both sending and reading  ;;; mh-utils.el --- MH-E code needed for both sending and reading
2    
3  ;; Copyright (C) 1993, 95, 1997,  ;; Copyright (C) 1993, 95, 1997,
4  ;;  2000, 01, 02, 2003 Free Software Foundation, Inc.  ;;  2000, 01, 02, 03, 2004 Free Software Foundation, Inc.
5    
6  ;; Author: Bill Wohler <wohler@newt.com>  ;; Author: Bill Wohler <wohler@newt.com>
7  ;; Maintainer: Bill Wohler <wohler@newt.com>  ;; Maintainer: Bill Wohler <wohler@newt.com>
# Line 37  Line 37 
37  (defvar mh-xemacs-flag (featurep 'xemacs)  (defvar mh-xemacs-flag (featurep 'xemacs)
38    "Non-nil means the current Emacs is XEmacs.")    "Non-nil means the current Emacs is XEmacs.")
39    
40  (require 'cl)  ;; The Emacs coding conventions require that the cl package not be required at
41    ;; runtime. However, the cl package in versions of Emacs prior to 21.4 left cl
42    ;; routines in their macro expansions. Use mh-require-cl to provide the cl
43    ;; routines in the best way possible.
44    (eval-when-compile (require 'cl))
45    (defmacro mh-require-cl ()
46      (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
47          `(require 'cl)
48        `(eval-when-compile (require 'cl))))
49    
50    (mh-require-cl)
51  (require 'gnus-util)  (require 'gnus-util)
52  (require 'font-lock)  (require 'font-lock)
53    (require 'mouse)
54    (load "tool-bar" t t)
55  (require 'mh-loaddefs)  (require 'mh-loaddefs)
56  (require 'mh-customize)  (require 'mh-customize)
57    (require 'mh-inc)
58    
59  (load "mm-decode" t t)                  ; Non-fatal dependency  (load "mm-decode" t t)                  ; Non-fatal dependency
60  (load "mm-view" t t)                    ; Non-fatal dependency  (load "mm-view" t t)                    ; Non-fatal dependency
61    (load "hl-line" t t)                    ; Non-fatal dependency
62  (load "executable" t t)                 ; Non-fatal dependency on  (load "executable" t t)                 ; Non-fatal dependency on
63                                          ; executable-find                                          ; executable-find
64    
# Line 52  Line 66 
66  (defvar font-lock-auto-fontify)  (defvar font-lock-auto-fontify)
67  (defvar font-lock-defaults)  (defvar font-lock-defaults)
68  (defvar mark-active)  (defvar mark-active)
 (defvar tool-bar-mode)  
69    
70  ;;; Autoloads  ;;; Autoloads
71  (autoload 'gnus-article-highlight-citation "gnus-cite")  (autoload 'gnus-article-highlight-citation "gnus-cite")
# Line 81  This directory contains, among other thi Line 94  This directory contains, among other thi
94  (defvar mh-nmh-flag nil  (defvar mh-nmh-flag nil
95    "Non-nil means nmh is installed on this system instead of MH.")    "Non-nil means nmh is installed on this system instead of MH.")
96    
97    (defvar mh-flists-present-flag nil
98      "Non-nil means that we have `flists'.")
99    
100  ;;;###autoload  ;;;###autoload
101  (put 'mh-progs 'risky-local-variable t)  (put 'mh-progs 'risky-local-variable t)
102  ;;;###autoload  ;;;###autoload
# Line 311  passed through `regexp-quote' before bei Line 327  passed through `regexp-quote' before bei
327    
328  ;; Copy of `goto-address-mail-regexp'  ;; Copy of `goto-address-mail-regexp'
329  (defvar mh-address-mail-regexp  (defvar mh-address-mail-regexp
330    "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+"    "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
331    "A regular expression probably matching an e-mail address.")    "A regular expression probably matching an e-mail address.")
332    
333  ;; From goto-addr.el, which we don't want to force-load on users.  ;; From goto-addr.el, which we don't want to force-load on users.
# Line 435  Argument LIMIT limits search." Line 451  Argument LIMIT limits search."
451             (4 font-lock-comment-face nil t)))))))             (4 font-lock-comment-face nil t)))))))
452    "Additional expressions to highlight in MH-show mode.")    "Additional expressions to highlight in MH-show mode.")
453    
454    (defvar mh-letter-font-lock-keywords
455      `(,@mh-show-font-lock-keywords-with-cite
456        (mh-font-lock-field-data (1 'mh-letter-header-field-face prepend t))))
457    
458  (defun mh-show-font-lock-fontify-region (beg end loudly)  (defun mh-show-font-lock-fontify-region (beg end loudly)
459    "Limit font-lock in `mh-show-mode' to the header.    "Limit font-lock in `mh-show-mode' to the header.
460  Used when `mh-highlight-citation-p' is set to gnus, leaving the body to be  Used when `mh-highlight-citation-p' is set to gnus, leaving the body to be
# Line 632  Stronger than `save-excursion', weaker t Line 652  Stronger than `save-excursion', weaker t
652    
653  (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)  (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
654    
655    (defmacro mh-do-at-event-location (event &rest body)
656      "Switch to the location of EVENT and execute BODY.
657    After BODY has been executed return to original window. The modification flag
658    of the buffer in the event window is preserved."
659      (let ((event-window (make-symbol "event-window"))
660            (event-position (make-symbol "event-position"))
661            (original-window (make-symbol "original-window"))
662            (original-position (make-symbol "original-position"))
663            (modified-flag (make-symbol "modified-flag")))
664        `(save-excursion
665           (let* ((,event-window
666                   (or (mh-funcall-if-exists posn-window (event-start ,event))
667                       (mh-funcall-if-exists event-window ,event)))
668                  (,event-position
669                   (or (mh-funcall-if-exists posn-point (event-start ,event))
670                       (mh-funcall-if-exists event-closest-point ,event)))
671                  (,original-window (selected-window))
672                  (,original-position (progn
673                                       (set-buffer (window-buffer ,event-window))
674                                       (set-marker (make-marker) (point))))
675                  (,modified-flag (buffer-modified-p))
676                  (buffer-read-only nil))
677             (unwind-protect (progn
678                               (select-window ,event-window)
679                               (goto-char ,event-position)
680                               ,@body)
681               (set-buffer-modified-p ,modified-flag)
682               (goto-char ,original-position)
683               (set-marker ,original-position nil)
684               (select-window ,original-window))))))
685    
686    (put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
687    
688  (defmacro mh-make-seq (name msgs)  (defmacro mh-make-seq (name msgs)
689    "Create sequence NAME with the given MSGS."    "Create sequence NAME with the given MSGS."
690    (list 'cons name msgs))    (list 'cons name msgs))
# Line 761  still visible.\n") Line 814  still visible.\n")
814               (prog1 (call-interactively (function ,original-function))               (prog1 (call-interactively (function ,original-function))
815                 (setq normal-exit t))                 (setq normal-exit t))
816             (mh-funcall-if-exists deactivate-mark)             (mh-funcall-if-exists deactivate-mark)
817               (when (eq major-mode 'mh-folder-mode)
818                 (mh-funcall-if-exists hl-line-highlight))
819             (cond ((not normal-exit)             (cond ((not normal-exit)
820                    (set-window-configuration config))                    (set-window-configuration config))
821                   ,(if dont-return                   ,(if dont-return
# Line 823  still visible.\n") Line 878  still visible.\n")
878  (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq)  (mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq)
879  (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq)  (mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq)
880  (mh-defun-show-buffer mh-show-widen mh-widen)  (mh-defun-show-buffer mh-show-widen mh-widen)
881  (mh-defun-show-buffer mh-show-narrow-to-subject  (mh-defun-show-buffer mh-show-narrow-to-subject mh-narrow-to-subject)
882                        mh-narrow-to-subject)  (mh-defun-show-buffer mh-show-narrow-to-from mh-narrow-to-from)
883    (mh-defun-show-buffer mh-show-narrow-to-cc mh-narrow-to-cc)
884    (mh-defun-show-buffer mh-show-narrow-to-range mh-narrow-to-range)
885    (mh-defun-show-buffer mh-show-narrow-to-to mh-narrow-to-to)
886  (mh-defun-show-buffer mh-show-store-msg mh-store-msg)  (mh-defun-show-buffer mh-show-store-msg mh-store-msg)
887  (mh-defun-show-buffer mh-show-page-digest mh-page-digest)  (mh-defun-show-buffer mh-show-page-digest mh-page-digest)
888  (mh-defun-show-buffer mh-show-page-digest-backwards  (mh-defun-show-buffer mh-show-page-digest-backwards
# Line 854  still visible.\n") Line 912  still visible.\n")
912  (mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist)  (mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist)
913  (mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist)  (mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist)
914  (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages)  (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages)
915    (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages)
916    (mh-defun-show-buffer mh-show-index-sequenced-messages
917                          mh-index-sequenced-messages)
918    
919  ;;; Populate mh-show-mode-map  ;;; Populate mh-show-mode-map
920  (gnus-define-keys mh-show-mode-map  (gnus-define-keys mh-show-mode-map
# Line 898  still visible.\n") Line 959  still visible.\n")
959    
960  (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map)  (gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map)
961    "?"    mh-prefix-help    "?"    mh-prefix-help
962      "'"    mh-index-ticked-messages
963    "S"    mh-show-sort-folder    "S"    mh-show-sort-folder
964    "f"    mh-show-visit-folder    "f"    mh-show-visit-folder
965    "i"    mh-index-search    "i"    mh-index-search
# Line 905  still visible.\n") Line 967  still visible.\n")
967    "l"    mh-show-list-folders    "l"    mh-show-list-folders
968    "n"    mh-index-new-messages    "n"    mh-index-new-messages
969    "o"    mh-show-visit-folder    "o"    mh-show-visit-folder
970      "q"    mh-show-index-sequenced-messages
971    "r"    mh-show-rescan-folder    "r"    mh-show-rescan-folder
972    "s"    mh-show-search-folder    "s"    mh-show-search-folder
973    "t"    mh-show-toggle-threads    "t"    mh-show-toggle-threads
# Line 912  still visible.\n") Line 975  still visible.\n")
975    "v"    mh-show-visit-folder)    "v"    mh-show-visit-folder)
976    
977  (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map)  (gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map)
978      "'"    mh-show-narrow-to-tick
979    "?"    mh-prefix-help    "?"    mh-prefix-help
980    "d"    mh-show-delete-msg-from-seq    "d"    mh-show-delete-msg-from-seq
981    "k"    mh-show-delete-seq    "k"    mh-show-delete-seq
# Line 940  still visible.\n") Line 1004  still visible.\n")
1004  (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map)  (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map)
1005    "'"    mh-show-narrow-to-tick    "'"    mh-show-narrow-to-tick
1006    "?"    mh-prefix-help    "?"    mh-prefix-help
1007      "c"    mh-show-narrow-to-cc
1008      "f"    mh-show-narrow-to-from
1009      "r"    mh-show-narrow-to-range
1010    "s"    mh-show-narrow-to-subject    "s"    mh-show-narrow-to-subject
1011      "t"    mh-show-narrow-to-to
1012    "w"    mh-show-widen)    "w"    mh-show-widen)
1013    
1014  (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map)  (gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map)
# Line 1039  still visible.\n") Line 1107  still visible.\n")
1107  ;;; Ensure new buffers won't get this mode if default-major-mode is nil.  ;;; Ensure new buffers won't get this mode if default-major-mode is nil.
1108  (put 'mh-show-mode 'mode-class 'special)  (put 'mh-show-mode 'mode-class 'special)
1109    
1110  ;; Avoid compiler warning  ;; Avoid compiler warnings in XEmacs and Emacs 20
1111  (defvar tool-bar-map)  (eval-when-compile
1112      (defvar tool-bar-mode)
1113      (defvar tool-bar-map))
1114    
1115  (define-derived-mode mh-show-mode text-mode "MH-Show"  (define-derived-mode mh-show-mode text-mode "MH-Show"
1116    "Major mode for showing messages in MH-E.\\<mh-show-mode-map>    "Major mode for showing messages in MH-E.\\<mh-show-mode-map>
# Line 1051  be called, with no arguments, upon entry Line 1121  be called, with no arguments, upon entry
1121    (mh-show-unquote-From)    (mh-show-unquote-From)
1122    (mh-show-xface)    (mh-show-xface)
1123    (mh-show-addr)    (mh-show-addr)
1124      (setq buffer-invisibility-spec '((vanish . t) t))
1125      (set (make-local-variable 'line-move-ignore-invisible) t)
1126    (make-local-variable 'font-lock-defaults)    (make-local-variable 'font-lock-defaults)
1127    ;;(set (make-local-variable 'font-lock-support-mode) nil)    ;;(set (make-local-variable 'font-lock-support-mode) nil)
1128    (cond    (cond
# Line 1067  be called, with no arguments, upon entry Line 1139  be called, with no arguments, upon entry
1139    (if (and mh-xemacs-flag    (if (and mh-xemacs-flag
1140             font-lock-auto-fontify)             font-lock-auto-fontify)
1141        (turn-on-font-lock))        (turn-on-font-lock))
1142    (if (and (boundp 'tool-bar-mode) tool-bar-mode)    (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)
       (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))  
1143    (mh-funcall-if-exists mh-toolbar-init :show)    (mh-funcall-if-exists mh-toolbar-init :show)
1144    (when mh-decode-mime-flag    (when mh-decode-mime-flag
1145      (mh-make-local-hook 'kill-buffer-hook)      (mh-make-local-hook 'kill-buffer-hook)
# Line 1318  If optional arg MSG is non-nil, display Line 1389  If optional arg MSG is non-nil, display
1389  (defun mh-show (&optional message)  (defun mh-show (&optional message)
1390    "Show message at cursor.    "Show message at cursor.
1391  If optional argument MESSAGE is non-nil, display that message instead.  If optional argument MESSAGE is non-nil, display that message instead.
1392  Force a two-window display with the folder window on top (size  Force a two-window display with the folder window on top (size given by the
1393  `mh-summary-height') and the show buffer below it.  variable `mh-summary-height') and the show buffer below it.
1394  If the message is already visible, display the start of the message.  If the message is already visible, display the start of the message.
1395    
1396  Display of the message is controlled by setting the variables  Display of the message is controlled by setting the variables
# Line 1338  Type \"\\[mh-header-display]\" to see th Line 1409  Type \"\\[mh-header-display]\" to see th
1409    (mouse-set-point EVENT)    (mouse-set-point EVENT)
1410    (mh-show))    (mh-show))
1411    
1412    (defun mh-summary-height ()
1413      "Return ideal value for the variable `mh-summary-height'.
1414    The current frame height is taken into consideration."
1415      (or (and (fboundp 'frame-height)
1416               (> (frame-height) 24)
1417               (min 10 (/ (frame-height) 6)))
1418          4))
1419    
1420  (defun mh-show-msg (msg)  (defun mh-show-msg (msg)
1421    "Show MSG.    "Show MSG.
1422  The value of `mh-show-hook' is a list of functions to be called, with no  The value of `mh-show-hook' is a list of functions to be called, with no
# Line 1347  arguments, after the message has been di Line 1426  arguments, after the message has been di
1426    (mh-showing-mode t)    (mh-showing-mode t)
1427    (setq mh-page-to-next-msg-flag nil)    (setq mh-page-to-next-msg-flag nil)
1428    (let ((folder mh-current-folder)    (let ((folder mh-current-folder)
1429            (folders (list mh-current-folder))
1430          (clean-message-header mh-clean-message-header-flag)          (clean-message-header mh-clean-message-header-flag)
1431          (show-window (get-buffer-window mh-show-buffer)))          (show-window (get-buffer-window mh-show-buffer)))
1432      (if (not (eq (next-window (minibuffer-window)) (selected-window)))      (if (not (eq (next-window (minibuffer-window)) (selected-window)))
# Line 1358  arguments, after the message has been di Line 1438  arguments, after the message has been di
1438              (goto-char (point-min))              (goto-char (point-min))
1439              (if (not clean-message-header)              (if (not clean-message-header)
1440                  (mh-start-of-uncleaned-message)))                  (mh-start-of-uncleaned-message)))
1441          (mh-display-msg msg folder))))          (mh-display-msg msg folder)))
1442    (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split      (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split
1443        (shrink-window (- (window-height) mh-summary-height)))          (shrink-window (- (window-height) (or mh-summary-height
1444    (mh-recenter nil)                                                (mh-summary-height)))))
1445    (if (not (memq msg mh-seen-list))      (mh-recenter nil)
1446        (setq mh-seen-list (cons msg mh-seen-list)))      (if (not (memq msg mh-seen-list))
1447    (when mh-update-sequences-after-mh-show-flag          (setq mh-seen-list (cons msg mh-seen-list)))
1448      (if mh-index-data (mh-index-update-unseen msg))      (when mh-update-sequences-after-mh-show-flag
1449      (mh-update-sequences))        (mh-update-sequences)
1450    (run-hooks 'mh-show-hook))        (when mh-index-data
1451            (setq folders
1452                  (append (mh-index-delete-from-sequence mh-unseen-seq (list msg))
1453                          folders)))
1454          (when (mh-speed-flists-active-p)
1455            (apply #'mh-speed-flists t folders)))
1456        (run-hooks 'mh-show-hook)))
1457    
1458  (defun mh-modify (&optional message)  (defun mh-modify (&optional message)
1459    "Edit message at cursor.    "Edit message at cursor.
1460  If optional argument MESSAGE is non-nil, edit that message instead.  If optional argument MESSAGE is non-nil, edit that message instead.
1461  Force a two-window display with the folder window on top (size  Force a two-window display with the folder window on top (size given by the
1462  `mh-summary-height') and the message editing buffer below it.  value of the variable `mh-summary-height') and the message editing buffer below
1463    it.
1464    
1465  The message is displayed in raw form."  The message is displayed in raw form."
1466    (interactive)    (interactive)
# Line 1533  lines to display. INVISIBLE-HEADERS is i Line 1620  lines to display. INVISIBLE-HEADERS is i
1620            (beginning-of-line)            (beginning-of-line)
1621            (mh-delete-line 1)            (mh-delete-line 1)
1622            (while (looking-at "[ \t]")            (while (looking-at "[ \t]")
1623              (mh-delete-line 1))))              (mh-delete-line 1)))))
1624        (unlock-buffer))))      (let ((mh-compose-skipped-header-fields ()))
1625          (mh-letter-hide-all-skipped-fields))
1626        (unlock-buffer)))
1627    
1628  (defun mh-delete-line (lines)  (defun mh-delete-line (lines)
1629    "Delete the next LINES lines."    "Delete the next LINES lines."
# Line 1550  If NOTATION is nil then no change in the Line 1639  If NOTATION is nil then no change in the
1639          (with-mh-folder-updating (t)          (with-mh-folder-updating (t)
1640            (beginning-of-line)            (beginning-of-line)
1641            (forward-char offset)            (forward-char offset)
1642            (let ((notation (or notation (char-after))))            (let* ((change-stack-flag (and (stringp notation)
1643              (delete-char 1)                                           (equal offset (1+ mh-cmd-note))
1644              (insert notation))))))                                           (not (eq notation mh-note-seq))))
1645                     (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))
1646                     (stack (and msg (gethash msg mh-sequence-notation-history)))
1647                     (notation (or notation (char-after))))
1648                (if stack
1649                    ;; The presence of the stack tells us that we don't need to
1650                    ;; notate the message, since the notation would be replaced
1651                    ;; by a sequence notation. So we will just put the notation
1652                    ;; at the bottom of the stack. If the sequence is deleted,
1653                    ;; the correct notation will be shown.
1654                    (setf (gethash msg mh-sequence-notation-history)
1655                          (reverse (cons (aref notation 0) (cdr (reverse stack)))))
1656                  ;; Since we don't have any sequence notations in the way, just
1657                  ;; notate the scan line.
1658                  (delete-char 1)
1659                  (insert notation))
1660                (when change-stack-flag
1661                  (mh-thread-update-scan-line-map msg notation offset)))))))
1662    
1663  (defun mh-find-msg-get-num (step)  (defun mh-find-msg-get-num (step)
1664    "Return the message number of the message nearest the cursor.    "Return the message number of the message nearest the cursor.
# Line 1666  arguments, after these variable have bee Line 1772  arguments, after these variable have bee
1772        (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:"))        (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:"))
1773        (if mh-previous-seq        (if mh-previous-seq
1774            (setq mh-previous-seq (intern mh-previous-seq)))            (setq mh-previous-seq (intern mh-previous-seq)))
1775        (run-hooks 'mh-find-path-hook))))        (run-hooks 'mh-find-path-hook)
1776          (mh-collect-folder-names))))
1777    
1778  (defun mh-file-command-p (file)  (defun mh-file-command-p (file)
1779    "Return t if file FILE is the name of a executable regular file."    "Return t if file FILE is the name of a executable regular file."
# Line 1710  directory names and set `mh-nmh-flag' if Line 1817  directory names and set `mh-nmh-flag' if
1817                            mh-nmh-flag t)))                            mh-nmh-flag t)))
1818              (kill-buffer tmp-buffer))))              (kill-buffer tmp-buffer))))
1819        (unless (and mh-progs mh-lib mh-lib-progs)        (unless (and mh-progs mh-lib mh-lib-progs)
1820          (error "Unable to determine paths from `mhparam' command")))))          (error "Unable to determine paths from `mhparam' command"))
1821          (setq mh-flists-present-flag
1822                (file-exists-p (expand-file-name "flists" mh-progs))))))
1823    
1824  (defun mh-path-search (path file)  (defun mh-path-search (path file)
1825    "Search PATH, a list of directory names, for FILE.    "Search PATH, a list of directory names, for FILE.
# Line 1799  addition. Line 1908  addition.
1908    
1909  If DONT-ANNOTATE-FLAG is non-nil then the annotations in the folder buffer are  If DONT-ANNOTATE-FLAG is non-nil then the annotations in the folder buffer are
1910  not updated."  not updated."
1911    (let ((entry (mh-find-seq seq)))    (let ((entry (mh-find-seq seq))
1912            (internal-seq-flag (mh-internal-seq seq)))
1913      (if (and msgs (atom msgs)) (setq msgs (list msgs)))      (if (and msgs (atom msgs)) (setq msgs (list msgs)))
1914        (unless internal-flag
1915          (mh-add-to-sequence seq msgs)
1916          (when (not dont-annotate-flag)
1917            (mh-iterate-on-range msg msgs
1918              (unless (memq msg (cdr entry))
1919                (mh-add-sequence-notation msg internal-seq-flag)))))
1920      (if (null entry)      (if (null entry)
1921          (setq mh-seq-list          (setq mh-seq-list
1922                (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))                (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
1923                      mh-seq-list))                      mh-seq-list))
1924        (if msgs (setcdr entry (mh-canonicalize-sequence        (if msgs (setcdr entry (mh-canonicalize-sequence
1925                                (append msgs (mh-seq-msgs entry))))))                                (append msgs (mh-seq-msgs entry))))))))
     (cond ((not internal-flag)  
            (mh-add-to-sequence seq msgs)  
            (unless dont-annotate-flag  
              (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note)))))))  
1926    
1927  (defun mh-canonicalize-sequence (msgs)  (defun mh-canonicalize-sequence (msgs)
1928    "Sort MSGS in decreasing order and remove duplicates."    "Sort MSGS in decreasing order and remove duplicates."
# Line 1824  not updated." Line 1936  not updated."
1936    
1937  (defvar mh-sub-folders-cache (make-hash-table :test #'equal))  (defvar mh-sub-folders-cache (make-hash-table :test #'equal))
1938  (defvar mh-current-folder-name nil)  (defvar mh-current-folder-name nil)
1939    (defvar mh-flists-partial-line "")
1940    (defvar mh-flists-process nil)
1941    
1942    ;; Initialize mh-sub-folders-cache...
1943    (defun mh-collect-folder-names ()
1944      "Collect folder names by running `flists'."
1945      (unless mh-flists-process
1946        (setq mh-flists-process
1947              (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter
1948                                  "-recurse" "-fast"))))
1949    
1950    (defun mh-collect-folder-names-filter (process output)
1951      "Read folder names.
1952    PROCESS is the flists process that was run to collect folder names and the
1953    function is called when OUTPUT is available."
1954      (let ((position 0)
1955            (prevailing-match-data (match-data))
1956            line-end folder)
1957        (unwind-protect
1958            (while (setq line-end (string-match "\n" output position))
1959              (setq folder (format "+%s%s"
1960                                   mh-flists-partial-line
1961                                   (substring output position line-end)))
1962              (setq mh-flists-partial-line "")
1963              (unless (equal (aref folder 1) ?.)
1964                (mh-populate-sub-folders-cache folder))
1965              (setq position (1+ line-end)))
1966          (set-match-data prevailing-match-data))
1967        (setq mh-flists-partial-line (substring output position))))
1968    
1969    (defun mh-populate-sub-folders-cache (folder)
1970      "Tell `mh-sub-folders-cache' about FOLDER."
1971      (let* ((last-slash (mh-search-from-end ?/ folder))
1972             (child1 (substring folder (1+ (or last-slash 0))))
1973             (parent (and last-slash (substring folder 0 last-slash)))
1974             (parent-slash (and parent (mh-search-from-end ?/ parent)))
1975             (child2 (and parent (substring parent (1+ (or parent-slash 0)))))
1976             (grand-parent (and parent-slash (substring parent 0 parent-slash)))
1977             (cache-entry (gethash parent mh-sub-folders-cache)))
1978        (unless (loop for x in cache-entry when (equal (car x) child1) return t
1979                      finally return nil)
1980          (push (list child1) cache-entry)
1981          (setf (gethash parent mh-sub-folders-cache)
1982                (sort cache-entry (lambda (x y) (string< (car x) (car y)))))
1983          (when parent
1984            (loop for x in (gethash grand-parent mh-sub-folders-cache)
1985                  when (equal (car x) child2)
1986                  do (progn (setf (cdr x) t) (return)))))))
1987    
1988  (defun mh-normalize-folder-name (folder &optional empty-string-okay  (defun mh-normalize-folder-name (folder &optional empty-string-okay
1989                                          dont-remove-trailing-slash)                                          dont-remove-trailing-slash)
# Line 1979  This variable should never be set.") Line 2139  This variable should never be set.")
2139  (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))  (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
2140  (define-key mh-folder-completion-map " " 'minibuffer-complete)  (define-key mh-folder-completion-map " " 'minibuffer-complete)
2141    
2142    (defvar mh-speed-flists-inhibit-flag nil)
2143    
2144  (defun mh-speed-flists-active-p ()  (defun mh-speed-flists-active-p ()
2145    "Check if speedbar is running with message counts enabled."    "Check if speedbar is running with message counts enabled."
2146    (and (featurep 'mh-speed)    (and (featurep 'mh-speed)
2147           (not mh-speed-flists-inhibit-flag)
2148         (> (hash-table-count mh-speed-flists-cache) 0)))         (> (hash-table-count mh-speed-flists-cache) 0)))
2149    
2150  (defun mh-folder-completion-function (name predicate flag)  (defun mh-folder-completion-function (name predicate flag)
# Line 2119  Any output is assumed to be an error and Line 2282  Any output is assumed to be an error and
2282  The output is not read or parsed by MH-E."  The output is not read or parsed by MH-E."
2283    (save-excursion    (save-excursion
2284      (set-buffer (get-buffer-create mh-log-buffer))      (set-buffer (get-buffer-create mh-log-buffer))
2285      (let ((initial-size (mh-truncate-log-buffer)))      (let* ((initial-size (mh-truncate-log-buffer))
2286        (apply 'call-process             (start (point))
2287               (expand-file-name command mh-progs) nil t nil             (args (mh-list-to-string args)))
2288               (mh-list-to-string args))        (apply 'call-process (expand-file-name command mh-progs) nil t nil args)
2289        (if (> (buffer-size) initial-size)        (when (> (buffer-size) initial-size)
2290            (save-window-excursion          (save-excursion
2291              (switch-to-buffer-other-window mh-log-buffer)            (goto-char start)
2292              (sit-for 5))))))            (insert "Errors when executing: " command)
2293              (loop for arg in args do (insert " " arg))
2294              (insert "\n"))
2295            (save-window-excursion
2296              (switch-to-buffer-other-window mh-log-buffer)
2297              (sit-for 5))))))
2298    
2299  (defun mh-exec-cmd-error (env command &rest args)  (defun mh-exec-cmd-error (env command &rest args)
2300    "In environment ENV, execute mh-command COMMAND with ARGS.    "In environment ENV, execute mh-command COMMAND with ARGS.
# Line 2161  ARGS are passed to COMMAND as command li Line 2329  ARGS are passed to COMMAND as command li
2329                           command nil                           command nil
2330                           (expand-file-name command mh-progs)                           (expand-file-name command mh-progs)
2331                           (mh-list-to-string args))))                           (mh-list-to-string args))))
2332      (set-process-filter process (or filter 'mh-process-daemon))))      (set-process-filter process (or filter 'mh-process-daemon))
2333        process))
2334    
2335  (defun mh-exec-cmd-env-daemon (env command filter &rest args)  (defun mh-exec-cmd-env-daemon (env command filter &rest args)
2336    "In ennvironment ENV, execute mh-command COMMAND in the background.    "In ennvironment ENV, execute mh-command COMMAND in the background.
# Line 2283  Put the output into buffer after point. Line 2452  Put the output into buffer after point.
2452        (setq l (cdr l)))        (setq l (cdr l)))
2453      new-list))      new-list))
2454    
2455    (defun mh-replace-in-string (regexp newtext string)
2456      "Replace REGEXP with NEWTEXT everywhere in STRING and return result.
2457    NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.
2458    
2459    The function body was copied from `dired-replace-in-string' in dired.el.
2460    Emacs21 has `replace-regexp-in-string' while XEmacs has `replace-in-string'.
2461    Neither is present in Emacs20. The file gnus-util.el in Gnus 5.10.1 and above
2462    has `gnus-replace-in-string'. We should use that when we decide to not support
2463    older versions of Gnus."
2464      (let ((result "") (start 0) mb me)
2465        (while (string-match regexp string start)
2466          (setq mb (match-beginning 0)
2467                me (match-end 0)
2468                result (concat result (substring string start mb) newtext)
2469                start me))
2470        (concat result (substring string start))))
2471    
2472  (provide 'mh-utils)  (provide 'mh-utils)
2473    
2474  ;;; Local Variables:  ;;; Local Variables:

Legend:
Removed from v.1.3.4.2  
changed lines
  Added in v.1.3.4.3

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