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> |
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. |
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")) |
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. |
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]+" |
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. |
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)) |
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 |
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)) |
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) |
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) |
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). |
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." |
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 |
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 |
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 |
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 |
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) |
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 |
|
|
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 |
"--" |
"--" |
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 |
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) |
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." |
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 |
|
|
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)))) |
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 |
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 |
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)) |
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) |
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 |
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. |
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 |
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) |
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) |
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) |
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))))) |
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 |
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)) |
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 "") |
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 |
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) |
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. |
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. |
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 |
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." |
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." |