Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-folder.el @ 54:05472e90ae02 r19-16-pre2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents 8b8b7f3559a2
children 131b0175ea99
comparison
equal deleted inserted replaced
53:875393c1a535 54:05472e90ae02
506 (set-buffer b) 506 (set-buffer b)
507 (setq temp-buffer (generate-new-buffer "*vm-work*")) 507 (setq temp-buffer (generate-new-buffer "*vm-work*"))
508 (set-buffer temp-buffer) 508 (set-buffer temp-buffer)
509 (if (file-readable-p file) 509 (if (file-readable-p file)
510 (condition-case nil 510 (condition-case nil
511 (let ((overriding-file-coding-system 'binary)) 511 (let ((coding-system-for-read 'binary))
512 (insert-file-contents file nil 0 4096)) 512 (insert-file-contents file nil 0 4096))
513 (wrong-number-of-arguments 513 (wrong-number-of-arguments
514 (call-process "sed" file temp-buffer nil 514 (call-process "sed" file temp-buffer nil
515 "-n" "1,/^$/p"))))))) 515 "-n" "1,/^$/p")))))))
516 (save-excursion 516 (save-excursion
1164 (vm-unread-count 0) 1164 (vm-unread-count 0)
1165 (vm-deleted-count 0) 1165 (vm-deleted-count 0)
1166 (vm-total-count 0) 1166 (vm-total-count 0)
1167 (modulus (+ (% (vm-abs (random)) 11) 25)) 1167 (modulus (+ (% (vm-abs (random)) 11) 25))
1168 (case-fold-search t) 1168 (case-fold-search t)
1169 data) 1169 oldpoint data)
1170 (while mp 1170 (while mp
1171 (vm-increment vm-total-count) 1171 (vm-increment vm-total-count)
1172 (if (vm-attributes-of (car mp)) 1172 (if (vm-attributes-of (car mp))
1173 () 1173 ()
1174 (goto-char (vm-headers-of (car mp))) 1174 (goto-char (vm-headers-of (car mp)))
1180 (cond 1180 (cond
1181 ((re-search-forward vm-attributes-header-regexp 1181 ((re-search-forward vm-attributes-header-regexp
1182 (vm-text-of (car mp)) t) 1182 (vm-text-of (car mp)) t)
1183 (goto-char (match-beginning 2)) 1183 (goto-char (match-beginning 2))
1184 (condition-case () 1184 (condition-case ()
1185 (setq data (read (current-buffer))) 1185 (progn
1186 (error (setq data 1186 (setq oldpoint (point)
1187 (list 1187 data (read (current-buffer)))
1188 (make-vector vm-attributes-vector-length nil) 1188 (if (and (or (not (listp data)) (not (= 3 (length data))))
1189 (make-vector vm-cache-vector-length nil) 1189 (not (vectorp data)))
1190 nil)) 1190 (progn
1191 ;; In lieu of a valid attributes header 1191 (error "Bad x-vm-v5-data at %d in buffer %s"
1192 ;; assume the message is new. avoid 1192 oldpoint (buffer-name))))
1193 ;; vm-set-new-flag because it asks for a 1193 data )
1194 ;; summary update. 1194 (error
1195 (vm-set-new-flag-in-vector (car data) t))) 1195 (message "Bad x-vm-v5-data header at %d in buffer %s, ignoring"
1196 oldpoint (buffer-name))
1197 (setq data
1198 (list
1199 (make-vector vm-attributes-vector-length nil)
1200 (make-vector vm-cache-vector-length nil)
1201 nil))
1202 ;; In lieu of a valid attributes header
1203 ;; assume the message is new. avoid
1204 ;; vm-set-new-flag because it asks for a
1205 ;; summary update.
1206 (vm-set-new-flag-in-vector (car data) t)))
1196 ;; support version 4 format 1207 ;; support version 4 format
1197 (cond ((vectorp data) 1208 (cond ((vectorp data)
1198 (setq data (vm-convert-v4-attributes data)) 1209 (setq data (vm-convert-v4-attributes data))
1199 ;; tink the message modflag so that if the 1210 ;; tink the message modflag so that if the
1200 ;; user saves we get rid of the old v4 1211 ;; user saves we get rid of the old v4
1404 (setq lim (point)) 1415 (setq lim (point))
1405 (goto-char (point-min)) 1416 (goto-char (point-min))
1406 (vm-skip-past-folder-header) 1417 (vm-skip-past-folder-header)
1407 (vm-skip-past-leading-message-separator) 1418 (vm-skip-past-leading-message-separator)
1408 (if (re-search-forward vm-labels-header-regexp lim t) 1419 (if (re-search-forward vm-labels-header-regexp lim t)
1409 (let (list) 1420 (let ((oldpoint (point))
1410 (setq list (read (current-buffer))) 1421 list)
1422 (condition-case ()
1423 (progn
1424 (setq list (read (current-buffer)))
1425 (if (not (listp list))
1426 (error "Bad global label list at %d in buffer %s"
1427 oldpoint (buffer-name)))
1428 list )
1429 (error
1430 (message "Bad global label list at %d in buffer %s, ignoring"
1431 oldpoint (buffer-name))
1432 (setq list nil) ))
1411 (mapcar (function 1433 (mapcar (function
1412 (lambda (s) 1434 (lambda (s)
1413 (intern s vm-label-obarray))) 1435 (intern s vm-label-obarray)))
1414 list)))))) 1436 list))))))
1415 t )) 1437 t ))
1416 1438
1417 ;; Go to the message specified in a bookmark and eat the bookmark. 1439 ;; Go to the message specified in a bookmark and eat the bookmark.
1418 ;; Returns non-nil if successful, nil otherwise. 1440 ;; Returns non-nil if successful, nil otherwise.
1419 (defun vm-gobble-bookmark () 1441 (defun vm-gobble-bookmark ()
1420 (let ((case-fold-search t) 1442 (let ((case-fold-search t)
1421 n lim) 1443 (n nil)
1444 lim oldpoint)
1422 (save-excursion 1445 (save-excursion
1423 (vm-save-restriction 1446 (vm-save-restriction
1424 (widen) 1447 (widen)
1425 (goto-char (point-min)) 1448 (goto-char (point-min))
1426 (vm-skip-past-folder-header) 1449 (vm-skip-past-folder-header)
1429 (setq lim (point)) 1452 (setq lim (point))
1430 (goto-char (point-min)) 1453 (goto-char (point-min))
1431 (vm-skip-past-folder-header) 1454 (vm-skip-past-folder-header)
1432 (vm-skip-past-leading-message-separator) 1455 (vm-skip-past-leading-message-separator)
1433 (if (re-search-forward vm-bookmark-header-regexp lim t) 1456 (if (re-search-forward vm-bookmark-header-regexp lim t)
1434 (setq n (read (current-buffer)))))) 1457 (condition-case ()
1458 (progn
1459 (setq oldpoint (point)
1460 n (read (current-buffer)))
1461 (if (not (natnump n))
1462 (error "Bad bookmark at %d in buffer %s"
1463 oldpoint (buffer-name)))
1464 n )
1465 (error
1466 (message "Bad bookmark at %d in buffer %s, ignoring"
1467 oldpoint (buffer-name))
1468 (setq n 1))))))
1435 (if n 1469 (if n
1436 (vm-record-and-change-message-pointer 1470 (vm-record-and-change-message-pointer
1437 vm-message-pointer 1471 vm-message-pointer
1438 (nthcdr (1- n) vm-message-list))) 1472 (nthcdr (1- n) vm-message-list)))
1439 t )) 1473 t ))
1488 (setq lim (point)) 1522 (setq lim (point))
1489 (goto-char (point-min)) 1523 (goto-char (point-min))
1490 (vm-skip-past-folder-header) 1524 (vm-skip-past-folder-header)
1491 (vm-skip-past-leading-message-separator) 1525 (vm-skip-past-leading-message-separator)
1492 (if (re-search-forward vm-message-order-header-regexp lim t) 1526 (if (re-search-forward vm-message-order-header-regexp lim t)
1493 (progn 1527 (let ((oldpoint (point)))
1494 (message "Reordering messages...") 1528 (message "Reordering messages...")
1495 (setq order (read (current-buffer)) 1529 (condition-case nil
1496 list-length (length vm-message-list) 1530 (progn
1531 (setq order (read (current-buffer)))
1532 (if (not (listp order))
1533 (error "Bad order header at %d in buffer %s"
1534 oldpoint (buffer-name)))
1535 order )
1536 (error
1537 (message "Bad order header at %d in buffer %s, ignoring"
1538 oldpoint (buffer-name))
1539 (setq order nil)))
1540 (setq list-length (length vm-message-list)
1497 v (make-vector (max list-length (length order)) nil)) 1541 v (make-vector (max list-length (length order)) nil))
1498 (while (and order mp) 1542 (while (and order mp)
1499 (aset v (1- (car order)) (car mp)) 1543 (condition-case nil
1544 (aset v (1- (car order)) (car mp))
1545 (args-out-of-range nil))
1500 (setq order (cdr order) mp (cdr mp))) 1546 (setq order (cdr order) mp (cdr mp)))
1501 ;; lock out interrupts while the message list is in 1547 ;; lock out interrupts while the message list is in
1502 ;; an inconsistent state. 1548 ;; an inconsistent state.
1503 (let ((inhibit-quit t)) 1549 (let ((inhibit-quit t))
1504 (setq vm-message-list (delq nil (append v mp)) 1550 (setq vm-message-list (delq nil (append v mp))
1527 (setq lim (point)) 1573 (setq lim (point))
1528 (goto-char (point-min)) 1574 (goto-char (point-min))
1529 (vm-skip-past-folder-header) 1575 (vm-skip-past-folder-header)
1530 (vm-skip-past-leading-message-separator) 1576 (vm-skip-past-leading-message-separator)
1531 (if (re-search-forward vm-summary-header-regexp lim t) 1577 (if (re-search-forward vm-summary-header-regexp lim t)
1532 (progn 1578 (let ((oldpoint (point)))
1533 (setq summary (read (current-buffer))) 1579 (condition-case ()
1580 (setq summary (read (current-buffer)))
1581 (error
1582 (message "Bad summary header at %d in buffer %s, ignoring"
1583 oldpoint (buffer-name))
1584 (setq summary "")))
1534 (if (not (equal summary vm-summary-format)) 1585 (if (not (equal summary vm-summary-format))
1535 (while mp 1586 (while mp
1536 (vm-set-summary-of (car mp) nil) 1587 (vm-set-summary-of (car mp) nil)
1537 ;; force restuffing of cache to clear old 1588 ;; force restuffing of cache to clear old
1538 ;; summary entry cache. 1589 ;; summary entry cache.
2171 ((condition-case data 2222 ((condition-case data
2172 (progn (require 'timer) t) 2223 (progn (require 'timer) t)
2173 (error nil)) 2224 (error nil))
2174 (let (timer) 2225 (let (timer)
2175 (and (natnump vm-flush-interval) 2226 (and (natnump vm-flush-interval)
2227 (not (vm-timer-using 'vm-flush-itimer-function))
2176 (setq timer (run-at-time vm-flush-interval vm-flush-interval 2228 (setq timer (run-at-time vm-flush-interval vm-flush-interval
2177 'vm-flush-itimer-function nil)) 2229 'vm-flush-itimer-function nil))
2178 (timer-set-function timer 'vm-flush-itimer-function 2230 (timer-set-function timer 'vm-flush-itimer-function
2179 (list timer))) 2231 (list timer)))
2180 (and (natnump vm-mail-check-interval) 2232 (and (natnump vm-mail-check-interval)
2233 (not (vm-timer-using 'vm-check-mail-itimer-function))
2181 (setq timer (run-at-time vm-mail-check-interval 2234 (setq timer (run-at-time vm-mail-check-interval
2182 vm-mail-check-interval 2235 vm-mail-check-interval
2183 'vm-check-mail-itimer-function nil)) 2236 'vm-check-mail-itimer-function nil))
2184 (timer-set-function timer 'vm-check-mail-itimer-function 2237 (timer-set-function timer 'vm-check-mail-itimer-function
2185 (list timer))) 2238 (list timer)))
2186 (and (natnump vm-auto-get-new-mail) 2239 (and (natnump vm-auto-get-new-mail)
2240 (not (vm-timer-using 'vm-get-mail-itimer-function))
2187 (setq timer (run-at-time vm-auto-get-new-mail 2241 (setq timer (run-at-time vm-auto-get-new-mail
2188 vm-auto-get-new-mail 2242 vm-auto-get-new-mail
2189 'vm-get-mail-itimer-function nil)) 2243 'vm-get-mail-itimer-function nil))
2190 (timer-set-function timer 'vm-get-mail-itimer-function 2244 (timer-set-function timer 'vm-get-mail-itimer-function
2191 (list timer))))) 2245 (list timer)))))
2192 (t 2246 (t
2193 (setq vm-flush-interval t 2247 (setq vm-flush-interval t
2194 vm-auto-get-new-mail t)))) 2248 vm-auto-get-new-mail t))))
2249
2250 (defun vm-timer-using (fun)
2251 (let ((p timer-list)
2252 (done nil))
2253 (while (and p (not done))
2254 (if (eq (aref (car p) 5) fun)
2255 (setq done t)
2256 (setq p (cdr p))))
2257 p ))
2195 2258
2196 ;; support for vm-mail-check-interval 2259 ;; support for vm-mail-check-interval
2197 ;; if timer argument is present, this means we're using the Emacs 2260 ;; if timer argument is present, this means we're using the Emacs
2198 ;; 'timer package rather than the 'itimer package. 2261 ;; 'timer package rather than the 'itimer package.
2199 (defun vm-check-mail-itimer-function (&optional timer) 2262 (defun vm-check-mail-itimer-function (&optional timer)
2482 "Display help for various VM activities." 2545 "Display help for various VM activities."
2483 (interactive) 2546 (interactive)
2484 (if (eq major-mode 'vm-summary-mode) 2547 (if (eq major-mode 'vm-summary-mode)
2485 (vm-select-folder-buffer)) 2548 (vm-select-folder-buffer))
2486 (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))) 2549 (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
2487 (pop-up-frames vm-mutable-frames)) 2550 (pop-up-frames (and vm-mutable-frames vm-frame-per-help)))
2488 (cond 2551 (cond
2489 ((eq last-command 'vm-help) 2552 ((eq last-command 'vm-help)
2490 (describe-function major-mode)) 2553 (describe-function major-mode))
2491 ((eq vm-system-state 'previewing) 2554 ((eq vm-system-state 'previewing)
2492 (message "Type SPC to read message, n previews next message (? gives more help)")) 2555 (message "Type SPC to read message, n previews next message (? gives more help)"))
2497 (substitute-command-keys 2560 (substitute-command-keys
2498 "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change."))) 2561 "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change.")))
2499 ((eq major-mode 'mail-mode) 2562 ((eq major-mode 'mail-mode)
2500 (message 2563 (message
2501 (substitute-command-keys 2564 (substitute-command-keys
2502 "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this message"))) 2565 "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this composition")))
2503 (t (describe-mode))))) 2566 (t (describe-mode)))))
2504 2567
2505 (defun vm-spool-move-mail (source destination) 2568 (defun vm-spool-move-mail (source destination)
2506 (let ((handler (and (fboundp 'find-file-name-handler) 2569 (let ((handler (and (fboundp 'find-file-name-handler)
2507 (condition-case () 2570 (condition-case ()
2553 ;; crash box could contain a letter bomb... 2616 ;; crash box could contain a letter bomb...
2554 ;; force user notification of file variables for v18 Emacses 2617 ;; force user notification of file variables for v18 Emacses
2555 ;; enable-local-variables == nil disables them for newer Emacses 2618 ;; enable-local-variables == nil disables them for newer Emacses
2556 (let ((inhibit-local-variables t) 2619 (let ((inhibit-local-variables t)
2557 (enable-local-variables nil) 2620 (enable-local-variables nil)
2558 (overriding-file-coding-system 'no-conversion)) 2621 (coding-system-for-read 'no-conversion))
2559 (find-file-noselect crash-box))) 2622 (find-file-noselect crash-box)))
2560 (save-excursion 2623 (save-excursion
2561 (set-buffer crash-buf) 2624 (set-buffer crash-buf)
2562 (setq crash-folder-type (vm-get-folder-type)) 2625 (setq crash-folder-type (vm-get-folder-type))
2563 (if (and crash-folder-type vm-check-folder-types) 2626 (if (and crash-folder-type vm-check-folder-types)
2884 folder)) 2947 folder))
2885 (save-excursion 2948 (save-excursion
2886 (vm-save-restriction 2949 (vm-save-restriction
2887 (widen) 2950 (widen)
2888 (goto-char (point-max)) 2951 (goto-char (point-max))
2889 (let ((overriding-file-coding-system 'binary)) 2952 (let ((coding-system-for-read 'binary))
2890 (insert-file-contents folder)))) 2953 (insert-file-contents folder))))
2891 (setq mcount (length vm-message-list)) 2954 (setq mcount (length vm-message-list))
2892 (if (vm-assimilate-new-messages) 2955 (if (vm-assimilate-new-messages)
2893 (progn 2956 (progn
2894 ;; say this NOW, before the non-previewers read 2957 ;; say this NOW, before the non-previewers read