Mercurial > emacs
comparison lisp/mh-e/mh-utils.el @ 67758:6b063593fdad
Follow Emacs coding conventions. Use default setting of
emacs-lisp-docstring-fill-column which is 65.
author | Bill Wohler <wohler@newt.com> |
---|---|
date | Fri, 23 Dec 2005 07:40:40 +0000 |
parents | 7ff92ad99326 |
children | 9c3504ae6060 |
comparison
equal
deleted
inserted
replaced
67757:488b4dbc7482 | 67758:6b063593fdad |
---|---|
77 | 77 |
78 ;;; CL Replacements | 78 ;;; CL Replacements |
79 | 79 |
80 (defun mh-search-from-end (char string) | 80 (defun mh-search-from-end (char string) |
81 "Return the position of last occurrence of CHAR in STRING. | 81 "Return the position of last occurrence of CHAR in STRING. |
82 If CHAR is not present in STRING then return nil. The function is used in lieu | 82 If CHAR is not present in STRING then return nil. The function is |
83 of `search' in the CL package." | 83 used in lieu of `search' in the CL package." |
84 (loop for index from (1- (length string)) downto 0 | 84 (loop for index from (1- (length string)) downto 0 |
85 when (equal (aref string index) char) return index | 85 when (equal (aref string index) char) return index |
86 finally return nil)) | 86 finally return nil)) |
87 | 87 |
88 ;; Additional header fields that might someday be added: | 88 ;; Additional header fields that might someday be added: |
92 | 92 |
93 ;;; Scan Line Formats | 93 ;;; Scan Line Formats |
94 | 94 |
95 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" | 95 (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" |
96 "This regular expression extracts the message number. | 96 "This regular expression extracts the message number. |
97 It must match from the beginning of the line. Note that the message number | 97 |
98 must be placed in a parenthesized expression as in the default of | 98 It must match from the beginning of the line. Note that the |
99 \"^ *\\\\([0-9]+\\\\)\".") | 99 message number must be placed in a parenthesized expression as in |
100 the default of \"^ *\\\\([0-9]+\\\\)\".") | |
100 | 101 |
101 (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" | 102 (defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" |
102 "This regular expression matches overflowed message numbers.") | 103 "This regular expression matches overflowed message numbers.") |
103 | 104 |
104 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" | 105 (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" |
105 "This regular expression finds the message number width in a scan format. | 106 "This regular expression finds the message number width in a scan format. |
106 Note that the message number must be placed in a parenthesized expression as | 107 |
107 in the default of \"%\\\\([0-9]*\\\\)(msg)\". This variable is only consulted | 108 Note that the message number must be placed in a parenthesized |
108 if `mh-scan-format-file' is set to \"Use MH-E scan Format\".") | 109 expression as in the default of \"%\\\\([0-9]*\\\\)(msg)\". This |
110 variable is only consulted if `mh-scan-format-file' is set to | |
111 \"Use MH-E scan Format\".") | |
109 | 112 |
110 (defvar mh-scan-msg-format-string "%d" | 113 (defvar mh-scan-msg-format-string "%d" |
111 "This is a format string for width of the message number in a scan format. | 114 "This is a format string for width of the message number in a scan format. |
112 Use `0%d' for zero-filled message numbers. This variable is only consulted if | 115 |
113 `mh-scan-format-file' is set to \"Use MH-E scan Format\".") | 116 Use `0%d' for zero-filled message numbers. This variable is only |
117 consulted if `mh-scan-format-file' is set to \"Use MH-E scan | |
118 Format\".") | |
114 | 119 |
115 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" | 120 (defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" |
116 "This regular expression matches a particular message. | 121 "This regular expression matches a particular message. |
117 It is a format string; use `%d' to represent the location of the message | 122 |
118 number within the expression as in the default of \"^[^0-9]*%d[^0-9]\".") | 123 It is a format string; use `%d' to represent the location of the |
124 message number within the expression as in the default of | |
125 \"^[^0-9]*%d[^0-9]\".") | |
119 | 126 |
120 (defvar mh-cmd-note 4 | 127 (defvar mh-cmd-note 4 |
121 "Column for notations. | 128 "Column for notations. |
122 This variable should be set with the function `mh-set-cmd-note'. This variable | 129 |
123 may be updated dynamically if `mh-adaptive-cmd-note-flag' is on. | 130 This variable should be set with the function `mh-set-cmd-note'. |
131 This variable may be updated dynamically if | |
132 `mh-adaptive-cmd-note-flag' is on. | |
124 | 133 |
125 Note that columns in Emacs start with 0.") | 134 Note that columns in Emacs start with 0.") |
126 (make-variable-buffer-local 'mh-cmd-note) | 135 (make-variable-buffer-local 'mh-cmd-note) |
127 | 136 |
128 (defvar mh-note-seq ?% | 137 (defvar mh-note-seq ?% |
129 "Messages in a user-defined sequence are marked by this character. | 138 "Messages in a user-defined sequence are marked by this character. |
130 Messages in the `search' sequence are marked by this character as well.") | 139 |
140 Messages in the `search' sequence are marked by this character as | |
141 well.") | |
131 | 142 |
132 | 143 |
133 | 144 |
134 (defvar mh-show-buffer-mode-line-buffer-id " {show-%s} %d" | 145 (defvar mh-show-buffer-mode-line-buffer-id " {show-%s} %d" |
135 "Format string to produce `mode-line-buffer-identification' for show buffers. | 146 "Format string to produce `mode-line-buffer-identification' for show buffers. |
136 First argument is folder name. Second is message number.") | 147 |
148 First argument is folder name. Second is message number.") | |
137 | 149 |
138 | 150 |
139 | 151 |
140 (defvar mh-mail-header-separator "--------" | 152 (defvar mh-mail-header-separator "--------" |
141 "*Line used by MH to separate headers from text in messages being composed. | 153 "*Line used by MH to separate headers from text in messages being composed. |
142 This variable should not be used directly in programs. Programs should use | 154 |
143 `mail-header-separator' instead. `mail-header-separator' is initialized to | 155 This variable should not be used directly in programs. Programs |
144 `mh-mail-header-separator' in `mh-letter-mode'; in other contexts, you may | 156 should use `mail-header-separator' instead. |
145 have to perform this initialization yourself. | 157 `mail-header-separator' is initialized to |
146 | 158 `mh-mail-header-separator' in `mh-letter-mode'; in other |
147 Do not make this a regular expression as it may be the argument to `insert' | 159 contexts, you may have to perform this initialization yourself. |
148 and it is passed through `regexp-quote' before being used by functions like | 160 |
149 `re-search-forward'.") | 161 Do not make this a regular expression as it may be the argument |
162 to `insert' and it is passed through `regexp-quote' before being | |
163 used by functions like `re-search-forward'.") | |
150 | 164 |
151 (defvar mh-signature-separator-regexp "^-- $" | 165 (defvar mh-signature-separator-regexp "^-- $" |
152 "This regular expression matches the signature separator. | 166 "This regular expression matches the signature separator. |
153 See `mh-signature-separator'.") | 167 See `mh-signature-separator'.") |
154 | 168 |
155 (defvar mh-signature-separator "-- \n" | 169 (defvar mh-signature-separator "-- \n" |
156 "Text of a signature separator. | 170 "Text of a signature separator. |
157 A signature separator is used to separate the body of a message from the | 171 |
158 signature. This can be used by user agents such as MH-E to render the | 172 A signature separator is used to separate the body of a message |
159 signature differently or to suppress the inclusion of the signature in a | 173 from the signature. This can be used by user agents such as MH-E |
160 reply. | 174 to render the signature differently or to suppress the inclusion |
161 Use `mh-signature-separator-regexp' when searching for a separator.") | 175 of the signature in a reply. Use `mh-signature-separator-regexp' |
176 when searching for a separator.") | |
162 | 177 |
163 (defun mh-signature-separator-p () | 178 (defun mh-signature-separator-p () |
164 "Return non-nil if buffer includes \"^-- $\"." | 179 "Return non-nil if buffer includes \"^-- $\"." |
165 (save-excursion | 180 (save-excursion |
166 (goto-char (point-min)) | 181 (goto-char (point-min)) |
286 | 301 |
287 ;; From goto-addr.el, which we don't want to force-load on users. | 302 ;; From goto-addr.el, which we don't want to force-load on users. |
288 | 303 |
289 (defun mh-goto-address-find-address-at-point () | 304 (defun mh-goto-address-find-address-at-point () |
290 "Find e-mail address around or before point. | 305 "Find e-mail address around or before point. |
291 Then search backwards to beginning of line for the start of an e-mail | 306 |
292 address. If no e-mail address found, return nil." | 307 Then search backwards to beginning of line for the start of an |
308 e-mail address. If no e-mail address found, return nil." | |
293 (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) | 309 (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) |
294 (if (or (looking-at mh-address-mail-regexp) ; already at start | 310 (if (or (looking-at mh-address-mail-regexp) ; already at start |
295 (and (re-search-forward mh-address-mail-regexp | 311 (and (re-search-forward mh-address-mail-regexp |
296 (line-end-position) 'lim) | 312 (line-end-position) 'lim) |
297 (goto-char (match-beginning 0)))) | 313 (goto-char (match-beginning 0)))) |
298 (match-string-no-properties 0))) | 314 (match-string-no-properties 0))) |
299 | 315 |
300 (defun mh-mail-header-end () | 316 (defun mh-mail-header-end () |
301 "Substitute for `mail-header-end' that doesn't widen the buffer. | 317 "Substitute for `mail-header-end' that doesn't widen the buffer. |
302 In MH-E we frequently need to find the end of headers in nested messages, where | 318 |
303 the buffer has been narrowed. This function works in this situation." | 319 In MH-E we frequently need to find the end of headers in nested |
320 messages, where the buffer has been narrowed. This function works | |
321 in this situation." | |
304 (save-excursion | 322 (save-excursion |
305 ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, | 323 ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, |
306 ;; mail headers that MH-E has to read contains lines of the form: | 324 ;; mail headers that MH-E has to read contains lines of the form: |
307 ;; From xxx@yyy Mon May 10 11:48:07 2004 | 325 ;; From xxx@yyy Mon May 10 11:48:07 2004 |
308 ;; In this situation, rfc822-goto-eoh doesn't go to the end of the | 326 ;; In this situation, rfc822-goto-eoh doesn't go to the end of the |
421 (mh-font-lock-field-data (1 'mh-letter-header-field prepend t)))) | 439 (mh-font-lock-field-data (1 'mh-letter-header-field prepend t)))) |
422 | 440 |
423 (defun mh-show-font-lock-fontify-region (beg end loudly) | 441 (defun mh-show-font-lock-fontify-region (beg end loudly) |
424 "Limit font-lock in `mh-show-mode' to the header. | 442 "Limit font-lock in `mh-show-mode' to the header. |
425 | 443 |
426 Used when the option `mh-highlight-citation-style' is set to \"Gnus\", leaving | 444 Used when the option `mh-highlight-citation-style' is set to |
427 the body to be dealt with by Gnus highlighting. The region between BEG and END | 445 \"Gnus\", leaving the body to be dealt with by Gnus highlighting. |
428 is given over to be fontified and LOUDLY controls if a user sees a message | 446 The region between BEG and END is given over to be fontified and |
429 about the fontification operation." | 447 LOUDLY controls if a user sees a message about the fontification |
448 operation." | |
430 (let ((header-end (mh-mail-header-end))) | 449 (let ((header-end (mh-mail-header-end))) |
431 (cond | 450 (cond |
432 ((and (< beg header-end)(< end header-end)) | 451 ((and (< beg header-end)(< end header-end)) |
433 (font-lock-default-fontify-region beg end loudly)) | 452 (font-lock-default-fontify-region beg end loudly)) |
434 ((and (< beg header-end)(>= end header-end)) | 453 ((and (< beg header-end)(>= end header-end)) |
467 | 486 |
468 | 487 |
469 | 488 |
470 ;;; Internal bookkeeping variables: | 489 ;;; Internal bookkeeping variables: |
471 | 490 |
472 ;; Cached value of the `Path:' component in the user's MH profile. | 491 (defvar mh-user-path nil |
473 ;; User's mail folder directory. | 492 "Cached value of the \"Path:\" MH profile component. |
474 (defvar mh-user-path nil) | 493 User's mail folder directory.") |
475 | 494 |
476 ;; An mh-draft-folder of nil means do not use a draft folder. | 495 (defvar mh-draft-folder nil |
477 ;; Cached value of the `Draft-Folder:' component in the user's MH profile. | 496 "Cached value of the \"Draft-Folder:\" MH profile component. |
478 ;; Name of folder containing draft messages. | 497 Name of folder containing draft messages. |
479 (defvar mh-draft-folder nil) | 498 Nil means do not use a draft folder.") |
480 | 499 |
481 ;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. | 500 (defvar mh-unseen-seq nil |
482 ;; Name of the Unseen sequence. | 501 "Cached value of the \"Unseen-Sequence:\" MH profile component. |
483 (defvar mh-unseen-seq nil) | 502 Name of the Unseen sequence.") |
484 | 503 |
485 ;; Cached value of the `Previous-Sequence:' component in the user's MH | 504 (defvar mh-previous-seq nil |
486 ;; profile. | 505 "Cached value of the \"Previous-Sequence:\" MH profile component. |
487 ;; Name of the Previous sequence. | 506 Name of the Previous sequence.") |
488 (defvar mh-previous-seq nil) | 507 |
489 | 508 (defvar mh-inbox nil |
490 ;; Cached value of the `Inbox:' component in the user's MH profile, | 509 "Cached value of the \"Inbox:\" MH profile component. |
491 ;; or "+inbox" if no such component. | 510 Set to \"+inbox\" if no such component. |
492 ;; Name of the Inbox folder. | 511 Name of the Inbox folder.") |
493 (defvar mh-inbox nil) | |
494 | 512 |
495 ;; The names of ephemeral buffers have a " *mh-" prefix (so that they are | 513 ;; The names of ephemeral buffers have a " *mh-" prefix (so that they are |
496 ;; hidden and can be programmatically removed in mh-quit), and the variable | 514 ;; hidden and can be programmatically removed in mh-quit), and the variable |
497 ;; names have the form mh-temp-.*-buffer. | 515 ;; names have the form mh-temp-.*-buffer. |
498 (defconst mh-temp-buffer " *mh-temp*") ;scratch | 516 (defconst mh-temp-buffer " *mh-temp*") ;scratch |
509 (defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on | 527 (defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on |
510 (defconst mh-mail-delivery-buffer "*MH-E Mail Delivery*") ;mail delivery log | 528 (defconst mh-mail-delivery-buffer "*MH-E Mail Delivery*") ;mail delivery log |
511 (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent | 529 (defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent |
512 (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list | 530 (defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list |
513 | 531 |
514 ;; Number of lines to keep in mh-log-buffer. | 532 (defvar mh-log-buffer-lines 100 |
515 (defvar mh-log-buffer-lines 100) | 533 "Number of lines to keep in `mh-log-buffer'.") |
516 | 534 |
517 ;; Window configuration before MH-E command. | 535 (defvar mh-previous-window-config nil |
518 (defvar mh-previous-window-config nil) | 536 "Window configuration before MH-E command.") |
519 | 537 |
520 ;;Non-nil means next SPC or whatever goes to next undeleted message. | 538 (defvar mh-page-to-next-msg-flag nil |
521 (defvar mh-page-to-next-msg-flag nil) | 539 "Non-nil means next SPC or whatever goes to next undeleted message.") |
522 | 540 |
523 | 541 |
524 | 542 |
525 ;;; Internal variables local to a folder. | 543 ;;; Internal variables local to a folder. |
526 | 544 |
527 ;; Name of current folder, a string. | 545 (defvar mh-current-folder nil |
528 (defvar mh-current-folder nil) | 546 "Name of current folder, a string.") |
529 | 547 |
530 ;; Buffer that displays message for this folder. | 548 (defvar mh-show-buffer nil |
531 (defvar mh-show-buffer nil) | 549 "Buffer that displays message for this folder.") |
532 | 550 |
533 ;; Full path of directory for this folder. | 551 (defvar mh-folder-filename nil |
534 (defvar mh-folder-filename nil) | 552 "Full path of directory for this folder.") |
535 | 553 |
536 ;;Number of msgs in buffer. | 554 (defvar mh-msg-count nil |
537 (defvar mh-msg-count nil) | 555 "Number of msgs in buffer.") |
538 | 556 |
539 ;; If non-nil, show the message in a separate window. | 557 (defvar mh-showing-mode nil |
540 (defvar mh-showing-mode nil) | 558 "If non-nil, show the message in a separate window.") |
541 | 559 |
542 (defvar mh-show-mode-map (make-sparse-keymap) | 560 (defvar mh-show-mode-map (make-sparse-keymap) |
543 "Keymap used by the show buffer.") | 561 "Keymap used by the show buffer.") |
544 | 562 |
545 (defvar mh-show-folder-buffer nil | 563 (defvar mh-show-folder-buffer nil |
592 | 610 |
593 (defmacro with-mh-folder-updating (save-modification-flag &rest body) | 611 (defmacro with-mh-folder-updating (save-modification-flag &rest body) |
594 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). | 612 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). |
595 Execute BODY, which can modify the folder buffer without having to | 613 Execute BODY, which can modify the folder buffer without having to |
596 worry about file locking or the read-only flag, and return its result. | 614 worry about file locking or the read-only flag, and return its result. |
597 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification | 615 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag |
598 flag is unchanged, otherwise it is cleared." | 616 is unchanged, otherwise it is cleared." |
599 (setq save-modification-flag (car save-modification-flag)) ; CL style | 617 (setq save-modification-flag (car save-modification-flag)) ; CL style |
600 `(prog1 | 618 `(prog1 |
601 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) | 619 (let ((mh-folder-updating-mod-flag (buffer-modified-p)) |
602 (buffer-read-only nil) | 620 (buffer-read-only nil) |
603 (buffer-file-name nil)) ;don't let the buffer get locked | 621 (buffer-file-name nil)) ;don't let the buffer get locked |
625 | 643 |
626 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun) | 644 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun) |
627 | 645 |
628 (defmacro mh-do-at-event-location (event &rest body) | 646 (defmacro mh-do-at-event-location (event &rest body) |
629 "Switch to the location of EVENT and execute BODY. | 647 "Switch to the location of EVENT and execute BODY. |
630 After BODY has been executed return to original window. The modification flag | 648 After BODY has been executed return to original window. The |
631 of the buffer in the event window is preserved." | 649 modification flag of the buffer in the event window is |
650 preserved." | |
632 (let ((event-window (make-symbol "event-window")) | 651 (let ((event-window (make-symbol "event-window")) |
633 (event-position (make-symbol "event-position")) | 652 (event-position (make-symbol "event-position")) |
634 (original-window (make-symbol "original-window")) | 653 (original-window (make-symbol "original-window")) |
635 (original-position (make-symbol "original-position")) | 654 (original-position (make-symbol "original-position")) |
636 (modified-flag (make-symbol "modified-flag"))) | 655 (modified-flag (make-symbol "modified-flag"))) |
670 "Extract messages from the given SEQUENCE." | 689 "Extract messages from the given SEQUENCE." |
671 (list 'cdr sequence)) | 690 (list 'cdr sequence)) |
672 | 691 |
673 (defun mh-recenter (arg) | 692 (defun mh-recenter (arg) |
674 "Like recenter but with three improvements: | 693 "Like recenter but with three improvements: |
694 | |
675 - At the end of the buffer it tries to show fewer empty lines. | 695 - At the end of the buffer it tries to show fewer empty lines. |
696 | |
676 - operates only if the current buffer is in the selected window. | 697 - operates only if the current buffer is in the selected window. |
677 (Commands like `save-some-buffers' can make this false.) | 698 (Commands like `save-some-buffers' can make this false.) |
699 | |
678 - nil ARG means recenter as if prefix argument had been given." | 700 - nil ARG means recenter as if prefix argument had been given." |
679 (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) | 701 (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) |
680 nil) | 702 nil) |
681 ((= (point-max) (save-excursion | 703 ((= (point-max) (save-excursion |
682 (forward-line (- (/ (window-height) 2) 2)) | 704 (forward-line (- (/ (window-height) 2) 2)) |
716 (setq buffer-file-name nil)) | 738 (setq buffer-file-name nil)) |
717 | 739 |
718 | 740 |
719 (defun mh-get-msg-num (error-if-no-message) | 741 (defun mh-get-msg-num (error-if-no-message) |
720 "Return the message number of the displayed message. | 742 "Return the message number of the displayed message. |
721 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is | 743 If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if |
722 not pointing to a message." | 744 the cursor is not pointing to a message." |
723 (save-excursion | 745 (save-excursion |
724 (beginning-of-line) | 746 (beginning-of-line) |
725 (cond ((looking-at mh-scan-msg-number-regexp) | 747 (cond ((looking-at mh-scan-msg-number-regexp) |
726 (string-to-number (buffer-substring (match-beginning 1) | 748 (string-to-number (buffer-substring (match-beginning 1) |
727 (match-end 1)))) | 749 (match-end 1)))) |
729 (error "Cursor not pointing to message")) | 751 (error "Cursor not pointing to message")) |
730 (t nil)))) | 752 (t nil)))) |
731 | 753 |
732 (defun mh-folder-name-p (name) | 754 (defun mh-folder-name-p (name) |
733 "Return non-nil if NAME is the name of a folder. | 755 "Return non-nil if NAME is the name of a folder. |
734 A name (a string or symbol) can be a folder name if it begins with \"+\"." | 756 A name (a string or symbol) can be a folder name if it begins |
757 with \"+\"." | |
735 (if (symbolp name) | 758 (if (symbolp name) |
736 (eq (aref (symbol-name name) 0) ?+) | 759 (eq (aref (symbol-name name) 0) ?+) |
737 (and (> (length name) 0) | 760 (and (> (length name) 0) |
738 (eq (aref name 0) ?+)))) | 761 (eq (aref name 0) ?+)))) |
739 | 762 |
759 ;; transient-mark-mode for XEmacs? Should we be restoring the mark in the | 782 ;; transient-mark-mode for XEmacs? Should we be restoring the mark in the |
760 ;; folder buffer after the operation has been carried out. | 783 ;; folder buffer after the operation has been carried out. |
761 (defmacro mh-defun-show-buffer (function original-function | 784 (defmacro mh-defun-show-buffer (function original-function |
762 &optional dont-return) | 785 &optional dont-return) |
763 "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. | 786 "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. |
764 If the buffer we start in is still visible and DONT-RETURN is nil then switch | 787 If the buffer we start in is still visible and DONT-RETURN is nil |
765 to it after that." | 788 then switch to it after that." |
766 `(defun ,function () | 789 `(defun ,function () |
767 ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" | 790 ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" |
768 original-function | 791 original-function |
769 (if dont-return "" | 792 (if dont-return "" |
770 "When function completes, returns to the show buffer if it is | 793 "When function completes, returns to the show buffer if it is |
1206 | 1229 |
1207 (mh-do-in-xemacs (defvar default-enable-multibyte-characters)) | 1230 (mh-do-in-xemacs (defvar default-enable-multibyte-characters)) |
1208 | 1231 |
1209 (defun mh-face-display-function () | 1232 (defun mh-face-display-function () |
1210 "Display a Face, X-Face, or X-Image-URL header field. | 1233 "Display a Face, X-Face, or X-Image-URL header field. |
1211 If more than one of these are present, then the first one found in this order | 1234 If more than one of these are present, then the first one found |
1212 is used." | 1235 in this order is used." |
1213 (save-restriction | 1236 (save-restriction |
1214 (goto-char (point-min)) | 1237 (goto-char (point-min)) |
1215 (re-search-forward "\n\n" (point-max) t) | 1238 (re-search-forward "\n\n" (point-max) t) |
1216 (narrow-to-region (point-min) (point)) | 1239 (narrow-to-region (point-min) (point)) |
1217 (let* ((case-fold-search t) | 1240 (let* ((case-fold-search t) |
1373 (setf (gethash canonical-address mh-picon-cache) | 1396 (setf (gethash canonical-address mh-picon-cache) |
1374 (mh-picon-file-contents match))))) | 1397 (mh-picon-file-contents match))))) |
1375 | 1398 |
1376 (defun mh-picon-file-contents (file) | 1399 (defun mh-picon-file-contents (file) |
1377 "Return details about FILE. | 1400 "Return details about FILE. |
1378 A list of consisting of a symbol for the type of the file and the file | 1401 A list of consisting of a symbol for the type of the file and the |
1379 contents as a string is returned. If FILE is nil, then both elements of the | 1402 file contents as a string is returned. If FILE is nil, then both |
1380 list are nil." | 1403 elements of the list are nil." |
1381 (if (stringp file) | 1404 (if (stringp file) |
1382 (with-temp-buffer | 1405 (with-temp-buffer |
1383 (let ((type (and (string-match ".*\\.\\(...\\)$" file) | 1406 (let ((type (and (string-match ".*\\.\\(...\\)$" file) |
1384 (intern (match-string 1 file))))) | 1407 (intern (match-string 1 file))))) |
1385 (insert-file-contents-literally file) | 1408 (insert-file-contents-literally file) |
1386 (values type (buffer-string)))) | 1409 (values type (buffer-string)))) |
1387 (values nil nil))) | 1410 (values nil nil))) |
1388 | 1411 |
1389 (defun mh-picon-generate-path (host-list user directory) | 1412 (defun mh-picon-generate-path (host-list user directory) |
1390 "Generate the image file path. | 1413 "Generate the image file path. |
1391 HOST-LIST is the parsed host address of the email address, USER the username | 1414 HOST-LIST is the parsed host address of the email address, USER |
1392 and DIRECTORY is the directory relative to which the path is generated." | 1415 the username and DIRECTORY is the directory relative to which the |
1416 path is generated." | |
1393 (loop with acc = "" | 1417 (loop with acc = "" |
1394 for elem in host-list | 1418 for elem in host-list |
1395 do (setq acc (format "%s/%s" elem acc)) | 1419 do (setq acc (format "%s/%s" elem acc)) |
1396 finally return (format "%s/%s%s" directory acc user))) | 1420 finally return (format "%s/%s%s" directory acc user))) |
1397 | 1421 |
1458 ((not (file-exists-p file)) nil) | 1482 ((not (file-exists-p file)) nil) |
1459 (t 'ok))) | 1483 (t 'ok))) |
1460 | 1484 |
1461 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel) | 1485 (defun mh-x-image-url-fetch-image (url cache-file marker sentinel) |
1462 "Fetch and display the image specified by URL. | 1486 "Fetch and display the image specified by URL. |
1463 After the image is fetched, it is stored in CACHE-FILE. It will be displayed | 1487 After the image is fetched, it is stored in CACHE-FILE. It will |
1464 in a buffer and position specified by MARKER. The actual display is carried | 1488 be displayed in a buffer and position specified by MARKER. The |
1465 out by the SENTINEL function." | 1489 actual display is carried out by the SENTINEL function." |
1466 (if mh-wget-executable | 1490 (if mh-wget-executable |
1467 (let ((buffer (get-buffer-create (generate-new-buffer-name | 1491 (let ((buffer (get-buffer-create (generate-new-buffer-name |
1468 mh-temp-fetch-buffer))) | 1492 mh-temp-fetch-buffer))) |
1469 (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") | 1493 (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") |
1470 (expand-file-name (make-temp-name "~/mhe-fetch"))))) | 1494 (expand-file-name (make-temp-name "~/mhe-fetch"))))) |
1574 (if mh-showing-mode (mh-show msg))) | 1598 (if mh-showing-mode (mh-show msg))) |
1575 | 1599 |
1576 (defun mh-show (&optional message redisplay-flag) | 1600 (defun mh-show (&optional message redisplay-flag) |
1577 "Display message\\<mh-folder-mode-map>. | 1601 "Display message\\<mh-folder-mode-map>. |
1578 | 1602 |
1579 If the message under the cursor is already displayed, this command scrolls to | 1603 If the message under the cursor is already displayed, this command |
1580 the beginning of the message. MH-E normally hides a lot of the superfluous | 1604 scrolls to the beginning of the message. MH-E normally hides a lot of |
1581 header fields that mailers add to a message, but if you wish to see all of | 1605 the superfluous header fields that mailers add to a message, but if |
1582 them, use the command \\[mh-header-display]. | 1606 you wish to see all of them, use the command \\[mh-header-display]. |
1583 | 1607 |
1584 From a program, optional argument MESSAGE can be used to display an | 1608 From a program, optional argument MESSAGE can be used to display an |
1585 alternative message. The optional argument REDISPLAY-FLAG forces the redisplay | 1609 alternative message. The optional argument REDISPLAY-FLAG forces the |
1586 of the message even if the show buffer was already displaying the correct | 1610 redisplay of the message even if the show buffer was already |
1587 message. | 1611 displaying the correct message. |
1588 | 1612 |
1589 See the \"mh-show\" customization group for a litany of options that control | 1613 See the \"mh-show\" customization group for a litany of options that |
1590 what displayed messages look like." | 1614 control what displayed messages look like." |
1591 (interactive (list nil t)) | 1615 (interactive (list nil t)) |
1592 (when (or redisplay-flag | 1616 (when (or redisplay-flag |
1593 (and mh-showing-with-headers | 1617 (and mh-showing-with-headers |
1594 (or mh-mhl-format-file mh-clean-message-header-flag))) | 1618 (or mh-mhl-format-file mh-clean-message-header-flag))) |
1595 (mh-invalidate-show-buffer)) | 1619 (mh-invalidate-show-buffer)) |
1654 (run-hooks 'mh-show-hook))) | 1678 (run-hooks 'mh-show-hook))) |
1655 | 1679 |
1656 (defun mh-modify (&optional message) | 1680 (defun mh-modify (&optional message) |
1657 "Edit message. | 1681 "Edit message. |
1658 | 1682 |
1659 There are times when you need to edit a message. For example, you may need to | 1683 There are times when you need to edit a message. For example, you |
1660 fix a broken Content-Type header field. You can do this with this command. It | 1684 may need to fix a broken Content-Type header field. You can do |
1661 displays the raw message in an editable buffer. When you are done editing, | 1685 this with this command. It displays the raw message in an |
1662 save and kill the buffer as you would any other. | 1686 editable buffer. When you are done editing, save and kill the |
1687 buffer as you would any other. | |
1663 | 1688 |
1664 From a program, edit MESSAGE instead if it is non-nil." | 1689 From a program, edit MESSAGE instead if it is non-nil." |
1665 (interactive) | 1690 (interactive) |
1666 (let* ((message (or message (mh-get-msg-num t))) | 1691 (let* ((message (or message (mh-get-msg-num t))) |
1667 (msg-filename (mh-msg-filename message)) | 1692 (msg-filename (mh-msg-filename message)) |
1791 (set-buffer folder) | 1816 (set-buffer folder) |
1792 (setq mh-showing-with-headers nil)))))) | 1817 (setq mh-showing-with-headers nil)))))) |
1793 | 1818 |
1794 (defun mh-clean-msg-header (start invisible-headers visible-headers) | 1819 (defun mh-clean-msg-header (start invisible-headers visible-headers) |
1795 "Flush extraneous lines in message header. | 1820 "Flush extraneous lines in message header. |
1821 | |
1796 Header is cleaned from START to the end of the message header. | 1822 Header is cleaned from START to the end of the message header. |
1797 INVISIBLE-HEADERS contains a regular expression specifying lines to delete | 1823 INVISIBLE-HEADERS contains a regular expression specifying lines |
1798 from the header. VISIBLE-HEADERS contains a regular expression specifying the | 1824 to delete from the header. VISIBLE-HEADERS contains a regular |
1799 lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil. | 1825 expression specifying the lines to display. INVISIBLE-HEADERS is |
1800 | 1826 ignored if VISIBLE-HEADERS is non-nil." |
1801 Note that MH-E no longer supports the `mh-visible-headers' variable, so | 1827 ;; XXX Note that MH-E no longer supports the `mh-visible-headers' |
1802 this function could be trimmed of this feature too." | 1828 ;; variable, so this function could be trimmed of this feature too." |
1803 (let ((case-fold-search t) | 1829 (let ((case-fold-search t) |
1804 (buffer-read-only nil) | 1830 (buffer-read-only nil) |
1805 (after-change-functions nil)) ;Work around emacs-20 font-lock bug | 1831 (after-change-functions nil)) ;Work around emacs-20 font-lock bug |
1806 ;causing an endless loop. | 1832 ;causing an endless loop. |
1807 (save-restriction | 1833 (save-restriction |
1868 "Go to a message\\<mh-folder-mode-map>. | 1894 "Go to a message\\<mh-folder-mode-map>. |
1869 | 1895 |
1870 You can enter the message NUMBER either before or after typing | 1896 You can enter the message NUMBER either before or after typing |
1871 \\[mh-goto-msg]. In the latter case, Emacs prompts you. | 1897 \\[mh-goto-msg]. In the latter case, Emacs prompts you. |
1872 | 1898 |
1873 In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE means | 1899 In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE |
1874 return nil instead of signaling an error if message does not exist\; in this | 1900 means return nil instead of signaling an error if message does not |
1875 case, the cursor is positioned near where the message would have been. Non-nil | 1901 exist\; in this case, the cursor is positioned near where the message |
1876 third argument DONT-SHOW means not to show the message." | 1902 would have been. Non-nil third argument DONT-SHOW means not to show |
1903 the message." | |
1877 (interactive "NGo to message: ") | 1904 (interactive "NGo to message: ") |
1878 (setq number (prefix-numeric-value number)) | 1905 (setq number (prefix-numeric-value number)) |
1879 (let ((point (point)) | 1906 (let ((point (point)) |
1880 (return-value t)) | 1907 (return-value t)) |
1881 (goto-char (point-min)) | 1908 (goto-char (point-min)) |
1908 "Set variables from user's MH profile. | 1935 "Set variables from user's MH profile. |
1909 | 1936 |
1910 This function sets `mh-user-path' from your \"Path:\" MH profile | 1937 This function sets `mh-user-path' from your \"Path:\" MH profile |
1911 component (but defaults to \"Mail\" if one isn't present), | 1938 component (but defaults to \"Mail\" if one isn't present), |
1912 `mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from | 1939 `mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from |
1913 \"Unseen-Sequence:\", `mh-previous-seq' from \"Previous-Sequence:\", | 1940 \"Unseen-Sequence:\", `mh-previous-seq' from |
1914 and `mh-inbox' from \"Inbox:\" (defaults to \"+inbox\"). | 1941 \"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults |
1915 | 1942 to \"+inbox\"). |
1916 The hook `mh-find-path-hook' is run after these variables have been | 1943 |
1917 set. This hook can be used the change the value of these variables if | 1944 The hook `mh-find-path-hook' is run after these variables have |
1918 you need to run with different values between MH and MH-E." | 1945 been set. This hook can be used the change the value of these |
1946 variables if you need to run with different values between MH and | |
1947 MH-E." | |
1919 (mh-variants) | 1948 (mh-variants) |
1920 (unless mh-find-path-run | 1949 (unless mh-find-path-run |
1921 (setq mh-find-path-run t) | 1950 (setq mh-find-path-run t) |
1922 (save-excursion | 1951 (save-excursion |
1923 ;; Be sure profile is fully expanded before switching buffers | 1952 ;; Be sure profile is fully expanded before switching buffers |
1968 | 1997 |
1969 (defvar mh-no-install nil) ;do not run install-mh | 1998 (defvar mh-no-install nil) ;do not run install-mh |
1970 | 1999 |
1971 (defun mh-install (profile error-val) | 2000 (defun mh-install (profile error-val) |
1972 "Initialize the MH environment. | 2001 "Initialize the MH environment. |
1973 This is called if we fail to read the PROFILE file. ERROR-VAL is the error | 2002 This is called if we fail to read the PROFILE file. ERROR-VAL is |
1974 that made this call necessary." | 2003 the error that made this call necessary." |
1975 (if (or (getenv "MH") | 2004 (if (or (getenv "MH") |
1976 (file-exists-p profile) | 2005 (file-exists-p profile) |
1977 mh-no-install) | 2006 mh-no-install) |
1978 (signal (car error-val) | 2007 (signal (car error-val) |
1979 (list (format "Cannot read MH profile \"%s\"" profile) | 2008 (list (format "Cannot read MH profile \"%s\"" profile) |
2005 (mh-seq-msgs (mh-find-seq seq))) | 2034 (mh-seq-msgs (mh-find-seq seq))) |
2006 | 2035 |
2007 (defun mh-update-scan-format (fmt width) | 2036 (defun mh-update-scan-format (fmt width) |
2008 "Return a scan format with the (msg) width in the FMT replaced with WIDTH. | 2037 "Return a scan format with the (msg) width in the FMT replaced with WIDTH. |
2009 | 2038 |
2010 The message number width portion of the format is discovered using | 2039 The message number width portion of the format is discovered |
2011 `mh-scan-msg-format-regexp'. Its replacement is controlled with | 2040 using `mh-scan-msg-format-regexp'. Its replacement is controlled |
2012 `mh-scan-msg-format-string'." | 2041 with `mh-scan-msg-format-string'." |
2013 (or (and | 2042 (or (and |
2014 (string-match mh-scan-msg-format-regexp fmt) | 2043 (string-match mh-scan-msg-format-regexp fmt) |
2015 (let ((begin (match-beginning 1)) | 2044 (let ((begin (match-beginning 1)) |
2016 (end (match-end 1))) | 2045 (end (match-end 1))) |
2017 (concat (substring fmt 0 begin) | 2046 (concat (substring fmt 0 begin) |
2036 (match-beginning 1) (match-end 1)))))) | 2065 (match-beginning 1) (match-end 1)))))) |
2037 width)) | 2066 width)) |
2038 | 2067 |
2039 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) | 2068 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) |
2040 "Add MSGS to SEQ. | 2069 "Add MSGS to SEQ. |
2041 Remove duplicates and keep sequence sorted. If optional INTERNAL-FLAG is | 2070 |
2042 non-nil, do not mark the message in the scan listing or inform MH of the | 2071 Remove duplicates and keep sequence sorted. If optional |
2043 addition. | 2072 INTERNAL-FLAG is non-nil, do not mark the message in the scan |
2044 | 2073 listing or inform MH of the addition. |
2045 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the folder buffer are | 2074 |
2046 not updated." | 2075 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the |
2076 folder buffer are not updated." | |
2047 (let ((entry (mh-find-seq seq)) | 2077 (let ((entry (mh-find-seq seq)) |
2048 (internal-seq-flag (mh-internal-seq seq))) | 2078 (internal-seq-flag (mh-internal-seq seq))) |
2049 (if (and msgs (atom msgs)) (setq msgs (list msgs))) | 2079 (if (and msgs (atom msgs)) (setq msgs (list msgs))) |
2050 (if (null entry) | 2080 (if (null entry) |
2051 (setq mh-seq-list | 2081 (setq mh-seq-list |
2083 (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter | 2113 (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter |
2084 "-recurse" "-fast")))) | 2114 "-recurse" "-fast")))) |
2085 | 2115 |
2086 (defun mh-collect-folder-names-filter (process output) | 2116 (defun mh-collect-folder-names-filter (process output) |
2087 "Read folder names. | 2117 "Read folder names. |
2088 PROCESS is the flists process that was run to collect folder names and the | 2118 PROCESS is the flists process that was run to collect folder |
2089 function is called when OUTPUT is available." | 2119 names and the function is called when OUTPUT is available." |
2090 (let ((position 0) | 2120 (let ((position 0) |
2091 (prevailing-match-data (match-data)) | 2121 (prevailing-match-data (match-data)) |
2092 line-end folder) | 2122 line-end folder) |
2093 (unwind-protect | 2123 (unwind-protect |
2094 (while (setq line-end (string-match "\n" output position)) | 2124 (while (setq line-end (string-match "\n" output position)) |
2122 do (progn (setf (cdr x) t) (return))))))) | 2152 do (progn (setf (cdr x) t) (return))))))) |
2123 | 2153 |
2124 (defun mh-normalize-folder-name (folder &optional empty-string-okay | 2154 (defun mh-normalize-folder-name (folder &optional empty-string-okay |
2125 dont-remove-trailing-slash) | 2155 dont-remove-trailing-slash) |
2126 "Normalizes FOLDER name. | 2156 "Normalizes FOLDER name. |
2127 Makes sure that two '/' characters never occur next to each other. Also all | 2157 |
2128 occurrences of \"..\" and \".\" are suitably processed. So \"+inbox/../news\" | 2158 Makes sure that two '/' characters never occur next to each |
2129 will be normalized to \"+news\". | 2159 other. Also all occurrences of \"..\" and \".\" are suitably |
2130 | 2160 processed. So \"+inbox/../news\" will be normalized to \"+news\". |
2131 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added at the | 2161 |
2132 front if FOLDER lacks one. If non-nil and FOLDER is the empty string then | 2162 If optional argument EMPTY-STRING-OKAY is nil then a '+' is added |
2133 nothing is added. | 2163 at the front if FOLDER lacks one. If non-nil and FOLDER is the |
2134 | 2164 empty string then nothing is added. |
2135 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a trailing '/' | 2165 |
2136 if present is retained (if present), otherwise it is removed." | 2166 If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a |
2167 trailing '/' if present is retained (if present), otherwise it is | |
2168 removed." | |
2137 (when (stringp folder) | 2169 (when (stringp folder) |
2138 ;; Replace two or more consecutive '/' characters with a single '/' | 2170 ;; Replace two or more consecutive '/' characters with a single '/' |
2139 (while (string-match "//" folder) | 2171 (while (string-match "//" folder) |
2140 (setq folder (replace-match "/" nil t folder))) | 2172 (setq folder (replace-match "/" nil t folder))) |
2141 (let* ((length (length folder)) | 2173 (let* ((length (length folder)) |
2174 ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder))))) | 2206 ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder))))) |
2175 folder) | 2207 folder) |
2176 | 2208 |
2177 (defun mh-sub-folders (folder &optional add-trailing-slash-flag) | 2209 (defun mh-sub-folders (folder &optional add-trailing-slash-flag) |
2178 "Find the subfolders of FOLDER. | 2210 "Find the subfolders of FOLDER. |
2179 The function avoids running folders unnecessarily by caching the results of | 2211 The function avoids running folders unnecessarily by caching the |
2180 the actual folders call. | 2212 results of the actual folders call. |
2181 | 2213 |
2182 If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added | 2214 If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a |
2183 to each of the sub-folder names that may have nested folders within them." | 2215 slash is added to each of the sub-folder names that may have |
2216 nested folders within them." | |
2184 (let* ((folder (mh-normalize-folder-name folder)) | 2217 (let* ((folder (mh-normalize-folder-name folder)) |
2185 (match (gethash folder mh-sub-folders-cache 'no-result)) | 2218 (match (gethash folder mh-sub-folders-cache 'no-result)) |
2186 (sub-folders (cond ((eq match 'no-result) | 2219 (sub-folders (cond ((eq match 'no-result) |
2187 (setf (gethash folder mh-sub-folders-cache) | 2220 (setf (gethash folder mh-sub-folders-cache) |
2188 (mh-sub-folders-actual folder))) | 2221 (mh-sub-folders-actual folder))) |
2193 sub-folders) | 2226 sub-folders) |
2194 sub-folders))) | 2227 sub-folders))) |
2195 | 2228 |
2196 (defun mh-sub-folders-actual (folder) | 2229 (defun mh-sub-folders-actual (folder) |
2197 "Execute the command folders to return the sub-folders of FOLDER. | 2230 "Execute the command folders to return the sub-folders of FOLDER. |
2198 Filters out the folder names that start with \".\" so that directories that | 2231 Filters out the folder names that start with \".\" so that |
2199 aren't usually mail folders are hidden." | 2232 directories that aren't usually mail folders are hidden." |
2200 (let ((arg-list `(,(expand-file-name "folders" mh-progs) | 2233 (let ((arg-list `(,(expand-file-name "folders" mh-progs) |
2201 nil (t nil) nil "-noheader" "-norecurse" "-nototal" | 2234 nil (t nil) nil "-noheader" "-norecurse" "-nototal" |
2202 ,@(if (stringp folder) (list folder) ()))) | 2235 ,@(if (stringp folder) (list folder) ()))) |
2203 (results ()) | 2236 (results ()) |
2204 (current-folder (concat | 2237 (current-folder (concat |
2241 results)))) | 2274 results)))) |
2242 results)) | 2275 results)) |
2243 | 2276 |
2244 (defun mh-remove-from-sub-folders-cache (folder) | 2277 (defun mh-remove-from-sub-folders-cache (folder) |
2245 "Remove FOLDER and its parent from `mh-sub-folders-cache'. | 2278 "Remove FOLDER and its parent from `mh-sub-folders-cache'. |
2246 FOLDER should be unconditionally removed from the cache. Also the last ancestor | 2279 FOLDER should be unconditionally removed from the cache. Also the |
2247 of FOLDER present in the cache must be removed as well. | 2280 last ancestor of FOLDER present in the cache must be removed as |
2248 | 2281 well. |
2249 To see why this is needed assume we have a folder +foo which has a single | 2282 |
2250 sub-folder qux. Now we create the folder +foo/bar/baz. Here we will need to | 2283 To see why this is needed assume we have a folder +foo which has |
2251 invalidate the cached sub-folders of +foo, otherwise completion on +foo won't | 2284 a single sub-folder qux. Now we create the folder +foo/bar/baz. |
2252 tell us about the option +foo/bar!" | 2285 Here we will need to invalidate the cached sub-folders of +foo, |
2286 otherwise completion on +foo won't tell us about the option | |
2287 +foo/bar!" | |
2253 (remhash folder mh-sub-folders-cache) | 2288 (remhash folder mh-sub-folders-cache) |
2254 (block ancestor-found | 2289 (block ancestor-found |
2255 (let ((parent folder) | 2290 (let ((parent folder) |
2256 (one-ancestor-found nil) | 2291 (one-ancestor-found nil) |
2257 last-slash) | 2292 last-slash) |
2268 (defvar mh-speed-folder-map) | 2303 (defvar mh-speed-folder-map) |
2269 (defvar mh-speed-flists-cache) | 2304 (defvar mh-speed-flists-cache) |
2270 | 2305 |
2271 (defvar mh-allow-root-folder-flag nil | 2306 (defvar mh-allow-root-folder-flag nil |
2272 "Non-nil means \"+\" is an acceptable folder name. | 2307 "Non-nil means \"+\" is an acceptable folder name. |
2273 This variable is used to communicate with `mh-folder-completion-function'. That | 2308 This variable is used to communicate with |
2274 function can have exactly three arguments so we bind this variable to t or nil. | 2309 `mh-folder-completion-function'. That function can have exactly |
2310 three arguments so we bind this variable to t or nil. | |
2275 | 2311 |
2276 This variable should never be set.") | 2312 This variable should never be set.") |
2277 | 2313 |
2278 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map)) | 2314 (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map)) |
2279 (define-key mh-folder-completion-map " " 'minibuffer-complete) | 2315 (define-key mh-folder-completion-map " " 'minibuffer-complete) |
2286 (not mh-speed-flists-inhibit-flag) | 2322 (not mh-speed-flists-inhibit-flag) |
2287 (> (hash-table-count mh-speed-flists-cache) 0))) | 2323 (> (hash-table-count mh-speed-flists-cache) 0))) |
2288 | 2324 |
2289 (defun mh-folder-completion-function (name predicate flag) | 2325 (defun mh-folder-completion-function (name predicate flag) |
2290 "Programmable completion for folder names. | 2326 "Programmable completion for folder names. |
2291 NAME is the partial folder name that has been input. PREDICATE if non-nil is a | 2327 NAME is the partial folder name that has been input. PREDICATE if |
2292 function that is used to filter the possible choices and FLAG determines | 2328 non-nil is a function that is used to filter the possible choices |
2293 whether the completion is over." | 2329 and FLAG determines whether the completion is over." |
2294 (let* ((orig-name name) | 2330 (let* ((orig-name name) |
2295 (name (mh-normalize-folder-name name nil t)) | 2331 (name (mh-normalize-folder-name name nil t)) |
2296 (last-slash (mh-search-from-end ?/ name)) | 2332 (last-slash (mh-search-from-end ?/ name)) |
2297 (last-complete (if last-slash (substring name 0 last-slash) nil)) | 2333 (last-complete (if last-slash (substring name 0 last-slash) nil)) |
2298 (remainder (cond (last-complete (substring name (1+ last-slash))) | 2334 (remainder (cond (last-complete (substring name (1+ last-slash))) |
2323 ((equal path mh-user-path) nil) | 2359 ((equal path mh-user-path) nil) |
2324 (t (file-exists-p path)))))))) | 2360 (t (file-exists-p path)))))))) |
2325 | 2361 |
2326 (defun mh-folder-completing-read (prompt default allow-root-folder-flag) | 2362 (defun mh-folder-completing-read (prompt default allow-root-folder-flag) |
2327 "Read folder name with PROMPT and default result DEFAULT. | 2363 "Read folder name with PROMPT and default result DEFAULT. |
2328 If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name | 2364 If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be |
2329 corresponding to `mh-user-path'." | 2365 a folder name corresponding to `mh-user-path'." |
2330 (mh-normalize-folder-name | 2366 (mh-normalize-folder-name |
2331 (let ((minibuffer-completing-file-name t) | 2367 (let ((minibuffer-completing-file-name t) |
2332 (completion-root-regexp "^[+/]") | 2368 (completion-root-regexp "^[+/]") |
2333 (minibuffer-local-completion-map mh-folder-completion-map) | 2369 (minibuffer-local-completion-map mh-folder-completion-map) |
2334 (mh-allow-root-folder-flag allow-root-folder-flag)) | 2370 (mh-allow-root-folder-flag allow-root-folder-flag)) |
2337 t)) | 2373 t)) |
2338 | 2374 |
2339 (defun mh-prompt-for-folder (prompt default can-create | 2375 (defun mh-prompt-for-folder (prompt default can-create |
2340 &optional default-string allow-root-folder-flag) | 2376 &optional default-string allow-root-folder-flag) |
2341 "Prompt for a folder name with PROMPT. | 2377 "Prompt for a folder name with PROMPT. |
2342 Returns the folder's name as a string. DEFAULT is used if the folder exists | 2378 Returns the folder's name as a string. DEFAULT is used if the |
2343 and the user types return. If the CAN-CREATE flag is t, then a folder is | 2379 folder exists and the user types return. If the CAN-CREATE flag |
2344 created if it doesn't already exist. If optional argument DEFAULT-STRING is | 2380 is t, then a folder is created if it doesn't already exist. If |
2345 non-nil, use it in the prompt instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is | 2381 optional argument DEFAULT-STRING is non-nil, use it in the prompt |
2346 non-nil then the function will accept the folder +, which means all folders | 2382 instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then the |
2347 when used in searching." | 2383 function will accept the folder +, which means all folders when |
2384 used in searching." | |
2348 (if (null default) | 2385 (if (null default) |
2349 (setq default "")) | 2386 (setq default "")) |
2350 (let* ((default-string (cond (default-string (format " (default %s)" default-string)) | 2387 (let* ((default-string (cond (default-string (format " (default %s)" default-string)) |
2351 ((equal "" default) "") | 2388 ((equal "" default) "") |
2352 (t (format " (default %s)" default)))) | 2389 (t (format " (default %s)" default)))) |
2395 (mh-expand-file-name folder-name))))) | 2432 (mh-expand-file-name folder-name))))) |
2396 folder-name)) | 2433 folder-name)) |
2397 | 2434 |
2398 (defun mh-truncate-log-buffer () | 2435 (defun mh-truncate-log-buffer () |
2399 "If `mh-log-buffer' is too big then truncate it. | 2436 "If `mh-log-buffer' is too big then truncate it. |
2400 If the number of lines in `mh-log-buffer' exceeds `mh-log-buffer-lines' then | 2437 If the number of lines in `mh-log-buffer' exceeds |
2401 keep only the last `mh-log-buffer-lines'. As a side effect the point is set to | 2438 `mh-log-buffer-lines' then keep only the last |
2402 the end of the log buffer. | 2439 `mh-log-buffer-lines'. As a side effect the point is set to the |
2440 end of the log buffer. | |
2403 | 2441 |
2404 The function returns the size of the final size of the log buffer." | 2442 The function returns the size of the final size of the log buffer." |
2405 (with-current-buffer (get-buffer-create mh-log-buffer) | 2443 (with-current-buffer (get-buffer-create mh-log-buffer) |
2406 (goto-char (point-max)) | 2444 (goto-char (point-max)) |
2407 (save-excursion | 2445 (save-excursion |
2417 | 2455 |
2418 ;;; Issue commands to MH. | 2456 ;;; Issue commands to MH. |
2419 | 2457 |
2420 (defun mh-exec-cmd (command &rest args) | 2458 (defun mh-exec-cmd (command &rest args) |
2421 "Execute mh-command COMMAND with ARGS. | 2459 "Execute mh-command COMMAND with ARGS. |
2422 The side effects are what is desired. | 2460 The side effects are what is desired. Any output is assumed to be |
2423 Any output is assumed to be an error and is shown to the user. | 2461 an error and is shown to the user. The output is not read or |
2424 The output is not read or parsed by MH-E." | 2462 parsed by MH-E." |
2425 (save-excursion | 2463 (save-excursion |
2426 (set-buffer (get-buffer-create mh-log-buffer)) | 2464 (set-buffer (get-buffer-create mh-log-buffer)) |
2427 (let* ((initial-size (mh-truncate-log-buffer)) | 2465 (let* ((initial-size (mh-truncate-log-buffer)) |
2428 (start (point)) | 2466 (start (point)) |
2429 (args (mh-list-to-string args))) | 2467 (args (mh-list-to-string args))) |
2456 nil t nil (mh-list-to-string args)))))) | 2494 nil t nil (mh-list-to-string args)))))) |
2457 | 2495 |
2458 (defun mh-exec-cmd-daemon (command filter &rest args) | 2496 (defun mh-exec-cmd-daemon (command filter &rest args) |
2459 "Execute MH command COMMAND in the background. | 2497 "Execute MH command COMMAND in the background. |
2460 | 2498 |
2461 If FILTER is non-nil then it is used to process the output otherwise the | 2499 If FILTER is non-nil then it is used to process the output |
2462 default filter `mh-process-daemon' is used. See `set-process-filter' for more | 2500 otherwise the default filter `mh-process-daemon' is used. See |
2463 details of FILTER. | 2501 `set-process-filter' for more details of FILTER. |
2464 | 2502 |
2465 ARGS are passed to COMMAND as command line arguments." | 2503 ARGS are passed to COMMAND as command line arguments." |
2466 (save-excursion | 2504 (save-excursion |
2467 (set-buffer (get-buffer-create mh-log-buffer)) | 2505 (set-buffer (get-buffer-create mh-log-buffer)) |
2468 (mh-truncate-log-buffer)) | 2506 (mh-truncate-log-buffer)) |
2478 "In ennvironment ENV, execute mh-command COMMAND in the background. | 2516 "In ennvironment ENV, execute mh-command COMMAND in the background. |
2479 | 2517 |
2480 ENV is nil or a string of space-separated \"var=value\" elements. | 2518 ENV is nil or a string of space-separated \"var=value\" elements. |
2481 Signals an error if process does not complete successfully. | 2519 Signals an error if process does not complete successfully. |
2482 | 2520 |
2483 If FILTER is non-nil then it is used to process the output otherwise the | 2521 If FILTER is non-nil then it is used to process the output |
2484 default filter `mh-process-daemon' is used. See `set-process-filter' for more | 2522 otherwise the default filter `mh-process-daemon' is used. See |
2485 details of FILTER. | 2523 `set-process-filter' for more details of FILTER. |
2486 | 2524 |
2487 ARGS are passed to COMMAND as command line arguments." | 2525 ARGS are passed to COMMAND as command line arguments." |
2488 (let ((process-environment process-environment)) | 2526 (let ((process-environment process-environment)) |
2489 (dolist (elem (if (stringp env) (split-string env " ") ())) | 2527 (dolist (elem (if (stringp env) (split-string env " ") ())) |
2490 (push elem process-environment)) | 2528 (push elem process-environment)) |
2491 (apply #'mh-exec-cmd-daemon command filter args))) | 2529 (apply #'mh-exec-cmd-daemon command filter args))) |
2492 | 2530 |
2493 (defun mh-process-daemon (process output) | 2531 (defun mh-process-daemon (process output) |
2494 "PROCESS daemon that puts OUTPUT into a temporary buffer. | 2532 "PROCESS daemon that puts OUTPUT into a temporary buffer. |
2495 Any output from the process is displayed in an asynchronous pop-up window." | 2533 Any output from the process is displayed in an asynchronous |
2534 pop-up window." | |
2496 (set-buffer (get-buffer-create mh-log-buffer)) | 2535 (set-buffer (get-buffer-create mh-log-buffer)) |
2497 (insert-before-markers output) | 2536 (insert-before-markers output) |
2498 (display-buffer mh-log-buffer)) | 2537 (display-buffer mh-log-buffer)) |
2499 | 2538 |
2500 (defun mh-exec-cmd-quiet (raise-error command &rest args) | 2539 (defun mh-exec-cmd-quiet (raise-error command &rest args) |
2501 "Signal RAISE-ERROR if COMMAND with ARGS fails. | 2540 "Signal RAISE-ERROR if COMMAND with ARGS fails. |
2502 Execute MH command COMMAND with ARGS. ARGS is a list of strings. | 2541 Execute MH command COMMAND with ARGS. ARGS is a list of strings. |
2503 Return at start of mh-temp buffer, where output can be parsed and used. | 2542 Return at start of mh-temp buffer, where output can be parsed and |
2504 Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is | 2543 used. |
2505 non-nil, in which case an error is signaled if `call-process' returns non-0." | 2544 Returns value of `call-process', which is 0 for success, unless |
2545 RAISE-ERROR is non-nil, in which case an error is signaled if | |
2546 `call-process' returns non-0." | |
2506 (set-buffer (get-buffer-create mh-temp-buffer)) | 2547 (set-buffer (get-buffer-create mh-temp-buffer)) |
2507 (erase-buffer) | 2548 (erase-buffer) |
2508 (let ((value | 2549 (let ((value |
2509 (apply 'call-process | 2550 (apply 'call-process |
2510 (expand-file-name command mh-progs) nil t nil | 2551 (expand-file-name command mh-progs) nil t nil |
2520 (mh-exec-cmd-quiet nil "mhparam" "-components" component) | 2561 (mh-exec-cmd-quiet nil "mhparam" "-components" component) |
2521 (mh-get-profile-field (concat component ":")))) | 2562 (mh-get-profile-field (concat component ":")))) |
2522 | 2563 |
2523 (defun mh-exchange-point-and-mark-preserving-active-mark () | 2564 (defun mh-exchange-point-and-mark-preserving-active-mark () |
2524 "Put the mark where point is now, and point where the mark is now. | 2565 "Put the mark where point is now, and point where the mark is now. |
2525 This command works even when the mark is not active, and preserves whether the | 2566 This command works even when the mark is not active, and |
2526 mark is active or not." | 2567 preserves whether the mark is active or not." |
2527 (interactive nil) | 2568 (interactive nil) |
2528 (let ((is-active (and (boundp 'mark-active) mark-active))) | 2569 (let ((is-active (and (boundp 'mark-active) mark-active))) |
2529 (let ((omark (mark t))) | 2570 (let ((omark (mark t))) |
2530 (if (null omark) | 2571 (if (null omark) |
2531 (error "No mark set in this buffer")) | 2572 (error "No mark set in this buffer")) |
2535 (setq mark-active is-active)) | 2576 (setq mark-active is-active)) |
2536 nil))) | 2577 nil))) |
2537 | 2578 |
2538 (defun mh-exec-cmd-output (command display &rest args) | 2579 (defun mh-exec-cmd-output (command display &rest args) |
2539 "Execute MH command COMMAND with DISPLAY flag and ARGS. | 2580 "Execute MH command COMMAND with DISPLAY flag and ARGS. |
2540 Put the output into buffer after point. Set mark after inserted text. | 2581 Put the output into buffer after point. |
2582 Set mark after inserted text. | |
2541 Output is expected to be shown to user, not parsed by MH-E." | 2583 Output is expected to be shown to user, not parsed by MH-E." |
2542 (push-mark (point) t) | 2584 (push-mark (point) t) |
2543 (apply 'call-process | 2585 (apply 'call-process |
2544 (expand-file-name command mh-progs) nil t display | 2586 (expand-file-name command mh-progs) nil t display |
2545 (mh-list-to-string args)) | 2587 (mh-list-to-string args)) |
2551 ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. | 2593 ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. |
2552 (mh-exchange-point-and-mark-preserving-active-mark)) | 2594 (mh-exchange-point-and-mark-preserving-active-mark)) |
2553 | 2595 |
2554 (defun mh-exec-lib-cmd-output (command &rest args) | 2596 (defun mh-exec-lib-cmd-output (command &rest args) |
2555 "Execute MH library command COMMAND with ARGS. | 2597 "Execute MH library command COMMAND with ARGS. |
2556 Put the output into buffer after point. Set mark after inserted text." | 2598 Put the output into buffer after point. |
2599 Set mark after inserted text." | |
2557 (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) | 2600 (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) |
2558 | 2601 |
2559 (defun mh-handle-process-error (command status) | 2602 (defun mh-handle-process-error (command status) |
2560 "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS." | 2603 "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS." |
2561 (if (equal status 0) | 2604 (if (equal status 0) |
2603 | 2646 |
2604 (defun mh-replace-in-string (regexp newtext string) | 2647 (defun mh-replace-in-string (regexp newtext string) |
2605 "Replace REGEXP with NEWTEXT everywhere in STRING and return result. | 2648 "Replace REGEXP with NEWTEXT everywhere in STRING and return result. |
2606 NEWTEXT is taken literally---no \\DIGIT escapes will be recognized. | 2649 NEWTEXT is taken literally---no \\DIGIT escapes will be recognized. |
2607 | 2650 |
2608 The function body was copied from `dired-replace-in-string' in dired.el. | 2651 The function body was copied from `dired-replace-in-string' in |
2609 Emacs21 has `replace-regexp-in-string' while XEmacs has `replace-in-string'. | 2652 dired.el. |
2610 Neither is present in Emacs20. The file gnus-util.el in Gnus 5.10.1 and above | 2653 Emacs21 has `replace-regexp-in-string' while XEmacs has |
2611 has `gnus-replace-in-string'. We should use that when we decide to not support | 2654 `replace-in-string'. |
2612 older versions of Gnus." | 2655 Neither is present in Emacs20. The file gnus-util.el in Gnus 5.10.1 |
2656 and above has `gnus-replace-in-string'. We should use that when we | |
2657 decide to not support older versions of Gnus." | |
2613 (let ((result "") (start 0) mb me) | 2658 (let ((result "") (start 0) mb me) |
2614 (while (string-match regexp string start) | 2659 (while (string-match regexp string start) |
2615 (setq mb (match-beginning 0) | 2660 (setq mb (match-beginning 0) |
2616 me (match-end 0) | 2661 me (match-end 0) |
2617 result (concat result (substring string start mb) newtext) | 2662 result (concat result (substring string start mb) newtext) |