/[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 by lektu, Tue Feb 4 13:15:32 2003 UTC revision 1.4 by wohler, Fri Apr 25 05:52:00 2003 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, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc.  ;; Copyright (C) 1993, 95, 1997,
4    ;;  2000, 01, 02, 2003 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 30  Line 31 
31    
32  ;;; Change Log:  ;;; Change Log:
33    
 ;; $Id$  
   
34  ;;; Code:  ;;; Code:
35    
36  ;; Is this XEmacs-land? Located here since needed by mh-customize.el.  ;; Is this XEmacs-land? Located here since needed by mh-customize.el.
# Line 57  Line 56 
56    
57  ;;; Autoloads  ;;; Autoloads
58  (autoload 'gnus-article-highlight-citation "gnus-cite")  (autoload 'gnus-article-highlight-citation "gnus-cite")
59  (autoload 'mail-header-end "sendmail")  (require 'sendmail)
60  (autoload 'Info-goto-node "info")  (autoload 'Info-goto-node "info")
61  (unless (fboundp 'make-hash-table)  (unless (fboundp 'make-hash-table)
62    (autoload 'make-hash-table "cl"))    (autoload 'make-hash-table "cl"))
# Line 100  of `search' in the CL package." Line 99  of `search' in the CL package."
99          when (equal (aref string index) char) return index          when (equal (aref string index) char) return index
100          finally return nil))          finally return nil))
101    
102  ;;; Macro to generate correct code for different emacs variants  ;;; Macros to generate correct code for different emacs variants
103    
104    (defmacro mh-do-in-gnu-emacs (&rest body)
105      "Execute BODY if in GNU Emacs."
106      (unless mh-xemacs-flag `(progn ,@body)))
107    (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
108    
109    (defmacro mh-do-in-xemacs (&rest body)
110      "Execute BODY if in GNU Emacs."
111      (when mh-xemacs-flag `(progn ,@body)))
112    (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
113    
114    (defmacro mh-funcall-if-exists (function &rest args)
115      "Call FUNCTION with ARGS as parameters if it exists."
116      (if (fboundp function)
117          `(funcall ',function ,@args)))
118    
119    (defmacro mh-make-local-hook (hook)
120      "Make HOOK local if needed.
121    XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be
122    called."
123      (when (and (fboundp 'make-local-hook)
124                 (not (get 'make-local-hook 'byte-obsolete-info)))
125        `(make-local-hook ,hook)))
126    
127  (defmacro mh-mark-active-p (check-transient-mark-mode-flag)  (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
128    "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.    "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
# Line 287  passed through `regexp-quote' before bei Line 309  passed through `regexp-quote' before bei
309      (".*" mm-inline-text mm-readable-p))      (".*" mm-inline-text mm-readable-p))
310    "Alist of media types/tests saying whether types can be displayed inline.")    "Alist of media types/tests saying whether types can be displayed inline.")
311    
 ;; Needed by mh-comp.el and mh-mime.el  
 (defvar mh-mhn-compose-insert-flag nil  
   "Non-nil means MIME insertion was done.  
 Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'.  
 This variable is buffer-local.")  
 (make-variable-buffer-local 'mh-mhn-compose-insert-flag)  
   
 (defvar mh-mml-compose-insert-flag nil  
   "Non-nil means that a MIME insertion was done.  
 This buffer-local variable is used to remember if a MIME insertion was done.  
 Triggers an automatic call to `mh-mml-to-mime' in `mh-send-letter'.")  
 (make-variable-buffer-local 'mh-mml-compose-insert-flag)  
   
312  ;; Copy of `goto-address-mail-regexp'  ;; Copy of `goto-address-mail-regexp'
313  (defvar mh-address-mail-regexp  (defvar mh-address-mail-regexp
314    "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+"    "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+"
# Line 318  address.  If no e-mail address found, re Line 327  address.  If no e-mail address found, re
327                 (goto-char (match-beginning 0))))                 (goto-char (match-beginning 0))))
328        (match-string-no-properties 0)))        (match-string-no-properties 0)))
329    
330    (defun mh-mail-header-end ()
331      "Substitute for `mail-header-end' that doesn't widen the buffer.
332    In MH-E we frequently need to find the end of headers in nested messages, where
333    the buffer has been narrowed. This function works in this situation."
334      (save-excursion
335        (rfc822-goto-eoh)
336        (point)))
337    
338  (defun mh-in-header-p ()  (defun mh-in-header-p ()
339    "Return non-nil if the point is in the header of a draft message."    "Return non-nil if the point is in the header of a draft message."
340    (< (point) (mail-header-end)))    (< (point) (mh-mail-header-end)))
341    
342  (defun mh-header-field-beginning ()  (defun mh-header-field-beginning ()
343    "Move to the beginning of the current header field.    "Move to the beginning of the current header field.
# Line 342  Handles RFC 822 continuation lines." Line 359  Handles RFC 822 continuation lines."
359  Argument LIMIT limits search."  Argument LIMIT limits search."
360    (if (= (point) limit)    (if (= (point) limit)
361        nil        nil
362      (let* ((mail-header-end (save-match-data (mail-header-end)))      (let* ((mail-header-end (save-match-data (mh-mail-header-end)))
363             (lesser-limit (if (< mail-header-end limit) mail-header-end limit)))             (lesser-limit (if (< mail-header-end limit) mail-header-end limit)))
364        (when (mh-in-header-p)        (when (mh-in-header-p)
365          (set-match-data (list 1 lesser-limit))          (set-match-data (list 1 lesser-limit))
# Line 354  Argument LIMIT limits search." Line 371  Argument LIMIT limits search."
371  Argument LIMIT limits search."  Argument LIMIT limits search."
372    (if (= (point) limit)    (if (= (point) limit)
373        nil        nil
374      (let* ((mail-header-end (mail-header-end))      (let* ((mail-header-end (mh-mail-header-end))
375             (lesser-limit (if (< mail-header-end limit) mail-header-end limit))             (lesser-limit (if (< mail-header-end limit) mail-header-end limit))
376             (case-fold-search t))             (case-fold-search t))
377        (when (and (< (point) mail-header-end) ;Only within header        (when (and (< (point) mail-header-end) ;Only within header
# Line 424  Used when `mh-highlight-citation-p' is s Line 441  Used when `mh-highlight-citation-p' is s
441  dealt with by gnus highlighting. The region between BEG and END is  dealt with by gnus highlighting. The region between BEG and END is
442  given over to be fontified and LOUDLY controls if a user sees a  given over to be fontified and LOUDLY controls if a user sees a
443  message about the fontification operation."  message about the fontification operation."
444    (let ((header-end (mail-header-end)))    (let ((header-end (mh-mail-header-end)))
445      (cond      (cond
446       ((and (< beg header-end)(< end header-end))       ((and (< beg header-end)(< end header-end))
447        (font-lock-default-fontify-region beg end loudly))        (font-lock-default-fontify-region beg end loudly))
# Line 501  message about the fontification operatio Line 518  message about the fontification operatio
518  (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
519  (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent  (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent
520  (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list  (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list
521    (defconst mh-mail-delivery-buffer "*MH-E Mail Delivery*") ;mail delivery log
522    
523    ;; Number of lines to keep in mh-log-buffer.
524    (defvar mh-log-buffer-lines 100)
525    
526  ;; Window configuration before MH-E command.  ;; Window configuration before MH-E command.
527  (defvar mh-previous-window-config nil)  (defvar mh-previous-window-config nil)
# Line 535  message about the fontification operatio Line 556  message about the fontification operatio
556    
557  (defun mh-logo-display ()  (defun mh-logo-display ()
558    "Modify mode line to display MH-E logo."    "Modify mode line to display MH-E logo."
559    (when (fboundp 'find-image)    (mh-do-in-gnu-emacs
560      (add-text-properties     (add-text-properties
561       0 2      0 2
562       `(display ,(or mh-logo-cache      `(display ,(or mh-logo-cache
563                      (setq mh-logo-cache                     (setq mh-logo-cache
564                            (find-image '((:type xpm :ascent center                           (mh-funcall-if-exists
565                                           :file "mh-logo.xpm"))))))                            find-image '((:type xpm :ascent center
566       (car mode-line-buffer-identification))))                                                :file "mh-logo.xpm"))))))
567        (car mode-line-buffer-identification)))
568      (mh-do-in-xemacs
569       (setq modeline-buffer-identification
570             (list
571              (if mh-modeline-glyph
572                  (cons modeline-buffer-id-left-extent mh-modeline-glyph)
573                (cons modeline-buffer-id-left-extent "XEmacs%N:"))
574              (cons modeline-buffer-id-right-extent " %17b")))))
575    
576    
577  ;;; This holds a documentation string used by describe-mode.  ;;; This holds a documentation string used by describe-mode.
578  (defun mh-showing-mode (&optional arg)  (defun mh-showing-mode (&optional arg)
# Line 585  flag is unchanged, otherwise it is clear Line 615  flag is unchanged, otherwise it is clear
615       ,@(if (not save-modification-flag)       ,@(if (not save-modification-flag)
616             '((mh-set-folder-modified-p nil)))))             '((mh-set-folder-modified-p nil)))))
617    
618  (put 'with-mh-folder-updating 'lisp-indent-hook 1)  (put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
619    
620  (defmacro mh-in-show-buffer (show-buffer &rest body)  (defmacro mh-in-show-buffer (show-buffer &rest body)
621    "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).    "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
# Line 600  Stronger than `save-excursion', weaker t Line 630  Stronger than `save-excursion', weaker t
630             ,@body)             ,@body)
631         (select-window mh-in-show-buffer-saved-window))))         (select-window mh-in-show-buffer-saved-window))))
632    
633  (put 'mh-in-show-buffer 'lisp-indent-hook 1)  (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
634    
635  (defmacro mh-make-seq (name msgs)  (defmacro mh-make-seq (name msgs)
636    "Create sequence NAME with the given MSGS."    "Create sequence NAME with the given MSGS."
# Line 726  still visible.\n") Line 756  still visible.\n")
756                          folder-buffer)                          folder-buffer)
757             (delete-other-windows))             (delete-other-windows))
758           (mh-goto-cur-msg t)           (mh-goto-cur-msg t)
759           (and (fboundp 'deactivate-mark) (deactivate-mark))           (mh-funcall-if-exists deactivate-mark)
760           (unwind-protect           (unwind-protect
761               (prog1 (call-interactively (function ,original-function))               (prog1 (call-interactively (function ,original-function))
762                 (setq normal-exit t))                 (setq normal-exit t))
763             (and (fboundp 'deactivate-mark) (deactivate-mark))             (mh-funcall-if-exists deactivate-mark)
764             (cond ((not normal-exit)             (cond ((not normal-exit)
765                    (set-window-configuration config))                    (set-window-configuration config))
766                   ,(if dont-return                   ,(if dont-return
# Line 819  still visible.\n") Line 849  still visible.\n")
849  (mh-defun-show-buffer mh-show-thread-previous-sibling  (mh-defun-show-buffer mh-show-thread-previous-sibling
850                        mh-thread-previous-sibling)                        mh-thread-previous-sibling)
851  (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t)  (mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t)
852    (mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick)
853    (mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick)
854    (mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist)
855    (mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist)
856    (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages)
857    
858  ;;; Populate mh-show-mode-map  ;;; Populate mh-show-mode-map
859  (gnus-define-keys mh-show-mode-map  (gnus-define-keys mh-show-mode-map
860    " "    mh-show-page-msg    " "    mh-show-page-msg
861    "!"    mh-show-refile-or-write-again    "!"    mh-show-refile-or-write-again
862      "'"    mh-show-toggle-tick
863    ","    mh-show-header-display    ","    mh-show-header-display
864    "."    mh-show-show    "."    mh-show-show
865    ">"    mh-show-write-message-to-file    ">"    mh-show-write-message-to-file
# Line 867  still visible.\n") Line 903  still visible.\n")
903    "i"    mh-index-search    "i"    mh-index-search
904    "k"    mh-show-kill-folder    "k"    mh-show-kill-folder
905    "l"    mh-show-list-folders    "l"    mh-show-list-folders
906      "n"    mh-index-new-messages
907    "o"    mh-show-visit-folder    "o"    mh-show-visit-folder
908    "r"    mh-show-rescan-folder    "r"    mh-show-rescan-folder
909    "s"    mh-show-search-folder    "s"    mh-show-search-folder
# Line 884  still visible.\n") Line 921  still visible.\n")
921    "s"    mh-show-msg-is-in-seq    "s"    mh-show-msg-is-in-seq
922    "w"    mh-show-widen)    "w"    mh-show-widen)
923    
924    (define-key mh-show-mode-map "I" mh-inc-spool-map)
925    
926    (gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map)
927      "?"    mh-prefix-help
928      "b"    mh-show-junk-blacklist
929      "w"    mh-show-junk-whitelist)
930    
931  (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map)  (gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map)
932    "?"    mh-prefix-help    "?"    mh-prefix-help
933    "u"    mh-show-thread-ancestor    "u"    mh-show-thread-ancestor
# Line 894  still visible.\n") Line 938  still visible.\n")
938    "o"    mh-show-thread-refile)    "o"    mh-show-thread-refile)
939    
940  (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map)  (gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map)
941      "'"    mh-show-narrow-to-tick
942    "?"    mh-prefix-help    "?"    mh-prefix-help
943    "s"    mh-show-narrow-to-subject    "s"    mh-show-narrow-to-subject
944    "w"    mh-show-widen)    "w"    mh-show-widen)
# Line 932  still visible.\n") Line 977  still visible.\n")
977      ["Widen from Sequence"              mh-show-widen t]      ["Widen from Sequence"              mh-show-widen t]
978      "--"      "--"
979      ["Narrow to Subject Sequence"       mh-show-narrow-to-subject t]      ["Narrow to Subject Sequence"       mh-show-narrow-to-subject t]
980        ["Narrow to Tick Sequence"          mh-show-narrow-to-tick
981         (save-excursion
982           (set-buffer mh-show-folder-buffer)
983           (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))]
984      ["Delete Rest of Same Subject"      mh-show-delete-subject t]      ["Delete Rest of Same Subject"      mh-show-delete-subject t]
985        ["Toggle Tick Mark"                 mh-show-toggle-tick t]
986      "--"      "--"
987      ["Push State Out to MH"             mh-show-update-sequences t]))      ["Push State Out to MH"             mh-show-update-sequences t]))
988    
# Line 979  still visible.\n") Line 1029  still visible.\n")
1029      "--"      "--"
1030      ["List Folders"                     mh-show-list-folders t]      ["List Folders"                     mh-show-list-folders t]
1031      ["Visit a Folder..."                mh-show-visit-folder t]      ["Visit a Folder..."                mh-show-visit-folder t]
1032        ["View New Messages"                mh-show-index-new-messages t]
1033      ["Search a Folder..."               mh-show-search-folder t]      ["Search a Folder..."               mh-show-search-folder t]
1034      ["Indexed Search..."                mh-index-search t]      ["Indexed Search..."                mh-index-search t]
1035      "--"      "--"
# Line 988  still visible.\n") Line 1039  still visible.\n")
1039  ;;; 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.
1040  (put 'mh-show-mode 'mode-class 'special)  (put 'mh-show-mode 'mode-class 'special)
1041    
1042    ;; Avoid compiler warning
1043    (defvar tool-bar-map)
1044    
1045  (define-derived-mode mh-show-mode text-mode "MH-Show"  (define-derived-mode mh-show-mode text-mode "MH-Show"
1046    "Major mode for showing messages in MH-E.\\<mh-show-mode-map>    "Major mode for showing messages in MH-E.\\<mh-show-mode-map>
1047  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
# Line 1015  be called, with no arguments, upon entry Line 1069  be called, with no arguments, upon entry
1069        (turn-on-font-lock))        (turn-on-font-lock))
1070    (if (and (boundp 'tool-bar-mode) tool-bar-mode)    (if (and (boundp 'tool-bar-mode) tool-bar-mode)
1071        (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))        (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))
1072      (mh-funcall-if-exists mh-toolbar-init :show)
1073    (when mh-decode-mime-flag    (when mh-decode-mime-flag
1074        (mh-make-local-hook 'kill-buffer-hook)
1075      (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t))      (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t))
1076    (easy-menu-add mh-show-sequence-menu)    (easy-menu-add mh-show-sequence-menu)
1077    (easy-menu-add mh-show-message-menu)    (easy-menu-add mh-show-message-menu)
# Line 1034  be called, with no arguments, upon entry Line 1090  be called, with no arguments, upon entry
1090      (if (fboundp 'goto-address)      (if (fboundp 'goto-address)
1091          (goto-address))))          (goto-address))))
1092    
1093    
1094    
1095    ;; X-Face and Face display
1096  (defvar mh-show-xface-function  (defvar mh-show-xface-function
1097    (cond ((and mh-xemacs-flag (locate-library "x-face"))    (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface)))
1098           (load "x-face" t t)           (load "x-face" t t)
1099           (if (fboundp 'x-face-xmas-wl-display-x-face)           #'mh-face-display-function)
1100               #'x-face-xmas-wl-display-x-face          ((>= emacs-major-version 21)
1101             #'ignore))           #'mh-face-display-function)
         ((and (not mh-xemacs-flag) (>= emacs-major-version 21))  
          (load "x-face-e21" t t)  
          (if (fboundp 'x-face-decode-message-header)  
              #'x-face-decode-message-header  
            #'ignore))  
1102          (t #'ignore))          (t #'ignore))
1103    "Determine at run time what function should be called to display X-Face.")    "Determine at run time what function should be called to display X-Face.")
1104    
1105    (defvar mh-uncompface-executable
1106      (and (fboundp 'executable-find) (executable-find "uncompface")))
1107    
1108    (defun mh-face-to-png (data)
1109      "Convert base64 encoded DATA to png image."
1110      (with-temp-buffer
1111        (insert data)
1112        (ignore-errors (base64-decode-region (point-min) (point-max)))
1113        (buffer-string)))
1114    
1115    (defun mh-uncompface (data)
1116      "Run DATA through `uncompface' to generate bitmap."
1117      (with-temp-buffer
1118        (insert data)
1119        (when (and mh-uncompface-executable
1120                   (equal (call-process-region (point-min) (point-max)
1121                                               mh-uncompface-executable t '(t nil))
1122                          0))
1123          (mh-icontopbm)
1124          (buffer-string))))
1125    
1126    (defun mh-icontopbm ()
1127      "Elisp substitute for `icontopbm'."
1128      (goto-char (point-min))
1129      (let ((end (point-max)))
1130        (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
1131          (save-excursion
1132            (goto-char (point-max))
1133            (insert (string-to-number (match-string 1) 16))
1134            (insert (string-to-number (match-string 2) 16))))
1135        (delete-region (point-min) end)
1136        (goto-char (point-min))
1137        (insert "P4\n48 48\n")))
1138    
1139    (mh-do-in-xemacs (defvar default-enable-multibyte-characters))
1140    
1141    (defun mh-face-display-function ()
1142      "Display a Face or X-Face header field.
1143    Display Face if both are present."
1144      (save-restriction
1145        (goto-char (point-min))
1146        (re-search-forward "\n\n" (point-max) t)
1147        (narrow-to-region (point-min) (point))
1148        (let* ((case-fold-search t)
1149               (default-enable-multibyte-characters nil)
1150               (face (message-fetch-field "face" t))
1151               (x-face (message-fetch-field "x-face" t))
1152               (url (message-fetch-field "x-image-url" t))
1153               raw type)
1154          (cond (face (setq raw (mh-face-to-png face)
1155                            type 'png))
1156                (x-face (setq raw (mh-uncompface x-face)
1157                              type 'pbm))
1158                (url (setq type 'url)))
1159          (when type
1160            (goto-char (point-min))
1161            (when (re-search-forward "^from:" (point-max) t)
1162              ;; GNU Emacs
1163              (mh-do-in-gnu-emacs
1164                (if (eq type 'url)
1165                    (mh-x-image-url-display url)
1166                  (mh-funcall-if-exists
1167                   insert-image (create-image
1168                                 raw type t
1169                                 :foreground (face-foreground 'mh-show-xface-face)
1170                                 :background (face-background 'mh-show-xface-face))
1171                                " ")))
1172              ;; XEmacs
1173              (mh-do-in-xemacs
1174                (cond
1175                 ((eq type 'url)
1176                  (mh-x-image-url-display url))
1177                 ((eq type 'png)
1178                  (when (featurep 'png)
1179                    (set-extent-begin-glyph
1180                     (make-extent (point) (point))
1181                     (make-glyph (vector 'png ':data (mh-face-to-png face))))))
1182                 ;; Try internal xface support if available...
1183                 ((and (eq type 'pbm) (featurep 'xface))
1184                  (set-glyph-face
1185                   (set-extent-begin-glyph
1186                    (make-extent (point) (point))
1187                    (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
1188                   'mh-show-xface-face))
1189                 ;; Otherwise try external support with x-face...
1190                 ((and (eq type 'pbm)
1191                       (fboundp 'x-face-xmas-wl-display-x-face)
1192                       (fboundp 'executable-find) (executable-find "uncompface"))
1193                  (mh-funcall-if-exists x-face-xmas-wl-display-x-face)))
1194                (when raw (insert " "))))))))
1195    
1196    
1197  (defun mh-show-xface ()  (defun mh-show-xface ()
1198    "Display X-Face."    "Display X-Face."
1199    (when (and mh-show-use-xface-flag    (when (and window-system mh-show-use-xface-flag
1200               (or mh-decode-mime-flag mhl-formfile               (or mh-decode-mime-flag mhl-formfile
1201                   mh-clean-message-header-flag))                   mh-clean-message-header-flag))
1202      (funcall mh-show-xface-function)))      (funcall mh-show-xface-function)))
1203    
1204    
1205    
1206    ;; X-Image-URL display
1207    
1208    (defvar mh-x-image-cache-directory nil
1209      "Directory where X-Image-URL images are cached.")
1210    
1211    (defvar mh-convert-executable (executable-find "convert"))
1212    (defvar mh-wget-executable (executable-find "wget"))
1213    (defvar mh-x-image-temp-file nil)
1214    (defvar mh-x-image-url nil)
1215    (defvar mh-x-image-marker nil)
1216    (defvar mh-x-image-url-cache-file nil)
1217    
1218    (defun mh-x-image-url-cache-canonicalize (url)
1219      "Canonicalize URL.
1220    Replace the ?/ character with a ?! character."
1221      (with-temp-buffer
1222        (insert url)
1223        (goto-char (point-min))
1224        (while (search-forward "/" nil t) (replace-match "!"))
1225        (format "%s/%s.png" mh-x-image-cache-directory (buffer-string))))
1226    
1227    (defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
1228      "Fetch and display the image specified by URL.
1229    After the image is fetched, it is stored in CACHE-FILE. It will be displayed
1230    in a buffer and position specified by MARKER. The actual display is carried
1231    out by the SENTINEL function."
1232      (if (and mh-wget-executable
1233               mh-fetch-x-image-url
1234               (or (eq mh-fetch-x-image-url t)
1235                   (y-or-n-p (format "Fetch %s? " url))))
1236          (let ((buffer (get-buffer-create (generate-new-buffer-name " *mh-url*")))
1237                (filename (make-temp-name "/tmp/mhe-wget")))
1238            (save-excursion
1239              (set-buffer buffer)
1240              (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
1241              (set (make-local-variable 'mh-x-image-marker) marker)
1242              (set (make-local-variable 'mh-x-image-temp-file) filename))
1243            (set-process-sentinel
1244             (start-process "*wget*" buffer mh-wget-executable "-O" filename url)
1245             sentinel))
1246        ;; Make sure we don't ask about this image again
1247        (when (and mh-wget-executable (eq mh-fetch-x-image-url 'ask))
1248          (make-symbolic-link mh-x-image-cache-directory cache-file t))))
1249    
1250    (defun mh-x-image-display (image marker)
1251      "Display IMAGE at MARKER."
1252      (save-excursion
1253        (set-buffer (marker-buffer marker))
1254        (let ((buffer-read-only nil)
1255              (default-enable-multibyte-characters nil)
1256              (buffer-modified-flag (buffer-modified-p)))
1257          (unwind-protect
1258              (when (and (file-readable-p image) (not (file-symlink-p image)))
1259                (goto-char marker)
1260                (mh-do-in-gnu-emacs
1261                  (mh-funcall-if-exists insert-image (create-image image 'png)))
1262                (mh-do-in-xemacs
1263                  (when (featurep 'png)
1264                    (set-extent-begin-glyph
1265                     (make-extent (point) (point))
1266                     (make-glyph
1267                      (vector 'png ':data (with-temp-buffer
1268                                            (insert-file-contents-literally image)
1269                                            (buffer-string))))))))
1270            (set-buffer-modified-p buffer-modified-flag)))))
1271    
1272    (defun mh-x-image-scale-and-display (process change)
1273      "When the wget PROCESS terminates scale and display image.
1274    The argument CHANGE is ignored."
1275      (when (eq (process-status process) 'exit)
1276        (let (marker temp-file cache-filename wget-buffer)
1277          (save-excursion
1278            (set-buffer (setq wget-buffer (process-buffer process)))
1279            (setq marker mh-x-image-marker
1280                  cache-filename mh-x-image-url-cache-file
1281                  temp-file mh-x-image-temp-file))
1282          (when mh-convert-executable
1283            (call-process mh-convert-executable nil nil nil "-resize" "96x48"
1284                           temp-file cache-filename))
1285          (if (file-exists-p cache-filename)
1286              (mh-x-image-display cache-filename marker)
1287            (make-symbolic-link mh-x-image-cache-directory cache-filename t))
1288          (ignore-errors
1289            (set-marker marker nil)
1290            (delete-process process)
1291            (kill-buffer wget-buffer)
1292            (delete-file temp-file)))))
1293    
1294    (defun mh-x-image-url-display (url)
1295      "Display image from location URL.
1296    If the URL isn't present in the cache then it is fetched with wget."
1297      (let ((cache-filename (mh-x-image-url-cache-canonicalize url))
1298            (marker (set-marker (make-marker) (point))))
1299        (cond ((file-exists-p cache-filename)
1300               (mh-x-image-display cache-filename marker))
1301              ((not mh-fetch-x-image-url)
1302               (set-marker marker nil))
1303              ((and (not (file-exists-p mh-x-image-cache-directory))
1304                    (call-process "mkdir" nil nil nil mh-x-image-cache-directory)
1305                    nil))
1306              ((and (file-exists-p mh-x-image-cache-directory)
1307                    (file-directory-p mh-x-image-cache-directory))
1308               (mh-x-image-url-fetch-image url cache-filename marker
1309                                           'mh-x-image-scale-and-display)))))
1310    
1311    
1312    
1313  (defun mh-maybe-show (&optional msg)  (defun mh-maybe-show (&optional msg)
1314    "Display message at cursor, but only if in show mode.    "Display message at cursor, but only if in show mode.
1315  If optional arg MSG is non-nil, display that message instead."  If optional arg MSG is non-nil, display that message instead."
# Line 1110  arguments, after the message has been di Line 1365  arguments, after the message has been di
1365    (if (not (memq msg mh-seen-list))    (if (not (memq msg mh-seen-list))
1366        (setq mh-seen-list (cons msg mh-seen-list)))        (setq mh-seen-list (cons msg mh-seen-list)))
1367    (when mh-update-sequences-after-mh-show-flag    (when mh-update-sequences-after-mh-show-flag
1368        (if mh-index-data (mh-index-update-unseen msg))
1369      (mh-update-sequences))      (mh-update-sequences))
1370    (run-hooks 'mh-show-hook))    (run-hooks 'mh-show-hook))
1371    
# Line 1147  The message is displayed in raw form." Line 1403  The message is displayed in raw form."
1403      (delete-other-windows)      (delete-other-windows)
1404      (switch-to-buffer edit-buffer)))      (switch-to-buffer edit-buffer)))
1405    
 (defun mh-decode-content-transfer-encoded-message ()  
   "Run mimencode on message body, if needed."  
   (let ((case-fold-search t)  
         (header-end (mail-header-end)))  
     (goto-char (point-min))  
     (when (re-search-forward "^content-transfer-encoding: " header-end t)  
       (let ((enc (buffer-substring-no-properties (point) (line-end-position)))  
             cmdline)  
         (setq cmdline  
               (cond ((string-match "base64" enc) (list "-u" "-b" "-p"))  
                     ((string-match "quoted-printable" enc) (list "-u" "-q"))  
                     (t nil)))  
         (when cmdline  
           (beginning-of-line)  
           (insert "Removed-")  
           (setq header-end (mail-header-end))  
           (goto-char (1+ header-end))  
           (apply #'call-process-region (1+ header-end) (point-max) "mimencode"  
                  t t nil cmdline))))))  
   
1406  (defun mh-show-unquote-From ()  (defun mh-show-unquote-From ()
1407    "Decode >From at beginning of lines for `mh-show-mode'."    "Decode >From at beginning of lines for `mh-show-mode'."
1408    (save-excursion    (save-excursion
1409      (let ((modified (buffer-modified-p))      (let ((modified (buffer-modified-p))
1410            (case-fold-search nil))            (case-fold-search nil))
1411        (goto-char (mail-header-end))        (goto-char (mh-mail-header-end))
1412        (while (re-search-forward "^>From" nil t)        (while (re-search-forward "^>From" nil t)
1413          (replace-match "From"))          (replace-match "From"))
1414        (set-buffer-modified-p modified))))        (set-buffer-modified-p modified))))
# Line 1226  Sets the current buffer to the show buff Line 1462  Sets the current buffer to the show buff
1462                                               (list "-form" formfile))                                               (list "-form" formfile))
1463                                           msg-filename)                                           msg-filename)
1464                 (insert-file-contents-literally msg-filename))                 (insert-file-contents-literally msg-filename))
              (if mh-decode-content-transfer-encoded-message-flag  
                  (mh-decode-content-transfer-encoded-message))  
1465               ;; Cleanup old mime handles               ;; Cleanup old mime handles
1466               (mh-mime-cleanup)               (mh-mime-cleanup)
1467               ;; Use mm to display buffer               ;; Use mm to display buffer
# Line 1235  Sets the current buffer to the show buff Line 1469  Sets the current buffer to the show buff
1469                 (mh-add-missing-mime-version-header)                 (mh-add-missing-mime-version-header)
1470                 (setf (mh-buffer-data) (mh-make-buffer-data))                 (setf (mh-buffer-data) (mh-make-buffer-data))
1471                 (mh-mime-display))                 (mh-mime-display))
1472                 (mh-show-mode)
1473               ;; Header cleanup               ;; Header cleanup
1474               (goto-char (point-min))               (goto-char (point-min))
1475               (cond (clean-message-header               (cond (clean-message-header
# Line 1244  Sets the current buffer to the show buff Line 1479  Sets the current buffer to the show buff
1479                      (goto-char (point-min)))                      (goto-char (point-min)))
1480                     (t                     (t
1481                      (mh-start-of-uncleaned-message)))                      (mh-start-of-uncleaned-message)))
1482                 (mh-decode-message-header)
1483               ;; the parts of visiting we want to do (no locking)               ;; the parts of visiting we want to do (no locking)
1484               (or (eq buffer-undo-list t) ;don't save undo info for prev msgs               (or (eq buffer-undo-list t) ;don't save undo info for prev msgs
1485                   (setq buffer-undo-list nil))                   (setq buffer-undo-list nil))
# Line 1253  Sets the current buffer to the show buff Line 1489  Sets the current buffer to the show buff
1489               (setq buffer-backed-up nil)               (setq buffer-backed-up nil)
1490               (auto-save-mode 1)               (auto-save-mode 1)
1491               (set-mark nil)               (set-mark nil)
              (mh-show-mode)  
1492               (unwind-protect               (unwind-protect
1493                   (when (and mh-decode-mime-flag (not formfile))                   (when (and mh-decode-mime-flag (not formfile))
1494                     (setq buffer-read-only nil)                     (setq buffer-read-only nil)
# Line 1276  INVISIBLE-HEADERS contains a regular exp Line 1511  INVISIBLE-HEADERS contains a regular exp
1511  from the header. VISIBLE-HEADERS contains a regular expression specifying the  from the header. VISIBLE-HEADERS contains a regular expression specifying the
1512  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."
1513    (let ((case-fold-search t)    (let ((case-fold-search t)
1514            (buffer-read-only nil)
1515          (after-change-functions nil))   ;Work around emacs-20 font-lock bug          (after-change-functions nil))   ;Work around emacs-20 font-lock bug
1516                                          ;causing an endless loop.                                          ;causing an endless loop.
1517      (save-restriction      (save-restriction
# Line 1306  lines to display. INVISIBLE-HEADERS is i Line 1542  lines to display. INVISIBLE-HEADERS is i
1542    
1543  (defun mh-notate (msg notation offset)  (defun mh-notate (msg notation offset)
1544    "Mark MSG with the character NOTATION at position OFFSET.    "Mark MSG with the character NOTATION at position OFFSET.
1545  Null MSG means the message at cursor."  Null MSG means the message at cursor.
1546    If NOTATION is nil then no change in the buffer occurs."
1547    (save-excursion    (save-excursion
1548      (if (or (null msg)      (if (or (null msg)
1549              (mh-goto-msg msg t t))              (mh-goto-msg msg t t))
1550          (with-mh-folder-updating (t)          (with-mh-folder-updating (t)
1551            (beginning-of-line)            (beginning-of-line)
1552            (forward-char offset)            (forward-char offset)
1553            (delete-char 1)            (let ((notation (or notation (char-after))))
1554            (insert notation)))))              (delete-char 1)
1555                (insert notation))))))
1556    
1557  (defun mh-find-msg-get-num (step)  (defun mh-find-msg-get-num (step)
1558    "Return the message number of the message nearest the cursor.    "Return the message number of the message nearest the cursor.
# Line 1405  arguments, after these variable have bee Line 1643  arguments, after these variable have bee
1643        (setq mh-user-path        (setq mh-user-path
1644              (file-name-as-directory              (file-name-as-directory
1645               (expand-file-name mh-user-path (expand-file-name "~"))))               (expand-file-name mh-user-path (expand-file-name "~"))))
1646          (unless mh-x-image-cache-directory
1647            (setq mh-x-image-cache-directory
1648                  (expand-file-name ".mhe-x-image-cache" mh-user-path)))
1649        (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:"))        (setq mh-draft-folder (mh-get-profile-field "Draft-Folder:"))
1650        (if mh-draft-folder        (if mh-draft-folder
1651            (progn            (progn
# Line 1542  The message number width portion of the Line 1783  The message number width portion of the
1783        (set-buffer tmp-buffer)        (set-buffer tmp-buffer)
1784        (erase-buffer)        (erase-buffer)
1785        (apply 'call-process        (apply 'call-process
1786               (expand-file-name "scan" mh-progs) nil '(t nil) nil               (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
1787               (list folder "last" "-format" "%(msg)"))               (list folder "last" "-format" "%(msg)"))
1788        (goto-char (point-min))        (goto-char (point-min))
1789        (if (re-search-forward mh-scan-msg-number-regexp nil 0 1)        (if (re-search-forward mh-scan-msg-number-regexp nil 0 1)
# Line 1582  not updated." Line 1823  not updated."
1823      sorted-msgs))      sorted-msgs))
1824    
1825  (defvar mh-sub-folders-cache (make-hash-table :test #'equal))  (defvar mh-sub-folders-cache (make-hash-table :test #'equal))
1826    (defvar mh-current-folder-name nil)
1827    
1828  (defun mh-normalize-folder-name (folder &optional empty-string-okay  (defun mh-normalize-folder-name (folder &optional empty-string-okay
1829                                          dont-remove-trailing-slash)                                          dont-remove-trailing-slash)
# Line 1602  if present is retained (if present), oth Line 1844  if present is retained (if present), oth
1844        (setq folder (replace-match "/" nil t folder)))        (setq folder (replace-match "/" nil t folder)))
1845      (let* ((length (length folder))      (let* ((length (length folder))
1846             (trailing-slash-present (and (> length 0)             (trailing-slash-present (and (> length 0)
1847                                          (equal (aref folder (1- length)) ?/))))                                          (equal (aref folder (1- length)) ?/)))
1848        (let ((components (split-string folder "/"))             (leading-slash-present (and (> length 0)
1849                                           (equal (aref folder 0) ?/))))
1850          (when (and (> length 0) (equal (aref folder 0) ?@)
1851                     (stringp mh-current-folder-name))
1852            (setq folder (format "%s/%s/" mh-current-folder-name
1853                                 (substring folder 1))))
1854          ;; XXX: Purge empty strings from the list that split-string returns. In
1855          ;;  XEmacs, (split-string "+foo/" "/") returns ("+foo" "") while in GNU
1856          ;;  Emacs it returns ("+foo"). In the code it is assumed that the
1857          ;; components list has no empty strings.
1858          (let ((components (delete "" (split-string folder "/")))
1859              (result ()))              (result ()))
1860          ;; Remove .. and . from the pathname.          ;; Remove .. and . from the pathname.
1861          (dolist (component components)          (dolist (component components)
# Line 1618  if present is retained (if present), oth Line 1870  if present is retained (if present), oth
1870          ;; Remove trailing '/' if needed.          ;; Remove trailing '/' if needed.
1871          (unless (and trailing-slash-present dont-remove-trailing-slash)          (unless (and trailing-slash-present dont-remove-trailing-slash)
1872            (when (not (equal folder ""))            (when (not (equal folder ""))
1873              (setq folder (substring folder 0 (1- (length folder))))))))              (setq folder (substring folder 0 (1- (length folder))))))
1874            (when leading-slash-present
1875              (setq folder (concat "/" folder)))))
1876      (cond ((and empty-string-okay (equal folder "")))      (cond ((and empty-string-okay (equal folder "")))
1877            ((equal folder "") (setq folder "+"))            ((equal folder "") (setq folder "+"))
1878            ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder)))))            ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder)))))
# Line 1713  tell us about the option +foo/bar!" Line 1967  tell us about the option +foo/bar!"
1967    
1968  (defvar mh-folder-hist nil)  (defvar mh-folder-hist nil)
1969  (defvar mh-speed-folder-map)  (defvar mh-speed-folder-map)
1970    (defvar mh-speed-flists-cache)
1971    
1972    (defvar mh-allow-root-folder-flag nil
1973      "Non-nil means \"+\" is an acceptable folder name.
1974    This variable is used to communicate with `mh-folder-completion-function'. That
1975    function can have exactly three arguments so we bind this variable to t or nil.
1976    
1977    This variable should never be set.")
1978    
1979  (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))  (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map))
1980  (define-key mh-folder-completion-map " " 'minibuffer-complete)  (define-key mh-folder-completion-map " " 'minibuffer-complete)
1981    
1982    (defun mh-speed-flists-active-p ()
1983      "Check if speedbar is running with message counts enabled."
1984      (and (featurep 'mh-speed)
1985           (> (hash-table-count mh-speed-flists-cache) 0)))
1986    
1987  (defun mh-folder-completion-function (name predicate flag)  (defun mh-folder-completion-function (name predicate flag)
1988    "Programmable completion for folder names.    "Programmable completion for folder names.
1989  NAME is the partial folder name that has been input. PREDICATE if non-nil is a  NAME is the partial folder name that has been input. PREDICATE if non-nil is a
# Line 1747  whether the completion is over." Line 2015  whether the completion is over."
2015             (all-completions             (all-completions
2016              remainder (mh-sub-folders last-complete t) predicate))              remainder (mh-sub-folders last-complete t) predicate))
2017            ((eq flag 'lambda)            ((eq flag 'lambda)
2018             (file-exists-p             (let ((path (concat mh-user-path
2019              (concat mh-user-path                                 (substring (mh-normalize-folder-name name) 1))))
2020                      (substring (mh-normalize-folder-name name) 1)))))))               (cond (mh-allow-root-folder-flag (file-exists-p path))
2021                       ((equal path mh-user-path) nil)
2022  (defun mh-folder-completing-read (prompt default)                     (t (file-exists-p path))))))))
2023    "Read folder name with PROMPT and default result DEFAULT."  
2024    (defun mh-folder-completing-read (prompt default allow-root-folder-flag)
2025      "Read folder name with PROMPT and default result DEFAULT.
2026    If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name
2027    corresponding to `mh-user-path'."
2028    (mh-normalize-folder-name    (mh-normalize-folder-name
2029     (let ((minibuffer-local-completion-map mh-folder-completion-map))     (let ((minibuffer-local-completion-map mh-folder-completion-map)
2030             (mh-allow-root-folder-flag allow-root-folder-flag))
2031       (completing-read prompt 'mh-folder-completion-function nil nil nil       (completing-read prompt 'mh-folder-completion-function nil nil nil
2032                        'mh-folder-hist default))                        'mh-folder-hist default))
2033     t))     t))
# Line 1775  when used in searching." Line 2048  when used in searching."
2048                                 ((equal "" default) "? ")                                 ((equal "" default) "? ")
2049                                 (t (format " [%s]? " default))))                                 (t (format " [%s]? " default))))
2050           (prompt (format "%s folder%s" prompt default-string))           (prompt (format "%s folder%s" prompt default-string))
2051             (mh-current-folder-name mh-current-folder)
2052           read-name folder-name)           read-name folder-name)
2053      (while (and (setq read-name (mh-folder-completing-read prompt default))      (while (and (setq read-name (mh-folder-completing-read
2054                                     prompt default allow-root-folder-flag))
2055                  (equal read-name "")                  (equal read-name "")
2056                  (equal default "")))                  (equal default "")))
2057      (cond ((or (equal read-name "")      (cond ((or (equal read-name "")
# Line 1790  when used in searching." Line 2065  when used in searching."
2065      (cond ((and (> (length folder-name) 0)      (cond ((and (> (length folder-name) 0)
2066                  (eq (aref folder-name (1- (length folder-name))) ?/))                  (eq (aref folder-name (1- (length folder-name))) ?/))
2067             (setq folder-name (substring folder-name 0 -1))))             (setq folder-name (substring folder-name 0 -1))))
2068        (let* ((last-slash (mh-search-from-end ?/ folder-name))
2069               (parent (and last-slash (substring folder-name 0 last-slash)))
2070               (child (if last-slash
2071                          (substring folder-name (1+ last-slash))
2072                        (substring folder-name 1))))
2073          (unless (member child
2074                          (mapcar #'car (gethash parent mh-sub-folders-cache)))
2075            (mh-remove-from-sub-folders-cache folder-name)))
2076      (let ((new-file-flag      (let ((new-file-flag
2077             (not (file-exists-p (mh-expand-file-name folder-name)))))             (not (file-exists-p (mh-expand-file-name folder-name)))))
2078        (cond ((and new-file-flag        (cond ((and new-file-flag
# Line 1809  when used in searching." Line 2092  when used in searching."
2092                      (mh-expand-file-name folder-name)))))                      (mh-expand-file-name folder-name)))))
2093      folder-name))      folder-name))
2094    
2095    (defun mh-truncate-log-buffer ()
2096      "If `mh-log-buffer' is too big then truncate it.
2097    If the number of lines in `mh-log-buffer' exceeds `mh-log-buffer-lines' then
2098    keep only the last `mh-log-buffer-lines'. As a side effect the point is set to
2099    the end of the log buffer.
2100    
2101    The function returns the size of the final size of the log buffer."
2102      (with-current-buffer (get-buffer-create mh-log-buffer)
2103        (goto-char (point-max))
2104        (save-excursion
2105          (when (equal (forward-line (- mh-log-buffer-lines)) 0)
2106            (delete-region (point-min) (point))))
2107        (unless (or (bobp)
2108                    (save-excursion
2109                      (and (equal (forward-line -1) 0) (equal (char-after) ? ))))
2110          (insert "\n \n"))
2111        (buffer-size)))
2112    
2113  ;;; Issue commands to MH.  ;;; Issue commands to MH.
2114    
2115  (defun mh-exec-cmd (command &rest args)  (defun mh-exec-cmd (command &rest args)
# Line 1818  Any output is assumed to be an error and Line 2119  Any output is assumed to be an error and
2119  The output is not read or parsed by MH-E."  The output is not read or parsed by MH-E."
2120    (save-excursion    (save-excursion
2121      (set-buffer (get-buffer-create mh-log-buffer))      (set-buffer (get-buffer-create mh-log-buffer))
2122      (erase-buffer)      (let ((initial-size (mh-truncate-log-buffer)))
2123      (apply 'call-process        (apply 'call-process
2124             (expand-file-name command mh-progs) nil t nil               (expand-file-name command mh-progs) nil t nil
2125             (mh-list-to-string args))               (mh-list-to-string args))
2126      (if (> (buffer-size) 0)        (if (> (buffer-size) initial-size)
2127          (save-window-excursion            (save-window-excursion
2128            (switch-to-buffer-other-window mh-log-buffer)              (switch-to-buffer-other-window mh-log-buffer)
2129            (sit-for 5)))))              (sit-for 5))))))
2130    
2131  (defun mh-exec-cmd-error (env command &rest args)  (defun mh-exec-cmd-error (env command &rest args)
2132    "In environment ENV, execute mh-command COMMAND with ARGS.    "In environment ENV, execute mh-command COMMAND with ARGS.
# Line 1834  Signals an error if process does not com Line 2135  Signals an error if process does not com
2135    (save-excursion    (save-excursion
2136      (set-buffer (get-buffer-create mh-temp-buffer))      (set-buffer (get-buffer-create mh-temp-buffer))
2137      (erase-buffer)      (erase-buffer)
2138      (let ((status      (let ((process-environment process-environment))
2139             (if env        ;; XXX: We should purge the list that split-string returns of empty
2140                 ;; the shell hacks necessary here shows just how broken Unix is        ;;  strings. This can happen in XEmacs if leading or trailing spaces
2141                 (apply 'call-process "/bin/sh" nil t nil "-c"        ;;  are present.
2142                        (format "%s %s ${1+\"$@\"}"        (dolist (elem (if (stringp env) (split-string env " ") ()))
2143                                env          (push elem process-environment))
2144                                (expand-file-name command mh-progs))        (mh-handle-process-error
2145                        command         command (apply #'call-process (expand-file-name command mh-progs)
2146                        (mh-list-to-string args))                        nil t nil (mh-list-to-string args))))))
              (apply 'call-process  
                     (expand-file-name command mh-progs) nil t nil  
                     (mh-list-to-string args)))))  
       (mh-handle-process-error command status))))  
2147    
2148  (defun mh-exec-cmd-daemon (command filter &rest args)  (defun mh-exec-cmd-daemon (command filter &rest args)
2149    "Execute MH command COMMAND in the background.    "Execute MH command COMMAND in the background.
# Line 1858  details of FILTER. Line 2155  details of FILTER.
2155  ARGS are passed to COMMAND as command line arguments."  ARGS are passed to COMMAND as command line arguments."
2156    (save-excursion    (save-excursion
2157      (set-buffer (get-buffer-create mh-log-buffer))      (set-buffer (get-buffer-create mh-log-buffer))
2158      (erase-buffer))      (mh-truncate-log-buffer))
2159    (let* ((process-connection-type nil)    (let* ((process-connection-type nil)
2160           (process (apply 'start-process           (process (apply 'start-process
2161                           command nil                           command nil
# Line 1866  ARGS are passed to COMMAND as command li Line 2163  ARGS are passed to COMMAND as command li
2163                           (mh-list-to-string args))))                           (mh-list-to-string args))))
2164      (set-process-filter process (or filter 'mh-process-daemon))))      (set-process-filter process (or filter 'mh-process-daemon))))
2165    
2166    (defun mh-exec-cmd-env-daemon (env command filter &rest args)
2167      "In ennvironment ENV, execute mh-command COMMAND in the background.
2168    
2169    ENV is nil or a string of space-separated \"var=value\" elements.
2170    Signals an error if process does not complete successfully.
2171    
2172    If FILTER is non-nil then it is used to process the output otherwise the
2173    default filter `mh-process-daemon' is used. See `set-process-filter' for more
2174    details of FILTER.
2175    
2176    ARGS are passed to COMMAND as command line arguments."
2177      (let ((process-environment process-environment))
2178        (dolist (elem (if (stringp env) (split-string env " ") ()))
2179          (push elem process-environment))
2180        (apply #'mh-exec-cmd-daemon command filter args)))
2181    
2182  (defun mh-process-daemon (process output)  (defun mh-process-daemon (process output)
2183    "PROCESS daemon that puts OUTPUT into a temporary buffer.    "PROCESS daemon that puts OUTPUT into a temporary buffer.
2184  Any output from the process is displayed in an asynchronous pop-up window."  Any output from the process is displayed in an asynchronous pop-up window."
# Line 1933  Put the output into buffer after point. Line 2246  Put the output into buffer after point.
2246    (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args))    (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args))
2247    
2248  (defun mh-handle-process-error (command status)  (defun mh-handle-process-error (command status)
2249    "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS.    "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS."
2250  STATUS is return value from `call-process'.    (if (equal status 0)
2251  Program output is in current buffer.        status
2252  If output is too long to include in error message, display the buffer."      (goto-char (point-min))
2253    (cond ((eq status 0)                  ;success      (insert (if (integerp status)
2254           status)                  (format "%s: exit code %d\n" command status)
2255          ((stringp status)               ;kill string                (format "%s: %s\n" command status)))
2256           (error "%s: %s" command status))      (save-excursion
2257          (t                              ;exit code        (let ((error-message (buffer-substring (point-min) (point-max))))
2258           (cond          (set-buffer (get-buffer-create mh-log-buffer))
2259            ((= (buffer-size) 0)          ;program produced no error message          (mh-truncate-log-buffer)
2260             (error "%s: exit code %d" command status))          (insert error-message)))
2261            (t      (error "%s failed, check %s buffer for error message"
2262             ;; will error message fit on one line?             command mh-log-buffer)))
            (goto-line 2)  
            (if (and (< (buffer-size) (frame-width))  
                     (eobp))  
                (error "%s"  
                       (buffer-substring 1 (progn (goto-char 1)  
                                                  (end-of-line)  
                                                  (point))))  
              (display-buffer (current-buffer))  
              (error "%s failed with status %d.  See error message in other window"  
                     command status)))))))  
2263    
2264  (defun mh-list-to-string (l)  (defun mh-list-to-string (l)
2265    "Flatten the list L and make every element of the new list into a string."    "Flatten the list L and make every element of the new list into a string."

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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