From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.ciao.gmane.io!not-for-mail From: Pieter van Oostrum Newsgroups: gmane.emacs.bugs Subject: bug#39962: 27.0.90; Crash in Emacs 27.0.90 Date: Mon, 09 Mar 2020 20:48:48 +0100 Message-ID: References: <24162.58107.725366.668639@cochabamba.vanoostrum.org> <329e58b1-6255-311e-bdd8-b6f5b3d5208f@cs.ucla.edu> <22225b66-44f6-d132-3036-92181d53c28d@cs.ucla.edu> <89A83582-358F-43DC-B96E-04EE9D655D5F@vanoostrum.org> <63b88e2d-9888-f3ce-a4b0-fcf344e803e5@cs.ucla.edu> <83d09lbgk5.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="ciao.gmane.io:159.69.161.202"; logging-data="117231"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.0.90 (darwin) Cc: 39962@debbugs.gnu.org, eggert@cs.ucla.edu, pieter@vanoostrum.org To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Mon Mar 09 20:53:14 2020 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1jBOSf-000UKk-Dj for geb-bug-gnu-emacs@m.gmane-mx.org; Mon, 09 Mar 2020 20:53:13 +0100 Original-Received: from localhost ([::1]:48936 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jBOSe-0000P0-BQ for geb-bug-gnu-emacs@m.gmane-mx.org; Mon, 09 Mar 2020 15:53:12 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:54809) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jBOOh-00007M-0T for bug-gnu-emacs@gnu.org; Mon, 09 Mar 2020 15:49:08 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1jBOOc-0001ML-IZ for bug-gnu-emacs@gnu.org; Mon, 09 Mar 2020 15:49:06 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:45509) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1jBOOc-0001M7-7P for bug-gnu-emacs@gnu.org; Mon, 09 Mar 2020 15:49:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jBOOc-0006aY-5C for bug-gnu-emacs@gnu.org; Mon, 09 Mar 2020 15:49:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Pieter van Oostrum Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Mon, 09 Mar 2020 19:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 39962 X-GNU-PR-Package: emacs Original-Received: via spool by 39962-submit@debbugs.gnu.org id=B39962.158378334025318 (code B ref 39962); Mon, 09 Mar 2020 19:49:02 +0000 Original-Received: (at 39962) by debbugs.gnu.org; 9 Mar 2020 19:49:00 +0000 Original-Received: from localhost ([127.0.0.1]:51482 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jBOOZ-0006aH-C3 for submit@debbugs.gnu.org; Mon, 09 Mar 2020 15:49:00 -0400 Original-Received: from [145.132.212.31] (port=58119 helo=cochabamba.vanoostrum.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jBOOV-0006a0-7I for 39962@debbugs.gnu.org; Mon, 09 Mar 2020 15:48:58 -0400 Original-Received: from cochabamba.vanoostrum.org (localhost [IPv6:::1]) by cochabamba.vanoostrum.org (Postfix) with ESMTP id 0DCE8AAAF24E; Mon, 9 Mar 2020 20:48:49 +0100 (CET) In-Reply-To: <83d09lbgk5.fsf@gnu.org> (Eli Zaretskii's message of "Mon, 09 Mar 2020 19:10:02 +0200") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.io gmane.emacs.bugs:177105 Archived-At: --=-=-= Content-Type: text/plain Eli Zaretskii writes: >> From: Pieter van Oostrum >> Cc: Pieter van Oostrum , 39962@debbugs.gnu.org, Eli >> Zaretskii >> Date: Mon, 09 Mar 2020 14:26:19 +0100 >> >> OK, with this change I get sensible information: >> >> (gdb) f 9 >> #9 0x0000000100314bfe in Ffuncall (nargs=2, args=0x7ffeefbf6e78) >> at eval.c:2796 >> 2796 val = funcall_lambda (fun, numargs, args + 1); >> (gdb) p args[0] >> $50 = XIL(0xcfeb420) >> (gdb) xtype >> Lisp_Symbol >> (gdb) xsymbol >> $51 = (struct Lisp_Symbol *) 0x10da24150 >> "vm-set-summary-pointer" > > Thanks (and thanks to Paul for making GD|B usable in this case). > > So does vm-set-summary-pointer indeed call mapatoms as part of its > job? If so, can you show the relevant code fragment(s)? You probably mean vm-update-summary-and-mode-line (in frame #24). That one indeed calls mapatoms. It uses it to find all the buffers. I don't know why they don't use '(buffer-list)'. And then that calls vm-do-needed-summary-rebuild which calls vm-set-summary-pointer But anyway, this shouldn't crash emacs. By the way, with Paul's patch, I now do get a normal Lisp backtrace. It's equal to what I got the hard way: Lisp Backtrace: "vm-set-summary-pointer" (0xefbf6e80) "vm-do-needed-summary-rebuild" (0xefbf7e50) 0x5c5b460 PVEC_COMPILED "mapatoms" (0xefbf91a0) "vm-update-summary-and-mode-line" (0xefbfa1c0) "vm" (0xefbfb610) "vm-visit-folder" (0xefbfc960) "funcall-interactively" (0xefbfc958) "call-interactively" (0xefbfd9c0) "command-execute" (0xefbfea20) (gdb) I include the whole Elisp file with these functions. --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=vm-summary.el Content-Transfer-Encoding: quoted-printable ;;; vm-summary.el --- Summary gathering and formatting routines for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1995, 2000 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; Copyright (C) 2009-2010 Uday S Reddy ;; Copyright (C) 2010 Arik Mitschang ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-summary) (eval-and-compile (require 'vm-misc) (require 'vm-crypto) (require 'vm-folder) (require 'vm-window) (require 'vm-menu) (require 'vm-toolbar) (require 'vm-mouse) (require 'vm-motion) (require 'vm-mime) (require 'vm-thread) (require 'vm-imap) (require 'vm-pop) (require 'vm-summary-faces) ) (declare-function set-specifier "vm-xemacs"=20 (specifier value &optional locale tag-set how-to-add)) (declare-function rfc822-addresses "ext:rfc822" (header-text)) (declare-function vm-visit-folder "vm.el"=20 (folder &optional read-only &key interactive just-visit)) (declare-function vm-set-folded-flag "vm-undo.el" (m flag &optional norecor= d)) (declare-function vm-sort-messages "vm-sort.el" (keys &optional lets-get-physical)) (defvar scrollbar-height) ; defined for XEmacs (defun vm-summary-trace-message () (interactive) (add-to-list 'vm-summary-traced-messages (vm-number-of (vm-current-message))) (message "%s" vm-summary-traced-messages)) (defsubst vm-summary-debug (m) (if (and vm-debug (member (vm-number-of m) vm-summary-traced-messages)) (debug 'vm-summary m))) (defsubst vm-summary-message-at-point () "Returns the message of the current summary line." (save-excursion (forward-line 0) ;; The point often ends up preceding the invisible stuff. Skip it. (while (get-text-property (point) 'invisible) (forward-char)) (if (eobp) nil (get-text-property (+ (point) 3) 'vm-message)))) (defsubst vm-summary-padded-thread-count (m) "Returns a formatted thread count of the message M, usable in summary display." (let ((count (vm-thread-count m))) (if (> count 1) (format "+%-2s" (1- (vm-thread-count m))) " "))) (defsubst vm-summary-message-number-thread-descendant (m) "Returns the message number of M, padded with spaces to display as an interior message of a thread." (concat " " (vm-padded-number-of m) " ")) (defsubst vm-expanded-root-p (m) "Returns t if M is the root of a thread that is currently shown expanded (using the folded attribute of the message)." (and (vm-thread-root-p m) (null (vm-folded-flag m)))) (defsubst vm-collapsed-root-p (m) "Returns t if M is the root fo a thread that is currently shown collapsed (usint the folded attribute of the message)." (and (vm-thread-root-p m) (vm-folded-flag m))) (defsubst vm-summary-set-root-collapsed (m) "Set a thread root message M as being collapsed. Folder is not marked as modified." (vm-set-folded-flag m t t)) (defsubst vm-summary-set-root-expanded (m) "Set a thread root message M as being expanded. Folder is not marked as modified." (vm-set-folded-flag m nil t)) (defsubst vm-summary-mark-root-collapsed (m) "Mark a thread root message M as collapsed." (vm-set-folded-flag m t)) (defsubst vm-summary-mark-root-expanded (m) "Mark a thread root message M as expanded." (vm-set-folded-flag m nil)) (defsubst vm-visible-message (m) (apply 'vm-vs-or m vm-summary-visible)) ;; This variable is only in Emacs 24 (defvar bidi-paragraph-direction) (defun vm-summary-mode-internal () (setq mode-name "VM Summary" major-mode 'vm-summary-mode mode-line-format vm-mode-line-format ;; must come after the setting of major-mode mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t vm-summary-pointer nil vm-summary-=3D> (if (stringp vm-summary-arrow) vm-summary-arrow "") vm-summary-no-=3D> (make-string (length vm-summary-=3D>) ? ) truncate-lines t ;; Needed for Emacs 24 bidi display bidi-paragraph-direction 'left-to-right) ;; horizontal scrollbar off by default ;; user can turn it on in summary hook if desired. (when (and vm-xemacs-p (featurep 'scrollbar)) (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-summary-mode-map) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) ;; using the 'mouse-face property gives faster highlighting than this. ;; (and vm-mouse-track-summary ;; (vm-mouse-support-possible-p) ;; (vm-mouse-xemacs-mouse-p) ;; (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) (when (and vm-mutable-frame-configuration=20 (or vm-frame-per-folder vm-frame-per-summary)) (vm-set-hooks-for-frame-deletion)) (run-hooks 'vm-summary-mode-hook) ;; Lucid Emacs apparently used this name (run-hooks 'vm-summary-mode-hooks)) (fset 'vm-summary-mode 'vm-mode) (put 'vm-summary-mode 'mode-class 'special) ;;;###autoload (defun vm-summarize (&optional display raise) "Summarize the contents of the folder in a summary buffer. The format is as described by the variable `vm-summary-format'. Generally one line per message is most pleasing to the eye but this is not mandatory." (interactive "p\np") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (null vm-summary-buffer) (let ((b (current-buffer)) (read-only vm-folder-read-only) (summary-buffer-name (format "%s Summary" (buffer-name)))) (setq vm-summary-buffer (or (get-buffer summary-buffer-name) (vm-generate-new-multibyte-buffer summary-buffer-name))) (save-excursion (set-buffer vm-summary-buffer) (abbrev-mode 0) (auto-fill-mode 0) ;; Experimental code to use buffer-face-mode to change font ;; (when (boundp 'vm-summary-face) ;; (setq bufer-face-mode-face vm-summary-face) ;; (buffer-face-mode 1)) (vm-fsfemacs-nonmule-display-8bit-chars) (if (fboundp 'buffer-disable-undo) (buffer-disable-undo (current-buffer)) ;; obfuscation to make the v19 compiler not whine ;; about obsolete functions. (let ((x 'buffer-flush-undo)) (funcall x (current-buffer)))) (setq vm-mail-buffer b vm-folder-read-only read-only) (vm-summary-mode-internal)) (vm-set-summary-redo-start-point t))) (if display (save-excursion (vm-goto-new-summary-frame-maybe) (vm-display vm-summary-buffer t '(vm-summarize vm-summarize-other-frame) (list this-command) (not raise)) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (set-buffer vm-summary-buffer) (vm-toolbar-install-or-uninstall-toolbar)) (vm-display nil nil '(vm-summarize vm-summarize-other-frame) (list this-command))) (vm-update-summary-and-mode-line)) (defalias 'vm-headers-summary 'vm-summarize) ;;;###autoload (defun vm-summarize-other-frame (&optional display) "Like vm-summarize, but run in a newly created frame." (interactive "p") (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'summary)) (vm-summarize display) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) (defalias 'vm-headers-summary-other-frame 'vm-summarize-other-frame) (defun vm-do-summary (&optional start-point) "Generate summary lines for all the messages in the optional argument START-POINT (a list of messages) or, if it is nil, all the messages in the current folder." (let ((m-list (or start-point vm-message-list)) (n 0) (modulus 100) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces))) ;; (setq mp m-list) (save-excursion (set-buffer vm-summary-buffer) (setq line-move-ignore-invisible vm-summary-show-threads) (let ((buffer-read-only nil) (modified (buffer-modified-p)) (debug nil) ; vm-summary-debug, if necessary track) (unwind-protect (progn (if (null start-point) (setq vm-summary-pointer nil)) (if start-point (goto-char (or (vm-su-start-of (car m-list)) (point-max))) (goto-char (point-min))) (vm-disable-extents (point) (point-max)) (delete-region (point) (point-max)) ;; avoid doing long runs down the marker chain while ;; building the summary. use integers to store positions ;; and then convert them to markers after all the ;; insertions are done. Likewise, detach overlays and ;; re-establish them afterwards. (vm-inform 7 "%s: Generating summary... %d"=20 (buffer-name vm-mail-buffer) n) (overlay-recenter (point)) (let ((mp m-list) m start end track) (while mp (setq m (car mp)) (setq start (vm-su-start-of m) end (vm-su-end-of m) track (vm-su-summary-mouse-track-overlay-of m)) (when start (set-marker start nil)) (vm-set-su-start-of m nil) (when end (set-marker end nil)) (vm-set-su-end-of m nil) (when track (vm-detach-extent track)) (setq mp (cdr mp)))) (overlay-recenter (point-max)) (let ((mp m-list)=20 m root) (while mp (setq m (car mp)) (vm-summary-debug m) (vm-set-su-start-of m (point)) (insert vm-summary-no-=3D>) (vm-tokenized-summary-insert m (vm-su-summary m)) (vm-set-su-end-of m (point)) (let ((s (vm-su-start-of m)) (e (vm-su-end-of m))) (when s (put-text-property s e 'vm-message m) (when (and vm-summary-enable-thread-folding vm-summary-show-threads) (if (=3D (vm-thread-indentation-of m) 0) (when (> (vm-thread-count m) 1) ;; FIXME this is not working yet. ;; USR 2012-11-12 ;; (if vm-summary-threads-collapsed ;; (vm-summary-set-root-collapsed m) ;; (vm-summary-set-root-expanded m)) (if vm-summary-threads-collapsed (vm-summary-mark-root-collapsed m) (vm-summary-mark-root-expanded m)) ) (setq root (vm-thread-root m)) (when (and root (vm-collapsed-root-p root)) (unless (vm-visible-message m) (put-text-property s e 'invisible t)) ;; why mess with the root here? USR, 2010-07-20 ;; (vm-summary-mark-root-collapsed root) ))))) (setq mp (cdr mp) n (1+ n)) (when (zerop (% n modulus)) (vm-inform 7 "%s: Generating summary... %d"=20 (buffer-name vm-mail-buffer) n) (if debug (debug "vm-debug-summary: Generating summary")) (setq debug nil))))) ;; unwind-protection ;; convert the summary markers back from ints (let ((mp m-list) m start end) (while mp (setq m (car mp)) (setq start (or (vm-su-start-of m) (point-max)) end (or (vm-su-end-of m) (point-max)) track (vm-su-summary-mouse-track-overlay-of m)) (when do-mouse-track (vm-set-su-summary-mouse-track-overlay-of m (vm-mouse-set-mouse-track-highlight start end track))) (vm-set-su-start-of m (vm-marker start)) (vm-set-su-end-of m (vm-marker end)) (when vm-summary-enable-faces (vm-summary-faces-add m)) (setq mp (cdr mp)))) (set-buffer-modified-p modified)) (run-hooks 'vm-summary-redo-hook))) (if (>=3D n modulus) (unless vm-summary-debug=20 (vm-inform 7 "%s: Generating summary... done"=20 (buffer-name vm-mail-buffer)))))) (defun vm-expand-thread (&optional root) "Expand the thread associated with the message at point. This will make visible all invisible elements of the thread tree and place a '-' character at the pointer position indicating that the thread can be collapsed. In a Lisp program, you should call it with an argument ROOT, which is the root of the thread you want expanded." (interactive) (unless vm-summary-enable-thread-folding=20 (error "Thread folding not enabled")) (when (vm-interactive-p) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (vm-follow-summary-cursor) (set-buffer vm-summary-buffer)) (let ((buffer-read-only nil)) (unless root (setq root (vm-thread-root (vm-summary-message-at-point)))) (when (> (vm-thread-count root) 1) (vm-summary-mark-root-expanded root) (vm-mark-for-summary-update root) (mapc (lambda (m)=20 (put-text-property=20 (vm-su-start-of m) (vm-su-end-of m) 'invisible nil)) (vm-thread-subtree (vm-thread-symbol root))) (when (vm-interactive-p) (vm-update-summary-and-mode-line))))) (defun vm-collapse-thread (&optional nomove root) "Collapse the thread associated with the message at point. This will make invisible all read and non-new elements of the thread tree and will place a '+' character at the pointer position indicating the thread can be expanded. Optional argument nomove directs vm-collapse-thread to not take the default action of moving the pointer to the thread root after collapsing. In a Lisp program, you should call it with an additional argument ROOT, which is the root of the thread you want collapsed." (interactive "P") (unless vm-summary-enable-thread-folding=20 (error "Thread folding not enabled")) (when (vm-interactive-p) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (vm-follow-summary-cursor) (set-buffer vm-summary-buffer)) (let ((buffer-read-only nil) (msg nil)) (unless root (setq msg (vm-summary-message-at-point)) (setq root (vm-thread-root msg))) (when (> (vm-thread-count root) 1) (vm-summary-mark-root-collapsed root) (vm-mark-for-summary-update root) (mapc (lambda (m)=20 (unless (or (eq m root) (vm-visible-message m)) (put-text-property=20 (vm-su-start-of m) (vm-su-end-of m) 'invisible t))) (vm-thread-subtree (vm-thread-symbol root))) ;; move to the parent thread only when not ;; instructed not to, AND when the currently ;; selected message will become invisible (when (vm-interactive-p) (unless nomove (when (get-text-property (+ (vm-su-start-of msg) 3) 'invisible) (goto-char (vm-su-start-of root)))) (vm-update-summary-and-mode-line))))) =09 (defun vm-expand-all-threads () "Expand all threads in the folder, which might have been collapsed (folded) earlier." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (let ((ml vm-message-list)) (with-current-buffer vm-summary-buffer (save-excursion (mapc (lambda (m) (when (and (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (vm-expand-thread m))) ml)))) (setq vm-summary-threads-collapsed nil) (when (vm-interactive-p) (vm-update-summary-and-mode-line))) (defun vm-collapse-all-threads () "Collapse (fold) all threads in the folder so that only the roots of the threads are shown in the Summary window." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (let ((ml vm-message-list) msg root) (with-current-buffer vm-summary-buffer (setq msg (vm-summary-message-at-point)) (setq root (vm-thread-root msg)) (save-excursion (mapc (lambda (m) (when (and (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (vm-collapse-thread t m))) ml)) (when (vm-interactive-p) (when (get-text-property (+ (vm-su-start-of msg) 3) 'invisible) (goto-char (vm-su-start-of root)))))) (setq vm-summary-threads-collapsed t) (when (vm-interactive-p) (vm-update-summary-and-mode-line))) =20=20=20=20=20=20 (defun vm-toggle-thread () "Toggle collapse/expand thread associated with message at point. see `vm-expand-thread' and `vm-collapse-thread' for a description of action." (interactive) (when (and vm-summary-enable-thread-folding vm-summary-show-threads) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (when vm-summary-buffer (set-buffer vm-summary-buffer) (let ((buffer-read-only nil) (msg (vm-summary-message-at-point)) root next) (when msg (setq root (vm-thread-root msg)) (if (vm-expanded-root-p root) (call-interactively 'vm-collapse-thread) (call-interactively 'vm-expand-thread)) ))))) (defun vm-do-needed-summary-rebuild () "Rebuild the summary lines of all the messages starting at `vm-summary-redo-start-point'. Also, reset the summary pointer to the current message. Do the latter anyway if `vm-need-summary-pointer-update' is non-NIL. All this, only if the Summary buffer exists. " (if (and vm-summary-redo-start-point vm-summary-buffer) (progn (vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads) (vm-do-summary (and (consp vm-summary-redo-start-point) vm-summary-redo-start-point)) (setq vm-summary-redo-start-point nil) (when vm-message-pointer (vm-set-summary-pointer (car vm-message-pointer))) (setq vm-need-summary-pointer-update nil)) (when (and vm-need-summary-pointer-update vm-summary-buffer vm-message-pointer) (vm-set-summary-pointer (car vm-message-pointer)) (setq vm-need-summary-pointer-update nil)))) (defun vm-update-message-summary (m) "Replace the summary line of the message M in the summary buffer by a regenerated summary line." (vm-summary-debug m) (if (and (buffer-name (vm-buffer-of m)) ; ignore deleted folders and (markerp (vm-su-start-of m)) ; markers into deleted buffers (marker-buffer (vm-su-start-of m))) (let ((modified (buffer-modified-p)) ; Folder or Presentation (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) summary) (save-excursion (setq summary (vm-su-summary m)) (set-buffer (marker-buffer (vm-su-start-of m))) (let ((buffer-read-only nil) s e i (selected nil) (indicator nil) (modified (buffer-modified-p))) ; Summary buffer (unwind-protect (save-excursion (goto-char (vm-su-start-of m)) (setq selected (looking-at "[+-]>")) (if (and vm-summary-show-threads (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (setq indicator (if (vm-collapsed-root-p m) "+" "-")) (setq indicator nil)) ;; We do a little dance to update the text in ;; order to make the markers in the text do ;; what we want. ;; ;; 1. We need to avoid having the su-start-of ;; and su-end-of markers clumping together at ;; the start position. ;; ;; 2. We want the window point marker (w->pointm ;; in the Emacs display code) to move to the ;; start of the summary entry if it is ;; anywhere within the su-start-of to ;; su-end-of region. ;; ;; We achieve (2) by deleting before inserting. ;; Reversing the order of insertion/deletion ;; pushes the point marker into the next ;; summary entry. We achieve (1) by inserting a ;; placeholder character at the end of the ;; summary entry before deleting the region.=09=09=20=20 (goto-char (vm-su-end-of m))=20=09=09 (insert-before-markers "z") (goto-char (vm-su-start-of m)) (setq s (vm-su-start-of m)) (setq e (vm-su-end-of m)) (setq i (get-text-property (+ s 2) 'invisible)) (delete-region (point) (1- (vm-su-end-of m)))=09=09=20=20 (if (not selected)=09=09=20=20=20=20=20 (insert (concat (or indicator " ") " ")) (if indicator (insert (concat indicator ">")) (insert vm-summary-=3D>))) (vm-tokenized-summary-insert m (vm-su-summary m)) (delete-char 1) ; delete "z" (run-hooks 'vm-summary-update-hook) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-su-start-of m) (vm-su-end-of m) (vm-su-summary-mouse-track-overlay-of m))) (if vm-summary-enable-faces (vm-summary-faces-add m) (if (and selected=20 (facep vm-summary-highlight-face)) (vm-summary-highlight-region=20 (vm-su-start-of m) (point) vm-summary-highlight-face)))) (when s (put-text-property s e 'vm-message m) (put-text-property s e 'invisible i)) (vm-reset-buffer-modified-p ; Summary buffer modified (current-buffer)) )))))) (defun vm-set-summary-pointer (m) "Set the summary-pointer in the summary window to the message M. Also move the cursor (point and window-point)." (if vm-summary-buffer (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) (old-window nil)) (with-current-buffer vm-summary-buffer (when w (setq old-window (selected-window)) (select-window w)) (unwind-protect (let ((buffer-read-only nil)) (when (and vm-summary-pointer (vm-su-start-of vm-summary-pointer)) (goto-char (vm-su-start-of vm-summary-pointer)) (if (not (get-text-property (+ (point) 3) 'invisible)) (let ((msg (vm-summary-message-at-point))) (if (and vm-summary-show-threads vm-summary-enable-thread-folding (eq msg (vm-thread-root msg)) (> (vm-thread-count msg) 1)) (if (vm-collapsed-root-p msg) (progn (insert "+ ")=20 (delete-char (length vm-summary-=3D>))) (progn (insert "- ") (delete-char (length vm-summary-=3D>)))) (insert vm-summary-no-=3D>) (delete-char (length vm-summary-=3D>)))) (delete-char (length vm-summary-=3D>)) (insert vm-summary-no-=3D>) ;; re-invisible it so we dont have problems (put-text-property=20 (- (point) (length vm-summary-no-=3D>)) (point)=20 'invisible t)) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-su-start-of vm-summary-pointer) (vm-su-end-of vm-summary-pointer) (vm-su-summary-mouse-track-overlay-of vm-summary-pointer))) (when vm-summary-enable-faces=20 (vm-summary-faces-add vm-summary-pointer))) (setq vm-summary-pointer m) (goto-char (vm-su-start-of m)) (let ((modified (buffer-modified-p))) (unwind-protect (progn ;; ;; when we move the cursor, the thread-state ;; indicator should have already changed, ;; check now to see if we should set the ;; cursor with indicator ;; ;; if, somehow, the cursor became on an ;; invisible message in a collapsed thread, ;; assume that there is a good reason for ;; this and expand the thread (e.g in ;; visiting a folder with bookmark on ;; sub-thread ;; (if vm-summary-show-threads (if (vm-collapsed-root-p m) (insert "+>") (if (get-text-property=20 (+ (vm-su-start-of m) 3) 'invisible) (progn (insert vm-summary-=3D>) (vm-expand-thread=20 (vm-thread-root m))) (insert vm-summary-=3D>))) (insert vm-summary-=3D>)) (delete-char (length vm-summary-=3D>)) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-su-start-of m) (vm-su-end-of m) (vm-su-summary-mouse-track-overlay-of m))) (when vm-summary-enable-faces=20 (vm-summary-faces-add m))) (set-buffer-modified-p modified))) (forward-char (- (length vm-summary-=3D>))) (when vm-summary-highlight-face (vm-summary-highlight-region (vm-su-start-of m) (vm-su-end-of m) vm-summary-highlight-face)) (when (and w vm-auto-center-summary) (vm-auto-center-summary)) (run-hooks 'vm-summary-pointer-update-hook)) ;; unwind-protections (when old-window (select-window old-window))))))) (defun vm-summary-highlight-region (start end face) (vm-summary-xxxx-highlight-region start end face 'vm-summary-overlay)) (defun vm-folders-summary-highlight-region (start end face) (vm-summary-xxxx-highlight-region start end face 'vm-folders-summary-overlay)) (defun vm-summary-xxxx-highlight-region (start end face var) (let ((ooo (symbol-value var))) (cond (vm-fsfemacs-p (if (and ooo (overlay-buffer ooo)) (move-overlay ooo start end) (setq ooo (make-overlay start end)) (set var ooo) (overlay-put ooo 'evaporate nil) (overlay-put ooo 'face face))) (vm-xemacs-p (if (and ooo (vm-extent-end-position ooo)) (vm-set-extent-endpoints ooo start end) (setq ooo (vm-make-extent start end)) (set var ooo) ;; the reason this isn't needed under FSF Emacs is ;; that insert-before-markers also inserts before ;; overlays! so a summary update of an entry just ;; before this overlay in the summary buffer won't ;; leak into the overlay, but it _will_ leak into an ;; XEmacs extent. (vm-set-extent-property ooo 'start-open t) (vm-set-extent-property ooo 'detachable nil) (vm-set-extent-property ooo 'face face)))))) (defun vm-auto-center-summary () (if vm-auto-center-summary (if (or (eq vm-auto-center-summary t) (not (one-window-p t))) (recenter '(4))))) (defvar vm-su-message nil) ; used for dynamic binding (defun vm-summary-sprintf (format message &optional tokenize) "Generates a summary in FORMAT for MESSAGE and return the result. The optional argument TOKENIZE says whether the summary should be in tokenized form. If so, the result is a list of tokens, including strings in mime-decoded form with text-properties. Otherwise, it is a string in mime-decoded form with text-properties. USR, 2010-05-13"=20 ;; compile the format into an eval'able s-expression ;; if it hasn't been compiled already. (let* ((alist-var (if tokenize 'vm-summary-tokenized-compiled-format-alist 'vm-summary-untokenized-compiled-format-alist)) (match (assoc format (symbol-value alist-var)))) (unless match (vm-summary-compile-format format tokenize) (setq match (assoc format (symbol-value alist-var)))) ;; The local variable name `vm-su-message' is mandatory here for ;; the format s-expression to work. (let ((vm-su-message message) (vm-mime-qp-decoder-program nil) ; speed up decoding (vm-mime-base64-decoder-program nil)) (if (or tokenize (null vm-display-using-mime)) (eval (cdr match)) (vm-decode-mime-encoded-words-in-string (eval (cdr match))))))) (defun vm-summary-compile-format (format tokenize) "Compile FORMAT into an eval'able expression that generates the summary. If TOKENIZE is t, the the summary generated will be a list of tokens. Otherwise it is a string in mime-decoded form with text-propertiies. USR, 2010-05-13." (let ((return-value (nth 1 (vm-summary-compile-format-1 format tokenize))= )) (if tokenize (setq vm-summary-tokenized-compiled-format-alist (cons (cons format return-value) vm-summary-tokenized-compiled-format-alist)) (setq vm-summary-untokenized-compiled-format-alist (cons (cons format return-value) vm-summary-untokenized-compiled-format-alist))))) ;; Inserts the summary line for MESSAGE created from TOKENS, which is ;; a list of tokens. A token is one of=20 ;; - string, which is inserted literally,=20 ;; - 'number, meaning message number, ;; - 'mark, meaning the message mark indicator, ;; - 'thread-indent, meaning the indentation space for the message ;; - 'group-begin and 'group-end (defun vm-tokenized-summary-insert (message tokens) "Insert a summary line for MESSAGE in the current buffer, using the tokenized summary TOKENS." (if (stringp tokens) (insert tokens) (let (token group-list) (while tokens (setq token (car tokens)) (cond ((stringp token) (if vm-display-using-mime (let ((vm-mime-qp-decoder-program nil) ; speed up decoding (vm-mime-base64-decoder-program nil)) (insert (vm-decode-mime-encoded-words-in-string token))) (insert token))) ((eq token 'group-begin) (setq group-list (cons (list (point) (nth 1 tokens) (nth 2 tokens)) group-list) tokens (cdr (cdr tokens)))) ((eq token 'group-end) (let* ((space (string-to-char " ")) (blob (car group-list)) (start (car blob)) (field-width (nth 1 blob)) (precision (nth 2 blob)) (end (vm-marker (point)))) (if (integerp field-width) (if (< (- end start) (vm-abs field-width)) (if (< field-width 0) (insert-char space (vm-abs (+ field-width (- end start)))) (save-excursion (goto-char start) (insert-char space (- field-width (- end start))))))) (if (integerp precision) (if (> (- end start) (vm-abs precision)) (if (> precision 0) (delete-char (- precision (- end start))) (save-excursion (goto-char start) (delete-char (vm-abs (+ precision (- end start)))))))) (setq group-list (cdr group-list)))) ((eq token 'number) (if (and vm-summary-enable-thread-folding vm-summary-show-threads vm-summary-show-thread-count) (if (=3D (vm-thread-indentation message) 0) (insert (concat (vm-padded-number-of message)=20 (vm-summary-padded-thread-count message))) (insert (vm-summary-message-number-thread-descendant message))) (insert (vm-padded-number-of message)))) ((eq token 'mark) (insert (vm-su-mark message))) ((eq token 'thread-indent) (if (and vm-summary-show-threads (natnump vm-summary-thread-indent-level)) (insert-char=20 ?\=20 (* vm-summary-thread-indent-level (min vm-summary-maximum-thread-indentation (vm-thread-indentation message))))))) (setq tokens (cdr tokens)))))) (defun vm-reencode-mime-encoded-words-in-tokenized-summary (summary) "Given a tokenized SUMMARY, with tokens including mime-decoded strings, returns another version where the strings are reencoded in mime. It is used for writing summary lines to disk. USR, 2010-05-13." (mapcar (function (lambda (token) (if (stringp token) (vm-reencode-mime-encoded-words-in-string token) token))) summary)) (defun vm-summary-compile-format-1 (format &optional tokenize start-index) (or start-index (setq start-index 0)) (let ((case-fold-search nil) (finished-parsing-format nil) (list nil) (sexp nil) (sexp-fmt nil) (saw-close-group nil) (last-match-end start-index) new-match-end token conv-spec splice) (store-match-data nil) (while (and (not saw-close-group) (not finished-parsing-format)) (setq token nil splice nil) (while (and (not saw-close-group) (not token) (string-match "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()pPaAbcSdfFhHiIlLmMns= tTwyz*%]\\|U[A-Za-z]\\)" format last-match-end)) (setq conv-spec (aref format (match-beginning 5))) (setq new-match-end (match-end 0)) (if (and (memq conv-spec '(?\( ?\) ?p ?P ?a ?A ?b ?c ?S ?d ?f ?F ?h ?H ?i = ?I ?l ?L ?M ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* )) ;; for the non-tokenized path, we don't want ;; the close group spcifier processed here, we ;; want to just bail out and return, which is ;; accomplished by setting a flag in the other ;; branch of this 'if'. (or tokenize (not (=3D conv-spec ?\))))) (progn (cond ((=3D conv-spec ?\() (if (not tokenize) (save-match-data (let ((retval (vm-summary-compile-format-1 format tokenize (match-end 5)))) (setq sexp (cons (nth 1 retval) sexp) new-match-end (car retval)))) (setq token `('group-begin ,(if (match-beginning 2) (string-to-number (concat (match-string 1 format) (match-string 2 format)))) ,(string-to-number (match-string 4 format))) splice t))) ((=3D conv-spec ?\)) (setq token ''group-end)) ((=3D conv-spec ?p) (setq sexp (cons (list 'vm-su-postponed-indicator 'vm-su-message) sexp))) ((=3D conv-spec ?P) (setq sexp (cons (list 'vm-su-attachment-indicator 'vm-su-message) sexp))) ((=3D conv-spec ?a) (setq sexp (cons (list 'vm-su-attribute-indicators 'vm-su-message) sexp))) ((=3D conv-spec ?A) (setq sexp (cons (list 'vm-su-attribute-indicators-long 'vm-su-message) sexp))) ((=3D conv-spec ?b) (setq sexp (cons (list 'vm-su-attribute-indicators-short 'vm-su-message) sexp))) ((=3D conv-spec ?c) (setq sexp (cons (list 'vm-su-byte-count 'vm-su-message) sexp))) ((=3D conv-spec ?S) (setq sexp (cons (list 'vm-su-size 'vm-su-message) sexp))) ((=3D conv-spec ?d) (setq sexp (cons (list 'vm-su-monthday 'vm-su-message) sexp))) ((=3D conv-spec ?f) (setq sexp (cons (list 'vm-su-interesting-from 'vm-su-message) sexp))) ((=3D conv-spec ?F) (setq sexp (cons (list 'vm-su-interesting-full-name 'vm-su-message) sexp))) ((=3D conv-spec ?h) (setq sexp (cons (list 'vm-su-hour 'vm-su-message) sexp))) ((=3D conv-spec ?H) (setq sexp (cons (list 'vm-su-hour-short 'vm-su-message) sexp))) ((=3D conv-spec ?i) (setq sexp (cons (list 'vm-su-message-id 'vm-su-message) sexp))) ((=3D conv-spec ?I) (if tokenize (setq token ''thread-indent) (setq sexp (cons (list 'vm-su-thread-indent 'vm-su-message) sexp)))) ((=3D conv-spec ?l) (setq sexp (cons (list 'vm-su-line-count 'vm-su-message) sexp))) ((=3D conv-spec ?L) (setq sexp (cons (list 'vm-su-labels 'vm-su-message) sexp))) ((=3D conv-spec ?m) (setq sexp (cons (list 'vm-su-month 'vm-su-message) sexp))) ((=3D conv-spec ?M) (setq sexp (cons (list 'vm-su-month-number 'vm-su-message) sexp))) ((=3D conv-spec ?n) (if tokenize (setq token ''number) (setq sexp (cons (list 'vm-padded-number-of 'vm-su-message) sexp)))) ((=3D conv-spec ?s) (setq sexp (cons (list 'vm-su-summary-subject 'vm-su-message) sexp))) ((=3D conv-spec ?T) (setq sexp (cons (list 'vm-su-to-names 'vm-su-message) sexp))) ((=3D conv-spec ?t) (setq sexp (cons (list 'vm-su-to 'vm-su-message) sexp))) ((=3D conv-spec ?R) (setq sexp (cons (list 'vm-su-to-cc-names 'vm-su-message) sexp))) ((=3D conv-spec ?r) (setq sexp (cons (list 'vm-su-to-cc 'vm-su-message) sexp))) ((=3D conv-spec ?U) (setq sexp (cons (list 'vm-run-user-summary-function (list 'quote (intern (concat "vm-summary-function-" (substring format (1+ (match-beginning 5)) (+ 2 (match-beginning 5)))))) 'vm-su-message) sexp))) ((=3D conv-spec ?w) (setq sexp (cons (list 'vm-su-weekday 'vm-su-message) sexp))) ((=3D conv-spec ?y) (setq sexp (cons (list 'vm-su-year 'vm-su-message) sexp))) ((=3D conv-spec ?z) (setq sexp (cons (list 'vm-su-zone 'vm-su-message) sexp))) ((=3D conv-spec ?*) (if tokenize (setq token ''mark) (setq sexp (cons (list 'vm-su-mark 'vm-su-message) sexp))))) (cond ((and (not token) vm-display-using-mime) ;; strings might have been already mime-decoded, ;; but there is no harm in doing it again. USR, 2010-05-13 (setcar sexp (list 'vm-decode-mime-encoded-words-in-string (car sexp))))) (cond ((and (not token) (match-beginning 1) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-left-justify-string 'vm-left-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2)))))) ((and (not token) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-right-justify-string 'vm-right-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2))))))) (cond ((and (not token) (match-beginning 3)) (setcar sexp (list 'vm-truncate-string (car sexp) (string-to-number (substring format (match-beginning 4) (match-end 4))))))) ;; Why do we reencode decoded strings? USR, 2010-05-12 ;; (cond ((and (not token) vm-display-using-mime) ;; (setcar sexp ;; (list 'vm-reencode-mime-encoded-words-in-string ;; (car sexp))))) (setq sexp-fmt (cons (if token "" "%s") (cons (substring format last-match-end (match-beginning 0)) sexp-fmt)))) (setq sexp-fmt (cons (if (eq conv-spec ?\)) (prog1 "" (setq saw-close-group t)) "%%") (cons (substring format (or last-match-end 0) (match-beginning 0)) sexp-fmt)))) (setq last-match-end new-match-end)) (if (and (not saw-close-group) (not token)) (setq sexp-fmt (cons (substring format last-match-end (length format)) sexp-fmt) finished-parsing-format t)) (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) (if sexp (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) (setq sexp sexp-fmt)) (if tokenize (setq list (nconc list (if (equal sexp "") nil (list sexp)) (and token (if splice token (list token)))) sexp nil sexp-fmt nil))) (list last-match-end (if list (cons 'list list) sexp)))) ;;;###autoload (defun vm-get-header-contents (message header-name-regexp &optional clump-s= ep) "Return the header field of MESSAGE with the header name matching HEADER-NAME-REGEXP. The result will be a string that is mime-encoded. The optional argument CLUMP-SEP, if present, should be a string, which can be used as a separator to concatenate the fields of multiple header lines which might match HEADER-NAME-REGEXP. USR, 2010-05-13." (let ((contents nil) (regexp (concat "^\\(" header-name-regexp "\\)"))) (setq message (vm-real-message-of message)) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) (save-restriction (widen) (goto-char (vm-headers-of message)) (let ((case-fold-search t)) (while (and (or (null contents) clump-sep) (re-search-forward regexp (vm-text-of message) t) (save-excursion (goto-char (match-beginning 0)) (vm-match-header))) (if contents (setq contents (concat contents clump-sep (vm-matched-header-contents))) (setq contents (vm-matched-header-contents)))))) contents ))) ;; Do not use Emacs 20's string-width here. ;; It does not consider buffer-display-table. (defun vm-string-width (string) (if (not (fboundp 'char-width)) (length string) (let ((i 0) (lim (length string)) (total 0)) (while (< i lim) (setq total (+ total (char-width (aref string i))) i (1+ i))) total ))) (defun vm-left-justify-string (string width) (let ((sw (vm-string-width string))) (if (>=3D sw width) string (concat string (make-string (- width sw) ?\ ))))) (defun vm-right-justify-string (string width) (let ((sw (vm-string-width string))) (if (>=3D sw width) string (concat (make-string (- width sw) ?\ ) string)))) ;; I don't think number glyphs ever have a width > 1 (defun vm-numeric-left-justify-string (string width) (let ((sw (length string))) (if (>=3D sw width) string (concat string (make-string (- width sw) ?0))))) ;; I don't think number glyphs ever have a width > 1 (defun vm-numeric-right-justify-string (string width) (let ((sw (length string))) (if (>=3D sw width) string (concat (make-string (- width sw) ?0) string)))) (defun vm-truncate-string (string width) "Truncate STRING to WIDTH number of columns." (cond ((fboundp 'trucate-string-to-width) (truncate-string-to-width string width)) ((fboundp 'char-width) (cond ((> width 0) (let ((i 0) (lim (length string)) (total 0)) (while (and (< i lim) (< total width)) (setq total (+ total (char-width (aref string i))) i (1+ i))) (if (< total width) string (substring string 0 i)))) (t (let ((i (1- (length string))) (lim -1) (total 0)) (setq width (- width)) (while (and (> i lim) (< total width)) (setq total (+ total (char-width (aref string i))) i (1- i))) (if (< total width) string (substring string (1+ i))))))) (t (vm-truncate-roman-string string width)))) (defun vm-truncate-roman-string (string width) "Truncate STRING in Roman alphabet to WIDTH number of columns." (cond ((<=3D (length string) (vm-abs width)) string) ((< width 0) (substring string width)) (t (substring string 0 width)))) (defvar vm-postponed-header) ; defined vm-pine.el (defun vm-su-postponed-indicator (msg) "Given a MESSAGE, ruturns a string indicating whether the message is a postponed draft that still needs to be sent. The indicator string is that defined by the variable `vm-summary-postponed-indicator'. USR, 2010-05-13." (if (vm-get-header-contents msg vm-postponed-header) vm-summary-postponed-indicator "")) (defun vm-su-attachment-indicator (msg) "Given a MESSAGE, ruturns a string indicating whether the message has attachments. The indicator string is the value of `vm-summary-attachment-indicator' followed by the number of attachments. USR, 2010-05-13." (let ((attachments 0)) (setq msg (vm-real-message-of msg)) ;; If this calls back vm-update-summary-and-mode-line ;; an infinite regress happens! (vm-mime-operate-on-attachments nil :action (lambda (msg layout type file) (setq attachments (1+ attachments))) :included vm-summary-attachment-mime-types :excluded vm-summary-attachment-mime-type-exceptions :messages (list msg)) (if (=3D attachments 0) "" (if (stringp vm-summary-attachment-indicator) vm-summary-attachment-indicator (format "%s%d" vm-summary-attachment-indicator attachments))))) (defun vm-su-attribute-indicators (m) "Given a MESSAGE, ruturns a short string showing the attributes of the message. The string is 4 characters long. USR, 2010-05-13." (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") ((vm-flagged-flag m) "!") (t " ")) (cond ((vm-filed-flag m) "F") ((vm-written-flag m) "W") (t " ")) (cond ((vm-replied-flag m) "R") ((vm-forwarded-flag m) "Z") ((vm-redistributed-flag m) "B") (t " ")) (cond ((vm-edited-flag m) "E") (t " ")))) (defun vm-su-attribute-indicators-short (m) "Given a MESSAGE, ruturns a short string showing the attributes of the message. The string is 1 character long. USR, 2011-01-08." (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") ((vm-flagged-flag m) "!") (t " ")))) (defun vm-su-attribute-indicators-long (m) "Given a MESSAGE, ruturns a long string showing the attributes of the message. The string is 7 characters long. USR, 2010-05-13." (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") ((vm-flagged-flag m) "!") (t " ")) (if (vm-replied-flag m) "r" " ") (if (vm-forwarded-flag m) "z" " ") (if (vm-redistributed-flag m) "b" " ") (if (vm-filed-flag m) "f" " ") (if (vm-written-flag m) "w" " ") (if (vm-edited-flag m) "e" " "))) (defun vm-su-byte-count (m) "Given a message M, returns a string showing the length of the message in bytes. USR, 2010-05-13." (or (vm-byte-count-of m) (let* ((real-m (vm-real-message-of m)) (size (if (vm-body-to-be-retrieved-of real-m) (vm-fetch-message-size=20 (list (vm-message-access-method-of real-m)) real-m) (int-to-string (- (vm-text-end-of real-m) (vm-text-of real-m)))))) (vm-set-byte-count-of real-m size) (vm-set-byte-count-of m size) (or size "0")))) (defun vm-su-size (msg) "Given a MESSAGE, return a string showing the the size of the message in bytes, kilobytes or megabytes. USR, 2010-05.13" (let ((size (string-to-number (vm-su-byte-count msg)))) (cond ((< size 1024) (format "%d" size)) ((< size 1048576) (setq size (/ size 1024)) (format "%dK" size)) (t (setq size (/ size 1048576)) (format "%dM" size))))) (defun vm-su-spam-score-aux (m) "Return the numeric spam level for M. The spam level is obtained from any of the headers listed in `vm-spam-score-headers'." (let ((spam-headers vm-spam-score-headers)) (catch 'done (while spam-headers (let* ((spam-selector (car spam-headers)) (score (vm-get-header-contents m (car spam-selector)))) (when (and score (string-match (nth 1 spam-selector) score)) (throw 'done=20 (funcall (nth 2 spam-selector) (match-string 0 score)))) (setq spam-headers (cdr spam-headers)))) 0))) (defun vm-su-spam-score (m) "Return the numeric spam level for M (possibly using the cached-data)." (or (vm-spam-score-of m) (vm-set-spam-score-of m (vm-su-spam-score-aux m)))) (defun vm-su-weekday (message) "Given a MESSAGE, returns a string showing the week day on which it was sent. USR, 2010-05-13" (or (vm-weekday-of message) (progn (vm-su-do-date message) (vm-weekday-of message)))) (defun vm-su-monthday (message) "Given a MESSAGE, returns a string showing the month day on which it was sent. USR, 2010-05-13" (or (vm-monthday-of message) (progn (vm-su-do-date message) (vm-monthday-of message)))) (defun vm-su-month (message) "Given a MESSAGE, returns a string showing the month name in which it was sent. USR, 2010-05-13" (or (vm-month-of message) (progn (vm-su-do-date message) (vm-month-of message)))) (defun vm-su-month-number (message) "Given a MESSAGE, returns a string showing the month number in which it was sent. USR, 2010-05-13" (or (vm-month-number-of message) (progn (vm-su-do-date message) (vm-month-number-of message)))) (defun vm-su-year (message) "Given a MESSAGE, returns a string showing the year in which it was sent. USR, 2010-05-13" (or (vm-year-of message) (progn (vm-su-do-date message) (vm-year-of message)))) (defun vm-su-hour-short (message) "Given a MESSAGE, returns a string showing the hour in which it was sent. The hour is short (6 characters long). USR, 2012-10-13" (let ((string (vm-su-hour message))) (if (> (length string) 5) (substring string 0 5) string))) (defun vm-su-hour (message) "Given a MESSAGE, returns a string showing the hour in which it was sent. USR, 2012-10-13" (or (vm-hour-of message) (progn (vm-su-do-date message) (vm-hour-of message)))) (defun vm-su-zone (message) "Given a MESSAGE, returns a string showing the time zone in which it was sent. USR, 2012-10-13" (or (vm-zone-of message) (progn (vm-su-do-date message) (vm-zone-of message)))) (defun vm-su-mark (message)=20 "Given a MESSAGE, returns the string that should appear in its mark field in the summary. USR, 2012-10-13" (if (vm-mark-of message) "*" " ")) ;; Some yogurt-headed delivery agents don't provide a Date: header. (defun vm-grok-From_-date (message) ;; This works only on the From_ types, obviously (if (not (memq (vm-message-type-of message) '(BellFrom_ From_ From_-with-Content-Length))) nil (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) (save-excursion (save-restriction (widen) (goto-char (vm-start-of message)) (let ((case-fold-search nil)) (if (or (looking-at ;; special case this so that the "remote from blah" ;; isn't included. "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) (vm-buffer-substring-no-properties (match-beginning 1) (match-end 1))))))))) (defconst vm-su-rfc822-date-format ;; The date format recognized here is the one specified in RFC 822. ;; Some slop is allowed e.g. dashes between the monthday, month and year ;; because such malformed headers have been observed. (concat "\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*" "\\([0-9][0-9]?\\)[ \t\n---]*" "\\([a-z][a-z][a-z]\\)[ \t\n---]*" "\\([0-9]*[0-9][0-9]\\)[ \t\n]*" "\\([0-9:]+\\)[ \t\n]*" "\\([a-z][a-z]?[a-z]?\\|\\(-\\|\\+\\)[01][0-9][0-9][0-9]\\)")) (defconst vm-su-ctime-format ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allo= w for ;; the possibility of a timezone at the end. (concat "\\([a-z][a-z][a-z]\\)[ \t\n]*"=20 "\\([a-z][a-z][a-z]\\)[ \t\n]*"=20 "\\([0-9][0-9]?\\)[ \t\n]*" "\\([0-9:]+\\)[ \t\n]*" "\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*" "\\([a-z][a-z]?[a-z]?\\|\\(-\\|\\+\\)[01][0-9][0-9][0-9]\\)?")) (defun vm-su-do-date (m) "Given a message M, extract its sent date and cache it in the cached-data-vector." (let ((case-fold-search t) vector date) (setq date=20 (or=20 ;; (and vm-sort-messages-by-delivery-date ;; (vm-get-header-contents m "Delivery-Date:")) (vm-get-header-contents m "Date:") (vm-grok-From_-date m))) (cond ((null date) (vm-set-weekday-of m "") (vm-set-monthday-of m "") (vm-set-month-of m "") (vm-set-month-number-of m "") (vm-set-year-of m "") (vm-set-hour-of m "") (vm-set-zone-of m "")) ((string-match vm-su-rfc822-date-format date) (if (match-beginning 2) (vm-su-do-weekday=20 m (substring date (match-beginning 2) (match-end 2))) (vm-set-weekday-of m "")) (vm-set-monthday-of m (substring date (match-beginning 3) (match-end = 3))) (vm-su-do-month m (substring date (match-beginning 4) (match-end 4))) (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) (if (=3D 2 (length (vm-year-of m))) (save-match-data (cond ((string-match "^[0-6]" (vm-year-of m)) (vm-set-year-of m (concat "20" (vm-year-of m)))) (t (vm-set-year-of m (concat "19" (vm-year-of m))))))) (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6))) (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7)))) ((string-match vm-su-ctime-format date) (vm-su-do-weekday m (substring date (match-beginning 1) (match-end 1)= )) (vm-su-do-month m (substring date (match-beginning 2) (match-end 2))) (vm-set-monthday-of m (substring date (match-beginning 3) (match-end = 3))) (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4))) (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) (if (match-beginning 6) (vm-set-zone-of m (substring date (match-beginning 6) (match-end 6))) (vm-set-zone-of m ""))) (t (setq vector (vm-parse-date date)) (vm-su-do-weekday m (elt vector 0)) (vm-set-monthday-of m (elt vector 1)) (vm-su-do-month m (elt vector 2)) (vm-set-year-of m (elt vector 3)) (vm-set-hour-of m (elt vector 4)) (vm-set-zone-of m (elt vector 5))))) ;; Normalize all hour and date specifications to avoid jagged margins. ;; If the hour is " 3:..." or "3:...", turn it into "03:...". ;; If the date is "03", turn it into " 3". (cond ((null (vm-hour-of m)) nil) ((string-match "\\`[0-9]:" (vm-hour-of m)) (vm-set-hour-of m (concat "0" (vm-hour-of m))))) (cond ((null (vm-monthday-of m)) nil) ((string-match "\\`0[0-9]\\'" (vm-monthday-of m)) (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2)))) ) (defun vm-su-do-month (m month-abbrev) (let ((val (assoc (downcase month-abbrev) vm-month-alist))) (if val (progn (vm-set-month-of m (nth 1 val)) (vm-set-month-number-of m (nth 2 val))) (vm-set-month-of m "") (vm-set-month-number-of m "")))) (defun vm-su-do-weekday (m weekday-abbrev) (let ((val (assoc (downcase weekday-abbrev) vm-weekday-alist))) (if val (vm-set-weekday-of m (nth 1 val)) (vm-set-weekday-of m "")))) (defun vm-su-datestring (m) "The sent date of message M in the format \"Sun Jan 01 00:00:00 2000\"." (when (and (vm-su-weekday m) (vm-su-month m) (vm-su-monthday m) (vm-su-hour m) (vm-su-year m)) (format "%s %s %s %s %s" (condition-case error (substring (vm-su-weekday m) 0 3) (error "Sun")) ; make up a valid weekday (substring (vm-su-month m) 0 3) (vm-su-monthday m) (vm-su-hour m) (vm-su-year m)))) ;; (defun vm-su-delivery-datestring (m) ;; "The delivery date of message M in the format \"Sun Jan 01 00:00:00 20= 00"." ;; (when (vm-su-d-weekday m) ;; (format "%s %s %s %s %s" ;; (condition-case error ;; (substring (vm-su-d-weekday m) 0 3) ;; (error "Sun")) ;; (substring (vm-su-d-month m) 0 3) ;; (vm-su-d-monthday m) ;; (vm-su-d-hour m) ;; (vm-su-d-year m)))) (defun vm-run-user-summary-function (function message) ;; (condition-case nil (let ((m (vm-real-message-of message))) (save-excursion (set-buffer (vm-buffer-of m)) (save-restriction (widen) (save-excursion (narrow-to-region (vm-headers-of m) (vm-text-end-of m)) (funcall function m))))) ;; (error " ")) ) (defun vm-su-decoded-full-name (m) "Returns the author name of M as a string, either from the stored entry (`vm-decoded-full-name-of') or recalculating it if necessa= ry. The result is a mime-decoded string with text-properties. USR 2010-05-13" (or (vm-decoded-full-name-of m) (progn (vm-su-do-author m) (vm-decoded-full-name-of m)))) (defalias 'vm-su-full-name 'vm-su-decoded-full-name) (defun vm-su-decoded-reply-to-name (m) "Returns the principal (Reply-To) name of M as a string, either from the stored entry (`vm-decoded-reply-to-name-of') or recalculating it if necessary. The result is a mime-decoded string with text-properties. USR 2010-05-13" (or (vm-decoded-reply-to-name-of m) (progn (vm-su-do-principal m) (vm-decoded-reply-to-name-of m)))) (defalias 'vm-su-reply-to-name 'vm-su-decoded-reply-to-name) (defun vm-su-interesting-full-name (m) "Returns the author name of M as a string. If the author is \"uninteresting\" then returns the value of `vm-summary-recipient-marker' followed by recipient names. If the recipient is also \"uninteresting\" then returns the value of `vm-summary-principal-marker' followed by the reply-to names. The result is a mime-decoded string with text properties. USR 2010-05-13" (let ((case-fold-search nil)) (cond=20 ((null vm-summary-uninteresting-senders) (vm-su-full-name m)) ((not (string-match vm-summary-uninteresting-senders (vm-su-from m))) (vm-su-full-name m)) ;; FIXME do we need to match each address separately? USR, 2012-03-02 ((not (string-match vm-summary-uninteresting-senders (vm-su-to-names m= ))) (concat vm-summary-recipient-marker (vm-su-to-names m))) ((not (string-match "\\?\\?\\?" (vm-su-reply-to-name m))) (concat vm-summary-principal-marker (vm-su-reply-to-name m))) (t (concat vm-summary-recipient-marker (vm-su-to-names m)))))) =20=20=20=20=20=20 (defun vm-su-from (m) "Returns the author address of M as a string, either from the stored entry (`vm-decoded-from-of') or recalculating it if necessary. The result is a mime-encoded string, but this is not certain. USR 2010-05-13" (or (vm-decoded-from-of m) (progn (vm-su-do-author m) (vm-decoded-from-of m)))) (defun vm-su-reply-to (m) "Returns the principal (Reply-To) address of M as a string, either from the stored entry (`vm-decoded-reply-to-of') or recalculating it if necessar= y. The result is a mime-encoded string, but this is not certain. USR 2010-05-13" (or (vm-decoded-reply-to-of m) (progn (vm-su-do-principal m) (vm-decoded-reply-to-of m)))) (defun vm-su-interesting-from (m) "Returns the author address of M as a string. If the author is \"uninteresting\" then returns the value of `vm-summary-recipient-marker' followed by recipient addresses. If the recipient is also \"uninteresting\" then returns the value of `vm-summary-principal-marker' followed by the reply-to address. The result is a mime-encoded string, but this is not certain. USR 2010-05-13" (let ((case-fold-search nil)) (cond=20 ((null vm-summary-uninteresting-senders) (vm-su-from m)) ((not (string-match vm-summary-uninteresting-senders (vm-su-from m))) (vm-su-from m)) ((not (string-match vm-summary-uninteresting-senders (vm-su-to m))) ;; FIXME do we need to match each address separately? USR, 2012-03-02 (concat vm-summary-uninteresting-senders-arrow (vm-su-to m))) ((not (string-match "\\?\\?\\?" (vm-su-reply-to m))) (concat vm-summary-principal-marker (vm-su-reply-to m))) (t (concat vm-summary-recipient-marker (vm-su-to m)))))) ;; Some yogurt-headed delivery agents don't even provide a From: header. (defun vm-grok-From_-author (message) ;; This works only on the From_ types, obviously (if (not (memq (vm-message-type-of message) '(From_ BellFrom_ From_-with-Content-Length))) nil (save-excursion (set-buffer (vm-buffer-of message)) (save-excursion (save-restriction (widen) (goto-char (vm-start-of message)) (let ((case-fold-search nil)) (if (looking-at "From \\([^ \t\n]+\\)") (vm-buffer-substring-no-properties (match-beginning 1) (match-end 1))))))))) (defun vm-su-do-author (m) "Parses the From headers of the message M and stores the results in the `from' and `full-name' entries of the cached-data vector. USR, 2010-0= 5-13" (let ((full-name (vm-get-header-contents m "Full-Name:")) (from (or (vm-get-header-contents m "From:" ", ") (vm-grok-From_-author m))) pair i) (if (and full-name (string-match "^[ \t]*$" full-name)) (setq full-name nil)) (if (null from) (progn (setq from "???") (if (null full-name) (setq full-name "???"))) (setq pair (funcall vm-chop-full-name-function from) from (or (nth 1 pair) from) full-name (or full-name (nth 0 pair) from))) (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) (while (setq i (string-match "\n" full-name i)) (aset full-name i ?\ )) (vm-set-decoded-full-name-of=20 m (vm-decode-mime-encoded-words-in-string full-name)) (vm-set-decoded-from-of=20 m (vm-decode-mime-encoded-words-in-string from)))) (defun vm-su-do-principal (m) "Parses the Reply-To header of the message M and stores the results in the `reply-to' and `reply-to-name' entries of the cached-data vector." (let ((reply-to (vm-get-header-contents m "Reply-To:" ", ")) reply-to-name pair i) (if (null reply-to) (setq reply-to "???" reply-to-name "???") (setq pair (funcall vm-chop-full-name-function reply-to) reply-to (or (nth 1 pair) reply-to) reply-to-name (or (nth 0 pair) reply-to))) (if (string-match "\\`\"\\([^\"]+\\)\"\\'" reply-to-name) (setq reply-to-name (substring reply-to-name (match-beginning 1) (match-end 1)))) (while (setq i (string-match "\n" reply-to-name i)) (aset reply-to-name i ?\ )) (vm-set-decoded-reply-to-name-of=20 m (vm-decode-mime-encoded-words-in-string reply-to-name)) (vm-set-decoded-reply-to-of=20 m (vm-decode-mime-encoded-words-in-string reply-to)))) (defconst vm-su-address-format (concat "\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*" "<\\([^>]+\\)>[ \t\n]*\\'")) (defconst vm-su-address-format-2 (concat "\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*" "(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'")) (defun vm-default-chop-full-name (address) (let ((from address) (full-name nil)) (cond ((string-match vm-su-address-format address) (if (match-beginning 1) (setq full-name (substring address (match-beginning 1) (match-end 1)))) (setq from (substring address (match-beginning 3) (match-end 3)))) ((string-match vm-su-address-format-2 address) (if (match-beginning 3) (setq full-name (substring address (match-beginning 3) (match-end 3)))) (setq from (substring address (match-beginning 1) (match-end 1))))) (list full-name from))) ;; test for existence and functionality of mail-extract-address-components ;; there are versions out there that don't work right, so we run ;; some test data through it to see if we can trust it. (defun vm-choose-chop-full-name-function (address) (let ((test-data '(("kyle@uunet.uu.net" . (nil "kyle@uunet.uu.net")) ("c++std=3Dlib@inet.research.att.com" . (nil "c++std=3Dlib@inet.research.att.com")) ("\"Piet.Rypens\" " . ("Piet Rypens" "rypens@reks.uia.ac.be")) ("makke@wins.uia.ac.be (Marc.Gemis)" . ("Marc Gemis" "makke@wins.uia.ac.be")) ("" . (nil nil)))) (failed nil) result) (while test-data (setq result (condition-case nil (mail-extract-address-components (car (car test-data))) (error nil))) (if (not (equal result (cdr (car test-data)))) ;; failed test, use default (setq failed t test-data nil) (setq test-data (cdr test-data)))) (if failed ;; it failed, use default (setq vm-chop-full-name-function 'vm-default-chop-full-name) ;; it passed the tests (setq vm-chop-full-name-function 'mail-extract-address-components)) (funcall vm-chop-full-name-function address))) (defun vm-su-do-recipients (m) "Given a message M, extract its recipients from the headers and store the strings in the cached data vector. USR, 2012-10-13" (let ((mail-use-rfc822 t) i names addresses to cc all list full-name) (setq to (or (vm-get-header-contents m "To:" ", ") (vm-get-header-contents m "Apparently-To:" ", ") (vm-get-header-contents m "Newsgroups:" ", ") ;; desperation.... (user-login-name)) cc (or (vm-get-header-contents m "Cc:" ", ") (vm-get-header-contents m "Bcc:" ", ")) all to all (if all (concat all ", " cc) cc) addresses (condition-case err (rfc822-addresses all) (error (vm-warn 0 5 err) (list "corrupted-header")))) (setq list (vm-parse-addresses all)) ; adds text properties for charsets (while list ;; Just like vm-su-do-author: (setq full-name (or (nth 0 (funcall vm-chop-full-name-function (car list))) (car list))) ;; If double quotes are around the full name, fish the name out. (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) (while (setq i (string-match "\n" full-name i)) (aset full-name i ?\ )) (setq names (cons full-name names)) (setq list (cdr list))) (setq names (nreverse names)) ;; added by jwz for fixed vm-parse-addresses (vm-set-decoded-to-cc-of=20 m (vm-decode-mime-encoded-words-in-string=20 (mapconcat 'identity addresses ", "))) (vm-set-decoded-to-cc-names-of=20 m (vm-decode-mime-encoded-words-in-string=20 (mapconcat 'identity names ", "))))) (defun vm-su-do-addressees (m) (let ((mail-use-rfc822 t) i names addresses to list full-name) (setq to (or (vm-get-header-contents m "To:" ", ") (vm-get-header-contents m "Apparently-To:" ", ") (vm-get-header-contents m "Newsgroups:" ", ") ;; desperation.... (user-login-name)) addresses (condition-case err (rfc822-addresses to) (error (vm-warn 0 5 err) (list "corrupted-header")))) (setq list (vm-parse-addresses to)) ; adds text properties for charsets (while list ;; Just like vm-su-do-author: (setq full-name (or (nth 0 (funcall vm-chop-full-name-function (car list))) (car list))) ;; If double quotes are around the full name, fish the name out. (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) (while (setq i (string-match "\n" full-name i)) (aset full-name i ?\ )) (setq names (cons full-name names)) (setq list (cdr list))) (setq names (nreverse names)) ;; added by jwz for fixed vm-parse-addresses (vm-set-decoded-to-of=20 m (vm-decode-mime-encoded-words-in-string=20 (mapconcat 'identity addresses ", "))) (vm-set-decoded-to-names-of=20 m (vm-decode-mime-encoded-words-in-string=20 (mapconcat 'identity names ", "))))) (defun vm-su-decoded-to (m) "Returns the email addresses of the addressees of M as a string, either from the stored entry (`vm-decoded-to-of') or recalculating them if necessary. The result is a mime-decoded string with text properties. USR 2012-10-07" (or (vm-decoded-to-of m)=20 (progn (vm-su-do-addressees m) (vm-decoded-to-of m)))) (defalias 'vm-su-to 'vm-su-decoded-to) (defun vm-su-decoded-to-names (m) "Returns the addressees of M as a string, either from the stored entry (`vm-decoded-to-names-of') or recalculating them if necessary. The result is a mime-decoded string with text properties. USR 2012-10-07" (or (vm-decoded-to-names-of m)=20 (progn (vm-su-do-addressees m) (vm-decoded-to-names-of m)))) (defalias 'vm-su-to-names 'vm-su-decoded-to-names) =09=09=09=09=20=20 (defun vm-su-decoded-to-cc (m) "Returns the recipient addresses of M as a string, either from the stored entry (`vm-decoded-to-cc-of') or recalculating them if necessary. The result is a mime-decoded string with text properties.=20=20 USR 2012-10-07" (or (vm-decoded-to-cc-of m)=20 (progn (vm-su-do-recipients m) (vm-decoded-to-cc-of m)))) (defalias 'vm-su-to-cc 'vm-su-decoded-to-cc) (defun vm-su-decoded-to-cc-names (m) "Returns the recipient names of M as a string, either from the stored entry (`vm-decoded-to-cc-names-of') or recalculating them if necessary. The result is a mime-decoded string with text properties.=20= =20 USR 2012-10-07" (or (vm-decoded-to-cc-names-of m)=20 (progn (vm-su-do-recipients m) (vm-decoded-to-cc-names-of m)))) (defalias 'vm-su-to-cc-names 'vm-su-decoded-to-cc-names) ;;;###autoload (defun vm-su-message-id (m) "Returns the message id of M. It is a mime-encoded string. USR 2010-12-16" (or (vm-message-id-of m) (vm-set-message-id-of m (or (let ((id (vm-get-header-contents m "Message-Id:"))) (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)")))) ;; try running md5 on the message body to produce an ID ;; better than nothing. (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (save-restriction (widen) (condition-case nil (concat "") (error nil)))) (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>"))))) (defun vm-su-line-count (m) "Returns the line count of M as a string, either from the stored entry (`vm-line-count-of') or recalculating it if necessary. USR 2010-05-1= 3" (or (vm-line-count-of m) (vm-set-line-count-of m (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (save-restriction (widen) (int-to-string (count-lines (vm-text-of (vm-real-message-of m)) (vm-text-end-of (vm-real-message-of m))))))))) ;;;###autoload (defun vm-su-decoded-subject (m) "Returns the subject string of M, either from the stored entry (`vm-decoded-subject-of') or recalculating it if necessary. It is a mime-decoded string with text properties. USR 2010-05-13" (or (vm-decoded-subject-of m) (vm-set-decoded-subject-of m (let ((subject (vm-decode-mime-encoded-words-in-string (or (vm-get-header-contents m "Subject:") ""))) (i nil)) (while (string-match "\n[ \t]*" subject) (setq subject (replace-match " " nil t subject))) subject )))) (defalias 'vm-su-subject 'vm-su-decoded-subject) (defun vm-su-decoded-summary-subject (m) "Returns the subject string of M, appropriate for display in summary lines. It is either from the stored entry (`vm-decoded-summary-subject-of') or recalculating it if necessary. It is a mime-decoded string with text properties. USR 2010-05-13" (or (vm-decoded-summary-subject-of m) (vm-set-decoded-summary-subject-of m (let ((subject (vm-decode-mime-encoded-words-in-string (or (vm-get-header-contents m "Subject:") ""))) (i nil)) (setq subject (vm-su-trim-subject subject)) (while (string-match "\n[ \t]*" subject) (setq subject (replace-match " " nil t subject))) subject )))) (defalias 'vm-su-summary-subject 'vm-su-decoded-summary-subject) (defun vm-su-trim-subject (subject) "Given SUBJECT string (which should be MIME-decoded with possible text properties), returns a modified string after stripping subject tags as determined by `vm-subject-tag-prefix' but not matching `vm-subject-tag-prefix-exceptions'. The other prefixes and suffixes (`vm-subject-ignored-prefix' and `vm-subject-ignored-suffix') are not modified." (let ((case-fold-search t) (prefix "") (tag-end nil)) (catch 'done (while vm-summary-strip-subject-tags ; constant in the loop (cond ((and vm-subject-ignored-prefix (string-match vm-subject-ignored-prefix subject) (zerop (match-beginning 0))) (setq prefix=20 (concat prefix (substring subject 0 (match-end 0)))) (setq subject (substring subject (match-end 0)))) ((and vm-subject-tag-prefix (string-match vm-subject-tag-prefix subject) (zerop (match-beginning 0)) (setq tag-end (match-end 0)) (or (null vm-subject-tag-prefix-exceptions) (not (string-match vm-subject-tag-prefix-exceptions subject)))) (setq subject (substring subject tag-end))) (t (throw 'done nil))))) (setq subject (vm-with-string-as-temp-buffer subject (function vm-collapse-whitespace))) (concat prefix subject) )) (defun vm-su-decoded-tokenized-summary (m) "Returns the tokenized summary line of M, either from the stored entry (`vm-decoded-tokenized-summary-of') or recalculating it if necessary. The summary line is a mime-decoded string with text properties.=20 USR 2010-05-13" (if (and (vm-virtual-message-p m) ;; Kyle also had (not (vm-virtual-messages-of m)) as a condition ;; here. USR 2012-10-14 ;; We put this back for now because removing it is giving ;; errors for virtual foldrs. USR 2012-10-19 (not (vm-virtual-messages-of m))) (or (vm-virtual-summary-of m) (with-current-buffer (vm-buffer-of m) (vm-set-virtual-summary-of=20 m (vm-summary-sprintf vm-summary-format m t)) (vm-virtual-summary-of m))) (or (vm-decoded-tokenized-summary-of m) (with-current-buffer (vm-buffer-of m) ;; FIXME Is this being set to a decoded string? USR, 2012-10-07 (vm-set-decoded-tokenized-summary-of=20 m (vm-summary-sprintf vm-summary-format m t)) (vm-decoded-tokenized-summary-of m))))) (defalias 'vm-su-summary 'vm-su-decoded-tokenized-summary) (defun vm-set-su-decoded-tokenized-summary (m summary) "Set the tokenized summary line of M to SUMMARY. SUMMARY should be a mime-decoded string with text properties." (if (vm-virtual-message-p m) ;; Kyle also had (not (vm-virtual-messages-of m)) as a condition ;; here. USR 2012-10-14 (with-current-buffer (vm-buffer-of m) (vm-set-virtual-summary-of m summary) (vm-virtual-summary-of m)) (with-current-buffer (vm-buffer-of m) (vm-set-decoded-tokenized-summary-of m summary) (vm-decoded-tokenized-summary-of m)))) ;;;###autoload (defun vm-fix-my-summary (&optional kill-local-summary) "Rebuild the summary. Call this function if you made changes to `vm-summary-format'." (interactive "P") (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if kill-local-summary (kill-local-variable 'vm-summary-format)) (vm-inform 5 "%s: Fixing your summary... %s" (buffer-name) vm-summary-for= mat) (let ((mp vm-message-list)) ;; Erase all the cached summary and threading data (while mp (vm-set-su-decoded-tokenized-summary (car mp) nil) (vm-set-thread-indentation-of (car mp) nil) (vm-set-thread-list-of (car mp) nil) (vm-set-thread-subtree-of (car mp) nil) (vm-mark-for-summary-update (car mp)) (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp))) ;; Erase threading information (setq vm-thread-obarray 'bonk vm-thread-subject-obarray 'bonk) ;; Ask for messages to be renumbered (vm-set-numbering-redo-start-point t) (vm-set-numbering-redo-end-point t) ;; Generate fresh summary data and stuff it ;; (vm-inform 7 "%s: Stuffing cached data..." (buffer-name)) ;; (vm-stuff-folder-data :interactive t :abort-if-input-pending nil) ;; (vm-inform 7 "%s: Stuffing cached data... done" (buffer-name)) ;; (set-buffer-modified-p t) ;; Regenerate the summary (vm-sort-messages (or vm-ml-sort-keys "activity")) (vm-inform 5 "%s: Recreating summary..." (buffer-name)) (vm-update-summary-and-mode-line) (unless vm-summary-debug (vm-inform 5 "%s: Recreating summary... done" (buffer-name)))) (if vm-thread-debug (vm-check-thread-integrity)) (vm-inform 5 "%s: Fixing your summary... done" (buffer-name))) (defun vm-su-thread-indent (m) (if (and vm-summary-show-threads (natnump vm-summary-thread-indent-level)) (make-string (* (vm-thread-indentation m) vm-summary-thread-indent-level) ?\ ) "" )) (defun vm-su-labels (m) (or (vm-decoded-label-string-of m) ;; FIXME Is this being set to a decoded string? (vm-set-decoded-label-string-of m (mapconcat=20 'identity=20 (sort (copy-sequence (vm-decoded-labels-of m)) 'string-lessp) ",")) (vm-decoded-label-string-of m))) (defun vm-make-folder-summary () (make-vector vm-folder-summary-vector-length nil)) (defun vm-fs-folder-of (fs) (aref fs 0)) (defun vm-fs-total-count-of (fs) (aref fs 1)) (defun vm-fs-new-count-of (fs) (aref fs 2)) (defun vm-fs-unread-count-of (fs) (aref fs 3)) (defun vm-fs-deleted-count-of (fs) (aref fs 4)) (defun vm-fs-start-of (fs) (aref fs 5)) (defun vm-fs-end-of (fs) (aref fs 6)) (defun vm-fs-folder-key-of (fs) (aref fs 7)) (defun vm-fs-mouse-track-overlay-of (fs) (aref fs 8)) (defun vm-fs-short-folder-of (fs) (aref fs 9)) (defun vm-fs-modflag-of (fs) (aref fs 10)) (defun vm-set-fs-folder-of (fs x) (aset fs 0 x)) (defun vm-set-fs-total-count-of (fs x) (aset fs 1 x)) (defun vm-set-fs-new-count-of (fs x) (aset fs 2 x)) (defun vm-set-fs-unread-count-of (fs x) (aset fs 3 x)) (defun vm-set-fs-deleted-count-of (fs x) (aset fs 4 x)) (defun vm-set-fs-start-of (fs x) (aset fs 5 x)) (defun vm-set-fs-end-of (fs x) (aset fs 6 x)) (defun vm-set-fs-folder-key-of (fs x) (aset fs 7 x)) (defun vm-set-fs-mouse-track-overlay-of (fs x) (aset fs 8 x)) (defun vm-set-fs-short-folder-of (fs x) (aset fs 9 x)) (defun vm-set-fs-modflag-of (fs x) (aset fs 10 x)) (defun vm-fs-spooled (fs) (let ((count 0) (list (symbol-value (intern-soft (vm-fs-folder-key-of fs) vm-folders-summary-folder-hash)))) (while list (setq count (+ count (car (vm-get-folder-totals (car list)))) list (cdr list))) (int-to-string count))) (defun vm-make-folders-summary-key (folder &optional dir) (cond ((vm-pop-folder-spec-p folder) (or (vm-pop-find-name-for-spec folder) (vm-safe-popdrop-string folder))) ((vm-imap-folder-spec-p folder) (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder))) (t (concat "folder-summary0:" (file-truename (expand-file-name folder (or dir vm-folder-directory))))))) (defun vm-open-folders-summary-database (mode) (condition-case data (open-database vm-folders-summary-database 'berkeley-db 'hash mode) (error (vm-warn 0 2 "open-database signaled: %S" data) nil ))) (defun vm-get-folder-totals (folder) (let ((default "(0 0 0 0)") fs db key data) (catch 'done (if (null vm-folders-summary-database) (throw 'done (read default))) (if (not (featurep 'berkeley-db)) (throw 'done (read default))) (if (null (setq db (vm-open-folders-summary-database "rw+"))) (throw 'done (read default))) (setq key (vm-make-folders-summary-key folder) data (read (get-database key db default))) (close-database db) data ))) (defun vm-store-folder-totals (folder totals) (let (fs db key data) (catch 'done (if (null vm-folders-summary-database) (throw 'done nil)) (if (not (featurep 'berkeley-db)) (throw 'done nil)) (if (null (setq db (vm-open-folders-summary-database "rw+"))) (throw 'done nil)) (setq key (vm-make-folders-summary-key folder) data (prin1-to-string totals)) (put-database key data db t) (close-database db) (if (null vm-folders-summary-hash) nil (setq fs (intern-soft key vm-folders-summary-hash) fs (symbol-value fs)) (if (null fs) nil (vm-set-fs-total-count-of fs (int-to-string (car totals))) (vm-set-fs-new-count-of fs (int-to-string (nth 1 totals))) (vm-set-fs-unread-count-of fs (int-to-string (nth 2 totals))) (vm-set-fs-deleted-count-of fs (int-to-string (nth 3 totals))))) (vm-mark-for-folders-summary-update folder)))) (defun vm-modify-folder-totals (folder action &rest objects) (let (fs db totals key data) (catch 'done (if (null vm-folders-summary-database) (throw 'done nil)) (if (not (featurep 'berkeley-db)) (throw 'done nil)) (if (null (setq db (vm-open-folders-summary-database "r"))) (throw 'done nil)) (setq key (vm-make-folders-summary-key folder)) (setq totals (get-database key db)) (close-database db) (if (null totals) (throw 'done nil)) (setq totals (read totals)) (cond ((eq action 'arrived) (let ((arrived (car objects)) c n) (setcar totals (+ (car totals) arrived)) (setq c (cdr totals)) (setcar c (+ (car c) arrived)))) ((eq action 'saved) (let ((arrived (car objects)) (m (nth 1 objects)) c n) (setcar totals (+ (car totals) arrived)) ;; increment new and unread counts if necessary. ;; messages are never saved with the deleted flag ;; set no need to check that. (setq c (cdr totals)) (if (eq (car c) -1) nil (if (vm-new-flag m) (setcar c (+ (car c) arrived)))) (setq c (cdr c)) (if (eq (car c) -1) nil (if (vm-unread-flag m) (setcar c (+ (car c) arrived))))))) (setq data (prin1-to-string totals)) (if (null (setq db (vm-open-folders-summary-database "rw+"))) (throw 'done nil)) (put-database key data db t) (close-database db) (if (null vm-folders-summary-hash) nil (setq fs (intern-soft key vm-folders-summary-hash) fs (symbol-value fs)) (if (null fs) nil (vm-set-fs-total-count-of fs (int-to-string (car totals))) (vm-set-fs-new-count-of fs (int-to-string (nth 1 totals))) (vm-set-fs-unread-count-of fs (int-to-string (nth 2 totals))) (vm-set-fs-deleted-count-of fs (int-to-string (nth 3 totals))))) (vm-mark-for-folders-summary-update folder)))) (defvar vm-folder-summary nil) ; used with dynamic binding (defun vm-folders-summary-sprintf (format layout) ;; compile the format into an eval'able s-expression ;; if it hasn't been compiled already. (let ((match (assoc format vm-folders-summary-compiled-format-alist))) (if (null match) (progn (vm-folders-summary-compile-format format) (setq match (assoc format vm-folders-summary-compiled-format-alist)))) ;; The local variable name `vm-folder-summary' is mandatory here for ;; the format s-expression to work. (let ((vm-folder-summary layout)) (eval (cdr match))))) (defun vm-folders-summary-compile-format (format) (let ((return-value (vm-folders-summary-compile-format-1 format 0))) (setq vm-folders-summary-compiled-format-alist (cons (cons format (nth 1 return-value)) vm-folders-summary-compiled-format-alist)))) (defun vm-folders-summary-compile-format-1 (format start-index) (let ((case-fold-search nil) (done nil) (sexp nil) (sexp-fmt nil) (last-match-end start-index) new-match-end conv-spec) (store-match-data nil) (while (not done) (while (and (not done) (string-match "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()dfnstu%]\\)" format last-match-end)) (setq conv-spec (aref format (match-beginning 5))) (setq new-match-end (match-end 0)) (if (memq conv-spec '(?\( ?d ?f ?n ?s ?t ?u)) (progn (cond ((=3D conv-spec ?\() (save-match-data (let ((retval (vm-folders-summary-compile-format-1 format (match-end 5)))) (setq sexp (cons (nth 1 retval) sexp) new-match-end (car retval))))) ((=3D conv-spec ?d) (setq sexp (cons (list 'vm-fs-deleted-count-of 'vm-folder-summary) sexp))) ((=3D conv-spec ?f) (setq sexp (cons (list 'vm-fs-short-folder-of 'vm-folder-summary) sexp))) ((=3D conv-spec ?n) (setq sexp (cons (list 'vm-fs-new-count-of 'vm-folder-summary) sexp))) ((=3D conv-spec ?t) (setq sexp (cons (list 'vm-fs-total-count-of 'vm-folder-summary) sexp))) ((=3D conv-spec ?s) (setq sexp (cons (list 'vm-fs-spooled 'vm-folder-summary) sexp))) ((=3D conv-spec ?u) (setq sexp (cons (list 'vm-fs-unread-count-of 'vm-folder-summary) sexp)))) (cond ((and (match-beginning 1) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-left-justify-string 'vm-left-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2)))))) ((match-beginning 2) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-right-justify-string 'vm-right-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2))))))) (cond ((match-beginning 3) (setcar sexp (list 'vm-truncate-string (car sexp) (string-to-number (substring format (match-beginning 4) (match-end 4))))))) (setq sexp-fmt (cons "%s" (cons (substring format last-match-end (match-beginning 0)) sexp-fmt)))) (setq sexp-fmt (cons (if (eq conv-spec ?\)) (prog1 "" (setq done t)) "%%") (cons (substring format (or last-match-end 0) (match-beginning 0)) sexp-fmt)))) (setq last-match-end new-match-end)) (if (not done) (setq sexp-fmt (cons (substring format last-match-end (length format)) sexp-fmt) done t)) (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) (if sexp (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) (setq sexp sexp-fmt))) (list last-match-end sexp))) (defun vm-update-folders-summary-entry (fs) (if (and (vm-fs-start-of fs) (marker-buffer (vm-fs-start-of fs))) (let ((modified (buffer-modified-p)) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) summary) (save-excursion (set-buffer (marker-buffer (vm-fs-start-of fs))) (let ((buffer-read-only nil)) (unwind-protect (save-excursion (goto-char (vm-fs-start-of fs)) ;; We do a little dance to update the text in ;; order to make the markers in the text do ;; what we want. ;; ;; 1. We need to avoid having the start ;; and end markers clumping together at ;; the start position. ;; ;; 2. We want the window point marker (w->pointm ;; in the Emacs display code) to move to the ;; start of the summary entry if it is ;; anywhere within the su-start-of to ;; su-end-of region. ;; ;; We achieve (2) by deleting before inserting. ;; Reversing the order of insertion/deletion ;; pushes the point marker into the next ;; summary entry. We achieve (1) by inserting a ;; placeholder character at the end of the ;; summary entry before deleting the region. (goto-char (vm-fs-end-of fs)) (insert-before-markers "z") (goto-char (vm-fs-start-of fs)) (delete-region (point) (1- (vm-fs-end-of fs))) (insert (vm-folders-summary-sprintf vm-folders-summary-format fs)) (delete-char 1) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-fs-start-of fs) (vm-fs-end-of fs) (vm-fs-mouse-track-overlay-of fs))) ;; VM Summary Faces may not work for this yet ;; (when vm-summary-enable-faces ;; (vm-summary-faces-add fs)) ) (set-buffer-modified-p modified))))))) (defun vm-folders-summary-mode-internal () (setq mode-name "VM Folders Summary" major-mode 'vm-folders-summary-mode mode-line-format '(" %b") ;; must come after the setting of major-mode mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t buffer-offer-save nil truncate-lines t) (when (and vm-xemacs-p (featurep 'scrollbar)) (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-folders-summary-mode-map) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) (when (and vm-mutable-frame-configuration vm-frame-per-folders-summary) (vm-set-hooks-for-frame-deletion)) (run-hooks 'vm-folders-summary-mode-hook)) (defun vm-do-folders-summary () (catch 'done (let ((fs-hash (make-vector 89 0)) db dp fp f key fs totals (format vm-folders-summary-format) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces))) (save-excursion (set-buffer vm-folders-summary-buffer) (erase-buffer) (let ((buffer-read-only nil)) (if (null vm-folders-summary-database) (throw 'done nil)) (if (not (featurep 'berkeley-db)) (throw 'done nil)) (if (null (setq db (vm-open-folders-summary-database "r"))) (throw 'done nil)) (setq dp vm-folders-summary-directories) (while dp (if (cdr vm-folders-summary-directories) (insert (car dp) ":\n")) (let ((default-directory (car dp))) (setq fp (sort (vm-delete-backup-file-names (vm-delete-auto-save-file-names (vm-delete-index-file-names (vm-delete-directory-names (directory-files (car dp)))))) (function string-lessp)))) (while fp (setq f (car fp) key (vm-make-folders-summary-key f (car dp)) totals (get-database key db)) (if (null totals) (let ((ff (expand-file-name f (car dp)))) (setq totals (list (or (vm-count-messages-in-file ff) -1) -1 -1 -1)) (if (eq (car totals) -1) nil (vm-store-folder-totals ff totals))) (setq totals (read totals))) (if (eq (car totals) -1) nil (setq fs (vm-make-folder-summary)) (vm-set-fs-folder-of fs (expand-file-name f (car dp))) (vm-set-fs-short-folder-of fs f) (vm-set-fs-total-count-of fs (vm-nonneg-string (car totals))) (vm-set-fs-new-count-of fs (vm-nonneg-string (nth 1 totals))) (vm-set-fs-unread-count-of fs (vm-nonneg-string (nth 2 totals))) (vm-set-fs-deleted-count-of fs (vm-nonneg-string (nth 3 totals))) (vm-set-fs-folder-key-of fs key) (vm-set-fs-start-of fs (vm-marker (point))) (insert (vm-folders-summary-sprintf format fs)) (vm-set-fs-end-of fs (vm-marker (point))) (when do-mouse-track (vm-set-fs-mouse-track-overlay-of fs (vm-mouse-set-mouse-track-highlight (vm-fs-start-of fs) (vm-fs-end-of fs)))) ;; VM Summary Faces may not work here yet ;; (when vm-summary-enable-faces ;; (vm-summary-faces-add fs)) (set (intern key fs-hash) fs)) (setq fp (cdr fp))) (setq dp (cdr dp))) (close-database db) (setq vm-folders-summary-hash fs-hash)) (goto-char (point-min)))))) (defun vm-update-folders-summary-highlight () (if (or (null vm-mail-buffer) (null (buffer-file-name vm-mail-buffer)) (null vm-folders-summary-hash)) (progn (and vm-folders-summary-overlay (vm-set-extent-endpoints vm-folders-summary-overlay 1 1)) (setq vm-mail-buffer nil)) (let ((ooo vm-folders-summary-overlay) (fs (symbol-value (intern-soft (vm-make-folders-summary-key (buffer-file-name vm-mail-buffer)) vm-folders-summary-hash)))) (if (and fs (or (null ooo) (null (vm-extent-object ooo)) (/=3D (vm-extent-end-position ooo) (vm-fs-end-of fs)))) (vm-folders-summary-highlight-region (vm-fs-start-of fs) (vm-fs-end-of fs) vm-summary-highlight-face))))) (defun vm-do-needed-folders-summary-update () (if (null vm-folders-summary-buffer) nil (save-excursion (set-buffer vm-folders-summary-buffer) (if (or (eq vm-modification-counter vm-flushed-modification-counter) (null vm-folders-summary-hash)) nil (mapatoms (function (lambda (sym) (let ((fs (symbol-value sym))) (if (null (vm-fs-modflag-of fs)) nil (vm-update-folders-summary-entry fs) (vm-set-fs-modflag-of fs nil))))) vm-folders-summary-hash) (vm-update-folders-summary-highlight) (setq vm-flushed-modification-counter vm-modification-counter))))) (defun vm-mark-for-folders-summary-update (folder &optional dont-descend) (let ((key (vm-make-folders-summary-key folder)) (hash vm-folders-summary-hash) (spool-hash vm-folders-summary-spool-hash) list fs ) (setq fs (symbol-value (intern-soft key hash))) (if (not fs) nil (vm-set-fs-modflag-of fs t) (vm-check-for-killed-summary) (if vm-folders-summary-buffer (save-excursion (set-buffer vm-folders-summary-buffer) (vm-increment vm-modification-counter)))) (if dont-descend nil (setq list (symbol-value (intern-soft key spool-hash))) (while list (vm-mark-for-folders-summary-update (car list) t) (setq list (cdr list)))))) (defun vm-make-folders-summary-associative-hashes () (let ((triples (vm-compute-spool-files t)) (spool-hash (make-vector 61 0)) (folder-hash (make-vector 61 0)) s-list f-list folder-key spool-key) (while triples (setq folder-key (vm-make-folders-summary-key (car (car triples))) spool-key (vm-make-folders-summary-key (nth 1 (car triples))) s-list (symbol-value (intern-soft spool-key spool-hash)) s-list (cons (car (car triples)) s-list) f-list (symbol-value (intern-soft folder-key folder-hash)) f-list (cons (nth 1 (car triples)) f-list) triples (cdr triples)) (set (intern spool-key spool-hash) s-list) (set (intern folder-key folder-hash) f-list)) (setq vm-folders-summary-spool-hash spool-hash) (setq vm-folders-summary-folder-hash folder-hash))) (defun vm-follow-folders-summary-cursor () (if (or (not (eq major-mode 'vm-folders-summary-mode)) (null vm-folders-summary-hash)) nil (catch 'done (mapatoms (function (lambda (sym) (let ((fs (symbol-value sym))) (if (and (>=3D (point) (vm-fs-start-of fs)) (< (point) (vm-fs-end-of fs)) (or (null vm-mail-buffer) (not (eq vm-mail-buffer (vm-get-file-buffer (vm-fs-folder-of fs)))))) (progn (setq vm-mail-buffer (save-excursion (vm-visit-folder (vm-fs-folder-of fs)) (current-buffer))) (vm-increment vm-modification-counter) (vm-update-summary-and-mode-line) (throw 'done t)))))) vm-folders-summary-hash) nil ))) ;;; vm-summary.el ends here --=-=-= Content-Type: text/plain -- Pieter van Oostrum www: http://pieter.vanoostrum.org/ PGP key: [8DAE142BE17999C4] --=-=-=--