/[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.3 by miles, Sat Jul 17 02:51:49 2004 UTC revision 1.3.4.4 by miles, Sat Sep 4 09:22:56 2004 UTC
# Line 33  Line 33 
33    
34  ;;; Code:  ;;; Code:
35    
36  ;; Is this XEmacs-land? Located here since needed by mh-customize.el.  (defvar recursive-load-depth-limit)
37  (defvar mh-xemacs-flag (featurep 'xemacs)  (eval-and-compile
38    "Non-nil means the current Emacs is XEmacs.")    (if (and (boundp 'recursive-load-depth-limit)
39               (integerp recursive-load-depth-limit)
40  ;; The Emacs coding conventions require that the cl package not be required at             (> 50 recursive-load-depth-limit))
41  ;; runtime. However, the cl package in versions of Emacs prior to 21.4 left cl        (setq recursive-load-depth-limit 50)))
 ;; routines in their macro expansions. Use mh-require-cl to provide the cl  
 ;; routines in the best way possible.  
 (eval-when-compile (require 'cl))  
 (defmacro mh-require-cl ()  
   (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)  
       `(require 'cl)  
     `(eval-when-compile (require 'cl))))  
42    
43    (eval-when-compile (require 'mh-acros))
44  (mh-require-cl)  (mh-require-cl)
45  (require 'gnus-util)  (require 'gnus-util)
46  (require 'font-lock)  (require 'font-lock)
# Line 58  Line 52 
52    
53  (load "mm-decode" t t)                  ; Non-fatal dependency  (load "mm-decode" t t)                  ; Non-fatal dependency
54  (load "mm-view" t t)                    ; Non-fatal dependency  (load "mm-view" t t)                    ; Non-fatal dependency
55    (load "vcard" t t)                      ; Non-fatal dependency
56  (load "hl-line" t t)                    ; Non-fatal dependency  (load "hl-line" t t)                    ; Non-fatal dependency
57  (load "executable" t t)                 ; Non-fatal dependency on  (load "executable" t t)                 ; Non-fatal dependency on
58                                          ; executable-find                                          ; executable-find
# Line 69  Line 64 
64    
65  ;;; Autoloads  ;;; Autoloads
66  (autoload 'gnus-article-highlight-citation "gnus-cite")  (autoload 'gnus-article-highlight-citation "gnus-cite")
67    (autoload 'message-fetch-field "message")
68    (autoload 'message-tokenize-header "message")
69  (require 'sendmail)  (require 'sendmail)
 (autoload 'Info-goto-node "info")  
70  (unless (fboundp 'make-hash-table)  (unless (fboundp 'make-hash-table)
71    (autoload 'make-hash-table "cl"))    (autoload 'make-hash-table "cl"))
72    
 ;;; Set for local environment:  
 ;;; mh-progs and mh-lib used to be set in paths.el, which tried to  
 ;;; figure out at build time which of several possible directories MH  
 ;;; was installed into.  But if you installed MH after building Emacs,  
 ;;; this would almost certainly be wrong, so now we do it at run time.  
   
 (defvar mh-progs nil  
   "Directory containing MH commands, such as inc, repl, and rmm.")  
   
 (defvar mh-lib nil  
   "Directory containing the MH library.  
 This directory contains, among other things, the components file.")  
   
 (defvar mh-lib-progs nil  
   "Directory containing MH helper programs.  
 This directory contains, among other things, the mhl program.")  
   
 (defvar mh-nmh-flag nil  
   "Non-nil means nmh is installed on this system instead of MH.")  
   
 (defvar mh-flists-present-flag nil  
   "Non-nil means that we have `flists'.")  
   
 ;;;###autoload  
 (put 'mh-progs 'risky-local-variable t)  
 ;;;###autoload  
 (put 'mh-lib 'risky-local-variable t)  
 ;;;###autoload  
 (put 'mh-lib-progs 'risky-local-variable t)  
 ;;;###autoload  
 (put 'mh-nmh-flag 'risky-local-variable t)  
   
73  ;;; CL Replacements  ;;; CL Replacements
74  (defun mh-search-from-end (char string)  (defun mh-search-from-end (char string)
75    "Return the position of last occurrence of CHAR in STRING.    "Return the position of last occurrence of CHAR in STRING.
# Line 115  of `search' in the CL package." Line 79  of `search' in the CL package."
79          when (equal (aref string index) char) return index          when (equal (aref string index) char) return index
80          finally return nil))          finally return nil))
81    
 ;;; Macros to generate correct code for different emacs variants  
   
 (defmacro mh-do-in-gnu-emacs (&rest body)  
   "Execute BODY if in GNU Emacs."  
   (unless mh-xemacs-flag `(progn ,@body)))  
 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)  
   
 (defmacro mh-do-in-xemacs (&rest body)  
   "Execute BODY if in GNU Emacs."  
   (when mh-xemacs-flag `(progn ,@body)))  
 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)  
   
 (defmacro mh-funcall-if-exists (function &rest args)  
   "Call FUNCTION with ARGS as parameters if it exists."  
   (if (fboundp function)  
       `(funcall ',function ,@args)))  
   
 (defmacro mh-make-local-hook (hook)  
   "Make HOOK local if needed.  
 XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be  
 called."  
   (when (and (fboundp 'make-local-hook)  
              (not (get 'make-local-hook 'byte-obsolete-info)))  
     `(make-local-hook ,hook)))  
   
 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)  
   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.  
 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if  
 variable `transient-mark-mode' is active."  
   (cond (mh-xemacs-flag                 ;XEmacs  
          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))  
         ((not check-transient-mark-mode-flag) ;GNU Emacs  
          `(and (boundp 'mark-active) mark-active))  
         (t                              ;GNU Emacs  
          `(and (boundp 'transient-mark-mode) transient-mark-mode  
                (boundp 'mark-active) mark-active))))  
   
82  ;;; Additional header fields that might someday be added:  ;;; Additional header fields that might someday be added:
83  ;;; "Sender: " "Reply-to: "  ;;; "Sender: " "Reply-to: "
84    
85    
86    ;;; Scan Line Formats
87    
88  (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)"  (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)"
89    "Regexp to find the number of a message in a scan line.    "This regexp is used to extract the message number from a scan line.
90  The message's number must be surrounded with \\( \\)")  Note that the message number must be placed in a parenthesized expression as
91    in the default of \"^ *\\\\([0-9]+\\\\)\".")
92    
93  (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]"  (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]"
94    "Regexp to find a scan line in which the message number overflowed.    "This regexp matches scan lines in which the message number overflowed.")
 The message's number is left truncated in this case.")  
95    
96  (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)"  (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)"
97    "Regexp to find message number width in an scan format.    "This regexp is used to find the message number width in a scan format.
98  The message number width must be surrounded with \\( \\).")  Note that the message number must be placed in a parenthesized expression as
99    in the default of \"%\\\\([0-9]*\\\\)(msg)\".")
100    
101  (defvar mh-scan-msg-format-string "%d"  (defvar mh-scan-msg-format-string "%d"
102    "Format string for width of the message number in a scan format.    "This is a format string for width of the message number in a scan format.
103  Use `0%d' for zero-filled message numbers.")  Use `0%d' for zero-filled message numbers.")
104    
105  (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]"  (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]"
106    "Format string containing a regexp matching the scan listing for a message.    "This format string regexp matches the scan line for a particular message.
107  The desired message's number will be an argument to format.")  Use `%d' to represent the location of the message number within the
108    expression as in the default of \"^[^0-9]*%d[^0-9]\".")
109    
110    (defvar mh-cmd-note 4
111      "This is the number of characters to skip over before inserting notation.
112    This variable should be set with the function `mh-set-cmd-note'. This variable
113    may be updated dynamically if `mh-adaptive-cmd-note-flag' is non-nil and
114    `mh-scan-format-file' is t.")
115    (make-variable-buffer-local 'mh-cmd-note)
116    
117  (defvar mh-default-folder-for-message-function nil  (defvar mh-note-seq ?%
118    "Function to select a default folder for refiling or Fcc.    "Messages in a user-defined sequence are marked by this character.
119  If set to a function, that function is called with no arguments by  Messages in the `search' sequence are marked by this character as well.")
120  `\\[mh-refile-msg]' and `\\[mh-to-fcc]' to get a default when  
121  prompting the user for a folder.  The function is called from within a  
 `save-excursion', with point at the start of the message.  It should  
 return the folder to offer as the refile or Fcc folder, as a string  
 with a leading `+' sign.  It can also return an empty string to use no  
 default, or nil to calculate the default the usual way.  
 NOTE: This variable is not an ordinary hook;  
 It may not be a list of functions.")  
122    
123  (defvar mh-show-buffer-mode-line-buffer-id "    {show-%s} %d"  (defvar mh-show-buffer-mode-line-buffer-id "    {show-%s} %d"
124    "Format string to produce `mode-line-buffer-identification' for show buffers.    "Format string to produce `mode-line-buffer-identification' for show buffers.
125  First argument is folder name.  Second is message number.")  First argument is folder name.  Second is message number.")
126    
127  (defvar mh-cmd-note 4  
   "Column to insert notation.  
 Use `mh-set-cmd-note' to modify it.  
 This value may be dynamically updated if `mh-adaptive-cmd-note-flag' is  
 non-nil and `mh-scan-format-file' is t.  
 Note that the first column is column number 0.")  
 (make-variable-buffer-local 'mh-cmd-note)  
   
 (defvar mh-note-seq "%"  
   "String whose first character is used to notate messages in a sequence.")  
128    
129  (defvar mh-mail-header-separator "--------"  (defvar mh-mail-header-separator "--------"
130    "*Line used by MH to separate headers from text in messages being composed.    "*Line used by MH to separate headers from text in messages being composed.
# Line 213  Do not make this a regexp as it may be t Line 137  Do not make this a regexp as it may be t
137  passed through `regexp-quote' before being used by functions like  passed through `regexp-quote' before being used by functions like
138  `re-search-forward'.")  `re-search-forward'.")
139    
140    (defvar mh-signature-separator-regexp "^-- $"
141      "Regexp used to find signature separator.
142    See `mh-signature-separator'.")
143    
144    (defvar mh-signature-separator "-- \n"
145      "Text of a signature separator.
146    A signature separator is used to separate the body of a message from the
147    signature. This can be used by user agents such as MH-E to render the
148    signature differently or to suppress the inclusion of the signature in a
149    reply.
150    Use `mh-signature-separator-regexp' when searching for a separator.")
151    
152    (defun mh-signature-separator-p ()
153      "Return non-nil if buffer includes \"^-- $\"."
154      (save-excursion
155        (goto-char (point-min))
156        (re-search-forward mh-signature-separator-regexp nil t)))
157    
158  ;; Variables for MIME display  ;; Variables for MIME display
159    
160  ;; Structure to keep track of MIME handles on a per buffer basis.  ;; Structure to keep track of MIME handles on a per buffer basis.
161  (defstruct (mh-buffer-data (:conc-name mh-mime-)  (mh-defstruct (mh-buffer-data (:conc-name mh-mime-)
162                             (:constructor mh-make-buffer-data))                                (:constructor mh-make-buffer-data))
163    (handles ())                          ; List of MIME handles    (handles ())                          ; List of MIME handles
164    (handles-cache (make-hash-table))     ; Cache to avoid multiple decodes of    (handles-cache (make-hash-table))     ; Cache to avoid multiple decodes of
165                                          ; nested messages                                          ; nested messages
# Line 331  passed through `regexp-quote' before bei Line 273  passed through `regexp-quote' before bei
273    "A regular expression probably matching an e-mail address.")    "A regular expression probably matching an e-mail address.")
274    
275  ;; 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.
276  ;;;###mh-autoload  
277  (defun mh-goto-address-find-address-at-point ()  (defun mh-goto-address-find-address-at-point ()
278    "Find e-mail address around or before point.    "Find e-mail address around or before point.
279  Then search backwards to beginning of line for the start of an e-mail  Then search backwards to beginning of line for the start of an e-mail
# Line 348  address.  If no e-mail address found, re Line 290  address.  If no e-mail address found, re
290  In MH-E we frequently need to find the end of headers in nested messages, where  In MH-E we frequently need to find the end of headers in nested messages, where
291  the buffer has been narrowed. This function works in this situation."  the buffer has been narrowed. This function works in this situation."
292    (save-excursion    (save-excursion
293      (rfc822-goto-eoh)      ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally,
294        ;; mail headers that MH-E has to read contains lines of the form:
295        ;;    From xxx@yyy Mon May 10 11:48:07 2004
296        ;; In this situation, rfc822-goto-eoh doesn't go to the end of the
297        ;; header. The replacement allows From_ lines in the mail header.
298        (goto-char (point-min))
299        (loop for p = (re-search-forward
300                       "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move)
301              do (cond ((null p) (return))
302                       (t (goto-char (match-beginning 0))
303                          (unless (looking-at "From ") (return))
304                          (goto-char p))))
305      (point)))      (point)))
306    
307  (defun mh-in-header-p ()  (defun mh-in-header-p ()
# Line 528  message about the fontification operatio Line 481  message about the fontification operatio
481  ;; hidden and can be programmatically removed in mh-quit), and the variable  ;; hidden and can be programmatically removed in mh-quit), and the variable
482  ;; names have the form mh-temp-.*-buffer.  ;; names have the form mh-temp-.*-buffer.
483  (defconst mh-temp-buffer " *mh-temp*")  ;scratch  (defconst mh-temp-buffer " *mh-temp*")  ;scratch
484    (defconst mh-temp-fetch-buffer " *mh-fetch*")  ;wget/curl/fetch output
485    
486  ;; The names of MH-E buffers that are not ephemeral and can be used by the  ;; The names of MH-E buffers that are not ephemeral and can be used by the
487  ;; user (and deleted by the user when no longer needed) have a "*MH-E " prefix  ;; user (and deleted by the user when no longer needed) have a "*MH-E " prefix
488  ;; (so they can be programmatically removed in mh-quit), and the variable  ;; (so they can be programmatically removed in mh-quit), and the variable
489  ;; names have the form mh-.*-buffer.  ;; names have the form mh-.*-buffer.
490    (defconst mh-aliases-buffer "*MH-E Aliases*") ;alias lookups
491  (defconst mh-folders-buffer "*MH-E Folders*") ;folder list  (defconst mh-folders-buffer "*MH-E Folders*") ;folder list
492    (defconst mh-help-buffer "*MH-E Help*") ;quick help
493  (defconst mh-info-buffer "*MH-E Info*") ;version information buffer  (defconst mh-info-buffer "*MH-E Info*") ;version information buffer
494  (defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on  (defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on
495    (defconst mh-mail-delivery-buffer "*MH-E Mail Delivery*") ;mail delivery log
496  (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent  (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent
497  (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list  (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list
 (defconst mh-mail-delivery-buffer "*MH-E Mail Delivery*") ;mail delivery log  
498    
499  ;; Number of lines to keep in mh-log-buffer.  ;; Number of lines to keep in mh-log-buffer.
500  (defvar mh-log-buffer-lines 100)  (defvar mh-log-buffer-lines 100)
# Line 593  message about the fontification operatio Line 549  message about the fontification operatio
549              (cons modeline-buffer-id-left-extent "XEmacs%N:"))              (cons modeline-buffer-id-left-extent "XEmacs%N:"))
550            (cons modeline-buffer-id-right-extent " %17b")))))            (cons modeline-buffer-id-right-extent " %17b")))))
551    
   
552  ;;; This holds a documentation string used by describe-mode.  ;;; This holds a documentation string used by describe-mode.
553  (defun mh-showing-mode (&optional arg)  (defun mh-showing-mode (&optional arg)
554    "Change whether messages should be displayed.    "Change whether messages should be displayed.
# Line 614  With arg, display messages iff ARG is po Line 569  With arg, display messages iff ARG is po
569  ;; Showing message with headers or normally.  ;; Showing message with headers or normally.
570  (defvar mh-showing-with-headers nil)  (defvar mh-showing-with-headers nil)
571    
   
572  ;;; MH-E macros  ;;; MH-E macros
573    
574  (defmacro with-mh-folder-updating (save-modification-flag &rest body)  (defmacro with-mh-folder-updating (save-modification-flag &rest body)
# Line 742  of the buffer in the event window is pre Line 696  of the buffer in the event window is pre
696    (unlock-buffer)    (unlock-buffer)
697    (setq buffer-file-name nil))    (setq buffer-file-name nil))
698    
699  ;;;###mh-autoload  
700  (defun mh-get-msg-num (error-if-no-message)  (defun mh-get-msg-num (error-if-no-message)
701    "Return the message number of the displayed message.    "Return the message number of the displayed message.
702  If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is  If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is
# Line 915  still visible.\n") Line 869  still visible.\n")
869  (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages)  (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages)
870  (mh-defun-show-buffer mh-show-index-sequenced-messages  (mh-defun-show-buffer mh-show-index-sequenced-messages
871                        mh-index-sequenced-messages)                        mh-index-sequenced-messages)
872    (mh-defun-show-buffer mh-show-catchup mh-catchup)
873    (mh-defun-show-buffer mh-show-ps-print-toggle-mime mh-ps-print-toggle-mime)
874    (mh-defun-show-buffer mh-show-ps-print-toggle-color mh-ps-print-toggle-color)
875    (mh-defun-show-buffer mh-show-ps-print-toggle-faces mh-ps-print-toggle-faces)
876    (mh-defun-show-buffer mh-show-ps-print-msg-file mh-ps-print-msg-file)
877    (mh-defun-show-buffer mh-show-ps-print-msg mh-ps-print-msg)
878    (mh-defun-show-buffer mh-show-ps-print-msg-show mh-ps-print-msg-show)
879    (mh-defun-show-buffer mh-show-toggle-mime-buttons mh-toggle-mime-buttons)
880    (mh-defun-show-buffer mh-show-display-with-external-viewer
881                          mh-display-with-external-viewer)
882    
883  ;;; Populate mh-show-mode-map  ;;; Populate mh-show-mode-map
884  (gnus-define-keys mh-show-mode-map  (gnus-define-keys mh-show-mode-map
# Line 941  still visible.\n") Line 905  still visible.\n")
905    "g"    mh-show-goto-msg    "g"    mh-show-goto-msg
906    "i"    mh-show-inc-folder    "i"    mh-show-inc-folder
907    "k"    mh-show-delete-subject-or-thread    "k"    mh-show-delete-subject-or-thread
   "l"    mh-show-print-msg  
908    "m"    mh-show-send    "m"    mh-show-send
909    "n"    mh-show-next-undeleted-msg    "n"    mh-show-next-undeleted-msg
910    "\M-n" mh-show-next-unread-msg    "\M-n" mh-show-next-unread-msg
# Line 961  still visible.\n") Line 924  still visible.\n")
924    "?"    mh-prefix-help    "?"    mh-prefix-help
925    "'"    mh-index-ticked-messages    "'"    mh-index-ticked-messages
926    "S"    mh-show-sort-folder    "S"    mh-show-sort-folder
927      "c"    mh-show-catchup
928    "f"    mh-show-visit-folder    "f"    mh-show-visit-folder
929    "i"    mh-index-search    "i"    mh-index-search
930    "k"    mh-show-kill-folder    "k"    mh-show-kill-folder
# Line 992  still visible.\n") Line 956  still visible.\n")
956    "b"    mh-show-junk-blacklist    "b"    mh-show-junk-blacklist
957    "w"    mh-show-junk-whitelist)    "w"    mh-show-junk-whitelist)
958    
959    (gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map)
960      "?"   mh-prefix-help
961      "A"   mh-show-ps-print-toggle-mime
962      "C"   mh-show-ps-print-toggle-color
963      "F"   mh-show-ps-print-toggle-faces
964      "M"   mh-show-ps-print-toggle-mime
965      "f"   mh-show-ps-print-msg-file
966      "l"   mh-show-print-msg
967      "p"   mh-show-ps-print-msg
968      "s"   mh-show-ps-print-msg-show)
969    
970  (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map)  (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map)
971    "?"    mh-prefix-help    "?"    mh-prefix-help
972    "u"    mh-show-thread-ancestor    "u"    mh-show-thread-ancestor
# Line 1026  still visible.\n") Line 1001  still visible.\n")
1001  (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map)  (gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map)
1002    "?"           mh-prefix-help    "?"           mh-prefix-help
1003    "a"           mh-mime-save-parts    "a"           mh-mime-save-parts
1004      "e"           mh-show-display-with-external-viewer
1005    "v"           mh-show-toggle-mime-part    "v"           mh-show-toggle-mime-part
1006    "o"           mh-show-save-mime-part    "o"           mh-show-save-mime-part
1007    "i"           mh-show-inline-mime-part    "i"           mh-show-inline-mime-part
1008      "t"           mh-show-toggle-mime-buttons
1009    "\t"          mh-show-next-button    "\t"          mh-show-next-button
1010    [backtab]     mh-show-prev-button    [backtab]     mh-show-prev-button
1011    "\M-\t"       mh-show-prev-button)    "\M-\t"       mh-show-prev-button)
# Line 1115  still visible.\n") Line 1092  still visible.\n")
1092  (define-derived-mode mh-show-mode text-mode "MH-Show"  (define-derived-mode mh-show-mode text-mode "MH-Show"
1093    "Major mode for showing messages in MH-E.\\<mh-show-mode-map>    "Major mode for showing messages in MH-E.\\<mh-show-mode-map>
1094  The value of `mh-show-mode-hook' is a list of functions to  The value of `mh-show-mode-hook' is a list of functions to
1095  be called, with no arguments, upon entry to this mode."  be called, with no arguments, upon entry to this mode.
1096    See also `mh-folder-mode'.
1097    
1098    \\{mh-show-mode-map}"
1099    (set (make-local-variable 'mail-header-separator) mh-mail-header-separator)    (set (make-local-variable 'mail-header-separator) mh-mail-header-separator)
1100    (setq paragraph-start (default-value 'paragraph-start))    (setq paragraph-start (default-value 'paragraph-start))
1101    (mh-show-unquote-From)    (mh-show-unquote-From)
# Line 1210  be called, with no arguments, upon entry Line 1190  be called, with no arguments, upon entry
1190  (mh-do-in-xemacs (defvar default-enable-multibyte-characters))  (mh-do-in-xemacs (defvar default-enable-multibyte-characters))
1191    
1192  (defun mh-face-display-function ()  (defun mh-face-display-function ()
1193    "Display a Face or X-Face header field.    "Display a Face, X-Face, or X-Image-URL header field.
1194  Display Face if both are present."  If more than one of these are present, then the first one found in this order
1195    is used."
1196    (save-restriction    (save-restriction
1197      (goto-char (point-min))      (goto-char (point-min))
1198      (re-search-forward "\n\n" (point-max) t)      (re-search-forward "\n\n" (point-max) t)
# Line 1226  Display Face if both are present." Line 1207  Display Face if both are present."
1207                          type 'png))                          type 'png))
1208              (x-face (setq raw (mh-uncompface x-face)              (x-face (setq raw (mh-uncompface x-face)
1209                            type 'pbm))                            type 'pbm))
1210              (url (setq type 'url)))              (url (setq type 'url))
1211                (t (multiple-value-setq (type raw) (mh-picon-get-image))))
1212        (when type        (when type
1213          (goto-char (point-min))          (goto-char (point-min))
1214          (when (re-search-forward "^from:" (point-max) t)          (when (re-search-forward "^from:" (point-max) t)
# Line 1261  Display Face if both are present." Line 1243  Display Face if both are present."
1243               ((and (eq type 'pbm)               ((and (eq type 'pbm)
1244                     (fboundp 'x-face-xmas-wl-display-x-face)                     (fboundp 'x-face-xmas-wl-display-x-face)
1245                     (fboundp 'executable-find) (executable-find "uncompface"))                     (fboundp 'executable-find) (executable-find "uncompface"))
1246                (mh-funcall-if-exists x-face-xmas-wl-display-x-face)))                (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
1247                 ;; Picon display
1248                 ((and raw (member type '(xpm xbm gif)))
1249                  (when (featurep type)
1250                    (set-extent-begin-glyph
1251                     (make-extent (point) (point))
1252                     (make-glyph (vector type ':data raw))))))
1253              (when raw (insert " "))))))))              (when raw (insert " "))))))))
1254    
   
1255  (defun mh-show-xface ()  (defun mh-show-xface ()
1256    "Display X-Face."    "Display X-Face."
1257    (when (and window-system mh-show-use-xface-flag    (when (and window-system mh-show-use-xface-flag
# Line 1274  Display Face if both are present." Line 1261  Display Face if both are present."
1261    
1262    
1263    
1264    ;; Picon display
1265    
1266    ;;; XXX: This should be customizable. As a side-effect of setting this
1267    ;;;   variable, arrange to reset mh-picon-existing-directory-list to 'unset.
1268    (defvar mh-picon-directory-list
1269      '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
1270        "~/.picons/domains" "~/.picons/misc"
1271        "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
1272        "/usr/share/picons/news" "/usr/share/picons/domains"
1273        "/usr/share/picons/misc")
1274      "List of directories where picons reside.
1275    The directories are searched for in the order they appear in the list.")
1276    
1277    (defvar mh-picon-existing-directory-list 'unset
1278      "List of directories to search in.")
1279    
1280    (defvar mh-picon-cache (make-hash-table :test #'equal))
1281    
1282    (defvar mh-picon-image-types
1283      (loop for type in '(xpm xbm gif)
1284            when (or (mh-do-in-gnu-emacs
1285                       (ignore-errors
1286                         (mh-funcall-if-exists image-type-available-p type)))
1287                     (mh-do-in-xemacs (featurep type)))
1288            collect type))
1289    
1290    (defun mh-picon-set-directory-list ()
1291      "Update `mh-picon-existing-directory-list' if needed."
1292      (when (eq mh-picon-existing-directory-list 'unset)
1293        (setq mh-picon-existing-directory-list
1294              (loop for x in mh-picon-directory-list
1295                    when (file-directory-p x) collect x))))
1296    
1297    (defun* mh-picon-get-image ()
1298      "Find the best possible match and return contents."
1299      (mh-picon-set-directory-list)
1300      (save-restriction
1301        (let* ((from-field (ignore-errors (car (message-tokenize-header
1302                                                (mh-get-header-field "from:")))))
1303               (from (car (ignore-errors
1304                            (mh-funcall-if-exists ietf-drums-parse-address
1305                                                  from-field))))
1306               (host (and from
1307                          (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
1308                          (downcase (match-string 3 from))))
1309               (user (and host (downcase (match-string 1 from))))
1310               (canonical-address (format "%s@%s" user host))
1311               (cached-value (gethash canonical-address mh-picon-cache))
1312               (host-list (and host (delete "" (split-string host "\\."))))
1313               (match nil))
1314          (cond (cached-value (return-from mh-picon-get-image cached-value))
1315                ((not host-list) (return-from mh-picon-get-image nil)))
1316          (setq match
1317                (block 'loop
1318                  ;; u@h search
1319                  (loop for dir in mh-picon-existing-directory-list
1320                        do (loop for type in mh-picon-image-types
1321                                 ;; [path]user@host
1322                                 for file1 = (format "%s/%s.%s"
1323                                                     dir canonical-address type)
1324                                 when (file-exists-p file1)
1325                                 do (return-from 'loop file1)
1326                                 ;; [path]user
1327                                 for file2 = (format "%s/%s.%s" dir user type)
1328                                 when (file-exists-p file2)
1329                                 do (return-from 'loop file2)
1330                                 ;; [path]host
1331                                 for file3 = (format "%s/%s.%s" dir host type)
1332                                 when (file-exists-p file3)
1333                                 do (return-from 'loop file3)))
1334                  ;; facedb search
1335                  ;; Search order for user@foo.net:
1336                  ;;   [path]net/foo/user
1337                  ;;   [path]net/foo/user/face
1338                  ;;   [path]net/user
1339                  ;;   [path]net/user/face
1340                  ;;   [path]net/foo/unknown
1341                  ;;   [path]net/foo/unknown/face
1342                  ;;   [path]net/unknown
1343                  ;;   [path]net/unknown/face
1344                  (loop for u in (list user "unknown")
1345                        do (loop for dir in mh-picon-existing-directory-list
1346                                 do (loop for x on host-list by #'cdr
1347                                          for y = (mh-picon-generate-path x u dir)
1348                                          do (loop for type in mh-picon-image-types
1349                                                   for z1 = (format "%s.%s" y type)
1350                                                   when (file-exists-p z1)
1351                                                   do (return-from 'loop z1)
1352                                                   for z2 = (format "%s/face.%s"
1353                                                                    y type)
1354                                                   when (file-exists-p z2)
1355                                                   do (return-from 'loop z2)))))))
1356          (setf (gethash canonical-address mh-picon-cache)
1357                (mh-picon-file-contents match)))))
1358    
1359    (defun mh-picon-file-contents (file)
1360      "Return details about FILE.
1361    A list of consisting of a symbol for the type of the file and the file
1362    contents as a string is returned. If FILE is nil, then both elements of the
1363    list are nil."
1364      (if (stringp file)
1365          (with-temp-buffer
1366            (let ((type (and (string-match ".*\\.\\(...\\)$" file)
1367                             (intern (match-string 1 file)))))
1368              (insert-file-contents-literally file)
1369              (values type (buffer-string))))
1370        (values nil nil)))
1371    
1372    (defun mh-picon-generate-path (host-list user directory)
1373      "Generate the image file path.
1374    HOST-LIST is the parsed host address of the email address, USER the username
1375    and DIRECTORY is the directory relative to which the path is generated."
1376      (loop with acc = ""
1377            for elem in host-list
1378            do (setq acc (format "%s/%s" elem acc))
1379            finally return (format "%s/%s%s" directory acc user)))
1380    
1381    
1382    
1383  ;; X-Image-URL display  ;; X-Image-URL display
1384    
1385  (defvar mh-x-image-cache-directory nil  (defvar mh-x-image-cache-directory nil
1386    "Directory where X-Image-URL images are cached.")    "Directory where X-Image-URL images are cached.")
1387    (defvar mh-x-image-scaling-function
1388  (defvar mh-convert-executable (executable-find "convert"))    (cond ((executable-find "convert")
1389  (defvar mh-wget-executable (executable-find "wget"))           'mh-x-image-scale-with-convert)
1390            ((and (executable-find "anytopnm") (executable-find "pnmscale")
1391                  (executable-find "pnmtopng"))
1392             'mh-x-image-scale-with-pnm)
1393            (t 'ignore))
1394      "Function to use to scale image to proper size.")
1395    (defvar mh-wget-executable nil)
1396    (defvar mh-wget-choice
1397      (or (and (setq mh-wget-executable (executable-find "wget")) 'wget)
1398          (and (setq mh-wget-executable (executable-find "fetch")) 'fetch)
1399          (and (setq mh-wget-executable (executable-find "curl")) 'curl)))
1400    (defvar mh-wget-option
1401      (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O")))))
1402  (defvar mh-x-image-temp-file nil)  (defvar mh-x-image-temp-file nil)
1403  (defvar mh-x-image-url nil)  (defvar mh-x-image-url nil)
1404  (defvar mh-x-image-marker nil)  (defvar mh-x-image-marker nil)
1405  (defvar mh-x-image-url-cache-file nil)  (defvar mh-x-image-url-cache-file nil)
1406    
1407    ;; Functions to scale image to proper size
1408    (defun mh-x-image-scale-with-pnm (input output)
1409      "Scale image in INPUT file and write to OUTPUT file using pnm tools."
1410      (let ((res (shell-command-to-string
1411                  (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s"
1412                          input output))))
1413        (unless (equal res "")
1414          (delete-file output))))
1415    
1416    (defun mh-x-image-scale-with-convert (input output)
1417      "Scale image in INPUT file and write to OUTPUT file using ImageMagick."
1418      (call-process "convert" nil nil nil "-geometry" "96x48" input output))
1419    
1420  (defun mh-x-image-url-cache-canonicalize (url)  (defun mh-x-image-url-cache-canonicalize (url)
1421    "Canonicalize URL.    "Canonicalize URL.
1422  Replace the ?/ character with a ?! character."  Replace the ?/ character with a ?! character and append .png."
1423    (with-temp-buffer     (format "%s/%s.png" mh-x-image-cache-directory
1424      (insert url)             (with-temp-buffer
1425      (goto-char (point-min))               (insert url)
1426      (while (search-forward "/" nil t) (replace-match "!"))               (mh-replace-string "/" "!")
1427      (format "%s/%s.png" mh-x-image-cache-directory (buffer-string))))               (buffer-string))))
1428    
1429    (defun mh-x-image-set-download-state (file data)
1430      "Setup a symbolic link from FILE to DATA."
1431      (if data
1432          (make-symbolic-link (symbol-name data) file t)
1433        (delete-file file)))
1434    
1435    (defun mh-x-image-get-download-state (file)
1436      "Check the state of FILE by following any symbolic links."
1437      (unless (file-exists-p mh-x-image-cache-directory)
1438        (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
1439      (cond ((file-symlink-p file)
1440             (intern (file-name-nondirectory (file-chase-links file))))
1441            ((not (file-exists-p file)) nil)
1442            (t 'ok)))
1443    
1444  (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)  (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
1445    "Fetch and display the image specified by URL.    "Fetch and display the image specified by URL.
1446  After the image is fetched, it is stored in CACHE-FILE. It will be displayed  After the image is fetched, it is stored in CACHE-FILE. It will be displayed
1447  in a buffer and position specified by MARKER. The actual display is carried  in a buffer and position specified by MARKER. The actual display is carried
1448  out by the SENTINEL function."  out by the SENTINEL function."
1449    (if (and mh-wget-executable    (if mh-wget-executable
1450             mh-fetch-x-image-url        (let ((buffer (get-buffer-create (generate-new-buffer-name
1451             (or (eq mh-fetch-x-image-url t)                                          mh-temp-fetch-buffer)))
1452                 (y-or-n-p (format "Fetch %s? " url))))              (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
1453        (let ((buffer (get-buffer-create (generate-new-buffer-name " *mh-url*")))                            (expand-file-name (make-temp-name "~/mhe-fetch")))))
             (filename (make-temp-name "/tmp/mhe-wget")))  
1454          (save-excursion          (save-excursion
1455            (set-buffer buffer)            (set-buffer buffer)
1456            (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)            (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
1457            (set (make-local-variable 'mh-x-image-marker) marker)            (set (make-local-variable 'mh-x-image-marker) marker)
1458            (set (make-local-variable 'mh-x-image-temp-file) filename))            (set (make-local-variable 'mh-x-image-temp-file) filename))
1459          (set-process-sentinel          (set-process-sentinel
1460           (start-process "*wget*" buffer mh-wget-executable "-O" filename url)           (start-process "*mh-x-image-url-fetch*" buffer
1461                            mh-wget-executable mh-wget-option filename url)
1462           sentinel))           sentinel))
1463      ;; Make sure we don't ask about this image again      ;; Temporary failure
1464      (when (and mh-wget-executable (eq mh-fetch-x-image-url 'ask))      (mh-x-image-set-download-state cache-file 'try-again)))
       (make-symbolic-link mh-x-image-cache-directory cache-file t))))  
1465    
1466  (defun mh-x-image-display (image marker)  (defun mh-x-image-display (image marker)
1467    "Display IMAGE at MARKER."    "Display IMAGE at MARKER."
# Line 1326  out by the SENTINEL function." Line 1471  out by the SENTINEL function."
1471            (default-enable-multibyte-characters nil)            (default-enable-multibyte-characters nil)
1472            (buffer-modified-flag (buffer-modified-p)))            (buffer-modified-flag (buffer-modified-p)))
1473        (unwind-protect        (unwind-protect
1474            (when (and (file-readable-p image) (not (file-symlink-p image)))            (when (and (file-readable-p image) (not (file-symlink-p image))
1475                         (eq marker mh-x-image-marker))
1476              (goto-char marker)              (goto-char marker)
1477              (mh-do-in-gnu-emacs              (mh-do-in-gnu-emacs
1478                (mh-funcall-if-exists insert-image (create-image image 'png)))                (mh-funcall-if-exists insert-image (create-image image 'png)))
# Line 1350  The argument CHANGE is ignored." Line 1496  The argument CHANGE is ignored."
1496          (setq marker mh-x-image-marker          (setq marker mh-x-image-marker
1497                cache-filename mh-x-image-url-cache-file                cache-filename mh-x-image-url-cache-file
1498                temp-file mh-x-image-temp-file))                temp-file mh-x-image-temp-file))
1499        (when mh-convert-executable        (cond
1500          (call-process mh-convert-executable nil nil nil "-resize" "96x48"         ;; Check if we have `convert'
1501                         temp-file cache-filename))         ((eq mh-x-image-scaling-function 'ignore)
1502        (if (file-exists-p cache-filename)          (message "The `convert' program is needed to display X-Image-URL")
1503            (mh-x-image-display cache-filename marker)          (mh-x-image-set-download-state cache-filename 'try-again))
1504          (make-symbolic-link mh-x-image-cache-directory cache-filename t))         ;; Scale fetched image
1505           ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
1506                 nil))
1507           ;; Attempt to display image if we have it
1508           ((file-exists-p cache-filename)
1509            (mh-x-image-display cache-filename marker))
1510           ;; We didn't find the image. Should we try to display it the next time?
1511           (t (mh-x-image-set-download-state cache-filename 'try-again)))
1512        (ignore-errors        (ignore-errors
1513          (set-marker marker nil)          (set-marker marker nil)
1514          (delete-process process)          (delete-process process)
1515          (kill-buffer wget-buffer)          (kill-buffer wget-buffer)
1516          (delete-file temp-file)))))          (delete-file temp-file)))))
1517    
1518    (defun mh-x-image-url-sane-p (url)
1519      "Check if URL is something sensible."
1520      (let ((len (length url)))
1521        (cond ((< len 5) nil)
1522              ((not (equal (substring url 0 5) "http:")) nil)
1523              ((> len 100) nil)
1524              (t t))))
1525    
1526  (defun mh-x-image-url-display (url)  (defun mh-x-image-url-display (url)
1527    "Display image from location URL.    "Display image from location URL.
1528  If the URL isn't present in the cache then it is fetched with wget."  If the URL isn't present in the cache then it is fetched with wget."
1529    (let ((cache-filename (mh-x-image-url-cache-canonicalize url))    (let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
1530          (marker (set-marker (make-marker) (point))))           (state (mh-x-image-get-download-state cache-filename))
1531      (cond ((file-exists-p cache-filename)           (marker (set-marker (make-marker) (point))))
1532        (set (make-local-variable 'mh-x-image-marker) marker)
1533        (cond ((not (mh-x-image-url-sane-p url)))
1534              ((eq state 'ok)
1535             (mh-x-image-display cache-filename marker))             (mh-x-image-display cache-filename marker))
1536              ((or (not mh-wget-executable)
1537                   (eq mh-x-image-scaling-function 'ignore)))
1538              ((eq state 'never))
1539            ((not mh-fetch-x-image-url)            ((not mh-fetch-x-image-url)
1540             (set-marker marker nil))             (set-marker marker nil))
1541            ((and (not (file-exists-p mh-x-image-cache-directory))            ((eq state 'try-again)
1542                  (call-process "mkdir" nil nil nil mh-x-image-cache-directory)             (mh-x-image-set-download-state cache-filename nil)
1543                  nil))             (mh-x-image-url-fetch-image url cache-filename marker
1544            ((and (file-exists-p mh-x-image-cache-directory)                                         'mh-x-image-scale-and-display))
1545                  (file-directory-p mh-x-image-cache-directory))            ((and (eq mh-fetch-x-image-url 'ask)
1546                    (not (y-or-n-p (format "Fetch %s? " url))))
1547               (mh-x-image-set-download-state cache-filename 'never))
1548              ((eq state nil)
1549             (mh-x-image-url-fetch-image url cache-filename marker             (mh-x-image-url-fetch-image url cache-filename marker
1550                                         'mh-x-image-scale-and-display)))))                                         'mh-x-image-scale-and-display)))))
1551    
# Line 1386  If the URL isn't present in the cache th Line 1556  If the URL isn't present in the cache th
1556  If optional arg MSG is non-nil, display that message instead."  If optional arg MSG is non-nil, display that message instead."
1557    (if mh-showing-mode (mh-show msg)))    (if mh-showing-mode (mh-show msg)))
1558    
1559  (defun mh-show (&optional message)  (defun mh-show (&optional message redisplay-flag)
1560    "Show message at cursor.    "Show message at cursor.
1561  If optional argument MESSAGE is non-nil, display that message instead.  If optional argument MESSAGE is non-nil, display that message instead.
1562  Force a two-window display with the folder window on top (size given by the  Force a two-window display with the folder window on top (size given by the
1563  variable `mh-summary-height') and the show buffer below it.  variable `mh-summary-height') and the show buffer below it.
1564  If the message is already visible, display the start of the message.  If the message is already visible, display the start of the message.
1565    
1566    If REDISPLAY-FLAG is non-nil, the default when called interactively, the
1567    message is redisplayed even if the show buffer was already displaying the
1568    correct message.
1569    
1570  Display of the message is controlled by setting the variables  Display of the message is controlled by setting the variables
1571  `mh-clean-message-header-flag' and `mhl-formfile'.  The default behavior is  `mh-clean-message-header-flag' and `mhl-formfile'.  The default behavior is
1572  to scroll uninteresting headers off the top of the window.  to scroll uninteresting headers off the top of the window.
1573  Type \"\\[mh-header-display]\" to see the message with all its headers."  Type \"\\[mh-header-display]\" to see the message with all its headers."
1574    (interactive)    (interactive (list nil t))
1575    (and mh-showing-with-headers    (when (or redisplay-flag
1576         (or mhl-formfile mh-clean-message-header-flag)              (and mh-showing-with-headers
1577         (mh-invalidate-show-buffer))                   (or mhl-formfile mh-clean-message-header-flag)))
1578        (mh-invalidate-show-buffer))
1579    (mh-show-msg message))    (mh-show-msg message))
1580    
1581  (defun mh-show-mouse (EVENT)  (defun mh-show-mouse (event)
1582    "Move point to mouse EVENT and show message."    "Move point to mouse EVENT and show message."
1583    (interactive "e")    (interactive "e")
1584    (mouse-set-point EVENT)    (mouse-set-point event)
1585    (mh-show))    (mh-show))
1586    
1587  (defun mh-summary-height ()  (defun mh-summary-height ()
# Line 1428  arguments, after the message has been di Line 1603  arguments, after the message has been di
1603    (let ((folder mh-current-folder)    (let ((folder mh-current-folder)
1604          (folders (list mh-current-folder))          (folders (list mh-current-folder))
1605          (clean-message-header mh-clean-message-header-flag)          (clean-message-header mh-clean-message-header-flag)
1606          (show-window (get-buffer-window mh-show-buffer)))          (show-window (get-buffer-window mh-show-buffer))
1607            (display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag))
1608      (if (not (eq (next-window (minibuffer-window)) (selected-window)))      (if (not (eq (next-window (minibuffer-window)) (selected-window)))
1609          (delete-other-windows))         ; force ourself to the top window          (delete-other-windows))         ; force ourself to the top window
1610      (mh-in-show-buffer (mh-show-buffer)      (mh-in-show-buffer (mh-show-buffer)
1611          (setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag)
1612        (if (and show-window        (if (and show-window
1613                 (equal (mh-msg-filename msg folder) buffer-file-name))                 (equal (mh-msg-filename msg folder) buffer-file-name))
1614            (progn                        ;just back up to start            (progn                        ;just back up to start
# Line 1443  arguments, after the message has been di Line 1620  arguments, after the message has been di
1620          (shrink-window (- (window-height) (or mh-summary-height          (shrink-window (- (window-height) (or mh-summary-height
1621                                                (mh-summary-height)))))                                                (mh-summary-height)))))
1622      (mh-recenter nil)      (mh-recenter nil)
1623        ;; The following line is a nop which forces update of the scan line so
1624        ;; that font-lock will update it (if needed)...
1625        (mh-notate nil nil mh-cmd-note)
1626      (if (not (memq msg mh-seen-list))      (if (not (memq msg mh-seen-list))
1627          (setq mh-seen-list (cons msg mh-seen-list)))          (setq mh-seen-list (cons msg mh-seen-list)))
1628      (when mh-update-sequences-after-mh-show-flag      (when mh-update-sequences-after-mh-show-flag
# Line 1518  Sets the current buffer to the show buff Line 1698  Sets the current buffer to the show buff
1698      ;; Bind variables in folder buffer in case they are local      ;; Bind variables in folder buffer in case they are local
1699      (let ((formfile mhl-formfile)      (let ((formfile mhl-formfile)
1700            (clean-message-header mh-clean-message-header-flag)            (clean-message-header mh-clean-message-header-flag)
1701            (invisible-headers mh-invisible-headers)            (invisible-headers mh-invisible-header-fields-compiled)
1702            (visible-headers mh-visible-headers)            (visible-headers nil)
1703            (msg-filename (mh-msg-filename msg-num folder-name))            (msg-filename (mh-msg-filename msg-num folder-name))
1704            (show-buffer mh-show-buffer)            (show-buffer mh-show-buffer)
1705            (mm-inline-media-tests mh-mm-inline-media-tests))            (mm-inline-media-tests mh-mm-inline-media-tests))
# Line 1596  Sets the current buffer to the show buff Line 1776  Sets the current buffer to the show buff
1776  Header is cleaned from START to the end of the message header.  Header is cleaned from START to the end of the message header.
1777  INVISIBLE-HEADERS contains a regular expression specifying lines to delete  INVISIBLE-HEADERS contains a regular expression specifying lines to delete
1778  from the header. VISIBLE-HEADERS contains a regular expression specifying the  from the header. VISIBLE-HEADERS contains a regular expression specifying the
1779  lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil."  lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil.
1780    
1781    Note that MH-E no longer supports the `mh-visible-headers' variable, so
1782    this function could be trimmed of this feature too."
1783    (let ((case-fold-search t)    (let ((case-fold-search t)
1784          (buffer-read-only nil)          (buffer-read-only nil)
1785          (after-change-functions nil))   ;Work around emacs-20 font-lock bug          (after-change-functions nil))   ;Work around emacs-20 font-lock bug
# Line 1639  If NOTATION is nil then no change in the Line 1822  If NOTATION is nil then no change in the
1822          (with-mh-folder-updating (t)          (with-mh-folder-updating (t)
1823            (beginning-of-line)            (beginning-of-line)
1824            (forward-char offset)            (forward-char offset)
1825            (let* ((change-stack-flag (and (stringp notation)            (let* ((change-stack-flag (and (equal offset (1+ mh-cmd-note))
                                          (equal offset (1+ mh-cmd-note))  
1826                                           (not (eq notation mh-note-seq))))                                           (not (eq notation mh-note-seq))))
1827                   (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))                   (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))
1828                   (stack (and msg (gethash msg mh-sequence-notation-history)))                   (stack (and msg (gethash msg mh-sequence-notation-history)))
# Line 1652  If NOTATION is nil then no change in the Line 1834  If NOTATION is nil then no change in the
1834                  ;; at the bottom of the stack. If the sequence is deleted,                  ;; at the bottom of the stack. If the sequence is deleted,
1835                  ;; the correct notation will be shown.                  ;; the correct notation will be shown.
1836                  (setf (gethash msg mh-sequence-notation-history)                  (setf (gethash msg mh-sequence-notation-history)
1837                        (reverse (cons (aref notation 0) (cdr (reverse stack)))))                        (reverse (cons notation (cdr (reverse stack)))))
1838                ;; Since we don't have any sequence notations in the way, just                ;; Since we don't have any sequence notations in the way, just
1839                ;; notate the scan line.                ;; notate the scan line.
1840                (delete-char 1)                (delete-char 1)
# Line 1660  If NOTATION is nil then no change in the Line 1842  If NOTATION is nil then no change in the
1842              (when change-stack-flag              (when change-stack-flag
1843                (mh-thread-update-scan-line-map msg notation offset)))))))                (mh-thread-update-scan-line-map msg notation offset)))))))
1844    
 (defun mh-find-msg-get-num (step)  
   "Return the message number of the message nearest the cursor.  
 Jumps over non-message lines, such as inc errors.  
 If we have to search, STEP tells whether to search forward or backward."  
   (or (mh-get-msg-num nil)  
       (let ((msg-num nil)  
             (nreverses 0))  
         (while (and (not msg-num)  
                     (< nreverses 2))  
           (cond ((eobp)  
                  (setq step -1)  
                  (setq nreverses (1+ nreverses)))  
                 ((bobp)  
                  (setq step 1)  
                  (setq nreverses (1+ nreverses))))  
           (forward-line step)  
           (setq msg-num (mh-get-msg-num nil)))  
         msg-num)))  
   
1845  (defun mh-goto-msg (number &optional no-error-if-no-message dont-show)  (defun mh-goto-msg (number &optional no-error-if-no-message dont-show)
1846    "Position the cursor at message NUMBER.    "Position the cursor at message NUMBER.
1847  Optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means return nil  Optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means return nil
# Line 1699  Non-nil third argument DONT-SHOW means n Line 1862  Non-nil third argument DONT-SHOW means n
1862      (or dont-show (not return-value) (mh-maybe-show number))      (or dont-show (not return-value) (mh-maybe-show number))
1863      return-value))      return-value))
1864    
 (defun mh-msg-search-pat (n)  
   "Return a search pattern for message N in the scan listing."  
   (format mh-scan-msg-search-regexp n))  
   
1865  (defun mh-get-profile-field (field)  (defun mh-get-profile-field (field)
1866    "Find and return the value of FIELD in the current buffer.    "Find and return the value of FIELD in the current buffer.
1867  Returns nil if the field is not in the buffer."  Returns nil if the field is not in the buffer."
# Line 1716  Returns nil if the field is not in the b Line 1875  Returns nil if the field is not in the b
1875               (end-of-line)               (end-of-line)
1876               (buffer-substring start (point)))))))               (buffer-substring start (point)))))))
1877    
 (defvar mail-user-agent)  
 (defvar read-mail-command)  
   
1878  (defvar mh-find-path-run nil  (defvar mh-find-path-run nil
1879    "Non-nil if `mh-find-path' has been run already.")    "Non-nil if `mh-find-path' has been run already.")
1880    
1881  (defun mh-find-path ()  (defun mh-find-path ()
1882    "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables.    "Set variables from user's MH profile.
1883  Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq',  Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq',
1884  `mh-inbox' from user's MH profile.  `mh-inbox' from user's MH profile.
1885  The value of `mh-find-path-hook' is a list of functions to be called, with no  The value of `mh-find-path-hook' is a list of functions to be called, with no
1886  arguments, after these variable have been set."  arguments, after these variable have been set."
1887    (mh-find-progs)    (mh-variants)
1888    (unless mh-find-path-run    (unless mh-find-path-run
1889      (setq mh-find-path-run t)      (setq mh-find-path-run t)
1890      (setq read-mail-command 'mh-rmail)      (save-excursion
1891      (setq mail-user-agent 'mh-e-user-agent))        ;; Be sure profile is fully expanded before switching buffers
1892    (save-excursion        (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile"))))
1893      ;; Be sure profile is fully expanded before switching buffers          (set-buffer (get-buffer-create mh-temp-buffer))
1894      (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile"))))          (setq buffer-offer-save nil)      ;for people who set default to t
1895        (set-buffer (get-buffer-create mh-temp-buffer))          (erase-buffer)
1896        (setq buffer-offer-save nil)      ;for people who set default to t          (condition-case err
1897        (erase-buffer)              (insert-file-contents profile)
1898        (condition-case err            (file-error
1899            (insert-file-contents profile)             (mh-install profile err)))
1900          (file-error          (setq mh-user-path (mh-get-profile-field "Path:"))
1901           (mh-install profile err)))          (if (not mh-user-path)
1902        (setq mh-user-path (mh-get-profile-field "Path:"))              (setq mh-user-path "Mail"))
1903        (if (not mh-user-path)          (setq mh-user-path
1904            (setq mh-user-path "Mail"))                (file-name-as-directory
1905        (setq mh-user-path                 (expand-file-name mh-user-path (expand-file-name "~"))))
1906              (file-name-as-directory          (unless mh-x-image-cache-directory
1907               (expand-file-name mh-user-path (expand-file-name "~"))))            (setq mh-x-image-cache-directory
1908        (unless mh-x-image-cache-directory                  (expand-file-name ".mhe-x-image-cache" mh-user-path)))
1909          (setq mh-x-image-cache-directory          (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:"))
1910                (expand-file-name ".mhe-x-image-cache" mh-user-path)))          (if mh-draft-folder
1911        (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:"))              (progn
1912        (if mh-draft-folder                (if (not (mh-folder-name-p mh-draft-folder))
1913            (progn                    (setq mh-draft-folder (format "+%s" mh-draft-folder)))
1914              (if (not (mh-folder-name-p mh-draft-folder))                (if (not (file-exists-p (mh-expand-file-name mh-draft-folder)))
1915                  (setq mh-draft-folder (format "+%s" mh-draft-folder)))                    (error
1916              (if (not (file-exists-p (mh-expand-file-name mh-draft-folder)))                     "Draft folder \"%s\" not found.  Create it and try again"
1917                  (error "Draft folder \"%s\" not found.  Create it and try again"                           (mh-expand-file-name mh-draft-folder)))))
1918                         (mh-expand-file-name mh-draft-folder)))))          (setq mh-inbox (mh-get-profile-field "Inbox:"))
1919        (setq mh-inbox (mh-get-profile-field "Inbox:"))          (cond ((not mh-inbox)
1920        (cond ((not mh-inbox)                 (setq mh-inbox "+inbox"))
1921               (setq mh-inbox "+inbox"))                ((not (mh-folder-name-p mh-inbox))
1922              ((not (mh-folder-name-p mh-inbox))                 (setq mh-inbox (format "+%s" mh-inbox))))
1923               (setq mh-inbox (format "+%s" mh-inbox))))          (setq mh-unseen-seq (mh-get-profile-field "Unseen-Sequence:"))
1924        (setq mh-unseen-seq (mh-get-profile-field "Unseen-Sequence:"))          (if mh-unseen-seq
1925        (if mh-unseen-seq              (setq mh-unseen-seq (intern mh-unseen-seq))
1926            (setq mh-unseen-seq (intern mh-unseen-seq))            (setq mh-unseen-seq 'unseen))   ;old MH default?
1927          (setq mh-unseen-seq 'unseen))   ;old MH default?          (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:"))
1928        (setq mh-previous-seq (mh-get-profile-field "Previous-Sequence:"))          (if mh-previous-seq
1929        (if mh-previous-seq              (setq mh-previous-seq (intern mh-previous-seq)))
1930            (setq mh-previous-seq (intern mh-previous-seq)))          (run-hooks 'mh-find-path-hook)
1931        (run-hooks 'mh-find-path-hook)          (mh-collect-folder-names)))))
       (mh-collect-folder-names))))  
1932    
1933  (defun mh-file-command-p (file)  (defun mh-file-command-p (file)
1934    "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."
1935    (and (file-regular-p file) (file-executable-p file)))    (and (file-regular-p file) (file-executable-p file)))
1936    
 (defun mh-find-progs ()  
   "Find the directories for the installed MH/nmh binaries and config files.  
 Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the  
 directory names and set `mh-nmh-flag' if we detect nmh instead of MH."  
   (unless (and mh-progs mh-lib mh-lib-progs)  
     (let ((path (or (mh-path-search exec-path "mhparam")  
                     (mh-path-search '("/usr/local/nmh/bin" ; nmh default  
                                       "/usr/local/bin/mh/"  
                                       "/usr/local/mh/"  
                                       "/usr/bin/mh/" ;Ultrix 4.2, Linux  
                                       "/usr/new/mh/" ;Ultrix <4.2  
                                       "/usr/contrib/mh/bin/" ;BSDI  
                                       "/usr/pkg/bin/" ; NetBSD  
                                       "/usr/local/bin/"  
                                       )  
                                     "mhparam"))))  
       (if (not path)  
           (error "Unable to find the `mhparam' command"))  
       (save-excursion  
         (let ((tmp-buffer (get-buffer-create mh-temp-buffer)))  
           (set-buffer tmp-buffer)  
           (unwind-protect  
               (progn  
                 (call-process (expand-file-name "mhparam" path)  
                               nil '(t nil) nil "libdir" "etcdir")  
                 (goto-char (point-min))  
                 (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$"  
                                            nil t)  
                     (setq mh-lib-progs (match-string 1)  
                           mh-lib mh-lib-progs  
                           mh-progs path))  
                 (goto-char (point-min))  
                 (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$"  
                                            nil t)  
                     (setq mh-lib (match-string 1)  
                           mh-nmh-flag t)))  
             (kill-buffer tmp-buffer))))  
       (unless (and mh-progs mh-lib mh-lib-progs)  
         (error "Unable to determine paths from `mhparam' command"))  
       (setq mh-flists-present-flag  
             (file-exists-p (expand-file-name "flists" mh-progs))))))  
   
 (defun mh-path-search (path file)  
   "Search PATH, a list of directory names, for FILE.  
 Returns the element of PATH that contains FILE, or nil if not found."  
   (while (and path  
               (not (funcall 'mh-file-command-p  
                             (expand-file-name file (car path)))))  
     (setq path (cdr path)))  
   (car path))  
   
1937  (defvar mh-no-install nil)              ;do not run install-mh  (defvar mh-no-install nil)              ;do not run install-mh
1938    
1939  (defun mh-install (profile error-val)  (defun mh-install (profile error-val)
# Line 1911  not updated." Line 2015  not updated."
2015    (let ((entry (mh-find-seq seq))    (let ((entry (mh-find-seq seq))
2016          (internal-seq-flag (mh-internal-seq seq)))          (internal-seq-flag (mh-internal-seq seq)))
2017      (if (and msgs (atom msgs)) (setq msgs (list msgs)))      (if (and msgs (atom msgs)) (setq msgs (list msgs)))
     (unless internal-flag  
       (mh-add-to-sequence seq msgs)  
       (when (not dont-annotate-flag)  
         (mh-iterate-on-range msg msgs  
           (unless (memq msg (cdr entry))  
             (mh-add-sequence-notation msg internal-seq-flag)))))  
2018      (if (null entry)      (if (null entry)
2019          (setq mh-seq-list          (setq mh-seq-list
2020                (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))                (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
2021                      mh-seq-list))                      mh-seq-list))
2022        (if msgs (setcdr entry (mh-canonicalize-sequence        (if msgs (setcdr entry (mh-canonicalize-sequence
2023                                (append msgs (mh-seq-msgs entry))))))))                                (append msgs (mh-seq-msgs entry))))))
2024        (unless internal-flag
2025          (mh-add-to-sequence seq msgs)
2026          (when (not dont-annotate-flag)
2027            (mh-iterate-on-range msg msgs
2028              (unless (memq msg (cdr entry))
2029                (mh-add-sequence-notation msg internal-seq-flag)))))))
2030    
2031  (defun mh-canonicalize-sequence (msgs)  (defun mh-canonicalize-sequence (msgs)
2032    "Sort MSGS in decreasing order and remove duplicates."    "Sort MSGS in decreasing order and remove duplicates."
# Line 2076  aren't usually mail folders are hidden." Line 2180  aren't usually mail folders are hidden."
2180        (goto-char (point-min))        (goto-char (point-min))
2181        (while (not (and (eolp) (bolp)))        (while (not (and (eolp) (bolp)))
2182          (goto-char (line-end-position))          (goto-char (line-end-position))
2183          (let ((has-pos (search-backward " has " (line-beginning-position) t)))          (let ((start-pos (line-beginning-position))
2184                  (has-pos (search-backward " has " (line-beginning-position) t)))
2185            (when (integerp has-pos)            (when (integerp has-pos)
2186              (while (equal (char-after has-pos) ? )              (while (equal (char-after has-pos) ? )
2187                (decf has-pos))                (decf has-pos))
2188              (incf has-pos)              (incf has-pos)
2189              (let* ((name (buffer-substring (line-beginning-position) has-pos))              (while (equal (char-after start-pos) ? )
2190                  (incf start-pos))
2191                (let* ((name (buffer-substring start-pos has-pos))
2192                     (first-char (aref name 0))                     (first-char (aref name 0))
2193                     (last-char (aref name (1- (length name)))))                     (last-char (aref name (1- (length name)))))
2194                (unless (member first-char '(?. ?# ?,))                (unless (member first-char '(?. ?# ?,))
# Line 2189  whether the completion is over." Line 2296  whether the completion is over."
2296  If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name  If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name
2297  corresponding to `mh-user-path'."  corresponding to `mh-user-path'."
2298    (mh-normalize-folder-name    (mh-normalize-folder-name
2299     (let ((minibuffer-local-completion-map mh-folder-completion-map)     (let ((minibuffer-completing-file-name t)
2300             (completion-root-regexp "^[+/]")
2301             (minibuffer-local-completion-map mh-folder-completion-map)
2302           (mh-allow-root-folder-flag allow-root-folder-flag))           (mh-allow-root-folder-flag allow-root-folder-flag))
2303       (completing-read prompt 'mh-folder-completion-function nil nil nil       (completing-read prompt 'mh-folder-completion-function nil nil nil
2304                        'mh-folder-hist default))                        'mh-folder-hist default))
# Line 2206  non-nil then the function will accept th Line 2315  non-nil then the function will accept th
2315  when used in searching."  when used in searching."
2316    (if (null default)    (if (null default)
2317        (setq default ""))        (setq default ""))
2318    (let* ((default-string (cond (default-string (format " [%s]? "    (let* ((default-string (cond (default-string (format "[%s] " default-string))
2319                                                         default-string))                                 ((equal "" default) "")
2320                                 ((equal "" default) "? ")                                 (t (format "[%s] " default))))
2321                                 (t (format " [%s]? " default))))           (prompt (format "%s folder: %s" prompt default-string))
          (prompt (format "%s folder%s" prompt default-string))  
2322           (mh-current-folder-name mh-current-folder)           (mh-current-folder-name mh-current-folder)
2323           read-name folder-name)           read-name folder-name)
2324      (while (and (setq read-name (mh-folder-completing-read      (while (and (setq read-name (mh-folder-completing-read
# Line 2452  Put the output into buffer after point. Line 2560  Put the output into buffer after point.
2560        (setq l (cdr l)))        (setq l (cdr l)))
2561      new-list))      new-list))
2562    
2563    (defun mh-replace-string (old new)
2564      "Replace all occurrences of OLD with NEW in the current buffer."
2565      (goto-char (point-min))
2566      (let ((case-fold-search t))
2567        (while (search-forward old nil t)
2568          (replace-match new t t))))
2569    
2570  (defun mh-replace-in-string (regexp newtext string)  (defun mh-replace-in-string (regexp newtext string)
2571    "Replace REGEXP with NEWTEXT everywhere in STRING and return result.    "Replace REGEXP with NEWTEXT everywhere in STRING and return result.
2572  NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.  NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.

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

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