cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-folder.el

   1 ;;; vm-folder.el --- VM folder related functions
   2 ;;
   3 ;; Copyright (C) 1989-2001 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (defun vm-number-messages (&optional start-point end-point)
  22   "Set the number-of and padded-number-of slots of messages
  23 in vm-message-list.
  24
  25 If non-nil, START-POINT should point to a cons cell in
  26 vm-message-list and the numbering will begin there, else the
  27 numbering will begin at the head of vm-message-list.  If
  28 START-POINT is non-nil the reverse-link-of slot of the message in
  29 the cons must be valid and the message pointed to (if any) must
  30 have a non-nil number-of slot, because it is used to determine
  31 what the starting message number should be.
  32
  33 If non-nil, END-POINT should point to a cons cell in
  34 vm-message-list and the numbering will end with the message just
  35 before this cell.  A nil value means numbering will be done until
  36 the end of vm-message-list is reached."
  37   (let ((n 1) (message-list (or start-point vm-message-list)))
  38     (if (and start-point (vm-reverse-link-of (car start-point)))
  39         (setq n (1+ (string-to-number
  40                      (vm-number-of
  41                       (car
  42                        (vm-reverse-link-of
  43                         (car start-point))))))))
  44     (while (not (eq message-list end-point))
  45       (vm-set-number-of (car message-list) (int-to-string n))
  46       (vm-set-padded-number-of (car message-list) (format "%3d" n))
  47       (setq n (1+ n) message-list (cdr message-list)))
  48     (or end-point (setq vm-ml-highest-message-number (int-to-string (1- n))))
  49     (if vm-summary-buffer
  50         (vm-copy-local-variables vm-summary-buffer
  51                                  'vm-ml-highest-message-number))))
  52
  53 (defun vm-set-numbering-redo-start-point (start-point)
  54   "Set vm-numbering-redo-start-point to START-POINT if appropriate.
  55 Also mark the current buffer as needing a display update.
  56
  57 START-POINT should be a cons in vm-message-list or just t.
  58  (t means start from the beginning of vm-message-list.)
  59 If START-POINT is closer to the head of vm-message-list than
  60 vm-numbering-redo-start-point or is equal to t, then
  61 vm-numbering-redo-start-point is set to match it."
  62   (intern (buffer-name) vm-buffers-needing-display-update)
  63   (if (eq vm-numbering-redo-start-point t)
  64       nil
  65     (if (and (consp start-point) (consp vm-numbering-redo-start-point))
  66         (let ((mp vm-message-list))
  67           (while (and mp
  68                       (not
  69                        (or (eq (car mp) (car start-point))
  70                            (eq (car mp) (car vm-numbering-redo-start-point)))))
  71             (setq mp (cdr mp)))
  72           (if (null mp)
  73               (error "Something is wrong in vm-set-numbering-redo-start-point"))
  74           (if (eq (car mp) (car start-point))
  75               (setq vm-numbering-redo-start-point start-point)))
  76       (setq vm-numbering-redo-start-point start-point))))
  77
  78 (defun vm-set-numbering-redo-end-point (end-point)
  79   "Set vm-numbering-redo-end-point to END-POINT if appropriate.
  80 Also mark the current buffer as needing a display update.
  81
  82 END-POINT should be a cons in vm-message-list or just t.
  83  (t means number all the way to the end of vm-message-list.)
  84 If END-POINT is closer to the end of vm-message-list or is equal
  85 to t, then vm-numbering-redo-start-point is set to match it.
  86 The number-of slot is used to determine proximity to the end of
  87 vm-message-list, so this slot must be valid in END-POINT's message
  88 and the message in the cons pointed to by vm-numbering-redo-end-point."
  89   (intern (buffer-name) vm-buffers-needing-display-update)
  90   (cond ((eq end-point t)
  91          (setq vm-numbering-redo-end-point t))
  92         ((and (consp end-point)
  93               (> (string-to-number
  94                   (vm-number-of
  95                    (car end-point)))
  96                  (string-to-number
  97                   (vm-number-of
  98                    (car vm-numbering-redo-end-point)))))
  99          (setq vm-numbering-redo-end-point end-point))
 100         ((null end-point)
 101          (setq vm-numbering-redo-end-point end-point))))
 102
 103 (defun vm-do-needed-renumbering ()
 104   "Number messages in vm-message-list as specified by
 105 vm-numbering-redo-start-point and vm-numbering-redo-end-point.
 106
 107 vm-numbering-redo-start-point = t means start at the head
 108 of vm-message-list.
 109 vm-numbering-redo-end-point = t means number all the way to the
 110 end of vm-message-list.
 111
 112 Otherwise the variables' values should be conses in vm-message-list
 113 or nil."
 114   (if vm-numbering-redo-start-point
 115       (progn
 116         (vm-number-messages (and (consp vm-numbering-redo-start-point)
 117                                  vm-numbering-redo-start-point)
 118                             vm-numbering-redo-end-point)
 119         (setq vm-numbering-redo-start-point nil
 120               vm-numbering-redo-end-point nil))))
 121
 122 (defun vm-set-summary-redo-start-point (start-point)
 123   "Set vm-summary-redo-start-point to START-POINT if appropriate.
 124 Also mark the current buffer as needing a display update.
 125
 126 START-POINT should be a cons in vm-message-list or just t.
 127  (t means start from the beginning of vm-message-list.)
 128 If START-POINT is closer to the head of vm-message-list than
 129 vm-summary-redo-start-point or is equal to t, then
 130 vm-summary-redo-start-point is set to match it."
 131   (intern (buffer-name) vm-buffers-needing-display-update)
 132   (if (eq vm-summary-redo-start-point t)
 133       nil
 134     (if (and (consp start-point) (consp vm-summary-redo-start-point))
 135         (let ((mp vm-message-list))
 136           (while (and mp (not (or (eq mp start-point)
 137                                   (eq mp vm-summary-redo-start-point))))
 138             (setq mp (cdr mp)))
 139           (if (null mp)
 140               (error "Something is wrong in vm-set-summary-redo-start-point"))
 141           (if (eq mp start-point)
 142               (setq vm-summary-redo-start-point start-point)))
 143       (setq vm-summary-redo-start-point start-point))))
 144
 145 (defun vm-mark-for-summary-update (m &optional dont-kill-cache)
 146   "Mark message M for a summary update.
 147 Also mark M's buffer as needing a display update. Any virtual
 148 messages of M and their buffers are similarly marked for update.
 149 If M is a virtual message and virtual mirroring is in effect for
 150 M (i.e. attribute-of eq attributes-of M's real message), M's real
 151 message and its buffer are scheduled for an update.
 152
 153 Optional arg DONT-KILL-CACHE non-nil means don't invalidate the
 154 summary-of slot for any messages marked for update.  This is
 155 meant to be used by functions that update message information
 156 that is not cached in the summary-of slot, e.g. message numbers
 157 and thread indentation."
 158   (cond ((eq m (vm-real-message-of m))
 159          ;; this is a real message.
 160          ;; its summary and modeline need to be updated.
 161          (if (not dont-kill-cache)
 162              ;; toss the cache.  this also tosses the cache of any
 163              ;; virtual messages mirroring this message.  the summary
 164              ;; entry cache must be cleared when an attribute of a
 165              ;; message that could appear in the summary has changed.
 166              (vm-set-summary-of m nil))
 167          (if (vm-su-start-of m)
 168              (setq vm-messages-needing-summary-update
 169                    (cons m vm-messages-needing-summary-update)))
 170          (intern (buffer-name (vm-buffer-of m))
 171                  vm-buffers-needing-display-update)
 172          ;; find the virtual messages of this real message that
 173          ;; need a summary update.
 174          (let ((m-list (vm-virtual-messages-of m)))
 175            (while m-list
 176              (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list)))
 177                  (progn
 178                    (and (vm-su-start-of (car m-list))
 179                         (setq vm-messages-needing-summary-update
 180                               (cons (car m-list)
 181                                     vm-messages-needing-summary-update)))
 182                    (intern (buffer-name (vm-buffer-of (car m-list)))
 183                            vm-buffers-needing-display-update)))
 184              (setq m-list (cdr m-list)))))
 185         (t
 186          ;; this is a virtual message.
 187          ;;
 188          ;; if this message has virtual messages then we need to
 189          ;; schedule updates for all the virtual messages that
 190          ;; share a cache with this message and we need to
 191          ;; schedule an update for the underlying real message
 192          ;; since we are mirroring it.
 193          ;;
 194          ;; if there are no virtual messages, then this virtual
 195          ;; message is not mirroring its real message so we need
 196          ;; only take care of this one message.
 197          (if (vm-virtual-messages-of m)
 198              (let ((m-list (vm-virtual-messages-of m)))
 199                ;; schedule updates for all the virtual message who share
 200                ;; the same cache as this message.
 201                (while m-list
 202                  (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list)))
 203                      (progn
 204                        (and (vm-su-start-of (car m-list))
 205                             (setq vm-messages-needing-summary-update
 206                                   (cons (car m-list)
 207                                         vm-messages-needing-summary-update)))
 208                        (intern (buffer-name (vm-buffer-of (car m-list)))
 209                                vm-buffers-needing-display-update)))
 210                  (setq m-list (cdr m-list)))
 211                ;; now take care of the real message
 212                (if (not dont-kill-cache)
 213                    ;; toss the cache.  this also tosses the cache of
 214                    ;; any virtual messages sharing the same cache as
 215                    ;; this message.
 216                    (vm-set-summary-of m nil))
 217                (and (vm-su-start-of (vm-real-message-of m))
 218                     (setq vm-messages-needing-summary-update
 219                           (cons (vm-real-message-of m)
 220                                 vm-messages-needing-summary-update)))
 221                (intern (buffer-name (vm-buffer-of (vm-real-message-of m)))
 222                        vm-buffers-needing-display-update))
 223            (if (not dont-kill-cache)
 224                (vm-set-virtual-summary-of m nil))
 225            (and (vm-su-start-of m)
 226                 (setq vm-messages-needing-summary-update
 227                       (cons m vm-messages-needing-summary-update)))
 228            (intern (buffer-name (vm-buffer-of m))
 229                    vm-buffers-needing-display-update)))))
 230
 231 (defun vm-force-mode-line-update ()
 232   "Force a mode line update in all frames."
 233   (if (fboundp 'force-mode-line-update)
 234       (force-mode-line-update t)
 235     (save-excursion
 236       (set-buffer (other-buffer))
 237       (set-buffer-modified-p (buffer-modified-p)))))
 238
 239 (defun vm-do-needed-mode-line-update ()
 240   "Do a modeline update for the current folder buffer.
 241 This means setting up all the various vm-ml attribute variables
 242 in the folder buffer and copying necessary variables to the
 243 folder buffer's summary and presentation buffers, and then
 244 forcing Emacs to update all modelines.
 245
 246 If a virtual folder being updated has no messages, then
 247 erase-buffer is called on its buffer.
 248
 249 If any type of folder is empty, erase-buffer is called
 250 on its presentation buffer, if any."
 251   ;; XXX This last bit should probably should be moved to
 252   ;; XXX vm-expunge-folder.
 253
 254   (if (null vm-message-pointer)
 255       (progn
 256         ;; erase the leftover message if the folder is really empty.
 257         (if (eq major-mode 'vm-virtual-mode)
 258             (let ((buffer-read-only nil)
 259                   (omodified (buffer-modified-p)))
 260               (unwind-protect
 261                   (erase-buffer)
 262                 (set-buffer-modified-p omodified))))
 263         (if vm-presentation-buffer
 264             (let ((omodified (buffer-modified-p)))
 265               (unwind-protect
 266                   (save-excursion
 267                     (set-buffer vm-presentation-buffer)
 268                     (let ((buffer-read-only nil))
 269                       (erase-buffer)))
 270                 (set-buffer-modified-p omodified)))))
 271     ;; try to avoid calling vm-su-labels if possible so as to
 272     ;; avoid loading vm-summary.el.
 273     (if (vm-labels-of (car vm-message-pointer))
 274         (setq vm-ml-labels (vm-su-labels (car vm-message-pointer)))
 275       (setq vm-ml-labels nil))
 276     (setq vm-ml-message-number (vm-number-of (car vm-message-pointer)))
 277     (setq vm-ml-message-new (vm-new-flag (car vm-message-pointer)))
 278     (setq vm-ml-message-unread (vm-unread-flag (car vm-message-pointer)))
 279     (setq vm-ml-message-read
 280           (and (not (vm-new-flag (car vm-message-pointer)))
 281                (not (vm-unread-flag (car vm-message-pointer)))))
 282     (setq vm-ml-message-edited (vm-edited-flag (car vm-message-pointer)))
 283     (setq vm-ml-message-filed (vm-filed-flag (car vm-message-pointer)))
 284     (setq vm-ml-message-written (vm-written-flag (car vm-message-pointer)))
 285     (setq vm-ml-message-replied (vm-replied-flag (car vm-message-pointer)))
 286     (setq vm-ml-message-forwarded (vm-forwarded-flag (car vm-message-pointer)))
 287     (setq vm-ml-message-redistributed (vm-redistributed-flag (car vm-message-pointer)))
 288     (setq vm-ml-message-deleted (vm-deleted-flag (car vm-message-pointer)))
 289     (setq vm-ml-message-marked (vm-mark-of (car vm-message-pointer))))
 290   (if vm-summary-buffer
 291       (let ((modified (buffer-modified-p)))
 292         (save-excursion
 293           (vm-copy-local-variables vm-summary-buffer
 294                                    'default-directory
 295                                    'vm-ml-message-new
 296                                    'vm-ml-message-unread
 297                                    'vm-ml-message-read
 298                                    'vm-ml-message-edited
 299                                    'vm-ml-message-replied
 300                                    'vm-ml-message-forwarded
 301                                    'vm-ml-message-filed
 302                                    'vm-ml-message-written
 303                                    'vm-ml-message-deleted
 304                                    'vm-ml-message-marked
 305                                    'vm-ml-message-redistributed
 306                                    'vm-ml-message-number
 307                                    'vm-ml-highest-message-number
 308                                    'vm-folder-read-only
 309                                    'vm-folder-type
 310                                    'vm-virtual-folder-definition
 311                                    'vm-virtual-mirror
 312                                    'vm-ml-sort-keys
 313                                    'vm-ml-labels
 314                                    'vm-spooled-mail-waiting
 315                                    'vm-message-list)
 316           (set-buffer vm-summary-buffer)
 317           (set-buffer-modified-p modified))))
 318   (if vm-presentation-buffer
 319       (let ((modified (buffer-modified-p)))
 320         (save-excursion
 321           (vm-copy-local-variables vm-presentation-buffer
 322                                    'default-directory
 323                                    'vm-ml-message-new
 324                                    'vm-ml-message-unread
 325                                    'vm-ml-message-read
 326                                    'vm-ml-message-edited
 327                                    'vm-ml-message-replied
 328                                    'vm-ml-message-forwarded
 329                                    'vm-ml-message-filed
 330                                    'vm-ml-message-written
 331                                    'vm-ml-message-deleted
 332                                    'vm-ml-message-marked
 333                                    'vm-ml-message-number
 334                                    'vm-ml-message-redistributed
 335                                    'vm-ml-highest-message-number
 336                                    'vm-folder-read-only
 337                                    'vm-folder-type
 338                                    'vm-virtual-folder-definition
 339                                    'vm-virtual-mirror
 340                                    'vm-ml-labels
 341                                    'vm-spooled-mail-waiting
 342                                    'vm-message-list)
 343           (set-buffer vm-presentation-buffer)
 344           (set-buffer-modified-p modified))))
 345   (vm-force-mode-line-update))
 346
 347 (defun vm-update-summary-and-mode-line ()
 348   "Update summary and mode line for all VM folder and summary buffers.
 349 Really this updates all the visible status indicators.
 350
 351 Message lists are renumbered.
 352 Summary entries are wiped and regenerated.
 353 Mode lines are updated.
 354 Toolbars are updated."
 355   (save-excursion
 356     (mapatoms (function
 357                (lambda (b)
 358                  (setq b (get-buffer (symbol-name b)))
 359                  (if b
 360                      (progn
 361                        (set-buffer b)
 362                        (intern (buffer-name)
 363                                vm-buffers-needing-undo-boundaries)
 364                        (vm-check-for-killed-summary)
 365                        (and vm-use-toolbar
 366                             (vm-toolbar-support-possible-p)
 367                             (vm-toolbar-update-toolbar))
 368                        (vm-do-needed-renumbering)
 369                        (if vm-summary-buffer
 370                            (vm-do-needed-summary-rebuild))
 371                        (vm-do-needed-mode-line-update)))))
 372               vm-buffers-needing-display-update)
 373     (fillarray vm-buffers-needing-display-update 0))
 374   (if vm-messages-needing-summary-update
 375       (progn
 376         (mapcar (function vm-update-message-summary)
 377                 vm-messages-needing-summary-update)
 378         (setq vm-messages-needing-summary-update nil)))
 379   (vm-do-needed-folders-summary-update)
 380   (vm-force-mode-line-update))
 381
 382 (defun vm-reverse-link-messages ()
 383   "Set reverse links for all messages in vm-message-list."
 384   (let ((mp vm-message-list)
 385         (prev nil))
 386     (while mp
 387       (vm-set-reverse-link-of (car mp) prev)
 388       (setq prev mp mp (cdr mp)))))
 389
 390 (defun vm-match-ordered-header (alist)
 391   "Try to match a header in ALIST and return the matching cell.
 392 This is used by header ordering code.
 393
 394 ALIST looks like this ((\"From\") (\"To\")).  This function returns
 395 the alist element whose car matches the header starting at point.
 396 The header ordering code uses the cdr of the element
 397 returned to hold headers to be output later."
 398   (let ((case-fold-search t))
 399     (catch 'match
 400       (while alist
 401         (if (looking-at (car (car alist)))
 402             (throw 'match (car alist)))
 403         (setq alist (cdr alist)))
 404       nil)))
 405
 406 (defun vm-match-header (&optional header-name)
 407   "Match a header and save some state information about the matched header.
 408 Optional first arg HEADER-NAME means match the header only
 409 if it matches HEADER-NAME.  HEADER-NAME should be a string
 410 containing a header name.  The string should end with a colon if just
 411 that name should be matched.  A string that does not end in a colon
 412 will match all headers that begin with that string.
 413
 414 State information is stored in vm-matched-header-vector bound to a vector
 415 of this form.
 416
 417  [ header-start header-end
 418    header-name-start header-name-end
 419    header-contents-start header-contents-end ]
 420
 421 Elements are integers.
 422 There are functions to access and use this info."
 423   (let ((case-fold-search t)
 424         (header-name-regexp "\\([^ \t\n:]+\\):"))
 425     (if (if header-name
 426             (and (looking-at header-name) (looking-at header-name-regexp))
 427           (looking-at header-name-regexp))
 428         (save-excursion
 429           (aset vm-matched-header-vector 0 (point))
 430           (aset vm-matched-header-vector 2 (point))
 431           (aset vm-matched-header-vector 3 (match-end 1))
 432           (goto-char (match-end 0))
 433           ;; skip leading whitespace
 434           (skip-chars-forward " \t")
 435           (aset vm-matched-header-vector 4 (point))
 436           (forward-line 1)
 437           (while (looking-at "[ \t]")
 438             (forward-line 1))
 439           (aset vm-matched-header-vector 1 (point))
 440           ;; drop the trailing newline
 441           (aset vm-matched-header-vector 5 (1- (point)))))))
 442
 443 (defun vm-matched-header ()
 444   "Returns the header last matched by vm-match-header.
 445 Trailing newline is included."
 446   (vm-buffer-substring-no-properties (aref vm-matched-header-vector 0)
 447                                      (aref vm-matched-header-vector 1)))
 448
 449 (defun vm-matched-header-name ()
 450   "Returns the name of the header last matched by vm-match-header."
 451   (vm-buffer-substring-no-properties (aref vm-matched-header-vector 2)
 452                                      (aref vm-matched-header-vector 3)))
 453
 454 (defun vm-matched-header-contents ()
 455   "Returns the contents of the header last matched by vm-match-header.
 456 Trailing newline is not included."
 457   (vm-buffer-substring-no-properties (aref vm-matched-header-vector 4)
 458                                      (aref vm-matched-header-vector 5)))
 459
 460 (defun vm-matched-header-start ()
 461   "Returns the start position of the header last matched by vm-match-header."
 462   (aref vm-matched-header-vector 0))
 463
 464 (defun vm-matched-header-end ()
 465   "Returns the end position of the header last matched by vm-match-header."
 466   (aref vm-matched-header-vector 1))
 467
 468 (defun vm-matched-header-name-start ()
 469   "Returns the start position of the name of the header last matched
 470 by vm-match-header."
 471   (aref vm-matched-header-vector 2))
 472
 473 (defun vm-matched-header-name-end ()
 474   "Returns the end position of the name of the header last matched
 475 by vm-match-header."
 476   (aref vm-matched-header-vector 3))
 477
 478 (defun vm-matched-header-contents-start ()
 479   "Returns the start position of the contents of the header last matched
 480 by vm-match-header."
 481   (aref vm-matched-header-vector 4))
 482
 483 (defun vm-matched-header-contents-end ()
 484   "Returns the end position of the contents of the header last matched
 485 by vm-match-header."
 486   (aref vm-matched-header-vector 5))
 487
 488 (defun vm-get-folder-type (&optional file start end ignore-visited)
 489   "Return a symbol indicating the folder type of the current buffer.
 490 This function works by examining the beginning of a folder.
 491 If optional arg FILE is present the type of FILE is returned instead.
 492 If FILE is being visited, the type of the buffer is returned.
 493 If optional second and third arg START and END are provided,
 494 vm-get-folder-type will examine the text between those buffer
 495 positions.  START and END default to 1 and (buffer-size) + 1.
 496 If IGNORED-VISITED is non-nil, even if FILE is being visited, its
 497 buffer is ignored and the disk copy of FILE is examined.
 498
 499 Returns
 500   nil       if folder has no type (empty)
 501   unknown   if the type is not known to VM
 502   mmdf      for MMDF folders
 503   babyl     for BABYL folders
 504   From_     for BSD UNIX From_ folders
 505   BellFrom_ for old SysV From_ folders
 506   From_-with-Content-Length
 507             for new SysV folders that use the Content-Length header
 508
 509 If vm-trust-From_-with-Content-Length is non-nil,
 510 From_-with-Content-Length is returned if the first message in the
 511 folder has a Content-Length header and the folder otherwise looks
 512 like a From_ folder.
 513
 514 Since BellFrom_ and From_ folders cannot be reliably distinguished
 515 from each other, you must tell VM which one your system uses by
 516 setting the variable vm-default-From_-folder-type to either From_ or
 517 BellFrom_.  For folders that could be From_ or BellFrom_ folders,
 518 the value of vm-default-From_folder-type will be returned."
 519   (let ((temp-buffer nil)
 520         (b nil)
 521         (case-fold-search nil))
 522     (unwind-protect
 523         (save-excursion
 524           (if file
 525               (progn
 526                 (if (not ignore-visited)
 527                     (setq b (vm-get-file-buffer file)))
 528                 (if b
 529                     (set-buffer b)
 530                   (setq temp-buffer (vm-make-work-buffer))
 531                   (set-buffer temp-buffer)
 532                   (if (file-readable-p file)
 533                       (condition-case nil
 534                           (let ((coding-system-for-read
 535                                     (vm-binary-coding-system)))
 536                             (insert-file-contents file nil 0 4096))
 537                         (wrong-number-of-arguments
 538                          (call-process "sed" file temp-buffer nil
 539                                        "-n" "1,/^$/p")))))))
 540           (save-excursion
 541             (save-restriction
 542               (or start (setq start 1))
 543               (or end (setq end (1+ (buffer-size))))
 544               (widen)
 545               (narrow-to-region start end)
 546               (goto-char (point-min))
 547               (cond ((zerop (buffer-size)) nil)
 548                     ((looking-at "\n*From ")
 549                      (if (not vm-trust-From_-with-Content-Length)
 550                          vm-default-From_-folder-type
 551                        (let ((case-fold-search t))
 552                          (re-search-forward vm-content-length-search-regexp
 553                                             nil t))
 554                        (cond ((match-beginning 1)
 555                               vm-default-From_-folder-type)
 556                              ((match-beginning 0)
 557                               'From_-with-Content-Length)
 558                              (t vm-default-From_-folder-type))))
 559                     ((looking-at "\001\001\001\001\n") 'mmdf)
 560                     ((looking-at "BABYL OPTIONS:") 'babyl)
 561                     (t 'unknown)))))
 562       (and temp-buffer (kill-buffer temp-buffer)))))
 563
 564 (defun vm-convert-folder-type (old-type new-type)
 565   "Convert buffer from OLD-TYPE to NEW-TYPE.
 566 OLD-TYPE and NEW-TYPE should be symbols returned from vm-get-folder-type.
 567 This should be called on non-live buffers like crash boxes.
 568 This will confuse VM if called on a folder buffer in vm-mode."
 569   (let ((vm-folder-type old-type)
 570         (pos-list nil)
 571         beg end)
 572     (goto-char (point-min))
 573     (vm-skip-past-folder-header)
 574     (while (vm-find-leading-message-separator)
 575       (setq pos-list (cons (point-marker) pos-list))
 576       (vm-skip-past-leading-message-separator)
 577       (setq pos-list (cons (point-marker) pos-list))
 578       (vm-find-trailing-message-separator)
 579       (setq pos-list (cons (point-marker) pos-list))
 580       (vm-skip-past-trailing-message-separator)
 581       (setq pos-list (cons (point-marker) pos-list)))
 582     (setq pos-list (nreverse pos-list))
 583     (goto-char (point-min))
 584     (vm-convert-folder-header old-type new-type)
 585     (while pos-list
 586       (setq beg (car pos-list))
 587       (goto-char (car pos-list))
 588       (insert-before-markers (vm-leading-message-separator new-type))
 589       (delete-region (car pos-list) (car (cdr pos-list)))
 590       (vm-convert-folder-type-headers old-type new-type)
 591       (setq pos-list (cdr (cdr pos-list)))
 592       (setq end (marker-position (car pos-list)))
 593       (goto-char (car pos-list))
 594       (insert-before-markers (vm-trailing-message-separator new-type))
 595       (delete-region (car pos-list) (car (cdr pos-list)))
 596       (goto-char beg)
 597       (vm-munge-message-separators new-type beg end)
 598       (setq pos-list (cdr (cdr pos-list))))))
 599
 600 (defun vm-convert-folder-header (old-type new-type)
 601   "Convert the folder header form OLD-TYPE to NEW-TYPE.
 602 The folder header is the text at the beginning of a folder that
 603 is a legal part of the folder but is not part of the first
 604 message.  This is for dealing with BABYL files."
 605   (if (eq old-type 'babyl)
 606       (save-excursion
 607         (let ((beg (point))
 608               (case-fold-search t))
 609           (cond ((and (looking-at "BABYL OPTIONS:")
 610                       (search-forward "\037" nil t))
 611                  (delete-region beg (point)))))))
 612   (if (eq new-type 'babyl)
 613       ;; insert before markers so that message location markers
 614       ;; for the first message get moved forward.
 615       (insert-before-markers "BABYL OPTIONS:\nVersion: 5\n\037")))
 616
 617 (defun vm-skip-past-folder-header ()
 618   "Move point past the folder header.
 619 The folder header is the text at the beginning of a folder that
 620 is a legal part of the folder but is not part of the first
 621 message.  This is for dealing with BABYL files."
 622   (cond ((eq vm-folder-type 'babyl)
 623          (search-forward "\037" nil 0))))
 624
 625 (defun vm-convert-folder-type-headers (old-type new-type)
 626   "Convert headers in the message around point from OLD-TYPE to NEW-TYPE.
 627 This means to add/delete Content-Length and any other
 628 headers related to folder-type as needed for folder type
 629 conversions.  This function expects point to be at the beginning
 630 of the header section of a message, and it only deals with that
 631 message."
 632   (let (length)
 633     ;; get the length now before the content-length headers are
 634     ;; removed.
 635     (if (eq new-type 'From_-with-Content-Length)
 636         (let (start)
 637           (save-excursion
 638             (save-excursion
 639               (search-forward "\n\n" nil 0)
 640               (setq start (point)))
 641             (let ((vm-folder-type old-type))
 642               (vm-find-trailing-message-separator))
 643             (setq length (- (point) start)))))
 644     ;; chop out content-length header if new format doesn't need
 645     ;; it or if the new format computed his own copy.
 646     (if (or (eq old-type 'From_-with-Content-Length)
 647             (eq new-type 'From_-with-Content-Length))
 648         (save-excursion
 649           (while (and (let ((case-fold-search t))
 650                         (re-search-forward vm-content-length-search-regexp
 651                                            nil t))
 652                       (null (match-beginning 1))
 653                       (progn (goto-char (match-beginning 0))
 654                              (vm-match-header vm-content-length-header)))
 655             (delete-region (vm-matched-header-start)
 656                            (vm-matched-header-end)))))
 657     ;; insert the content-length header if needed
 658     (if (eq new-type 'From_-with-Content-Length)
 659         (save-excursion
 660           (insert vm-content-length-header " " (int-to-string length) "\n")))))
 661
 662 (defun vm-munge-message-separators (folder-type start end)
 663   "Munge message separators of FOLDER-TYPE found between START and END.
 664 This function is used to eliminate message separators for a particular
 665 folder type that happen to occur in a message.  \">\" is prepended to such
 666 separators."
 667   (save-excursion
 668     ;; when munging From-type separators it is best to use the
 669     ;; least forgiving of the folder types, so that we don't
 670     ;; create folders that other mailers or older versions of VM
 671     ;; will misparse.
 672     (if (eq folder-type 'From_)
 673         (setq folder-type 'BellFrom_))
 674     (let ((vm-folder-type folder-type))
 675       (cond ((memq folder-type '(From_ From_-with-Content-Length mmdf
 676                                  BellFrom_ babyl))
 677              (setq end (vm-marker end))
 678              (goto-char start)
 679              (while (and (vm-find-leading-message-separator)
 680                          (< (point) end))
 681                (insert ">"))
 682              (set-marker end nil))))))
 683
 684 (defun vm-compatible-folder-p (file)
 685   "Return non-nil if FILE is a compatible folder with the current buffer.
 686 The current folder must have vm-folder-type initialized.
 687 FILE is compatible if
 688   - it is empty
 689   - the current folder is empty
 690   - the two folder types are equal"
 691   (let ((type (vm-get-folder-type file)))
 692     (or (not (and vm-folder-type type))
 693         (eq vm-folder-type type))))
 694
 695 (defun vm-leading-message-separator (&optional folder-type message
 696                                      for-other-folder)
 697   "Returns a leading message separator for the current folder.
 698 Defaults to returning a separator for the current folder type.
 699
 700 Optional first arg FOLDER-TYPE means return a separator for that
 701 folder type instead.
 702
 703 Optional second arg MESSAGE should be a message struct.  This is used
 704 generating BABYL separators, because they contain message attributes
 705 and labels that must must be copied from the message.
 706
 707 Optional third arg FOR-OTHER-FOLDER non-nil means that this separator will
 708 be used a `foreign' folder.  This means that the `deleted'
 709 attributes should not be copied for BABYL folders."
 710   (let ((type (or folder-type vm-folder-type)))
 711     (cond ((memq type '(From_ From_-with-Content-Length BellFrom_))
 712            (concat "From VM " (current-time-string) "\n"))
 713           ((eq type 'mmdf)
 714            "\001\001\001\001\n")
 715           ((eq type 'babyl)
 716            (cond (message
 717                   (concat "\014\n0,"
 718                           (vm-babyl-attributes-string message for-other-folder)
 719                           ",\n*** EOOH ***\n"))
 720                  (t "\014\n0, recent, unseen,,\n*** EOOH ***\n"))))))
 721
 722 (defun vm-trailing-message-separator (&optional folder-type)
 723   "Returns a trailing message separator for the current folder.
 724 Defaults to returning a separator for the current folder type.
 725
 726 Optional first arg FOLDER-TYPE means return a separator for that
 727 folder type instead."
 728   (let ((type (or folder-type vm-folder-type)))
 729     (cond ((eq type 'From_) "\n")
 730           ((eq type 'From_-with-Content-Length) "")
 731           ((eq type 'BellFrom_) "")
 732           ((eq type 'mmdf) "\001\001\001\001\n")
 733           ((eq type 'babyl) "\037"))))
 734
 735 (defun vm-folder-header (&optional folder-type label-obarray)
 736   "Returns a folder header for the current folder.
 737 Defaults to returning a folder header for the current folder type.
 738
 739 Optional first arg FOLDER-TYPE means return a folder header for that
 740 folder type instead.
 741
 742 Optional second arg LABEL-OBARRAY should be an obarray of labels
 743 that have been used in this folder.  This is used for BABYL folders."
 744   (let ((type (or folder-type vm-folder-type)))
 745     (cond ((eq type 'babyl)
 746            (let ((list nil))
 747              (if label-obarray
 748                  (mapatoms (function
 749                             (lambda (sym)
 750                               (setq list (cons sym list))))
 751                            label-obarray))
 752              (if list
 753                  (format "BABYL OPTIONS:\nVersion: 5\nLabels: %s\n\037"
 754                          (mapconcat (function symbol-name) list ", "))
 755                "BABYL OPTIONS:\nVersion: 5\n\037")))
 756           (t ""))))
 757
 758 (defun vm-find-leading-message-separator ()
 759   "Find the next leading message separator in a folder.
 760 Returns non-nil if the separator is found, nil otherwise."
 761   (cond
 762    ((eq vm-folder-type 'From_)
 763     (let ((reg1 "^From .*[0-9]$")
 764           (case-fold-search nil))
 765       (catch 'done
 766         (while (re-search-forward reg1 nil 'no-error)
 767           (goto-char (match-beginning 0))
 768           (if (or (< (point) 3)
 769                   (equal (char-after (- (point) 2)) ?\n))
 770               (throw 'done t)
 771             (forward-char 1)))
 772         nil )))
 773    ((eq vm-folder-type 'BellFrom_)
 774     (let ((reg1 "^From .*[0-9]$")
 775           (case-fold-search nil))
 776       (if (re-search-forward reg1 nil 'no-error)
 777           (progn
 778             (goto-char (match-beginning 0))
 779             t )
 780         nil )))
 781    ((eq vm-folder-type 'From_-with-Content-Length)
 782     (let ((reg1 "\\(^\\|\n+\\)From ")
 783           (case-fold-search nil))
 784       (if (re-search-forward reg1 nil 'no-error)
 785           (progn (goto-char (match-end 1)) t)
 786         nil )))
 787    ((eq vm-folder-type 'mmdf)
 788     (let ((reg1 "^\001\001\001\001")
 789           (case-fold-search nil))
 790       (if (re-search-forward reg1 nil 'no-error)
 791           (progn
 792             (goto-char (match-beginning 0))
 793             t )
 794         nil )))
 795    ((eq vm-folder-type 'baremessage)
 796     (goto-char (point-max)))
 797    ((eq vm-folder-type 'babyl)
 798     (let ((reg1 "\014\n[01],")
 799           (case-fold-search nil))
 800       (catch 'done
 801         (while (re-search-forward reg1 nil 'no-error)
 802           (goto-char (match-beginning 0))
 803           (if (and (not (bobp)) (= (preceding-char) ?\037))
 804               (throw 'done t)
 805             (forward-char 1)))
 806         nil )))))
 807
 808 (defun vm-find-trailing-message-separator ()
 809   "Find the next trailing message separator in a folder."
 810   (cond
 811    ((eq vm-folder-type 'From_)
 812     (vm-find-leading-message-separator)
 813     (forward-char -1))
 814    ((eq vm-folder-type 'BellFrom_)
 815     (vm-find-leading-message-separator))
 816    ((eq vm-folder-type 'From_-with-Content-Length)
 817     (let ((reg1 "^From ")
 818           content-length
 819           (start-point (point))
 820           (case-fold-search nil))
 821       (if (and (let ((case-fold-search t))
 822                  (re-search-forward vm-content-length-search-regexp nil t))
 823                (null (match-beginning 1))
 824                (progn (goto-char (match-beginning 0))
 825                       (vm-match-header vm-content-length-header)))
 826           (progn
 827             (setq content-length
 828                   (string-to-number (vm-matched-header-contents)))
 829             ;; if search fails, we'll be at point-max
 830             ;; if specified content-length is too long, go to point-max
 831             (if (search-forward "\n\n" nil 0)
 832                 (if (>= (- (point-max) (point)) content-length)
 833                     (forward-char content-length)
 834                   (goto-char (point-max))))
 835             ;; Some systems seem to add a trailing newline that's
 836             ;; not counted in the Content-Length header.  Allow
 837             ;; any number of them to avoid trouble.
 838             (skip-chars-forward "\n")))
 839       (if (or (eobp) (looking-at reg1))
 840           nil
 841         (goto-char start-point)
 842         (if (re-search-forward reg1 nil 0)
 843             (forward-char -5)))))
 844    ((eq vm-folder-type 'mmdf)
 845     (vm-find-leading-message-separator))
 846    ((eq vm-folder-type 'baremessage)
 847     (goto-char (point-max)))
 848    ((eq vm-folder-type 'babyl)
 849     (vm-find-leading-message-separator)
 850     (forward-char -1))))
 851
 852 (defun vm-skip-past-leading-message-separator ()
 853   "Move point past a leading message separator at point."
 854   (cond
 855    ((memq vm-folder-type '(From_ BellFrom_ From_-with-Content-Length))
 856     (let ((reg1 "^>From ")
 857           (case-fold-search nil))
 858       (forward-line 1)
 859       (while (looking-at reg1)
 860         (forward-line 1))))
 861    ((eq vm-folder-type 'mmdf)
 862     (forward-char 5)
 863     ;; skip >From.  Either SCO's MMDF implementation leaves this
 864     ;; stuff in the message, or many sysadmins have screwed up
 865     ;; their mail configuration.  Either way I'm tired of getting
 866     ;; bug reports about it.
 867     (let ((reg1 "^>From ")
 868           (case-fold-search nil))
 869       (while (looking-at reg1)
 870         (forward-line 1))))
 871    ((eq vm-folder-type 'babyl)
 872     (search-forward "\n*** EOOH ***\n" nil 0))))
 873
 874 (defun vm-skip-past-trailing-message-separator ()
 875   "Move point past a trailing message separator at point."
 876   (cond
 877    ((eq vm-folder-type 'From_)
 878     (if (not (eobp))
 879         (forward-char 1)))
 880    ((eq vm-folder-type 'From_-with-Content-Length))
 881    ((eq vm-folder-type 'BellFrom_))
 882    ((eq vm-folder-type 'mmdf)
 883     (forward-char 5))
 884    ((eq vm-folder-type 'babyl)
 885     (forward-char 1))))
 886
 887 (defun vm-build-message-list ()
 888   "Build a chain of message structures, stored them in vm-message-list.
 889 Finds the start and end of each message and fills in the relevant
 890 fields in the message structures.
 891
 892 Also finds the beginning of the header section and the end of the
 893 text section and fills in these fields in the message structures.
 894
 895 vm-text-of and vm-vheaders-of fields don't get filled until they
 896 are needed.
 897
 898 If vm-message-list already contained messages, the end of the last
 899 known message is found and then the parsing of new messages begins
 900 there and the message are appended to vm-message-list.
 901
 902 vm-folder-type is initialized here."
 903   (setq vm-folder-type (vm-get-folder-type))
 904   (save-excursion
 905     (let ((tail-cons nil)
 906           (n 0)
 907           ;; Just for yucks, make the update interval vary.
 908           (modulus (+ (% (vm-abs (random)) 11) 25))
 909           message last-end)
 910       (if vm-message-list
 911           ;; there are already messages, therefore we're supposed
 912           ;; to add to this list.
 913           (let ((mp vm-message-list)
 914                 (end (point-min)))
 915             ;; first we have to find physical end of the folder
 916             ;; prior to the new messages that just came in.
 917             (while mp
 918               (if (< end (vm-end-of (car mp)))
 919                   (setq end (vm-end-of (car mp))))
 920               (if (not (consp (cdr mp)))
 921                   (setq tail-cons mp))
 922               (setq mp (cdr mp)))
 923             (goto-char end))
 924         ;; there are no messages so we're building the whole list.
 925         ;; start from the beginning of the folder.
 926         (goto-char (point-min))
 927         ;; whine about newlines at the beginning of the folder.
 928         ;; technically I think this is corruption, but there are
 929         ;; too many busted mail-do-fcc's installed out there to
 930         ;; do more than whine.
 931         (if (and (memq vm-folder-type '(From_ BellFrom_
 932                                         From_-with-Content-Length))
 933                  (= (following-char) ?\n))
 934             (progn
 935               (message "Warning: newline found at beginning of folder, %s"
 936                        (or buffer-file-name (buffer-name)))
 937               (sleep-for 2)))
 938         (vm-skip-past-folder-header))
 939       (setq last-end (point))
 940       ;; parse the messages, set the markers that specify where
 941       ;; things are.
 942       (while (vm-find-leading-message-separator)
 943         (setq message (vm-make-message))
 944         (vm-set-message-type-of message vm-folder-type)
 945         (vm-set-message-access-method-of message vm-folder-access-method)
 946         (vm-set-start-of message (vm-marker (point)))
 947         (vm-skip-past-leading-message-separator)
 948         (vm-set-headers-of message (vm-marker (point)))
 949         (vm-find-trailing-message-separator)
 950         (vm-set-text-end-of message (vm-marker (point)))
 951         (vm-skip-past-trailing-message-separator)
 952         (setq last-end (point))
 953         (vm-set-end-of message (vm-marker (point)))
 954         (vm-set-reverse-link-of message tail-cons)
 955         (if (null tail-cons)
 956             (setq vm-message-list (list message)
 957                   tail-cons vm-message-list)
 958           (setcdr tail-cons (list message))
 959           (setq tail-cons (cdr tail-cons)))
 960         (vm-increment n)
 961         (if (zerop (% n modulus))
 962             (message "Parsing messages... %d" n)))
 963       (if (>= n modulus)
 964           (message "Parsing messages... done"))
 965       (if (and (not (= last-end (point-max)))
 966                (not (eq vm-folder-type 'unknown)))
 967           (progn
 968             (message "Warning: garbage found at end of folder, %s, starting at %d"
 969                      (or buffer-file-name (buffer-name))
 970                      last-end)
 971             (sleep-for 2))))))
 972
 973 (defun vm-build-header-order-alist (vheaders)
 974   (let ((order-alist (cons nil nil))
 975         list)
 976     (setq list order-alist)
 977     (while vheaders
 978       (setcdr list (cons (cons (car vheaders) nil) nil))
 979       (setq list (cdr list) vheaders (cdr vheaders)))
 980     (cdr order-alist)))
 981
 982 ;; Reorder the headers in a message.
 983 ;;
 984 ;; If a message struct is passed into this function, then we're
 985 ;; operating on a message in a folder buffer.  Headers are
 986 ;; grouped so that the headers that the user wants to see are at
 987 ;; the end of the headers section so we can narrow to them.  This
 988 ;; is done according to the preferences specified in
 989 ;; vm-visible-header and vm-invisible-header-regexp.  The
 990 ;; vheaders field of the message struct is also set.  This
 991 ;; function is called on demand whenever a vheaders field is
 992 ;; discovered to be nil for a particular message.
 993 ;;
 994 ;; If the message argument is nil, then we are operating on a
 995 ;; freestanding message that is not part of a folder buffer.  The
 996 ;; keep-list and discard-regexp parameters are used in this case.
 997 ;; Headers not matched by the keep list or matched by the discard
 998 ;; list are stripped from the message.  The remaining headers
 999 ;; are ordered according to the order of the keep list.
1000
1001 (defun vm-reorder-message-headers (message keep-list discard-regexp)
1002   (save-excursion
1003     (if message
1004         (progn
1005           (set-buffer (vm-buffer-of message))
1006           (setq keep-list vm-visible-headers
1007                 discard-regexp vm-invisible-header-regexp)))
1008     (save-excursion
1009       (save-restriction
1010         (widen)
1011         ;; if there is a cached regexp that points to the already
1012         ;; ordered headers then use it and avoid a lot of work.
1013         (if (and message (vm-vheaders-regexp-of message))
1014             (save-excursion
1015               (goto-char (vm-headers-of message))
1016               (let ((case-fold-search t))
1017                 (re-search-forward (vm-vheaders-regexp-of message)
1018                                    (vm-text-of message) t))
1019               (vm-set-vheaders-of message (vm-marker (match-beginning 0))))
1020           ;; oh well, we gotta do it the hard way.
1021           ;;
1022           ;; header-alist will contain an assoc list version of
1023           ;; keep-list.  For messages associated with a folder
1024           ;; buffer: when a matching header is found, the
1025           ;; header's start and end positions are added to its
1026           ;; corresponding assoc cell.  The positions of unwanted
1027           ;; headers are remember also so that they can be copied
1028           ;; to the top of the message, to be out of sight after
1029           ;; narrowing.  Once the positions have all been
1030           ;; recorded a new copy of the headers is inserted in
1031           ;; the proper order and the old headers are deleted.
1032           ;;
1033           ;; For free standing messages, unwanted headers are
1034           ;; stripped from the message, unremembered.
1035           (vm-save-restriction
1036            (let ((header-alist (vm-build-header-order-alist keep-list))
1037                  (buffer-read-only nil)
1038                  (work-buffer nil)
1039                  (extras nil)
1040                  list end-of-header vheader-offset
1041                  (folder-buffer (current-buffer))
1042                  ;; This prevents file locking from occuring.  Disabling
1043                  ;; locking can speed things noticeably if the lock directory
1044                  ;; is on a slow device.  We don't need locking here because
1045                  ;; in a mail context reordering headers is harmless.
1046                  (buffer-file-name nil)
1047                  (case-fold-search t)
1048                  (unwanted-list nil)
1049                  unwanted-tail
1050                  new-header-start
1051                  old-header-start
1052                  (old-buffer-modified-p (buffer-modified-p)))
1053              (unwind-protect
1054                  (progn
1055                    (if message
1056                        (progn
1057                          ;; for babyl folders, keep an untouched
1058                          ;; copy of the headers between the
1059                          ;; attributes line and the *** EOOH ***
1060                          ;; line.
1061                          (if (and (eq vm-folder-type 'babyl)
1062                                   (null (vm-babyl-frob-flag-of message)))
1063                              (progn
1064                                (goto-char (vm-start-of message))
1065                                (forward-line 2)
1066                                (vm-set-babyl-frob-flag-of message t)
1067                                (insert-buffer-substring
1068                                 (current-buffer)
1069                                 (vm-headers-of message)
1070                                 (1- (vm-text-of message)))
1071                                ;; Yep, messages can come in
1072                                ;; without the two newlines after
1073                                ;; the header section.
1074                                (if (not (eq (char-after (1- (point))) ?\n))
1075                                    (insert ?\n))))
1076                          (setq work-buffer (vm-make-work-buffer))
1077                          (set-buffer work-buffer)
1078                          (insert-buffer-substring
1079                           folder-buffer
1080                           (vm-headers-of message)
1081                           (vm-text-of message))
1082                          (goto-char (point-min))))
1083                    (setq old-header-start (point))
1084                    ;; as we loop through the headers, skip >From
1085                    ;; lines.  these can occur anywhere in the
1086                    ;; header section if the message has been
1087                    ;; manhandled by some dumb delivery agents
1088                    ;; (SCO and Solaris are the usual suspects.)
1089                    ;; it's a tough ol' world.
1090                    (while (progn (while (looking-at ">From ")
1091                                    (forward-line))
1092                                  (and (not (= (following-char) ?\n))
1093                                       (vm-match-header)))
1094                      (setq end-of-header (vm-matched-header-end)
1095                            list (vm-match-ordered-header header-alist))
1096                      ;; don't display/keep this header if
1097                      ;;  keep-list not matched
1098                      ;;  and discard-regexp is nil
1099                      ;;       or
1100                      ;;  discard-regexp is matched
1101                      (if (or (and (null list) (null discard-regexp))
1102                              (and discard-regexp (looking-at discard-regexp)))
1103                          ;; delete the unwanted header if not doing
1104                          ;; work for a folder buffer, otherwise
1105                          ;; remember the start and end of the
1106                          ;; unwanted header so we can copy it
1107                          ;; later.
1108                          (if (not message)
1109                              (delete-region (point) end-of-header)
1110                            (if (null unwanted-list)
1111                                (setq unwanted-list
1112                                      (cons (point) (cons end-of-header nil))
1113                                      unwanted-tail unwanted-list)
1114                              (if (= (point) (car (cdr unwanted-tail)))
1115                                  (setcar (cdr unwanted-tail)
1116                                          end-of-header)
1117                                (setcdr (cdr unwanted-tail)
1118                                        (cons (point)
1119                                              (cons end-of-header nil)))
1120                                (setq unwanted-tail (cdr (cdr unwanted-tail)))))
1121                            (goto-char end-of-header))
1122                        ;; got a match
1123                        ;; stuff the start and end of the header
1124                        ;; into the cdr of the returned alist
1125                        ;; element.
1126                        (if list
1127                            ;; reverse point and end-of-header.
1128                            ;; list will be nreversed later.
1129                            (setcdr list (cons end-of-header
1130                                               (cons (point)
1131                                                     (cdr list))))
1132                          ;; reverse point and end-of-header.
1133                          ;; list will be nreversed later.
1134                          (setq extras
1135                                (cons end-of-header
1136                                      (cons (point) extras))))
1137                        (goto-char end-of-header)))
1138                    (setq new-header-start (point))
1139                    (while unwanted-list
1140                      (insert-buffer-substring (current-buffer)
1141                                               (car unwanted-list)
1142                                               (car (cdr unwanted-list)))
1143                      (setq unwanted-list (cdr (cdr unwanted-list))))
1144                    ;; remember the offset of where the visible
1145                    ;; header start so we can initialize the
1146                    ;; vm-vheaders-of field later.
1147                    (if message
1148                        (setq vheader-offset (- (point) new-header-start)))
1149                    (while header-alist
1150                      (setq list (nreverse (cdr (car header-alist))))
1151                      (while list
1152                        (insert-buffer-substring (current-buffer)
1153                                                 (car list)
1154                                                 (car (cdr list)))
1155                        (setq list (cdr (cdr list))))
1156                      (setq header-alist (cdr header-alist)))
1157                    ;; now the headers that were not explicitly
1158                    ;; undesirable, if any.
1159                    (setq extras (nreverse extras))
1160                    (while extras
1161                      (insert-buffer-substring (current-buffer)
1162                                               (car extras)
1163                                               (car (cdr extras)))
1164                      (setq extras (cdr (cdr extras))))
1165                    (delete-region old-header-start new-header-start)
1166                    ;; update the folder buffer if we're supposed to.
1167                    ;; lock out interrupts.
1168                    (if message
1169                        (let ((inhibit-quit t))
1170                          (set-buffer (vm-buffer-of message))
1171                          (goto-char (vm-headers-of message))
1172                          (insert-buffer-substring work-buffer)
1173                          (delete-region (point) (vm-text-of message))
1174                          (set-buffer-modified-p old-buffer-modified-p))))
1175                (and work-buffer (kill-buffer work-buffer)))
1176              (if message
1177                  (progn
1178                    (vm-set-vheaders-of message
1179                                        (vm-marker (+ (vm-headers-of message)
1180                                                      vheader-offset)))
1181                    ;; cache a regular expression that can be used to
1182                    ;; find the start of the reordered header the next
1183                    ;; time this folder is visited.
1184                    (goto-char (vm-vheaders-of message))
1185                    (if (vm-match-header)
1186                        (vm-set-vheaders-regexp-of
1187                         message
1188                         (concat "^" (vm-matched-header-name) ":"))))))))))))
1189
1190 ;; Reads the message attributes and cached header information from the
1191 ;; header portion of the each message, if our X-VM- attributes header is
1192 ;; present.  If the header is not present, assume the message is new,
1193 ;; unless we are being compatible with Berkeley Mail in which case we
1194 ;; also check for a Status header.
1195 ;;
1196 ;; If a message already has attributes don't bother checking the
1197 ;; headers.
1198 ;;
1199 ;; This function also discovers and stores the position where the
1200 ;; message text begins.
1201 ;;
1202 ;; Totals are gathered for use by vm-emit-totals-blurb.
1203 ;;
1204 ;; Supports version 4 format of attribute storage, for backward compatibility.
1205
1206 (defun vm-read-attributes (message-list)
1207   (save-excursion
1208     (let ((mp (or message-list vm-message-list))
1209           (vm-new-count 0)
1210           (vm-unread-count 0)
1211           (vm-deleted-count 0)
1212           (vm-total-count 0)
1213           (modulus (+ (% (vm-abs (random)) 11) 25))
1214           (case-fold-search t)
1215           oldpoint data)
1216       (while mp
1217         (vm-increment vm-total-count)
1218         (if (vm-attributes-of (car mp))
1219             ()
1220           (goto-char (vm-headers-of (car mp)))
1221           ;; find start of text section and save it
1222           (search-forward "\n\n" (vm-text-end-of (car mp)) 0)
1223           (vm-set-text-of (car mp) (point-marker))
1224           ;; now look for our header
1225           (goto-char (vm-headers-of (car mp)))
1226           (cond
1227            ((re-search-forward vm-attributes-header-regexp
1228                                (vm-text-of (car mp)) t)
1229             (goto-char (match-beginning 2))
1230             (condition-case ()
1231                 (progn
1232                   (setq oldpoint (point)
1233                         data (read (current-buffer)))
1234                   (if (and (or (not (listp data)) (not (> (length data) 1)))
1235                            (not (vectorp data)))
1236                       (progn
1237                         (error "Bad x-vm-v5-data at %d in buffer %s"
1238                                oldpoint (buffer-name))))
1239                   data )
1240               (error
1241                (message "Bad x-vm-v5-data header at %d in buffer %s, ignoring"
1242                         oldpoint (buffer-name))
1243                (setq data
1244                      (list
1245                       (make-vector vm-attributes-vector-length nil)
1246                       (make-vector vm-cache-vector-length nil)
1247                       nil))
1248                ;; In lieu of a valid attributes header
1249                ;; assume the message is new.  avoid
1250                ;; vm-set-new-flag because it asks for a
1251                ;; summary update.
1252                (vm-set-new-flag-in-vector (car data) t)))
1253             ;; support version 4 format
1254             (cond ((vectorp data)
1255                    (setq data (vm-convert-v4-attributes data))
1256                    ;; tink the message stuff flag so that if the
1257                    ;; user saves we get rid of the old v4
1258                    ;; attributes header.  otherwise we could be
1259                    ;; dealing with these things for all eternity.
1260                    (vm-set-stuff-flag-of (car mp) t))
1261                   (t
1262                    ;; extend vectors if necessary to accomodate
1263                    ;; more caching and attributes without alienating
1264                    ;; other version 5 folders.
1265                    (cond ((< (length (car data))
1266                              vm-attributes-vector-length)
1267                           ;; tink the message stuff flag so that if
1268                           ;; the user saves we get rid of the old
1269                           ;; short vector.  otherwise we could be
1270                           ;; dealing with these things for all
1271                           ;; eternity.
1272                           (vm-set-stuff-flag-of (car mp) t)
1273                           (setcar data (vm-extend-vector
1274                                         (car data)
1275                                         vm-attributes-vector-length))))
1276                    (cond ((< (length (car (cdr data)))
1277                              vm-cache-vector-length)
1278                           ;; tink the message stuff flag so that if
1279                           ;; the user saves we get rid of the old
1280                           ;; short vector.  otherwise we could be
1281                           ;; dealing with these things for all
1282                           ;; eternity.
1283                           (vm-set-stuff-flag-of (car mp) t)
1284                           (setcar (cdr data)
1285                                   (vm-extend-vector
1286                                    (car (cdr data))
1287                                    vm-cache-vector-length))))))
1288             ;; data list might not be long enough for (nth 2 ...)  but
1289             ;; that's OK because nth returns nil if you overshoot the
1290             ;; end of the list.
1291             (vm-set-labels-of (car mp) (nth 2 data))
1292             (vm-set-cache-of (car mp) (car (cdr data)))
1293             (vm-set-attributes-of (car mp) (car data)))
1294            ((and vm-berkeley-mail-compatibility
1295                  (re-search-forward vm-berkeley-mail-status-header-regexp
1296                                     (vm-text-of (car mp)) t))
1297             (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
1298                                                    nil))
1299             (goto-char (match-beginning 1))
1300             (vm-set-attributes-of
1301              (car mp)
1302              (make-vector vm-attributes-vector-length nil))
1303             (vm-set-unread-flag (car mp) (not (looking-at ".*R.*")) t))
1304            (t
1305             (vm-set-cache-of (car mp) (make-vector vm-cache-vector-length
1306                                                    nil))
1307             (vm-set-attributes-of
1308              (car mp)
1309              (make-vector vm-attributes-vector-length nil))
1310             ;; In lieu of a valid attributes header
1311             ;; assume the message is new.  avoid
1312             ;; vm-set-new-flag because it asks for a
1313             ;; summary update.
1314             (vm-set-new-flag-of (car mp) t)))
1315           ;; let babyl attributes override the normal VM
1316           ;; attributes header.
1317           (cond ((eq vm-folder-type 'babyl)
1318                  (vm-read-babyl-attributes (car mp)))))
1319         (cond ((vm-deleted-flag (car mp))
1320                (vm-increment vm-deleted-count))
1321               ((vm-new-flag (car mp))
1322                (vm-increment vm-new-count))
1323               ((vm-unread-flag (car mp))
1324                (vm-increment vm-unread-count)))
1325         (if (zerop (% vm-total-count modulus))
1326             (message "Reading attributes... %d" vm-total-count))
1327         (setq mp (cdr mp)))
1328       (if (>= vm-total-count modulus)
1329           (message "Reading attributes... done"))
1330       (if (null message-list)
1331           (setq vm-totals (list vm-modification-counter
1332                                 vm-total-count
1333                                 vm-new-count
1334                                 vm-unread-count
1335                                 vm-deleted-count))))))
1336
1337 (defun vm-read-babyl-attributes (message)
1338   (let ((case-fold-search t)
1339         (labels nil)
1340         (vect (make-vector vm-attributes-vector-length nil)))
1341     (vm-set-attributes-of message vect)
1342     (save-excursion
1343       (goto-char (vm-start-of message))
1344       ;; skip past ^L\n
1345       (forward-char 2)
1346       (vm-set-babyl-frob-flag-of message (if (= (following-char) ?1) t nil))
1347       ;; skip past 0,
1348       (forward-char 2)
1349       ;; loop, noting attributes as we go.
1350       (while (and (not (eobp)) (not (looking-at ",")))
1351         (cond ((looking-at " unseen,")
1352                (vm-set-unread-flag-of message t))
1353               ((looking-at " recent,")
1354                (vm-set-new-flag-of message t))
1355               ((looking-at " deleted,")
1356                (vm-set-deleted-flag-of message t))
1357               ((looking-at " answered,")
1358                (vm-set-replied-flag-of message t))
1359               ((looking-at " forwarded,")
1360                (vm-set-forwarded-flag-of message t))
1361               ((looking-at " filed,")
1362                (vm-set-filed-flag-of message t))
1363               ((looking-at " redistributed,")
1364                (vm-set-redistributed-flag-of message t))
1365               ;; only VM knows about these, as far as I know.
1366               ((looking-at " edited,")
1367                (vm-set-forwarded-flag-of message t))
1368               ((looking-at " written,")
1369                (vm-set-forwarded-flag-of message t)))
1370         (skip-chars-forward "^,")
1371         (and (not (eobp)) (forward-char 1)))
1372       (and (not (eobp)) (forward-char 1))
1373       (while (looking-at " \\([^\000-\040,\177-\377]+\\),")
1374         (setq labels (cons (vm-buffer-substring-no-properties
1375                             (match-beginning 1)
1376                             (match-end 1))
1377                            labels))
1378         (goto-char (match-end 0)))
1379       (vm-set-labels-of message labels))))
1380
1381 (defun vm-set-default-attributes (message-list)
1382   (let ((mp (or message-list vm-message-list)) attr cache)
1383     (while mp
1384       (setq attr (make-vector vm-attributes-vector-length nil)
1385             cache (make-vector vm-cache-vector-length nil))
1386       (vm-set-cache-of (car mp) cache)
1387       (vm-set-attributes-of (car mp) attr)
1388       ;; make message be new by default, but avoid vm-set-new-flag
1389       ;; because it asks for a summary update for the message.
1390       (vm-set-new-flag-of (car mp) t)
1391       ;; since this function is usually called in lieu of reading
1392       ;; attributes from the buffer, the buffer attributes may be
1393       ;; untrustworthy.  tink the message stuff flag to force the
1394       ;; new attributes out if the user saves.
1395       (vm-set-stuff-flag-of (car mp) t)
1396       (setq mp (cdr mp)))))
1397
1398 (defun vm-compute-totals ()
1399   (save-excursion
1400     (vm-select-folder-buffer)
1401     (let ((mp vm-message-list)
1402           (vm-new-count 0)
1403           (vm-unread-count 0)
1404           (vm-deleted-count 0)
1405           (vm-total-count 0))
1406       (while mp
1407         (vm-increment vm-total-count)
1408         (cond ((vm-deleted-flag (car mp))
1409                (vm-increment vm-deleted-count))
1410               ((vm-new-flag (car mp))
1411                (vm-increment vm-new-count))
1412               ((vm-unread-flag (car mp))
1413                (vm-increment vm-unread-count)))
1414         (setq mp (cdr mp)))
1415       (setq vm-totals (list vm-modification-counter
1416                             vm-total-count
1417                             vm-new-count
1418                             vm-unread-count
1419                             vm-deleted-count)))))
1420
1421 (defun vm-emit-totals-blurb ()
1422   (interactive)
1423   (save-excursion
1424     (vm-select-folder-buffer)
1425     (if (not (equal (nth 0 vm-totals) vm-modification-counter))
1426         (vm-compute-totals))
1427     (if (equal (nth 1 vm-totals) 0)
1428         (message "No messages.")
1429       (message "%d message%s, %d new, %d unread, %d deleted"
1430                (nth 1 vm-totals) (if (= (nth 1 vm-totals) 1) "" "s")
1431                (nth 2 vm-totals)
1432                (nth 3 vm-totals)
1433                (nth 4 vm-totals)))))
1434
1435 (defun vm-convert-v4-attributes (data)
1436   (list (apply 'vector
1437                (nconc (vm-vector-to-list data)
1438                       (make-list (- vm-attributes-vector-length
1439                                     (length data))
1440                                  nil)))
1441         (make-vector vm-cache-vector-length nil)))
1442
1443 (defun vm-gobble-last-modified ()
1444   (let ((case-fold-search t)
1445         (time nil)
1446         time lim oldpoint)
1447     (save-excursion
1448       (vm-save-restriction
1449        (widen)
1450        (goto-char (point-min))
1451        (vm-skip-past-folder-header)
1452        (vm-skip-past-leading-message-separator)
1453        (search-forward "\n\n" nil t)
1454        (setq lim (point))
1455        (goto-char (point-min))
1456        (vm-skip-past-folder-header)
1457        (vm-skip-past-leading-message-separator)
1458        (if (re-search-forward vm-last-modified-header-regexp lim t)
1459            (condition-case ()
1460                (progn
1461                  (setq oldpoint (point)
1462                        time (read (current-buffer)))
1463                  (if (not (consp time))
1464                      (error "Bad last-modified header at %d in buffer %s"
1465                             oldpoint (buffer-name)))
1466                  time )
1467              (error
1468               (message "Bad last-modified header at %d in buffer %s, ignoring"
1469                        oldpoint (buffer-name))
1470               (setq time '(0 0 0)))))))
1471     time ))
1472
1473 (defun vm-gobble-labels ()
1474   (let ((case-fold-search t)
1475         lim)
1476     (save-excursion
1477       (vm-save-restriction
1478        (widen)
1479        (if (eq vm-folder-type 'babyl)
1480            (progn
1481              (goto-char (point-min))
1482              (vm-skip-past-folder-header)
1483              (setq lim (point))
1484              (goto-char (point-min))
1485              (if (re-search-forward "^Labels:" lim t)
1486                  (let (string list)
1487                    (setq string (buffer-substring
1488                                  (point)
1489                                  (progn (end-of-line) (point)))
1490                          list (vm-parse string
1491 "[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*"))
1492                    (mapcar (function
1493                             (lambda (s)
1494                               (intern (downcase s) vm-label-obarray)))
1495                            list))))
1496          (goto-char (point-min))
1497          (vm-skip-past-folder-header)
1498          (vm-skip-past-leading-message-separator)
1499          (search-forward "\n\n" nil t)
1500          (setq lim (point))
1501          (goto-char (point-min))
1502          (vm-skip-past-folder-header)
1503          (vm-skip-past-leading-message-separator)
1504          (if (re-search-forward vm-labels-header-regexp lim t)
1505              (let ((oldpoint (point))
1506                    list)
1507                (condition-case ()
1508                    (progn
1509                      (setq list (read (current-buffer)))
1510                      (if (not (listp list))
1511                          (error "Bad global label list at %d in buffer %s"
1512                                 oldpoint (buffer-name)))
1513                      list )
1514                  (error
1515                   (message "Bad global label list at %d in buffer %s, ignoring"
1516                            oldpoint (buffer-name))
1517                   (setq list nil) ))
1518                (vm-startup-apply-labels list))))))
1519     t ))
1520
1521 (defun vm-startup-apply-labels (labels)
1522   (mapcar (function (lambda (s) (intern s vm-label-obarray))) labels))
1523
1524 ;; Go to the message specified in a bookmark and eat the bookmark.
1525 ;; Returns non-nil if successful, nil otherwise.
1526 (defun vm-gobble-bookmark ()
1527   (let ((case-fold-search t)
1528         (n nil)
1529         lim oldpoint)
1530     (save-excursion
1531       (vm-save-restriction
1532        (widen)
1533        (goto-char (point-min))
1534        (vm-skip-past-folder-header)
1535        (vm-skip-past-leading-message-separator)
1536        (search-forward "\n\n" nil t)
1537        (setq lim (point))
1538        (goto-char (point-min))
1539        (vm-skip-past-folder-header)
1540        (vm-skip-past-leading-message-separator)
1541        (if (re-search-forward vm-bookmark-header-regexp lim t)
1542            (condition-case ()
1543                (progn
1544                  (setq oldpoint (point)
1545                        n (read (current-buffer)))
1546                  (if (not (natnump n))
1547                      (error "Bad bookmark at %d in buffer %s"
1548                             oldpoint (buffer-name)))
1549                  n )
1550              (error
1551               (message "Bad bookmark at %d in buffer %s, ignoring"
1552                        oldpoint (buffer-name))
1553               (setq n 1))))))
1554     (vm-startup-apply-bookmark n)
1555     t ))
1556
1557 (defun vm-startup-apply-bookmark (n)
1558   (if n
1559       (vm-record-and-change-message-pointer
1560        vm-message-pointer
1561        (nthcdr (1- n) vm-message-list))))
1562
1563 (defun vm-gobble-pop-retrieved ()
1564   (let ((case-fold-search t)
1565         ob lim oldpoint)
1566     (save-excursion
1567       (vm-save-restriction
1568        (widen)
1569        (goto-char (point-min))
1570        (vm-skip-past-folder-header)
1571        (vm-skip-past-leading-message-separator)
1572        (search-forward "\n\n" nil t)
1573        (setq lim (point))
1574        (goto-char (point-min))
1575        (vm-skip-past-folder-header)
1576        (vm-skip-past-leading-message-separator)
1577        (if (re-search-forward vm-pop-retrieved-header-regexp lim t)
1578            (condition-case ()
1579                (progn
1580                  (setq oldpoint (point)
1581                        ob (read (current-buffer)))
1582                  (if (not (listp ob))
1583                      (error "Bad pop-retrieved header at %d in buffer %s"
1584                             oldpoint (buffer-name)))
1585                  (setq vm-pop-retrieved-messages ob))
1586              (error
1587               (message "Bad pop-retrieved header at %d in buffer %s, ignoring"
1588                        oldpoint (buffer-name)))))))
1589     t ))
1590
1591 (defun vm-gobble-imap-retrieved ()
1592   (let ((case-fold-search t)
1593         ob lim oldpoint)
1594     (save-excursion
1595       (vm-save-restriction
1596        (widen)
1597        (goto-char (point-min))
1598        (vm-skip-past-folder-header)
1599        (vm-skip-past-leading-message-separator)
1600        (search-forward "\n\n" nil t)
1601        (setq lim (point))
1602        (goto-char (point-min))
1603        (vm-skip-past-folder-header)
1604        (vm-skip-past-leading-message-separator)
1605        (if (re-search-forward vm-imap-retrieved-header-regexp lim t)
1606            (condition-case ()
1607                (progn
1608                  (setq oldpoint (point)
1609                        ob (read (current-buffer)))
1610                  (if (not (listp ob))
1611                      (error "Bad imap-retrieved header at %d in buffer %s"
1612                             oldpoint (buffer-name)))
1613                  (setq vm-imap-retrieved-messages ob))
1614              (error
1615               (message "Bad imap-retrieved header at %d in buffer %s, ignoring"
1616                        oldpoint (buffer-name)))))))
1617     t ))
1618
1619 (defun vm-gobble-visible-header-variables ()
1620   (save-excursion
1621     (vm-save-restriction
1622      (let ((case-fold-search t)
1623            lim)
1624        (widen)
1625        (goto-char (point-min))
1626        (vm-skip-past-folder-header)
1627        (vm-skip-past-leading-message-separator)
1628        (search-forward "\n\n" nil t)
1629        (setq lim (point))
1630        (goto-char (point-min))
1631        (vm-skip-past-folder-header)
1632        (vm-skip-past-leading-message-separator)
1633        (if (re-search-forward vm-vheader-header-regexp lim t)
1634            (let (vis invis (got nil))
1635              (condition-case ()
1636                  (setq vis (read (current-buffer))
1637                        invis (read (current-buffer))
1638                        got t)
1639                (error nil))
1640              (if got
1641                  (vm-startup-apply-header-variables vis invis))))))))
1642
1643 (defun vm-startup-apply-header-variables (vis invis)
1644   ;; if the variables don't match the values stored when this
1645   ;; folder was saved, then we have to discard any cached
1646   ;; vheader info so the user will see the right headers.
1647   (and (or (not (equal vis vm-visible-headers))
1648            (not (equal invis vm-invisible-header-regexp)))
1649        (let ((mp vm-message-list))
1650          (message "Discarding visible header info...")
1651          (while mp
1652            (vm-set-vheaders-regexp-of (car mp) nil)
1653            (vm-set-vheaders-of (car mp) nil)
1654            (setq mp (cdr mp))))))
1655
1656 ;; Read and delete the header that gives the folder's desired
1657 ;; message order.
1658 (defun vm-gobble-message-order ()
1659   (let ((case-fold-search t)
1660         lim order)
1661     (save-excursion
1662       (save-restriction
1663         (widen)
1664         (goto-char (point-min))
1665         (vm-skip-past-folder-header)
1666         (vm-skip-past-leading-message-separator)
1667         (search-forward "\n\n" nil t)
1668         (setq lim (point))
1669         (goto-char (point-min))
1670         (vm-skip-past-folder-header)
1671         (vm-skip-past-leading-message-separator)
1672         (if (re-search-forward vm-message-order-header-regexp lim t)
1673             (let ((oldpoint (point)))
1674               (condition-case nil
1675                   (progn
1676                     (setq order (read (current-buffer)))
1677                     (if (not (listp order))
1678                         (error "Bad order header at %d in buffer %s"
1679                                oldpoint (buffer-name)))
1680                     order )
1681                 (error
1682                  (message "Bad order header at %d in buffer %s, ignoring"
1683                           oldpoint (buffer-name))
1684                  (setq order nil)))
1685               (if order
1686                   (progn
1687                     (message "Reordering messages...")
1688                     (vm-startup-apply-message-order order)
1689                     (message "Reordering messages... done")))))))))
1690
1691 (defun vm-has-message-order ()
1692   (let ((case-fold-search t)
1693         lim order)
1694     (save-excursion
1695       (save-restriction
1696         (widen)
1697         (goto-char (point-min))
1698         (vm-skip-past-folder-header)
1699         (vm-skip-past-leading-message-separator)
1700         (search-forward "\n\n" nil t)
1701         (setq lim (point))
1702         (goto-char (point-min))
1703         (vm-skip-past-folder-header)
1704         (vm-skip-past-leading-message-separator)
1705         (re-search-forward vm-message-order-header-regexp lim t)))))
1706
1707 (defun vm-startup-apply-message-order (order)
1708   (let (list-length v (mp vm-message-list))
1709     (setq list-length (length vm-message-list)
1710           v (make-vector (max list-length (length order)) nil))
1711     (while (and order mp)
1712       (condition-case nil
1713           (aset v (1- (car order)) (car mp))
1714         (args-out-of-range nil))
1715       (setq order (cdr order) mp (cdr mp)))
1716     ;; lock out interrupts while the message list is in
1717     ;; an inconsistent state.
1718     (let ((inhibit-quit t))
1719       (setq vm-message-list (delq nil (append v mp))
1720             vm-message-order-changed nil
1721             vm-message-order-header-present t
1722             vm-message-pointer (memq (car vm-message-pointer)
1723                                      vm-message-list))
1724       (vm-set-numbering-redo-start-point t)
1725       (vm-reverse-link-messages))))
1726
1727 ;; Read the header that gives the folder's cached summary format
1728 ;; If the current summary format is different, then the cached
1729 ;; summary lines are discarded.
1730 (defun vm-gobble-summary ()
1731   (let ((case-fold-search t)
1732         summary lim)
1733     (save-excursion
1734       (vm-save-restriction
1735        (widen)
1736        (goto-char (point-min))
1737        (vm-skip-past-folder-header)
1738        (vm-skip-past-leading-message-separator)
1739        (search-forward "\n\n" nil t)
1740        (setq lim (point))
1741        (goto-char (point-min))
1742        (vm-skip-past-folder-header)
1743        (vm-skip-past-leading-message-separator)
1744        (if (re-search-forward vm-summary-header-regexp lim t)
1745            (let ((oldpoint (point)))
1746              (condition-case ()
1747                  (setq summary (read (current-buffer)))
1748                (error
1749                 (message "Bad summary header at %d in buffer %s, ignoring"
1750                          oldpoint (buffer-name))
1751                 (setq summary "")))
1752              (vm-startup-apply-summary summary)))))))
1753
1754 (defun vm-startup-apply-summary (summary)
1755   (if (not (equal summary vm-summary-format))
1756       (let ((mp vm-message-list))
1757         (while mp
1758           (vm-set-summary-of (car mp) nil)
1759           ;; force restuffing of cache to clear old
1760           ;; summary entry cache.
1761           (vm-set-stuff-flag-of (car mp) t)
1762           (setq mp (cdr mp))))))
1763
1764 ;; Stuff the message attributes back into the message as headers.
1765 (defun vm-stuff-attributes (m &optional for-other-folder)
1766   (save-excursion
1767     (vm-save-restriction
1768      (widen)
1769      (let ((old-buffer-modified-p (buffer-modified-p))
1770            attributes cache
1771            (case-fold-search t)
1772            (buffer-read-only nil)
1773            ;; don't truncate the printing of large Lisp objects
1774            (print-length nil)
1775            opoint
1776            ;; This prevents file locking from occuring.  Disabling
1777            ;; locking can speed things noticeably if the lock
1778            ;; directory is on a slow device.  We don't need locking
1779            ;; here because the user shouldn't care about VM stuffing
1780            ;; its own status headers.
1781            (buffer-file-name nil)
1782            (delflag (vm-deleted-flag m)))
1783        (unwind-protect
1784            (progn
1785              ;; don't put this folder's summary entry into another folder.
1786              (if for-other-folder
1787                  (vm-set-summary-of m nil)
1788                (if (vm-su-start-of m)
1789                    ;; fill the summary cache if it's not done already.
1790                    (vm-su-summary m)))
1791              (setq attributes (vm-attributes-of m)
1792                    cache (vm-cache-of m))
1793              (and delflag for-other-folder
1794                   (vm-set-deleted-flag-in-vector
1795                    (setq attributes (copy-sequence attributes)) nil))
1796              (if (eq vm-folder-type 'babyl)
1797                  (vm-stuff-babyl-attributes m for-other-folder))
1798              (goto-char (vm-headers-of m))
1799              (while (re-search-forward vm-attributes-header-regexp
1800                                        (vm-text-of m) t)
1801                (delete-region (match-beginning 0) (match-end 0)))
1802              (goto-char (vm-headers-of m))
1803              (setq opoint (point))
1804              (insert-before-markers
1805               vm-attributes-header " ("
1806               (let ((print-escape-newlines t))
1807                 (prin1-to-string attributes))
1808               "\n\t"
1809               (vm-mime-encode-words-in-string
1810                (let ((print-escape-newlines t))
1811                  (prin1-to-string cache)))
1812               "\n\t"
1813               (let ((print-escape-newlines t))
1814                 (prin1-to-string (vm-labels-of m)))
1815               ")\n")
1816              (set-marker (vm-headers-of m) opoint)
1817              (cond ((and (eq vm-folder-type 'From_)
1818                          vm-berkeley-mail-compatibility)
1819                     (goto-char (vm-headers-of m))
1820                     (while (re-search-forward
1821                             vm-berkeley-mail-status-header-regexp
1822                             (vm-text-of m) t)
1823                       (delete-region (match-beginning 0) (match-end 0)))
1824                     (goto-char (vm-headers-of m))
1825                     (cond ((not (vm-new-flag m))
1826                            (insert-before-markers
1827                             vm-berkeley-mail-status-header
1828                             (if (vm-unread-flag m) "" "R")
1829                             "O\n")
1830                            (set-marker (vm-headers-of m) opoint)))))
1831              (vm-set-stuff-flag-of m (not for-other-folder)))
1832          (set-buffer-modified-p old-buffer-modified-p))))))
1833
1834 (defun vm-stuff-folder-attributes (&optional abort-if-input-pending quiet)
1835   (let ((newlist nil) mp len (n 0))
1836     ;; stuff the attributes of messages that need it.
1837     ;; build a list of messages that need their attributes stuffed
1838     (setq mp vm-message-list)
1839     (while mp
1840       (if (vm-stuff-flag-of (car mp))
1841           (setq newlist (cons (car mp) newlist)))
1842       (setq mp (cdr mp)))
1843     (if (and newlist (not quiet))
1844         (progn
1845           (setq len (length newlist))
1846           (message "%d message%s to stuff" len (if (= 1 len) "" "s"))))
1847     ;; now sort the list by physical order so that we
1848     ;; reduce the amount of gap motion induced by modifying
1849     ;; the buffer.  what we want to avoid is updating
1850     ;; message 3, then 234, then 10, then 500, thus causing
1851     ;; large chunks of memory to be copied repeatedly as
1852     ;; the gap moves to accomodate the insertions.
1853     (if (not quiet)
1854         (message "Ordering updates..."))
1855     (let ((vm-key-functions '(vm-sort-compare-physical-order-r)))
1856       (setq mp (sort newlist 'vm-sort-compare-xxxxxx)))
1857     (while (and mp (or (not abort-if-input-pending) (not (input-pending-p))))
1858       (vm-stuff-attributes (car mp))
1859       (setq n (1+ n))
1860       (if (not quiet)
1861           (message "Stuffing %d%% complete..." (* (/ (+ n 0.0) len) 100)))
1862       (setq mp (cdr mp)))
1863     (if mp nil t)))
1864
1865 ;; we can be a bit lazy in this function since it's only called
1866 ;; from within vm-stuff-attributes.  we don't worry about
1867 ;; restoring the modified flag, setting buffer-read-only, or
1868 ;; about not moving point.
1869 (defun vm-stuff-babyl-attributes (m for-other-folder)
1870   (goto-char (vm-start-of m))
1871   (forward-char 2)
1872   (if (vm-babyl-frob-flag-of m)
1873       (insert "1")
1874     (insert "0"))
1875   (delete-char 1)
1876   (forward-char 1)
1877   (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+")
1878       (delete-region (match-beginning 0) (match-end 0)))
1879   (if (vm-new-flag m)
1880       (insert " recent, unseen,")
1881     (if (vm-unread-flag m)
1882         (insert " unseen,")))
1883   (if (and (not for-other-folder) (vm-deleted-flag m))
1884       (insert " deleted,"))
1885   (if (vm-replied-flag m)
1886       (insert " answered,"))
1887   (if (vm-forwarded-flag m)
1888       (insert " forwarded,"))
1889   (if (vm-redistributed-flag m)
1890       (insert " redistributed,"))
1891   (if (vm-filed-flag m)
1892       (insert " filed,"))
1893   (if (vm-edited-flag m)
1894       (insert " edited,"))
1895   (if (vm-written-flag m)
1896       (insert " written,"))
1897   (forward-char 1)
1898   (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+")
1899       (delete-region (match-beginning 0) (match-end 0)))
1900   (mapcar (function (lambda (label) (insert " " label ",")))
1901           (vm-labels-of m)))
1902
1903 (defun vm-babyl-attributes-string (m for-other-folder)
1904   (concat
1905    (if (vm-new-flag m)
1906        " recent, unseen,"
1907      (if (vm-unread-flag m)
1908          " unseen,"))
1909    (if (and (not for-other-folder) (vm-deleted-flag m))
1910        " deleted,")
1911    (if (vm-replied-flag m)
1912        " answered,")
1913    (if (vm-forwarded-flag m)
1914        " forwarded,")
1915    (if (vm-redistributed-flag m)
1916        " redistributed,")
1917    (if (vm-filed-flag m)
1918        " filed,")
1919    (if (vm-edited-flag m)
1920        " edited,")
1921    (if (vm-written-flag m)
1922        " written,")))
1923
1924 (defun vm-babyl-labels-string (m)
1925   (let ((list nil)
1926         (labels (vm-labels-of m)))
1927     (while labels
1928       (setq list (cons "," (cons (car labels) (cons " " list)))
1929             labels (cdr labels)))
1930     (apply 'concat (nreverse list))))
1931
1932 (defun vm-stuff-virtual-attributes (message)
1933   (let ((virtual (vm-virtual-message-p message)))
1934     (if (or (not virtual) (and virtual (vm-virtual-messages-of message)))
1935         (save-excursion
1936           (set-buffer
1937            (vm-buffer-of
1938             (vm-real-message-of message)))
1939           (vm-stuff-attributes (vm-real-message-of message))))))
1940
1941 (defun vm-stuff-labels ()
1942   (if vm-message-list
1943       (save-excursion
1944         (vm-save-restriction
1945          (widen)
1946          (let ((old-buffer-modified-p (buffer-modified-p))
1947                (case-fold-search t)
1948                ;; don't truncate the printing of large Lisp objects
1949                (print-length nil)
1950                ;; This prevents file locking from occuring.  Disabling
1951                ;; locking can speed things noticeably if the lock
1952                ;; directory is on a slow device.  We don't need locking
1953                ;; here because the user shouldn't care about VM stuffing
1954                ;; its own status headers.
1955                (buffer-file-name nil)
1956                (buffer-read-only nil)
1957                lim)
1958            (if (eq vm-folder-type 'babyl)
1959                (progn
1960                  (goto-char (point-min))
1961                  (vm-skip-past-folder-header)
1962                  (delete-region (point) (point-min))
1963                  (insert-before-markers (vm-folder-header vm-folder-type
1964                                                           vm-label-obarray))))
1965            (goto-char (point-min))
1966            (vm-skip-past-folder-header)
1967            (vm-find-leading-message-separator)
1968            (vm-skip-past-leading-message-separator)
1969            (search-forward "\n\n" nil t)
1970            (setq lim (point))
1971            (goto-char (point-min))
1972            (vm-skip-past-folder-header)
1973            (vm-find-leading-message-separator)
1974            (vm-skip-past-leading-message-separator)
1975            (while (re-search-forward vm-labels-header-regexp lim t)
1976              (progn (goto-char (match-beginning 0))
1977                     (if (vm-match-header vm-labels-header)
1978                         (delete-region (vm-matched-header-start)
1979                                        (vm-matched-header-end)))))
1980            ;; To insert or to insert-before-markers, that is the question.
1981            ;;
1982            ;; If we insert-before-markers we push a header behind
1983            ;; vm-headers-of, which is clearly undesirable.  So we
1984            ;; just insert.  This will cause the summary header
1985            ;; to be visible if there are no non-visible headers,
1986            ;; oh well, no way around this.
1987            (insert vm-labels-header " "
1988                    (let ((print-escape-newlines t)
1989                          (list nil))
1990                      (mapatoms (function
1991                                 (lambda (sym)
1992                                   (setq list (cons (symbol-name sym) list))))
1993                                vm-label-obarray)
1994                      (prin1-to-string list))
1995                    "\n")
1996            (set-buffer-modified-p old-buffer-modified-p))))))
1997
1998 ;; Insert a bookmark into the first message in the folder.
1999 (defun vm-stuff-bookmark ()
2000   (if vm-message-list
2001       (save-excursion
2002         (vm-save-restriction
2003          (widen)
2004          (let ((old-buffer-modified-p (buffer-modified-p))
2005                (case-fold-search t)
2006                ;; This prevents file locking from occuring.  Disabling
2007                ;; locking can speed things noticeably if the lock
2008                ;; directory is on a slow device.  We don't need locking
2009                ;; here because the user shouldn't care about VM stuffing
2010                ;; its own status headers.
2011                (buffer-file-name nil)
2012                (buffer-read-only nil)
2013                lim)
2014            (goto-char (point-min))
2015            (vm-skip-past-folder-header)
2016            (vm-find-leading-message-separator)
2017            (vm-skip-past-leading-message-separator)
2018            (search-forward "\n\n" nil t)
2019            (setq lim (point))
2020            (goto-char (point-min))
2021            (vm-skip-past-folder-header)
2022            (vm-find-leading-message-separator)
2023            (vm-skip-past-leading-message-separator)
2024            (if (re-search-forward vm-bookmark-header-regexp lim t)
2025                (progn (goto-char (match-beginning 0))
2026                       (if (vm-match-header vm-bookmark-header)
2027                           (delete-region (vm-matched-header-start)
2028                                          (vm-matched-header-end)))))
2029            ;; To insert or to insert-before-markers, that is the question.
2030            ;;
2031            ;; If we insert-before-markers we push a header behind
2032            ;; vm-headers-of, which is clearly undesirable.  So we
2033            ;; just insert.  This will cause the bookmark header
2034            ;; to be visible if there are no non-visible headers,
2035            ;; oh well, no way around this.
2036            (insert vm-bookmark-header " "
2037                    (vm-number-of (car vm-message-pointer))
2038                    "\n")
2039            (set-buffer-modified-p old-buffer-modified-p))))))
2040
2041 (defun vm-stuff-last-modified ()
2042   (if vm-message-list
2043       (save-excursion
2044         (vm-save-restriction
2045          (widen)
2046          (let ((old-buffer-modified-p (buffer-modified-p))
2047                (case-fold-search t)
2048                ;; This prevents file locking from occuring.  Disabling
2049                ;; locking can speed things noticeably if the lock
2050                ;; directory is on a slow device.  We don't need locking
2051                ;; here because the user shouldn't care about VM stuffing
2052                ;; its own status headers.
2053                (buffer-file-name nil)
2054                (buffer-read-only nil)
2055                lim)
2056            (goto-char (point-min))
2057            (vm-skip-past-folder-header)
2058            (vm-find-leading-message-separator)
2059            (vm-skip-past-leading-message-separator)
2060            (search-forward "\n\n" nil t)
2061            (setq lim (point))
2062            (goto-char (point-min))
2063            (vm-skip-past-folder-header)
2064            (vm-find-leading-message-separator)
2065            (vm-skip-past-leading-message-separator)
2066            (if (re-search-forward vm-last-modified-header-regexp lim t)
2067                (progn (goto-char (match-beginning 0))
2068                       (if (vm-match-header vm-last-modified-header)
2069                           (delete-region (vm-matched-header-start)
2070                                          (vm-matched-header-end)))))
2071            ;; To insert or to insert-before-markers, that is the question.
2072            ;;
2073            ;; If we insert-before-markers we push a header behind
2074            ;; vm-headers-of, which is clearly undesirable.  So we
2075            ;; just insert.  This will cause the last-modified header
2076            ;; to be visible if there are no non-visible headers,
2077            ;; oh well, no way around this.
2078            (insert vm-last-modified-header " "
2079                    (prin1-to-string (current-time))
2080                    "\n")
2081            (set-buffer-modified-p old-buffer-modified-p))))))
2082
2083 (defun vm-stuff-pop-retrieved ()
2084   (if vm-message-list
2085       (save-excursion
2086         (vm-save-restriction
2087          (widen)
2088          (let ((old-buffer-modified-p (buffer-modified-p))
2089                (case-fold-search t)
2090                ;; This prevents file locking from occuring.  Disabling
2091                ;; locking can speed things noticeably if the lock
2092                ;; directory is on a slow device.  We don't need locking
2093                ;; here because the user shouldn't care about VM stuffing
2094                ;; its own status headers.
2095                (buffer-file-name nil)
2096                (buffer-read-only nil)
2097                (print-length nil)
2098                (p vm-pop-retrieved-messages)
2099                (curbuf (current-buffer))
2100                lim)
2101            (goto-char (point-min))
2102            (vm-skip-past-folder-header)
2103            (vm-find-leading-message-separator)
2104            (vm-skip-past-leading-message-separator)
2105            (search-forward "\n\n" nil t)
2106            (setq lim (point))
2107            (goto-char (point-min))
2108            (vm-skip-past-folder-header)
2109            (vm-find-leading-message-separator)
2110            (vm-skip-past-leading-message-separator)
2111            (if (re-search-forward vm-pop-retrieved-header-regexp lim t)
2112                (progn (goto-char (match-beginning 0))
2113                       (if (vm-match-header vm-pop-retrieved-header)
2114                           (delete-region (vm-matched-header-start)
2115                                          (vm-matched-header-end)))))
2116            ;; To insert or to insert-before-markers, that is the question.
2117            ;;
2118            ;; If we insert-before-markers we push a header behind
2119            ;; vm-headers-of, which is clearly undesirable.  So we
2120            ;; just insert.  This will cause the pop-retrieved header
2121            ;; to be visible if there are no non-visible headers,
2122            ;; oh well, no way around this.
2123            (insert vm-pop-retrieved-header)
2124            (if (null p)
2125                (insert " nil\n")
2126              (insert "\n   (\n")
2127              (while p
2128                (insert "\t")
2129                (prin1 (car p) curbuf)
2130                (insert "\n")
2131                (setq p (cdr p)))
2132              (insert "   )\n"))
2133            (set-buffer-modified-p old-buffer-modified-p))))))
2134
2135 (defun vm-stuff-imap-retrieved ()
2136   (if vm-message-list
2137       (save-excursion
2138         (vm-save-restriction
2139          (widen)
2140          (let ((old-buffer-modified-p (buffer-modified-p))
2141                (case-fold-search t)
2142                ;; This prevents file locking from occuring.  Disabling
2143                ;; locking can speed things noticeably if the lock
2144                ;; directory is on a slow device.  We don't need locking
2145                ;; here because the user shouldn't care about VM stuffing
2146                ;; its own status headers.
2147                (buffer-file-name nil)
2148                (buffer-read-only nil)
2149                (print-length nil)
2150                (p vm-imap-retrieved-messages)
2151                (curbuf (current-buffer))
2152                lim)
2153            (goto-char (point-min))
2154            (vm-skip-past-folder-header)
2155            (vm-find-leading-message-separator)
2156            (vm-skip-past-leading-message-separator)
2157            (search-forward "\n\n" nil t)
2158            (setq lim (point))
2159            (goto-char (point-min))
2160            (vm-skip-past-folder-header)
2161            (vm-find-leading-message-separator)
2162            (vm-skip-past-leading-message-separator)
2163            (if (re-search-forward vm-imap-retrieved-header-regexp lim t)
2164                (progn (goto-char (match-beginning 0))
2165                       (if (vm-match-header vm-imap-retrieved-header)
2166                           (delete-region (vm-matched-header-start)
2167                                          (vm-matched-header-end)))))
2168            ;; To insert or to insert-before-markers, that is the question.
2169            ;;
2170            ;; If we insert-before-markers we push a header behind
2171            ;; vm-headers-of, which is clearly undesirable.  So we
2172            ;; just insert.  This will cause the imap-retrieved header
2173            ;; to be visible if there are no non-visible headers,
2174            ;; oh well, no way around this.
2175            (insert vm-imap-retrieved-header)
2176            (if (null p)
2177                (insert " nil\n")
2178              (insert "\n   (\n")
2179              (while p
2180                (insert "\t")
2181                (prin1 (car p) curbuf)
2182                (insert "\n")
2183                (setq p (cdr p)))
2184              (insert "   )\n"))
2185            (set-buffer-modified-p old-buffer-modified-p))))))
2186
2187 ;; Insert the summary format variable header into the first message.
2188 (defun vm-stuff-summary ()
2189   (if vm-message-list
2190       (save-excursion
2191         (vm-save-restriction
2192          (widen)
2193          (let ((old-buffer-modified-p (buffer-modified-p))
2194                (case-fold-search t)
2195                ;; don't truncate the printing of large Lisp objects
2196                (print-length nil)
2197                ;; This prevents file locking from occuring.  Disabling
2198                ;; locking can speed things noticeably if the lock
2199                ;; directory is on a slow device.  We don't need locking
2200                ;; here because the user shouldn't care about VM stuffing
2201                ;; its own status headers.
2202                (buffer-file-name nil)
2203                (buffer-read-only nil)
2204                lim)
2205            (goto-char (point-min))
2206            (vm-skip-past-folder-header)
2207            (vm-find-leading-message-separator)
2208            (vm-skip-past-leading-message-separator)
2209            (search-forward "\n\n" nil t)
2210            (setq lim (point))
2211            (goto-char (point-min))
2212            (vm-skip-past-folder-header)
2213            (vm-find-leading-message-separator)
2214            (vm-skip-past-leading-message-separator)
2215            (while (re-search-forward vm-summary-header-regexp lim t)
2216              (progn (goto-char (match-beginning 0))
2217                     (if (vm-match-header vm-summary-header)
2218                         (delete-region (vm-matched-header-start)
2219                                        (vm-matched-header-end)))))
2220            ;; To insert or to insert-before-markers, that is the question.
2221            ;;
2222            ;; If we insert-before-markers we push a header behind
2223            ;; vm-headers-of, which is clearly undesirable.  So we
2224            ;; just insert.  This will cause the summary header
2225            ;; to be visible if there are no non-visible headers,
2226            ;; oh well, no way around this.
2227            (insert vm-summary-header " "
2228                    (let ((print-escape-newlines t))
2229                      (prin1-to-string vm-summary-format))
2230                    "\n")
2231            (set-buffer-modified-p old-buffer-modified-p))))))
2232
2233 ;; stuff the current values of the header variables for future messages.
2234 (defun vm-stuff-header-variables ()
2235   (if vm-message-list
2236       (save-excursion
2237         (vm-save-restriction
2238          (widen)
2239          (let ((old-buffer-modified-p (buffer-modified-p))
2240                (case-fold-search t)
2241                (print-escape-newlines t)
2242                lim
2243                ;; don't truncate the printing of large Lisp objects
2244                (print-length nil)
2245                (buffer-read-only nil)
2246                ;; This prevents file locking from occuring.  Disabling
2247                ;; locking can speed things noticeably if the lock
2248                ;; directory is on a slow device.  We don't need locking
2249                ;; here because the user shouldn't care about VM stuffing
2250                ;; its own status headers.
2251                (buffer-file-name nil))
2252            (goto-char (point-min))
2253            (vm-skip-past-folder-header)
2254            (vm-find-leading-message-separator)
2255            (vm-skip-past-leading-message-separator)
2256            (search-forward "\n\n" nil t)
2257            (setq lim (point))
2258            (goto-char (point-min))
2259            (vm-skip-past-folder-header)
2260            (vm-find-leading-message-separator)
2261            (vm-skip-past-leading-message-separator)
2262            (while (re-search-forward vm-vheader-header-regexp lim t)
2263              (progn (goto-char (match-beginning 0))
2264                     (if (vm-match-header vm-vheader-header)
2265                         (delete-region (vm-matched-header-start)
2266                                        (vm-matched-header-end)))))
2267            ;; To insert or to insert-before-markers, that is the question.
2268            ;;
2269            ;; If we insert-before-markers we push a header behind
2270            ;; vm-headers-of, which is clearly undesirable.  So we
2271            ;; just insert.  This header will be visible if there
2272            ;; are no non-visible headers, oh well, no way around this.
2273            (insert vm-vheader-header " "
2274                    (prin1-to-string vm-visible-headers) " "
2275                    (prin1-to-string vm-invisible-header-regexp)
2276                    "\n")
2277            (set-buffer-modified-p old-buffer-modified-p))))))
2278
2279 ;; Insert a header into the first message of the folder that lists
2280 ;; the folder's message order.
2281 (defun vm-stuff-message-order ()
2282   (if (cdr vm-message-list)
2283       (save-excursion
2284         (vm-save-restriction
2285          (widen)
2286          (let ((old-buffer-modified-p (buffer-modified-p))
2287                (case-fold-search t)
2288                ;; This prevents file locking from occuring.  Disabling
2289                ;; locking can speed things noticeably if the lock
2290                ;; directory is on a slow device.  We don't need locking
2291                ;; here because the user shouldn't care about VM stuffing
2292                ;; its own status headers.
2293                (buffer-file-name nil)
2294                lim n
2295                (buffer-read-only nil)
2296                (mp (copy-sequence vm-message-list)))
2297            (setq mp
2298                  (sort mp
2299                        (function
2300                         (lambda (p q)
2301                           (< (vm-start-of p) (vm-start-of q))))))
2302            (goto-char (point-min))
2303            (vm-skip-past-folder-header)
2304            (vm-find-leading-message-separator)
2305            (vm-skip-past-leading-message-separator)
2306            (search-forward "\n\n" nil t)
2307            (setq lim (point))
2308            (goto-char (point-min))
2309            (vm-skip-past-folder-header)
2310            (vm-find-leading-message-separator)
2311            (vm-skip-past-leading-message-separator)
2312            (while (re-search-forward vm-message-order-header-regexp lim t)
2313              (progn (goto-char (match-beginning 0))
2314                     (if (vm-match-header vm-message-order-header)
2315                         (delete-region (vm-matched-header-start)
2316                                        (vm-matched-header-end)))))
2317            ;; To insert or to insert-before-markers, that is the question.
2318            ;;
2319            ;; If we insert-before-markers we push a header behind
2320            ;; vm-headers-of, which is clearly undesirable.  So we
2321            ;; just insert.  This header will be visible if there
2322            ;; are no non-visible headers, oh well, no way around this.
2323            (insert vm-message-order-header "\n\t(")
2324            (setq n 0)
2325            (while mp
2326              (insert (vm-number-of (car mp)))
2327              (setq n (1+ n) mp (cdr mp))
2328              (and mp (insert
2329                       (if (zerop (% n 15))
2330                           "\n\t "
2331                         " "))))
2332            (insert ")\n")
2333            (setq vm-message-order-changed nil
2334                  vm-message-order-header-present t)
2335            (set-buffer-modified-p old-buffer-modified-p))))))
2336
2337 ;; Remove the message order header.
2338 (defun vm-remove-message-order ()
2339   (if (cdr vm-message-list)
2340       (save-excursion
2341         (vm-save-restriction
2342          (widen)
2343          (let ((old-buffer-modified-p (buffer-modified-p))
2344                (case-fold-search t)
2345                lim
2346                ;; This prevents file locking from occuring.  Disabling
2347                ;; locking can speed things noticeably if the lock
2348                ;; directory is on a slow device.  We don't need locking
2349                ;; here because the user shouldn't care about VM stuffing
2350                ;; its own status headers.
2351                (buffer-file-name nil)
2352                (buffer-read-only nil))
2353            (goto-char (point-min))
2354            (vm-skip-past-folder-header)
2355            (vm-skip-past-leading-message-separator)
2356            (search-forward "\n\n" nil t)
2357            (setq lim (point))
2358            (goto-char (point-min))
2359            (vm-skip-past-folder-header)
2360            (vm-skip-past-leading-message-separator)
2361            (while (re-search-forward vm-message-order-header-regexp lim t)
2362              (progn (goto-char (match-beginning 0))
2363                     (if (vm-match-header vm-message-order-header)
2364                         (delete-region (vm-matched-header-start)
2365                                        (vm-matched-header-end)))))
2366            (setq vm-message-order-header-present nil)
2367            (set-buffer-modified-p old-buffer-modified-p))))))
2368
2369 (defun vm-make-index-file-name ()
2370   (concat (file-name-directory buffer-file-name)
2371           "."
2372           (file-name-nondirectory buffer-file-name)
2373           vm-index-file-suffix))
2374
2375 (defun vm-read-index-file-maybe ()
2376   (catch 'done
2377     (if (or (not (stringp buffer-file-name))
2378             (not (stringp vm-index-file-suffix)))
2379         (throw 'done nil))
2380     (let ((index-file (vm-make-index-file-name)))
2381       (if (file-readable-p index-file)
2382           (vm-read-index-file index-file)
2383         nil ))))
2384
2385 (defun vm-read-index-file (index-file)
2386   (catch 'done
2387     (condition-case error-data
2388         (let ((work-buffer nil))
2389           (unwind-protect
2390               (let (obj attr-list cache-list location-list label-list
2391                     validity-check vis invis folder-type
2392                     bookmark summary labels pop-retrieved imap-retrieved order
2393                     v m (m-list nil) tail)
2394                 (message "Reading index file...")
2395                 (setq work-buffer (vm-make-work-buffer))
2396                 (save-excursion
2397                   (set-buffer work-buffer)
2398                   (insert-file-contents-literally index-file))
2399                 (goto-char (point-min))
2400
2401                 ;; check version
2402                 (setq obj (read work-buffer))
2403                 (if (not (eq obj 1))
2404                     (error "Unsupported index file version: %s") obj)
2405
2406                 ;; folder type
2407                 (setq folder-type (read work-buffer))
2408
2409                 ;; validity check
2410                 (setq validity-check (read work-buffer))
2411                 (if (null (vm-check-index-file-validity validity-check))
2412                     (throw 'done nil))
2413
2414                 ;; bookmark
2415                 (setq bookmark (read work-buffer))
2416
2417                 ;; message order
2418                 (setq order (read work-buffer))
2419
2420                 ;; what summary format was used to produce the
2421                 ;; folder's summary cache line.
2422                 (setq summary (read work-buffer))
2423
2424                 ;; folder-wide list of labels
2425                 (setq labels (read work-buffer))
2426
2427                 ;; what vm-visible-headers / vm-invisible-header-regexp
2428                 ;; settings were used to order the headers and to
2429                 ;; produce the vm-headers-regexp-of slot value.
2430                 (setq vis (read work-buffer))
2431                 (setq invis (read work-buffer))
2432
2433                 ;; location offsets
2434                 ;; attributes list
2435                 ;; cache list
2436                 ;; label list
2437                 (setq location-list (read work-buffer))
2438                 (setq attr-list (read work-buffer))
2439                 (setq cache-list (read work-buffer))
2440                 (setq label-list (read work-buffer))
2441                 (while location-list
2442                   (setq v (car location-list)
2443                         m (vm-make-message))
2444                   (if (null m-list)
2445                       (setq m-list (list m)
2446                             tail m-list)
2447                     (setcdr tail (list m))
2448                     (setq tail (cdr tail)))
2449                   (vm-set-start-of m (vm-marker (aref v 0)))
2450                   (vm-set-headers-of m (vm-marker (aref v 1)))
2451                   (vm-set-text-end-of m (vm-marker (aref v 2)))
2452                   (vm-set-end-of m (vm-marker (aref v 3)))
2453                   (if (null attr-list)
2454                       (error "Attribute list is shorter than location list")
2455                     (setq v (car attr-list))
2456                     (if (< (length v) vm-attributes-vector-length)
2457                         (setq v (vm-extend-vector
2458                                  v vm-attributes-vector-length)))
2459                     (vm-set-attributes-of m v))
2460                   (if (null cache-list)
2461                       (error "Cache list is shorter than location list")
2462                     (setq v (car cache-list))
2463                     (if (< (length v) vm-cache-vector-length)
2464                         (setq v (vm-extend-vector v vm-cache-vector-length)))
2465                     (vm-set-cache-of m v))
2466                   (if (null label-list)
2467                       (error "Label list is shorter than location list")
2468                     (vm-set-labels-of m (car label-list)))
2469                   (setq location-list (cdr location-list)
2470                         attr-list (cdr attr-list)
2471                         cache-list (cdr cache-list)
2472                         label-list (cdr label-list)))
2473
2474                 ;; pop retrieved messages
2475                 (setq pop-retrieved (read work-buffer))
2476
2477                 ;; imap retrieved messages
2478                 (setq imap-retrieved (read work-buffer))
2479
2480                 (setq vm-message-list m-list
2481                       vm-folder-type folder-type
2482                       vm-pop-retrieved-messages pop-retrieved
2483                       vm-imap-retrieved-messages imap-retrieved)
2484
2485                 (vm-startup-apply-bookmark bookmark)
2486                 (and order (vm-startup-apply-message-order order))
2487                 (if vm-summary-show-threads
2488                     (progn
2489                       ;; get numbering of new messages done now
2490                       ;; so that the sort code only has to worry about the
2491                       ;; changes it needs to make.
2492                       (vm-update-summary-and-mode-line)
2493                       (vm-sort-messages "thread")))
2494                 (vm-startup-apply-summary summary)
2495                 (vm-startup-apply-labels labels)
2496                 (vm-startup-apply-header-variables vis invis)
2497
2498                 (message "Reading index file... done")
2499                 t )
2500             (and work-buffer (kill-buffer work-buffer))))
2501       (error (message "Index file read of %s signaled: %s"
2502                       index-file error-data)
2503              (sleep-for 2)
2504              (message "Ignoring index file...")
2505              (sleep-for 2)))))
2506
2507 (defun vm-check-index-file-validity (blob)
2508   (save-excursion
2509     (widen)
2510     (catch 'done
2511       (cond ((not (consp blob))
2512              (error "Validity check object not a cons: %s"))
2513             ((eq (car blob) 'file)
2514              (let (ch time time2)
2515                (setq blob (cdr blob))
2516                (setq time (car blob)
2517                      time2 (vm-gobble-last-modified))
2518                (if (and time2 (> 0 (vm-time-difference time time2)))
2519                    (throw 'done nil))
2520                (setq blob (cdr blob))
2521                (while blob
2522                  (setq ch (char-after (car blob)))
2523                  (if (or (null ch) (not (eq (vm-char-to-int ch) (nth 1 blob))))
2524                      (throw 'done nil))
2525                  (setq blob (cdr (cdr blob)))))
2526              t )
2527             (t (error "Unknown validity check type: %s" (car blob)))))))
2528
2529 (defun vm-generate-index-file-validity-check ()
2530   (save-restriction
2531     (widen)
2532     (let ((step (max 1 (/ (point-max) 11)))
2533           (pos (1- (point-max)))
2534           (lim (point-min))
2535           (blob nil))
2536       (while (>= pos lim)
2537         (setq blob (cons pos (cons (vm-char-to-int (char-after pos)) blob))
2538               pos (- pos step)))
2539       (cons 'file (cons (current-time) blob)))))
2540
2541 (defun vm-write-index-file-maybe ()
2542   (catch 'done
2543     (if (not (stringp buffer-file-name))
2544         (throw 'done nil))
2545     (if (not (stringp vm-index-file-suffix))
2546         (throw 'done nil))
2547     (let ((index-file (vm-make-index-file-name)))
2548       (vm-write-index-file index-file))))
2549
2550 (defun vm-write-index-file (index-file)
2551   (let ((work-buffer nil))
2552     (unwind-protect
2553         (let ((print-escape-newlines t)
2554               (print-length nil)
2555               m-list mp m)
2556           (message "Sorting for index file...")
2557           (setq m-list (sort (copy-sequence vm-message-list)
2558                              (function vm-sort-compare-physical-order)))
2559           (message "Stuffing index file...")
2560           (setq work-buffer (vm-make-work-buffer))
2561
2562           (princ ";; index file version\n" work-buffer)
2563           (prin1 1 work-buffer)
2564           (terpri work-buffer)
2565
2566           (princ ";; folder type\n" work-buffer)
2567           (prin1 vm-folder-type work-buffer)
2568           (terpri work-buffer)
2569
2570           (princ
2571            ";; timestamp + sample of folder bytes for consistency check\n"
2572            work-buffer)
2573           (prin1 (vm-generate-index-file-validity-check) work-buffer)
2574           (terpri work-buffer)
2575
2576           (princ ";; bookmark\n" work-buffer)
2577           (princ (if vm-message-pointer
2578                      (vm-number-of (car vm-message-pointer))
2579                    "1")
2580                  work-buffer)
2581           (terpri work-buffer)
2582
2583           (princ ";; message order\n" work-buffer)
2584           (let ((n 0) (mp vm-message-list))
2585            (princ "(" work-buffer)
2586            (setq n 0)
2587            (while mp
2588              (if (zerop (% n 15))
2589                  (princ "\n\t" work-buffer)
2590                (princ " " work-buffer))
2591              (princ (vm-number-of (car mp)) work-buffer)
2592              (setq n (1+ n) mp (cdr mp)))
2593            (princ "\n)\n" work-buffer))
2594
2595           (princ ";; summary\n" work-buffer)
2596           (prin1 vm-summary-format work-buffer)
2597           (terpri work-buffer)
2598
2599           (princ ";; labels used in this folder\n" work-buffer)
2600           (let ((list nil))
2601             (mapatoms (function
2602                        (lambda (sym)
2603                          (setq list (cons (symbol-name sym) list))))
2604                       vm-label-obarray)
2605             (prin1 list work-buffer))
2606           (terpri work-buffer)
2607
2608           (princ ";; visible headers\n" work-buffer)
2609           (prin1 vm-visible-headers work-buffer)
2610           (terpri work-buffer)
2611
2612           (princ ";; hidden headers\n" work-buffer)
2613           (prin1 vm-invisible-header-regexp work-buffer)
2614           (terpri work-buffer)
2615
2616           (princ ";; location list\n" work-buffer)
2617           (princ "(\n" work-buffer)
2618           (setq mp m-list)
2619           (while mp
2620             (setq m (car mp))
2621             (princ "  [" work-buffer)
2622             (prin1 (marker-position (vm-start-of m)) work-buffer)
2623             (princ " " work-buffer)
2624             (prin1 (marker-position (vm-headers-of m)) work-buffer)
2625             (princ " " work-buffer)
2626             (prin1 (marker-position (vm-text-end-of m)) work-buffer)
2627             (princ " " work-buffer)
2628             (prin1 (marker-position (vm-end-of m)) work-buffer)
2629             (princ "]\n" work-buffer)
2630             (setq mp (cdr mp)))
2631           (princ ")\n" work-buffer)
2632           (princ ";; attribute list\n" work-buffer)
2633           (princ "(\n" work-buffer)
2634           (setq mp m-list)
2635           (while mp
2636             (setq m (car mp))
2637             (princ "  " work-buffer)
2638             (prin1 (vm-attributes-of m) work-buffer)
2639             (princ "\n" work-buffer)
2640             (setq mp (cdr mp)))
2641           (princ ")\n" work-buffer)
2642           (princ ";; cache list\n" work-buffer)
2643           (princ "(\n" work-buffer)
2644           (setq mp m-list)
2645           (while mp
2646             (setq m (car mp))
2647             (princ "  " work-buffer)
2648             (prin1 (vm-cache-of m) work-buffer)
2649             (princ "\n" work-buffer)
2650             (setq mp (cdr mp)))
2651           (princ ")\n" work-buffer)
2652           (princ ";; labels list\n" work-buffer)
2653           (princ "(\n" work-buffer)
2654           (setq mp m-list)
2655           (while mp
2656             (setq m (car mp))
2657             (princ "  " work-buffer)
2658             (prin1 (vm-labels-of m) work-buffer)
2659             (princ "\n" work-buffer)
2660             (setq mp (cdr mp)))
2661           (princ ")\n" work-buffer)
2662           (princ ";; retrieved POP messages\n" work-buffer)
2663           (let ((p vm-pop-retrieved-messages))
2664             (if (null p)
2665                 (princ "nil\n" work-buffer)
2666               (princ "(\n" work-buffer)
2667               (while p
2668                 (princ "\t" work-buffer)
2669                 (prin1 (car p) work-buffer)
2670                 (princ "\n" work-buffer)
2671                 (setq p (cdr p)))
2672               (princ ")\n" work-buffer)))
2673           (princ ";; retrieved IMAP messages\n" work-buffer)
2674           (let ((p vm-imap-retrieved-messages))
2675             (if (null p)
2676                 (princ "nil\n" work-buffer)
2677               (princ "(\n" work-buffer)
2678               (while p
2679                 (princ "\t" work-buffer)
2680                 (prin1 (car p) work-buffer)
2681                 (princ "\n" work-buffer)
2682                 (setq p (cdr p)))
2683               (princ ")\n" work-buffer)))
2684
2685           (princ ";; end of index file\n" work-buffer)
2686
2687           (message "Writing index file...")
2688           (catch 'done
2689             (save-excursion
2690               (set-buffer work-buffer)
2691               (condition-case data
2692                   (let ((coding-system-for-write (vm-binary-coding-system))
2693                         (selective-display nil))
2694                     (write-region (point-min) (point-max) index-file))
2695                 (error
2696                  (message "Write of %s signaled: %s" index-file data)
2697                  (sleep-for 2)
2698                  (throw 'done nil))))
2699             (vm-error-free-call 'set-file-modes index-file (vm-octal 600))
2700             (message "Writing index file... done")
2701             t ))
2702       (and work-buffer (kill-buffer work-buffer)))))
2703
2704 (defun vm-delete-index-file ()
2705   (if (stringp vm-index-file-suffix)
2706       (let ((index-file (vm-make-index-file-name)))
2707         (vm-error-free-call 'delete-file index-file))))
2708
2709 (defun vm-change-all-new-to-unread ()
2710   (let ((mp vm-message-list))
2711     (while mp
2712       (if (vm-new-flag (car mp))
2713           (progn
2714             (vm-set-new-flag (car mp) nil)
2715             (vm-set-unread-flag (car mp) t)))
2716       (setq mp (cdr mp)))))
2717
2718 ;;;###autoload
2719 (defun vm-unread-message (&optional count)
2720   "Set the `unread' attribute for the current message.  If the message is
2721 already new or unread, then it is left unchanged.
2722
2723 Numeric prefix argument N means to unread the current message plus the
2724 next N-1 messages.  A negative N means unread the current message and
2725 the previous N-1 messages.
2726
2727 When invoked on marked messages (via vm-next-command-uses-marks),
2728 all marked messages are affected, other messages are ignored."
2729   (interactive "p")
2730   (or count (setq count 1))
2731   (vm-follow-summary-cursor)
2732   (vm-select-folder-buffer)
2733   (vm-check-for-killed-summary)
2734   (vm-error-if-folder-empty)
2735   (let ((mlist (vm-select-marked-or-prefixed-messages count)))
2736     (while mlist
2737       (if (and (not (vm-unread-flag (car mlist)))
2738                (not (vm-new-flag (car mlist))))
2739           (vm-set-unread-flag (car mlist) t))
2740       (setq mlist (cdr mlist))))
2741   (vm-display nil nil '(vm-unread-message) '(vm-unread-message))
2742   (vm-update-summary-and-mode-line))
2743
2744 ;;;###autoload
2745 (defun vm-quit-just-bury ()
2746   "Bury the current VM folder and summary buffers.
2747 The folder is not altered and Emacs is still visiting it.  You
2748 can switch back to it with switch-to-buffer or by using the
2749 Buffer Menu."
2750   (interactive)
2751   (vm-select-folder-buffer)
2752   (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
2753       (error "%s must be invoked from a VM buffer." this-command))
2754   (vm-check-for-killed-summary)
2755   (vm-check-for-killed-presentation)
2756
2757   (save-excursion (run-hooks 'vm-quit-hook))
2758
2759   (vm-garbage-collect-message)
2760
2761   (vm-display nil nil '(vm-quit-just-bury)
2762               '(vm-quit-just-bury quitting))
2763   (if vm-summary-buffer
2764       (vm-display vm-summary-buffer nil nil nil))
2765   (if vm-summary-buffer
2766       (vm-bury-buffer vm-summary-buffer))
2767   (if vm-presentation-buffer-handle
2768       (vm-display vm-presentation-buffer-handle nil nil nil))
2769   (if vm-presentation-buffer-handle
2770       (vm-bury-buffer vm-presentation-buffer-handle))
2771   (vm-display (current-buffer) nil nil nil)
2772   (vm-bury-buffer (current-buffer)))
2773
2774 ;;;###autoload
2775 (defun vm-quit-just-iconify ()
2776   "Iconify the frame and bury the current VM folder and summary buffers.
2777 The folder is not altered and Emacs is still visiting it."
2778   (interactive)
2779   (vm-select-folder-buffer)
2780   (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
2781       (error "%s must be invoked from a VM buffer." this-command))
2782   (vm-check-for-killed-summary)
2783   (vm-check-for-killed-presentation)
2784
2785   (save-excursion (run-hooks 'vm-quit-hook))
2786
2787   (vm-garbage-collect-message)
2788
2789   (vm-display nil nil '(vm-quit-just-iconify)
2790               '(vm-quit-just-iconify quitting))
2791   (let ((summary-buffer vm-summary-buffer)
2792         (pres-buffer vm-presentation-buffer-handle))
2793     (vm-bury-buffer (current-buffer))
2794     (if summary-buffer
2795         (vm-bury-buffer summary-buffer))
2796     (if pres-buffer
2797         (vm-bury-buffer pres-buffer))
2798     (vm-iconify-frame)))
2799
2800 ;;;###autoload
2801 (defun vm-quit-no-change ()
2802   "Quit visiting the current folder without saving changes made to the folder."
2803   (interactive)
2804   (vm-quit t))
2805
2806 ;;;###autoload
2807 (defun vm-quit (&optional no-change)
2808   "Quit visiting the current folder, saving changes.  Deleted messages are not expunged."
2809   (interactive)
2810   (vm-select-folder-buffer)
2811   (if (not (memq major-mode '(vm-mode vm-virtual-mode)))
2812       (error "%s must be invoked from a VM buffer." this-command))
2813   (vm-check-for-killed-summary)
2814   (vm-check-for-killed-presentation)
2815   (vm-display nil nil '(vm-quit vm-quit-no-change)
2816               (list this-command 'quitting))
2817   (let ((virtual (eq major-mode 'vm-virtual-mode)))
2818     (cond
2819      ((and (not virtual) no-change (buffer-modified-p)
2820            (or buffer-file-name buffer-offer-save)
2821            (not (zerop vm-messages-not-on-disk))
2822            ;; Folder may have been saved with C-x C-s and attributes may have
2823            ;; been changed after that; in that case vm-messages-not-on-disk
2824            ;; would not have been zeroed.  However, all modification flag
2825            ;; undos are cleared if VM actually modifies the folder buffer
2826            ;; (as opposed to the folder's attributes), so this can be used
2827            ;; to verify that there are indeed unsaved messages.
2828            (null (assq 'vm-set-buffer-modified-p vm-undo-record-list))
2829            (not
2830             (y-or-n-p
2831              (format
2832               "%d message%s have not been saved to disk, quit anyway? "
2833               vm-messages-not-on-disk
2834               (if (= 1 vm-messages-not-on-disk) "" "s")))))
2835       (error "Aborted"))
2836      ((and (not virtual)
2837            no-change
2838            (or buffer-file-name buffer-offer-save)
2839            (buffer-modified-p)
2840            vm-confirm-quit
2841            (not (y-or-n-p "There are unsaved changes, quit anyway? ")))
2842       (error "Aborted"))
2843      ((and (eq vm-confirm-quit t)
2844            (not (y-or-n-p "Do you really want to quit? ")))
2845       (error "Aborted")))
2846
2847     (save-excursion (run-hooks 'vm-quit-hook))
2848
2849     (vm-garbage-collect-message)
2850     (vm-garbage-collect-folder)
2851
2852     (vm-virtual-quit)
2853     (if (and (not no-change) (not virtual))
2854         (progn
2855           ;; this could take a while, so give the user some feedback
2856           (message "Quitting...")
2857           (or vm-folder-read-only (eq major-mode 'vm-virtual-mode)
2858               (vm-change-all-new-to-unread))))
2859     (if (and (buffer-modified-p)
2860              (or buffer-file-name buffer-offer-save)
2861              (not no-change)
2862              (not virtual))
2863         (vm-save-folder))
2864     (message "")
2865     (let ((summary-buffer vm-summary-buffer)
2866           (pres-buffer vm-presentation-buffer-handle)
2867           (mail-buffer (current-buffer)))
2868       (if summary-buffer
2869           (progn
2870             (vm-display summary-buffer nil nil nil)
2871             (kill-buffer summary-buffer)))
2872       (if pres-buffer
2873           (progn
2874             (vm-display pres-buffer nil nil nil)
2875             (kill-buffer pres-buffer)))
2876       (set-buffer mail-buffer)
2877       (vm-display mail-buffer nil nil nil)
2878       ;; vm-display is not supposed to change the current buffer.
2879       ;; still it's better to be safe here.
2880       (set-buffer mail-buffer)
2881       ;; if folder is selected in the folders summary, force
2882       ;; selcetion of some other folder.
2883       (if buffer-file-name
2884           (vm-mark-for-folders-summary-update buffer-file-name))
2885       (set-buffer-modified-p nil)
2886       (kill-buffer (current-buffer)))
2887     (vm-update-summary-and-mode-line)))
2888
2889 (defun vm-start-itimers-if-needed ()
2890   (cond ((and (not (natnump vm-flush-interval))
2891               (not (natnump vm-auto-get-new-mail))
2892               (not (natnump vm-mail-check-interval))))
2893         ((condition-case data
2894              (progn (require 'itimer) t)
2895            (error nil))
2896          (and (natnump vm-flush-interval) (not (get-itimer "vm-flush"))
2897               (start-itimer "vm-flush" 'vm-flush-itimer-function
2898                             vm-flush-interval nil))
2899          (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail"))
2900               (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function
2901                             vm-auto-get-new-mail nil))
2902          (and (natnump vm-mail-check-interval)
2903               (not (get-itimer "vm-check-mail"))
2904               (start-itimer "vm-check-mail" 'vm-check-mail-itimer-function
2905                             vm-mail-check-interval nil)))
2906         ((condition-case data
2907              (progn (require 'timer) t)
2908            (error nil))
2909          (let (timer)
2910            (and (natnump vm-flush-interval)
2911                 (not (vm-timer-using 'vm-flush-itimer-function))
2912                 (setq timer (run-at-time vm-flush-interval vm-flush-interval
2913                                          'vm-flush-itimer-function nil))
2914                 (timer-set-function timer 'vm-flush-itimer-function
2915                                     (list timer)))
2916            (and (natnump vm-mail-check-interval)
2917                 (not (vm-timer-using 'vm-check-mail-itimer-function))
2918                 (setq timer (run-at-time vm-mail-check-interval
2919                                          vm-mail-check-interval
2920                                          'vm-check-mail-itimer-function nil))
2921                 (timer-set-function timer 'vm-check-mail-itimer-function
2922                                     (list timer)))
2923            (and (natnump vm-auto-get-new-mail)
2924                 (not (vm-timer-using 'vm-get-mail-itimer-function))
2925                 (setq timer (run-at-time vm-auto-get-new-mail
2926                                          vm-auto-get-new-mail
2927                                          'vm-get-mail-itimer-function nil))
2928                 (timer-set-function timer 'vm-get-mail-itimer-function
2929                                     (list timer)))))
2930         (t
2931          (setq vm-flush-interval t
2932                vm-auto-get-new-mail t))))
2933
2934 (defvar timer-list)
2935 (defun vm-timer-using (fun)
2936   (let ((p timer-list)
2937         (done nil))
2938     (while (and p (not done))
2939       (if (eq (aref (car p) 5) fun)
2940           (setq done t)
2941         (setq p (cdr p))))
2942     p ))
2943
2944 ;; support for vm-mail-check-interval
2945 ;; if timer argument is present, this means we're using the Emacs
2946 ;; 'timer package rather than the 'itimer package.
2947 (defun vm-check-mail-itimer-function (&optional timer)
2948   ;; FSF Emacs sets this non-nil, which means the user can't
2949   ;; interrupt the check.  Bogus.
2950   (setq inhibit-quit nil)
2951   (if (integerp vm-mail-check-interval)
2952       (if timer
2953           (timer-set-time timer (timer-relative-time (current-time) vm-mail-check-interval) vm-mail-check-interval)
2954         (set-itimer-restart current-itimer vm-mail-check-interval))
2955     ;; user has changed the variable value to something that
2956     ;; isn't a number, make the timer go away.
2957     (if timer
2958         (cancel-timer timer)
2959       (set-itimer-restart current-itimer nil)))
2960   (let ((b-list (buffer-list))
2961         (found-one nil)
2962         oldval)
2963     (while (and (not (input-pending-p)) b-list)
2964       (save-excursion
2965         (if (not (buffer-live-p (car b-list)))
2966             nil
2967           (set-buffer (car b-list))
2968           (if (and (eq major-mode 'vm-mode)
2969                    (setq found-one t)
2970                    ;; to avoid reentrance into the pop and imap code
2971                    (not vm-global-block-new-mail))
2972               (progn
2973                 (setq oldval vm-spooled-mail-waiting)
2974                 (setq vm-spooled-mail-waiting (vm-check-for-spooled-mail nil t))
2975                 (if (not (eq oldval vm-spooled-mail-waiting))
2976                     (progn
2977                       (intern (buffer-name) vm-buffers-needing-display-update)
2978                       (run-hooks 'vm-spooled-mail-waiting-hook)))))))
2979       (setq b-list (cdr b-list)))
2980     (vm-update-summary-and-mode-line)
2981     ;; make the timer go away if we didn't encounter a vm-mode buffer.
2982     (if (and (not found-one) (null b-list))
2983         (if timer
2984             (cancel-timer timer)
2985           (set-itimer-restart current-itimer nil)))))
2986
2987 ;; support for numeric vm-auto-get-new-mail
2988 ;; if timer argument is present, this means we're using the Emacs
2989 ;; 'timer package rather than the 'itimer package.
2990 (defun vm-get-mail-itimer-function (&optional timer)
2991   ;; FSF Emacs sets this non-nil, which means the user can't
2992   ;; interrupt mail retrieval.  Bogus.
2993   (setq inhibit-quit nil)
2994   (if (integerp vm-auto-get-new-mail)
2995       (if timer
2996           (timer-set-time timer (timer-relative-time (current-time) vm-auto-get-new-mail) vm-auto-get-new-mail)
2997         (set-itimer-restart current-itimer vm-auto-get-new-mail))
2998     ;; user has changed the variable value to something that
2999     ;; isn't a number, make the timer go away.
3000     (if timer
3001         (cancel-timer timer)
3002       (set-itimer-restart current-itimer nil)))
3003   (let ((b-list (buffer-list))
3004         (found-one nil))
3005     (while (and (not (input-pending-p)) b-list)
3006       (save-excursion
3007         (if (not (buffer-live-p (car b-list)))
3008             nil
3009           (set-buffer (car b-list))
3010           (if (and (eq major-mode 'vm-mode)
3011                    (setq found-one t)
3012                    (not vm-global-block-new-mail)
3013                    (not vm-block-new-mail)
3014                    (not vm-folder-read-only)
3015                    (not (and (not (buffer-modified-p))
3016                              buffer-file-name
3017                              (file-newer-than-file-p
3018                               (make-auto-save-file-name)
3019                               buffer-file-name)))
3020                    (vm-get-spooled-mail nil))
3021               (progn
3022                 ;; don't move the message pointer unless the folder
3023                 ;; was empty.
3024                 (if (and (null vm-message-pointer)
3025                          (vm-thoughtfully-select-message))
3026                     (vm-preview-current-message)
3027                   (vm-update-summary-and-mode-line))))))
3028       (setq b-list (cdr b-list)))
3029     ;; make the timer go away if we didn't encounter a vm-mode buffer.
3030     (if (and (not found-one) (null b-list))
3031         (if timer
3032             (cancel-timer timer)
3033           (set-itimer-restart current-itimer nil)))))
3034
3035 ;; support for numeric vm-flush-interval
3036 ;; if timer argument is present, this means we're using the Emacs
3037 ;; 'timer package rather than the 'itimer package.
3038 (defun vm-flush-itimer-function (&optional timer)
3039   (if (integerp vm-flush-interval)
3040       (if timer
3041           (timer-set-time timer (timer-relative-time (current-time) vm-flush-interval) vm-flush-interval)
3042         (set-itimer-restart current-itimer vm-flush-interval)))
3043   ;; if no vm-mode buffers are found, we might as well shut down the
3044   ;; flush itimer.
3045   (if (not (vm-flush-cached-data))
3046       (if timer
3047           (cancel-timer timer)
3048         (set-itimer-restart current-itimer nil))))
3049
3050 ;; flush cached data in all vm-mode buffers.
3051 ;; returns non-nil if any vm-mode buffers were found.
3052 (defun vm-flush-cached-data ()
3053   (save-excursion
3054     (let ((buf-list (buffer-list))
3055           (found-one nil))
3056       (while (and buf-list (not (input-pending-p)))
3057         (if (not (buffer-live-p (car buf-list)))
3058             nil
3059           (set-buffer (car buf-list))
3060           (cond ((and (eq major-mode 'vm-mode) vm-message-list)
3061                  (setq found-one t)
3062                  (if (not (eq vm-modification-counter
3063                               vm-flushed-modification-counter))
3064                      (progn
3065                        (vm-stuff-last-modified)
3066                        (vm-stuff-pop-retrieved)
3067                        (vm-stuff-imap-retrieved)
3068                        (vm-stuff-summary)
3069                        (vm-stuff-labels)
3070                        (and vm-message-order-changed
3071                             (vm-stuff-message-order))
3072                        (and (vm-stuff-folder-attributes t t)
3073                             (setq vm-flushed-modification-counter
3074                                   vm-modification-counter)))))))
3075         (setq buf-list (cdr buf-list)))
3076       ;; if we haven't checked them all return non-nil so
3077       ;; the flusher won't give up trying.
3078       (or buf-list found-one) )))
3079
3080 ;; This allows C-x C-s to do the right thing for VM mail buffers.
3081 ;; Note that deleted messages are not expunged.
3082 (defun vm-write-file-hook ()
3083   (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook))
3084     ;; The vm-save-restriction isn't really necessary here, since
3085     ;; the stuff routines clean up after themselves, but should remain
3086     ;; as a safeguard against the time when other stuff is added here.
3087     (vm-save-restriction
3088      (let ((buffer-read-only))
3089        (message "Stuffing attributes...")
3090        (vm-stuff-folder-attributes nil)
3091        (message "Stuffing attributes... done")
3092        (if vm-message-list
3093            (progn
3094              (if (and vm-folders-summary-database buffer-file-name)
3095                  (progn
3096                    (vm-compute-totals)
3097                    (vm-store-folder-totals buffer-file-name (cdr vm-totals))))
3098              ;; get summary cache up-to-date
3099              (vm-update-summary-and-mode-line)
3100              (vm-stuff-bookmark)
3101              (vm-stuff-pop-retrieved)
3102              (vm-stuff-imap-retrieved)
3103              (vm-stuff-last-modified)
3104              (vm-stuff-header-variables)
3105              (vm-stuff-labels)
3106              (vm-stuff-summary)
3107              (and vm-message-order-changed
3108                   (vm-stuff-message-order))))
3109        nil ))))
3110
3111 ;;;###autoload
3112 (defun vm-save-buffer (prefix)
3113   (interactive "P")
3114   (vm-select-folder-buffer)
3115   (vm-error-if-virtual-folder)
3116   (save-buffer prefix)
3117   (intern (buffer-name) vm-buffers-needing-display-update)
3118   (setq vm-block-new-mail nil)
3119   (vm-display nil nil '(vm-save-buffer) '(vm-save-buffer))
3120   (if (and vm-folders-summary-database buffer-file-name)
3121       (progn
3122         (vm-compute-totals)
3123         (vm-store-folder-totals buffer-file-name (cdr vm-totals))))
3124   (vm-update-summary-and-mode-line)
3125   (vm-write-index-file-maybe))
3126
3127 ;;;###autoload
3128 (defun vm-write-file ()
3129   (interactive)
3130   (vm-select-folder-buffer)
3131   (vm-error-if-virtual-folder)
3132   (let ((old-buffer-name (buffer-name))
3133         (oldmodebits (and (fboundp 'default-file-modes)
3134                           (default-file-modes))))
3135     (unwind-protect
3136         (save-excursion
3137           (and oldmodebits (set-default-file-modes
3138                             vm-default-folder-permission-bits))
3139           (call-interactively 'write-file))
3140       (and oldmodebits (set-default-file-modes oldmodebits)))
3141     (if (and vm-folders-summary-database buffer-file-name)
3142         (progn
3143           (vm-compute-totals)
3144           (vm-store-folder-totals buffer-file-name (cdr vm-totals))))
3145     (if (not (equal (buffer-name) old-buffer-name))
3146         (progn
3147           (vm-check-for-killed-summary)
3148           (if vm-summary-buffer
3149               (save-excursion
3150                 (let ((name (buffer-name)))
3151                   (set-buffer vm-summary-buffer)
3152                   (rename-buffer (format "%s Summary" name) t))))
3153           (vm-check-for-killed-presentation)
3154           (if vm-presentation-buffer-handle
3155               (save-excursion
3156                 (let ((name (buffer-name)))
3157                   (set-buffer vm-presentation-buffer-handle)
3158                   (rename-buffer (format "%s Presentation" name) t)))))))
3159   (intern (buffer-name) vm-buffers-needing-display-update)
3160   (setq vm-block-new-mail nil)
3161   (vm-display nil nil '(vm-write-file) '(vm-write-file))
3162   (vm-update-summary-and-mode-line)
3163   (vm-write-index-file-maybe))
3164
3165 (defun vm-unblock-new-mail ()
3166   (setq vm-block-new-mail nil))
3167
3168 ;;;###autoload
3169 (defun vm-save-folder (&optional prefix)
3170   "Save current folder to disk.
3171 Deleted messages are not expunged.
3172 Prefix arg is handled the same as for the command `save-buffer'.
3173
3174 When applied to a virtual folder, this command runs itself on
3175 each of the underlying real folders associated with the virtual
3176 folder."
3177   (interactive (list current-prefix-arg))
3178   (vm-select-folder-buffer)
3179   (vm-check-for-killed-summary)
3180   (vm-display nil nil '(vm-save-folder) '(vm-save-folder))
3181   (if (eq major-mode 'vm-virtual-mode)
3182       (vm-virtual-save-folder prefix)
3183     (if (buffer-modified-p)
3184         (let (mp (newlist nil))
3185           (cond ((eq vm-folder-access-method 'pop)
3186                  (vm-pop-synchronize-folder t t t nil))
3187                 ((eq vm-folder-access-method 'imap)
3188                  (vm-imap-synchronize-folder t t t nil t)))
3189           ;; stuff the attributes of messages that need it.
3190           (message "Stuffing attributes...")
3191           (vm-stuff-folder-attributes nil)
3192           (message "Stuffing attributes... done")
3193           ;; stuff bookmark and header variable values
3194           (if vm-message-list
3195               (progn
3196                 ;; get summary cache up-to-date
3197                 (vm-update-summary-and-mode-line)
3198                 (vm-stuff-bookmark)
3199                 (vm-stuff-pop-retrieved)
3200                 (vm-stuff-imap-retrieved)
3201                 (vm-stuff-last-modified)
3202                 (vm-stuff-header-variables)
3203                 (vm-stuff-labels)
3204                 (vm-stuff-summary)
3205                 (and vm-message-order-changed
3206                      (vm-stuff-message-order))))
3207           (message "Saving...")
3208           (let ((vm-inhibit-write-file-hook t)
3209                 (oldmodebits (and (fboundp 'default-file-modes)
3210                                   (default-file-modes))))
3211             (unwind-protect
3212                 (progn
3213                   (and oldmodebits (set-default-file-modes
3214                                     vm-default-folder-permission-bits))
3215                   (save-buffer prefix))
3216               (and oldmodebits (set-default-file-modes oldmodebits))))
3217           (vm-set-buffer-modified-p nil)
3218           ;; clear the modified flag in virtual folders if all the
3219           ;; real buffers associated with them are unmodified.
3220           (let ((b-list vm-virtual-buffers) rb-list one-modified)
3221             (save-excursion
3222               (while b-list
3223                 (if (null (cdr (vm-buffer-variable-value (car b-list)
3224                                                          'vm-real-buffers)))
3225                     (vm-set-buffer-modified-p nil (car b-list))
3226                   (set-buffer (car b-list))
3227                   (setq rb-list vm-real-buffers one-modified nil)
3228                   (while rb-list
3229                     (if (buffer-modified-p (car rb-list))
3230                         (setq one-modified t rb-list nil)
3231                       (setq rb-list (cdr rb-list))))
3232                   (if (not one-modified)
3233                       (vm-set-buffer-modified-p nil (car b-list))))
3234                 (setq b-list (cdr b-list)))))
3235           (vm-clear-modification-flag-undos)
3236           (setq vm-messages-not-on-disk 0)
3237           (setq vm-block-new-mail nil)
3238           (vm-write-index-file-maybe)
3239           (if (and vm-folders-summary-database buffer-file-name)
3240               (progn
3241                 (vm-compute-totals)
3242                 (vm-store-folder-totals buffer-file-name (cdr vm-totals))))
3243           (vm-update-summary-and-mode-line)
3244           (and (zerop (buffer-size))
3245                vm-delete-empty-folders
3246                buffer-file-name
3247                (or (eq vm-delete-empty-folders t)
3248                    (y-or-n-p (format "%s is empty, remove it? "
3249                                      (or buffer-file-name (buffer-name)))))
3250                (condition-case ()
3251                    (progn
3252                      (delete-file buffer-file-name)
3253                      (vm-delete-index-file)
3254                      (clear-visited-file-modtime)
3255                      (message "%s removed" buffer-file-name))
3256                  ;; no can do, oh well.
3257                  (error nil))))
3258       (message "No changes need to be saved"))))
3259
3260 ;;;###autoload
3261 (defun vm-save-and-expunge-folder (&optional prefix)
3262   "Expunge folder, then save it to disk.
3263 Prefix arg is handled the same as for the command save-buffer.
3264 Expunge won't be done if folder is read-only.
3265
3266 When applied to a virtual folder, this command works as if you had
3267 run vm-expunge-folder followed by vm-save-folder."
3268   (interactive (list current-prefix-arg))
3269   (vm-select-folder-buffer)
3270   (vm-check-for-killed-summary)
3271   (vm-display nil nil '(vm-save-and-expunge-folder)
3272               '(vm-save-and-expunge-folder))
3273   (if (not vm-folder-read-only)
3274       (progn
3275         (message "Expunging...")
3276         (vm-expunge-folder t)))
3277   (vm-save-folder prefix))
3278
3279 ;;;###autoload
3280 (defun vm-revert-buffer (&rest args)
3281   (interactive)
3282   (vm-select-folder-buffer-if-possible)
3283   (call-interactively 'revert-buffer))
3284
3285 ;;;###autoload
3286 (defun vm-recover-file (&rest args)
3287   (interactive)
3288   (vm-select-folder-buffer-if-possible)
3289   (call-interactively 'recover-file))
3290
3291 (defun vm-handle-file-recovery-or-reversion (recovery)
3292   (if (and vm-summary-buffer (buffer-name vm-summary-buffer))
3293       (kill-buffer vm-summary-buffer))
3294   (vm-virtual-quit)
3295   ;; reset major mode, this will cause vm to start from scratch.
3296   (setq major-mode 'fundamental-mode)
3297   ;; If this is a recovery, we can't allow the user to get new
3298   ;; mail until a real save is performed.  Until then the buffer
3299   ;; and the disk don't match.
3300   (if recovery
3301       (setq vm-block-new-mail t))
3302   (let ((name (cond ((eq vm-folder-access-method 'pop)
3303                      (vm-pop-find-name-for-buffer (current-buffer)))
3304                     ((eq vm-folder-access-method 'imap)
3305                      (vm-imap-find-spec-for-buffer (current-buffer))))))
3306     (vm (or name buffer-file-name) nil vm-folder-access-method)))
3307
3308 ;; detect if a recover-file is being performed
3309 ;; and handle things properly.
3310 (defun vm-handle-file-recovery ()
3311   (if (and (buffer-modified-p)
3312            (eq major-mode 'vm-mode)
3313            (or (null vm-message-list)
3314                (= (vm-end-of (car vm-message-list)) 1)))
3315       (vm-handle-file-recovery-or-reversion t)))
3316
3317 ;; detect if a revert-buffer is being performed
3318 ;; and handle things properly.
3319 (defun vm-handle-file-reversion ()
3320   (if (and (not (buffer-modified-p))
3321            (eq major-mode 'vm-mode)
3322            (or (null vm-message-list)
3323                (= (vm-end-of (car vm-message-list)) 1)))
3324       (vm-handle-file-recovery-or-reversion nil)))
3325
3326 ;; FSF v19.23 revert-buffer doesn't mash all the markers together
3327 ;; like v18 and prior v19 versions, so the check in
3328 ;; vm-handle-file-reversion doesn't work.  However v19.23 has a
3329 ;; hook we can use, after-revert-hook.
3330 (defun vm-after-revert-buffer-hook ()
3331   (if (eq major-mode 'vm-mode)
3332       (vm-handle-file-recovery-or-reversion nil)))
3333
3334 ;;;###autoload
3335 (defun vm-help ()
3336   "Display help for various VM activities."
3337   (interactive)
3338   (if (eq major-mode 'vm-summary-mode)
3339       (vm-select-folder-buffer))
3340   (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
3341         (pop-up-frames (and vm-mutable-frames vm-frame-per-help)))
3342     (cond
3343      ((eq last-command 'vm-help)
3344       (describe-function major-mode))
3345      ((eq vm-system-state 'previewing)
3346       (message "Type SPC to read message, n previews next message   (? gives more help)"))
3347      ((memq vm-system-state '(showing reading))
3348       (message "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply   (? gives more help)"))
3349      ((eq vm-system-state 'editing)
3350       (message
3351        (substitute-command-keys
3352         "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change.")))
3353      ((eq major-mode 'mail-mode)
3354       (message
3355        (substitute-command-keys
3356         "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this composition")))
3357      (t (describe-mode)))))
3358
3359 ;;;###autoload
3360 (defun vm-spool-move-mail (source destination)
3361   (let ((handler (and (fboundp 'find-file-name-handler)
3362                       (condition-case ()
3363                           (find-file-name-handler source 'vm-spool-move-mail)
3364                         (wrong-number-of-arguments
3365                           (find-file-name-handler source)))))
3366         status error-buffer)
3367     (if handler
3368         (funcall handler 'vm-spool-move-mail source destination)
3369       (setq error-buffer
3370             (get-buffer-create
3371              (format "*output of %s %s %s*"
3372                      vm-movemail-program source destination)))
3373       (save-excursion
3374         (set-buffer error-buffer)
3375         (erase-buffer))
3376       (setq status
3377             (apply 'call-process
3378                    (nconc
3379                     (list vm-movemail-program nil error-buffer t)
3380                     (copy-sequence vm-movemail-program-switches)
3381                     (list source destination))))
3382       (save-excursion
3383         (set-buffer error-buffer)
3384         (if (and (numberp status) (not (= 0 status)))
3385             (insert (format "\n%s exited with code %s\n"
3386                             vm-movemail-program status)))
3387         (if (> (buffer-size) 0)
3388             (progn
3389               (vm-display-buffer error-buffer)
3390               (if (and (numberp status) (not (= 0 status)))
3391                   (error "Failed getting new mail from %s" source)
3392                 (message "Warning: unexpected output from %s"
3393                          vm-movemail-program)
3394                 (sleep-for 2)))
3395           ;; nag, nag, nag.
3396           (kill-buffer error-buffer))
3397         t ))))
3398
3399 (defun vm-gobble-crash-box (crash-box)
3400   (save-excursion
3401     (vm-save-restriction
3402      (widen)
3403      (let ((opoint-max (point-max)) crash-buf
3404            (buffer-read-only nil)
3405            (inbox-buffer-file buffer-file-name)
3406            (inbox-folder-type vm-folder-type)
3407            (inbox-empty (zerop (buffer-size)))
3408            got-mail crash-folder-type
3409            (old-buffer-modified-p (buffer-modified-p)))
3410        (setq crash-buf
3411              ;; crash box could contain a letter bomb...
3412              ;; force user notification of file variables for v18 Emacses
3413              ;; enable-local-variables == nil disables them for newer Emacses
3414              (let ((inhibit-local-variables t)
3415                    (enable-local-variables nil)
3416                    (enable-local-eval nil)
3417                    (coding-system-for-read (vm-line-ending-coding-system)))
3418                (find-file-noselect crash-box)))
3419        (if (eq (current-buffer) crash-buf)
3420            (error "folder is the same file as crash box, cannot continue"))
3421        (save-excursion
3422          (set-buffer crash-buf)
3423          (setq crash-folder-type (vm-get-folder-type))
3424          (if (and crash-folder-type vm-check-folder-types)
3425              (cond ((eq crash-folder-type 'unknown)
3426                     (error "crash box %s's type is unrecognized" crash-box))
3427                    ((eq inbox-folder-type 'unknown)
3428                     (error "inbox %s's type is unrecognized"
3429                            inbox-buffer-file))
3430                    ((null inbox-folder-type)
3431                     (if vm-default-folder-type
3432                         (if (not (eq vm-default-folder-type
3433                                      crash-folder-type))
3434                             (if vm-convert-folder-types
3435                                 (progn
3436                                   (vm-convert-folder-type
3437                                    crash-folder-type
3438                                    vm-default-folder-type)
3439                                   ;; so that kill-buffer won't ask a
3440                                   ;; question later...
3441                                   (set-buffer-modified-p nil))
3442                               (error "crash box %s mismatches vm-default-folder-type: %s, %s"
3443                                      crash-box crash-folder-type
3444                                      vm-default-folder-type)))))
3445                    ((not (eq inbox-folder-type crash-folder-type))
3446                     (if vm-convert-folder-types
3447                         (progn
3448                           (vm-convert-folder-type crash-folder-type
3449                                                   inbox-folder-type)
3450                           ;; so that kill-buffer won't ask a
3451                           ;; question later...
3452                           (set-buffer-modified-p nil))
3453                       (error "crash box %s mismatches %s's folder type: %s, %s"
3454                              crash-box inbox-buffer-file
3455                              crash-folder-type inbox-folder-type)))))
3456          ;; toss the folder header if the inbox is not empty
3457          (goto-char (point-min))
3458          (if (not inbox-empty)
3459              (progn
3460                (vm-convert-folder-header (or inbox-folder-type
3461                                              vm-default-folder-type)
3462                                          nil)
3463                (set-buffer-modified-p nil))))
3464        (goto-char (point-max))
3465        (insert-buffer-substring crash-buf
3466                                 1 (1+ (save-excursion
3467                                         (set-buffer crash-buf)
3468                                         (widen)
3469                                         (buffer-size))))
3470        (setq got-mail (/= opoint-max (point-max)))
3471        (if (not got-mail)
3472            nil
3473          (let ((coding-system-for-write (vm-binary-coding-system))
3474                (selective-display nil))
3475            (write-region opoint-max (point-max) buffer-file-name t t))
3476          (vm-increment vm-modification-counter)
3477          (set-buffer-modified-p old-buffer-modified-p))
3478        (kill-buffer crash-buf)
3479        (if (not (stringp vm-keep-crash-boxes))
3480            (vm-error-free-call 'delete-file crash-box)
3481          (let ((time (decode-time (current-time)))
3482                name)
3483            (setq name
3484                  (expand-file-name (format "Z-%02d-%02d-%02d%02d%02d-%05d"
3485                                            (nth 4 time)
3486                                            (nth 3 time)
3487                                            (nth 2 time)
3488                                            (nth 1 time)
3489                                            (nth 0 time)
3490                                            (% (vm-abs (random)) 100000))
3491                                    vm-keep-crash-boxes))
3492            (while (file-exists-p name)
3493              (setq name
3494                    (expand-file-name (format "Z-%02d-%02d-%02d%02d%02d-%05d"
3495                                              (nth 4 time)
3496                                              (nth 3 time)
3497                                              (nth 2 time)
3498                                              (nth 1 time)
3499                                              (nth 0 time)
3500                                              (% (vm-abs (random)) 100000))
3501                                      vm-keep-crash-boxes)))
3502            (rename-file crash-box name)))
3503        got-mail ))))
3504
3505 (defun vm-compute-spool-files (&optional all)
3506   (let ((fallback-triples nil)
3507         (crash-box (or vm-crash-box
3508                        (concat vm-primary-inbox vm-crash-box-suffix)))
3509         file file-list
3510         triples)
3511     (cond ((null (vm-spool-files))
3512            (setq triples (list
3513                           (list vm-primary-inbox
3514                                 (concat vm-spool-directory (user-login-name))
3515                                 crash-box))))
3516           ((stringp (car (vm-spool-files)))
3517            (setq triples
3518                  (mapcar (function
3519                           (lambda (s) (list vm-primary-inbox s crash-box)))
3520                          (vm-spool-files))))
3521           ((consp (car (vm-spool-files)))
3522            (setq triples (vm-spool-files))))
3523     (setq file-list (if all (mapcar 'car triples) (list buffer-file-name)))
3524     (while file-list
3525       (setq file (car file-list))
3526       (setq file-list (cdr file-list))
3527       (cond ((and file
3528                   (consp vm-spool-file-suffixes)
3529                   (stringp vm-crash-box-suffix))
3530              (setq fallback-triples
3531                    (mapcar (function
3532                             (lambda (suffix)
3533                               (list file
3534                                     (concat file suffix)
3535                                     (concat file
3536                                             vm-crash-box-suffix))))
3537                            vm-spool-file-suffixes))))
3538       (cond ((and file
3539                   vm-make-spool-file-name vm-make-crash-box-name)
3540              (setq fallback-triples
3541                    (nconc fallback-triples
3542                           (list (list file
3543                                       (save-excursion
3544                                         (funcall vm-make-spool-file-name
3545                                                  file))
3546                                       (save-excursion
3547                                         (funcall vm-make-crash-box-name
3548                                                  file)))))))))
3549     (setq triples (append triples fallback-triples))
3550     triples ))
3551
3552 (defun vm-spool-check-mail (source)
3553   (let ((handler (and (fboundp 'find-file-name-handler)
3554                       (condition-case ()
3555                           (find-file-name-handler source 'vm-spool-check-mail)
3556                         (wrong-number-of-arguments
3557                          (find-file-name-handler source))))))
3558     (if handler
3559         (funcall handler 'vm-spool-check-mail source)
3560       (let ((size (nth 7 (file-attributes source)))
3561             (hash vm-spool-file-message-count-hash)
3562             val)
3563         (setq val (symbol-value (intern-soft source hash)))
3564         (if (and val (equal size (car val)))
3565             (> (nth 1 val) 0)
3566           (let ((count (vm-count-messages-in-file source)))
3567             (if (null count)
3568                 nil
3569               (set (intern source hash) (list size count))
3570               (vm-store-folder-totals source (list count 0 0 0))
3571               (> count 0))))))))
3572
3573 (defun vm-count-messages-in-file (file &optional quietly)
3574   (let ((type (vm-get-folder-type file nil nil t))
3575         (work-buffer nil)
3576         count)
3577     (if (or (memq type '(unknown nil)) (null vm-grep-program))
3578         nil
3579       (unwind-protect
3580           (let (regexp)
3581             (save-excursion
3582               (setq work-buffer (vm-make-work-buffer))
3583               (set-buffer work-buffer)
3584               (cond ((memq type '(From_ BellFrom_ From_-with-Content-Length))
3585                      (setq regexp "^From "))
3586                     ((eq type 'mmdf)
3587                      (setq regexp "^\001\001\001\001"))
3588                     ((eq type 'babyl)
3589                      (setq regexp "^\037")))
3590               (condition-case data
3591                   (progn
3592                     (or quietly (message "Counting messages in %s..." file))
3593                     (call-process vm-grep-program nil t nil "-c" regexp
3594                                   (expand-file-name file))
3595                     (or quietly (message "Counting messages in %s... done" file)))
3596                 (error (message "Attempt to run %s on %s signaled: %s"
3597                                 vm-grep-program file data)
3598                        (sleep-for 2)
3599                        (setq vm-grep-program nil)))
3600               (setq count (string-to-number (buffer-string)))
3601               (cond ((memq type '(From_ BellFrom_ From_-with-Content-Length))
3602                      t )
3603                     ((eq type 'mmdf)
3604                      (setq count (/ count 2)))
3605                     ((eq type 'babyl)
3606                      (setq count (1- count))))
3607               count ))
3608         (and work-buffer (kill-buffer work-buffer))))))
3609
3610 (defun vm-movemail-specific-spool-file-p (file)
3611   (string-match "^po:[^:]+$" file))
3612
3613 (defun vm-check-for-spooled-mail (&optional interactive this-buffer-only)
3614   (if vm-global-block-new-mail
3615       nil
3616     (if (and vm-folder-access-method this-buffer-only)
3617         (cond ((eq vm-folder-access-method 'pop)
3618                (vm-pop-folder-check-for-mail interactive))
3619               ((eq vm-folder-access-method 'imap)
3620                (vm-imap-folder-check-for-mail interactive)))
3621       (let ((triples (vm-compute-spool-files (not this-buffer-only)))
3622             ;; since we could accept-process-output here (POP code),
3623             ;; a timer process might try to start retrieving mail
3624             ;; before we finish.  block these attempts.
3625             (vm-global-block-new-mail t)
3626             (vm-pop-ok-to-ask interactive)
3627             (vm-imap-ok-to-ask interactive)
3628             ;; for string-match calls below
3629             (case-fold-search nil)
3630             this-buffer crash in maildrop meth
3631             (mail-waiting nil))
3632         (while triples
3633           (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)
3634                 maildrop (nth 1 (car triples))
3635                 crash (nth 2 (car triples)))
3636           (if (vm-movemail-specific-spool-file-p maildrop)
3637               ;; spool file is accessible only with movemail
3638               ;; so skip it.
3639               nil
3640             (setq this-buffer (eq (current-buffer) (vm-get-file-buffer in)))
3641             (if (or this-buffer (not this-buffer-only))
3642                 (progn
3643                   (if (file-exists-p crash)
3644                       (progn
3645                         (setq mail-waiting t))
3646                     (cond ((and vm-recognize-imap-maildrops
3647                                 (string-match vm-recognize-imap-maildrops
3648                                               maildrop))
3649                            (setq meth 'vm-imap-check-mail))
3650                           ((and vm-recognize-pop-maildrops
3651                                 (string-match vm-recognize-pop-maildrops
3652                                               maildrop))
3653                            (setq meth 'vm-pop-check-mail))
3654                           (t (setq meth 'vm-spool-check-mail)))
3655                     (if (not interactive)
3656                         ;; allow no error to be signaled
3657                         (condition-case nil
3658                             (setq mail-waiting
3659                                   (or mail-waiting
3660                                       (funcall meth maildrop)))
3661                           (error nil))
3662                       (setq mail-waiting
3663                             (or mail-waiting
3664                                 (funcall meth maildrop))))))))
3665           (setq triples (cdr triples)))
3666         mail-waiting ))))
3667
3668 (defun vm-get-spooled-mail (&optional interactive)
3669   (if vm-block-new-mail
3670       (error "Can't get new mail until you save this folder."))
3671   (cond ((eq vm-folder-access-method 'pop)
3672          (vm-pop-synchronize-folder interactive nil nil t))
3673         ((eq vm-folder-access-method 'imap)
3674          (vm-imap-synchronize-folder interactive nil nil t))
3675         (t (vm-get-spooled-mail-normal interactive))))
3676
3677 (defun vm-get-spooled-mail-normal (&optional interactive)
3678   (if vm-global-block-new-mail
3679       nil
3680     (let ((triples (vm-compute-spool-files))
3681           ;; since we could accept-process-output here (POP code),
3682           ;; a timer process might try to start retrieving mail
3683           ;; before we finish.  block these attempts.
3684           (vm-global-block-new-mail t)
3685           (vm-pop-ok-to-ask interactive)
3686           (vm-imap-ok-to-ask interactive)
3687           ;; for string-match calls below
3688           (case-fold-search nil)
3689           non-file-maildrop crash in safe-maildrop maildrop popdrop
3690           retrieval-function
3691           (got-mail nil))
3692       (if (and (not (verify-visited-file-modtime (current-buffer)))
3693                (or (null interactive)
3694                    (not (yes-or-no-p
3695                          (format
3696                           "Folder %s changed on disk, discard those changes? "
3697                           (buffer-name (current-buffer)))))))
3698           (progn
3699             (message "Folder %s changed on disk, consider M-x revert-buffer"
3700                      (buffer-name (current-buffer)))
3701             (sleep-for 2)
3702             nil )
3703         (while triples
3704           (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)
3705                 maildrop (nth 1 (car triples))
3706                 crash (nth 2 (car triples)))
3707           (setq safe-maildrop maildrop
3708                 non-file-maildrop nil)
3709           (cond ((vm-movemail-specific-spool-file-p maildrop)
3710                  (setq non-file-maildrop t)
3711                  (setq retrieval-function 'vm-spool-move-mail))
3712                 ((and vm-recognize-imap-maildrops
3713                       (string-match vm-recognize-imap-maildrops
3714                                     maildrop))
3715                  (setq non-file-maildrop t)
3716                  (setq safe-maildrop (vm-safe-imapdrop-string maildrop))
3717                  (setq retrieval-function 'vm-imap-move-mail))
3718                 ((and vm-recognize-pop-maildrops
3719                       (string-match vm-recognize-pop-maildrops
3720                                     maildrop))
3721                  (setq non-file-maildrop t)
3722                  (setq safe-maildrop (vm-safe-popdrop-string maildrop))
3723                  (setq retrieval-function 'vm-pop-move-mail))
3724                 (t (setq retrieval-function 'vm-spool-move-mail)))
3725           (if (eq (current-buffer) (vm-get-file-buffer in))
3726               (progn
3727                 (if (file-exists-p crash)
3728                     (progn
3729                       (message "Recovering messages from %s..." crash)
3730                       (setq got-mail (or (vm-gobble-crash-box crash) got-mail))
3731                       (message "Recovering messages from %s... done" crash)))
3732                 (if (or non-file-maildrop
3733                         (and (not (equal 0 (nth 7 (file-attributes maildrop))))
3734                              (file-readable-p maildrop)))
3735                     (progn
3736                       (setq crash (expand-file-name crash vm-folder-directory))
3737                       (if (not non-file-maildrop)
3738                           (setq maildrop (expand-file-name maildrop
3739                                                            vm-folder-directory)))
3740                       (if (if got-mail
3741                               ;; don't allow errors to be signaled unless no
3742                               ;; mail has been appended to the incore
3743                               ;; copy of the folder.  otherwise the
3744                               ;; user will wonder where the mail is,
3745                               ;; since it is not in the crash box or
3746                               ;; the spool file and doesn't _appear_ to
3747                               ;; be in the folder either.
3748                               (condition-case error-data
3749                                   (funcall retrieval-function maildrop crash)
3750                                 (error (message "%s signaled: %s"
3751                                                 retrieval-function
3752                                                 error-data)
3753                                        (sleep-for 2)
3754                                        ;; we don't know if mail was
3755                                        ;; put into the crash box or
3756                                        ;; not, so return t just to be
3757                                        ;; safe.
3758                                        t )
3759                                 (quit (message "quitting from %s..."
3760                                                retrieval-function)
3761                                       (sleep-for 2)
3762                                       ;; we don't know if mail was
3763                                       ;; put into the crash box or
3764                                       ;; not, so return t just to be
3765                                       ;; safe.
3766                                       t ))
3767                             (funcall retrieval-function maildrop crash))
3768                           (if (vm-gobble-crash-box crash)
3769                               (progn
3770                                 (setq got-mail t)
3771                                 (if (not non-file-maildrop)
3772                                     (vm-store-folder-totals maildrop
3773                                                             '(0 0 0 0)))
3774                                 (message "Got mail from %s."
3775                                          safe-maildrop))))))))
3776           (setq triples (cdr triples)))
3777         ;; not really correct, but it is what the user expects to see.
3778         (setq vm-spooled-mail-waiting nil)
3779         (intern (buffer-name) vm-buffers-needing-display-update)
3780         (vm-update-summary-and-mode-line)
3781         (if got-mail
3782             (run-hooks 'vm-retrieved-spooled-mail-hook))
3783         (and got-mail (vm-assimilate-new-messages t))))))
3784
3785 (defun vm-safe-popdrop-string (drop)
3786   (or (and (string-match "^\\(pop:\\|pop-ssl:\\|pop-ssh:\\)?\\([^:]+\\):[^:]+:[^:]+:\\([^:]+\\):[^:]+" drop)
3787            (concat (substring drop (match-beginning 3) (match-end 3))
3788                    "@"
3789                    (substring drop (match-beginning 2) (match-end 2))))
3790       "???"))
3791
3792 (defun vm-safe-imapdrop-string (drop)
3793   (or (and (string-match "^\\(imap\\|imap-ssl\\|imap-ssh\\):\\([^:]+\\):[^:]+:\\([^:]+\\):[^:]+:\\([^:]+\\):[^:]+" drop)
3794            (concat (substring drop (match-beginning 4) (match-end 4))
3795                    "@"
3796                    (substring drop (match-beginning 2) (match-end 2))
3797                    " ["
3798                    (substring drop (match-beginning 3) (match-end 3))
3799                    "]"))
3800       "???"))
3801
3802 ;;;###autoload
3803 (defun vm-get-new-mail (&optional arg)
3804   "Move any new mail that has arrived in any of the spool files for the
3805 current folder into the folder.  New mail is appended to the disk
3806 and buffer copies of the folder.
3807
3808 Prefix arg means to gather mail from a user specified folder, instead of
3809 the usual spool files.  The file name will be read from the minibuffer.
3810 Unlike when getting mail from a spool file, the source file is left
3811 undisturbed after its messages have been copied.
3812
3813 When applied to a virtual folder, this command runs itself on
3814 each of the underlying real folders associated with this virtual
3815 folder.  A prefix argument has no effect when this command is
3816 applied to virtual folder; mail is always gathered from the spool
3817 files."
3818   (interactive "P")
3819   (vm-select-folder-buffer)
3820   (vm-check-for-killed-summary)
3821   (vm-error-if-folder-read-only)
3822   (cond ((eq major-mode 'vm-virtual-mode)
3823          (vm-virtual-get-new-mail))
3824         ((not (eq major-mode 'vm-mode))
3825          (error "Can't get mail for a non-VM folder buffer"))
3826         ((null arg)
3827          (if (not (eq major-mode 'vm-mode))
3828              (vm-mode))
3829          (if (consp (car (vm-spool-files)))
3830              (message "Checking for new mail for %s..."
3831                       (or buffer-file-name (buffer-name)))
3832            (message "Checking for new mail..."))
3833          (let (totals-blurb)
3834            (if (vm-get-spooled-mail t)
3835                (progn
3836                  ;; say this NOW, before the non-previewers read
3837                  ;; a message, alter the new message count and
3838                  ;; confuse themselves.
3839                  (setq totals-blurb (vm-emit-totals-blurb))
3840                  (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail))
3841                  (if (vm-thoughtfully-select-message)
3842                      (vm-preview-current-message)
3843                    (vm-update-summary-and-mode-line))
3844                  (message totals-blurb))
3845              (if (consp (car (vm-spool-files)))
3846                  (message "No new mail for %s"
3847                           (or buffer-file-name (buffer-name)))
3848                (message "No new mail."))
3849              (and (interactive-p) (sit-for 4) (message "")))))
3850         (t
3851          (let ((buffer-read-only nil)
3852                folder mcount totals-blurb)
3853            (setq folder (read-file-name "Gather mail from folder: "
3854                                         vm-folder-directory nil t))
3855            (if (and vm-check-folder-types
3856                     (not (vm-compatible-folder-p folder)))
3857                (error "Folder %s is not the same format as this folder."
3858                       folder))
3859            (save-excursion
3860              (vm-save-restriction
3861               (widen)
3862               (goto-char (point-max))
3863               (let ((coding-system-for-read (vm-binary-coding-system)))
3864                 (insert-file-contents folder))))
3865            (setq mcount (length vm-message-list))
3866            (if (vm-assimilate-new-messages)
3867                (progn
3868                  ;; say this NOW, before the non-previewers read
3869                  ;; a message, alter the new message count and
3870                  ;; confuse themselves.
3871                  (setq totals-blurb (vm-emit-totals-blurb))
3872                  (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail))
3873                  (if (vm-thoughtfully-select-message)
3874                      (vm-preview-current-message)
3875                    (vm-update-summary-and-mode-line))
3876                  (message totals-blurb)
3877                  ;; The gathered messages are actually still on disk
3878                  ;; unless the user deletes the folder himself.
3879                  ;; However, users may not understand what happened if
3880                  ;; the messages go away after a "quit, no save".
3881                  (setq vm-messages-not-on-disk
3882                        (+ vm-messages-not-on-disk
3883                           (- (length vm-message-list)
3884                              mcount))))
3885              (message "No messages gathered."))))))
3886
3887 ;; returns list of new messages if there were any new messages, nil otherwise
3888 (defun vm-assimilate-new-messages (&optional
3889                                    dont-read-attributes
3890                                    gobble-order
3891                                    labels first-time)
3892   (let ((tail-cons (vm-last vm-message-list))
3893         b-list new-messages)
3894     (save-excursion
3895       (vm-save-restriction
3896        (widen)
3897        (vm-build-message-list)
3898        (if (or (null tail-cons) (cdr tail-cons))
3899            (progn
3900              (if (not vm-assimilate-new-messages-sorted)
3901                  (setq vm-ml-sort-keys nil))
3902              (if dont-read-attributes
3903                  (vm-set-default-attributes (cdr tail-cons))
3904                (vm-read-attributes (cdr tail-cons)))
3905              ;; Yuck.  This has to be done here instead of in the
3906              ;; vm function because this needs to be done before
3907              ;; any initial thread sort (so that if the thread
3908              ;; sort matches the saved order the folder won't be
3909              ;; modified) but after the message list is created.
3910              ;; Since thread sorting is done here this has to be
3911              ;; done here too.
3912              (if gobble-order
3913                  (vm-gobble-message-order))
3914              (if (or (vectorp vm-thread-obarray)
3915                      vm-summary-show-threads)
3916                  (vm-build-threads (cdr tail-cons))))))
3917       (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list))
3918       (vm-set-numbering-redo-start-point new-messages)
3919       (vm-set-summary-redo-start-point new-messages))
3920     ;; Only update the folders summary count here if new messages
3921     ;; have arrived, not when we're reading the folder for the
3922     ;; first time, and not if we cannot assume that all the arrived
3923     ;; messages should be considered new.  Use gobble-order as a
3924     ;; first time indicator along with the new messages being equal
3925     ;; to the whole message list.
3926     (if (and new-messages dont-read-attributes
3927              (or (not (eq new-messages vm-message-list))
3928                  (null gobble-order)))
3929         (vm-modify-folder-totals buffer-file-name 'arrived
3930                                  (length new-messages)))
3931     ;; copy the new-messages list because sorting might scramble
3932     ;; it.  Also something the user does when
3933     ;; vm-arrived-message-hook is run might affect it.
3934     ;; vm-assimilate-new-messages returns this value so it must
3935     ;; not be mangled.
3936     (setq new-messages (copy-sequence new-messages))
3937     ;; add the labels
3938     (if (and new-messages labels vm-burst-digest-messages-inherit-labels)
3939         (let ((mp new-messages))
3940           (while mp
3941             (vm-set-labels-of (car mp) (copy-sequence labels))
3942             (setq mp (cdr mp)))))
3943     (if (and new-messages vm-summary-show-threads)
3944         (progn
3945           ;; get numbering of new messages done now
3946           ;; so that the sort code only has to worry about the
3947           ;; changes it needs to make.
3948           (vm-update-summary-and-mode-line)
3949           (vm-sort-messages "thread")))
3950     (if (and new-messages
3951              (or vm-arrived-message-hook vm-arrived-messages-hook)
3952              ;; Run the hooks only if this is not the first
3953              ;; time vm-assimilate-new-messages has been called
3954              ;; in this folder.
3955              (not first-time))
3956         (let ((new-messages new-messages))
3957           ;; seems wise to do this so that if the user runs VM
3958           ;; commands here they start with as much of a clean
3959           ;; slate as we can provide, given we're currently deep
3960           ;; in the guts of VM.
3961           (vm-update-summary-and-mode-line)
3962           (if vm-arrived-message-hook
3963               (while new-messages
3964                 (vm-run-message-hook (car new-messages)
3965                                      'vm-arrived-message-hook)
3966                 (setq new-messages (cdr new-messages))))
3967           (run-hooks 'vm-arrived-messages-hook)))
3968     (if (and new-messages vm-virtual-buffers)
3969         (save-excursion
3970           (setq b-list vm-virtual-buffers)
3971           (while b-list
3972             ;; buffer might be dead
3973             (if (buffer-name (car b-list))
3974                 (let (tail-cons)
3975                   (set-buffer (car b-list))
3976                   (setq tail-cons (vm-last vm-message-list))
3977                   (vm-build-virtual-message-list new-messages)
3978                   (if (or (null tail-cons) (cdr tail-cons))
3979                       (progn
3980                         (if (not vm-assimilate-new-messages-sorted)
3981                             (setq vm-ml-sort-keys nil))
3982                         (if (vectorp vm-thread-obarray)
3983                             (vm-build-threads (cdr tail-cons)))
3984                         (vm-set-summary-redo-start-point
3985                          (or (cdr tail-cons) vm-message-list))
3986                         (vm-set-numbering-redo-start-point
3987                          (or (cdr tail-cons) vm-message-list))
3988                         (if (null vm-message-pointer)
3989                             (progn (setq vm-message-pointer vm-message-list
3990                                          vm-need-summary-pointer-update t)
3991                                    (if vm-message-pointer
3992                                        (vm-preview-current-message))))
3993                         (if vm-summary-show-threads
3994                             (progn
3995                               (vm-update-summary-and-mode-line)
3996                               (vm-sort-messages "thread")))))))
3997             (setq b-list (cdr b-list)))))
3998     (if (and new-messages vm-ml-sort-keys)
3999         (vm-sort-messages vm-ml-sort-keys))
4000     new-messages ))
4001
4002 (defun vm-select-marked-or-prefixed-messages (prefix)
4003   "Return a list of all marked messages or the messages indicated by a
4004 prefix argument.  If the prefix argument is supplied *and we are
4005 not in a vm-next-command-uses-marks context*, then return a number
4006 of messages around vm-message-pointer equal to (abs prefix),
4007 either backward (prefix is negative) or forward (positive)."
4008   (if (eq last-command 'vm-next-command-uses-marks)
4009       (vm-marked-messages)
4010     (let (mlist
4011           (direction (if (< prefix 0) 'backward 'forward))
4012           (count (vm-abs prefix))
4013           (vm-message-pointer vm-message-pointer))
4014       (unless (eq vm-circular-folders t)
4015         (vm-check-count prefix))
4016       (while (not (zerop count))
4017         (setq mlist (cons (car vm-message-pointer) mlist))
4018         (vm-decrement count)
4019         (unless (zerop count)
4020           (vm-move-message-pointer direction)))
4021       (nreverse mlist))))
4022
4023 (defun vm-display-startup-message ()
4024   (if (sit-for 5)
4025       (let ((lines vm-startup-message-lines))
4026         (message "VM %s. Type ? for help." (vm-version))
4027         (setq vm-startup-message-displayed t)
4028         (while (and (sit-for 4) lines)
4029           (message (substitute-command-keys (car lines)))
4030           (setq lines (cdr lines)))))
4031   (message ""))
4032
4033 ;;;###autoload
4034 (defun vm-toggle-read-only ()
4035   (interactive)
4036   (vm-select-folder-buffer)
4037   (setq vm-folder-read-only (not vm-folder-read-only))
4038   (intern (buffer-name) vm-buffers-needing-display-update)
4039   (message "Folder is now %s"
4040            (if vm-folder-read-only "read-only" "modifiable"))
4041   (vm-display nil nil '(vm-toggle-read-only) '(vm-toggle-read-only))
4042   (vm-update-summary-and-mode-line))
4043
4044 (defvar scroll-in-place)
4045
4046 ;; this does the real major mode scutwork.
4047 (defun vm-mode-internal (&optional access-method)
4048   (widen)
4049   (make-local-variable 'require-final-newline)
4050   ;; don't kill local variables, as there is some state we'd like to
4051   ;; keep.  rather than non-portably marking the variables we
4052   ;; want to keep, just avoid calling kill-local-variables and
4053   ;; reset everything that needs to be reset.
4054   (setq
4055    major-mode 'vm-mode
4056    mode-line-format vm-mode-line-format
4057    mode-name "VM"
4058    ;; must come after the setting of major-mode
4059    mode-popup-menu (and vm-use-menus
4060                         (vm-menu-support-possible-p)
4061                         (vm-menu-mode-menu))
4062    buffer-read-only t
4063    ;; If the user quits a vm-mode buffer, the default action is
4064    ;; to kill the buffer.  Make a note that we should offer to
4065    ;; save this buffer even if it has no file associated with it.
4066    ;; We have no idea of the value of the data in the buffer
4067    ;; before it was put into vm-mode.
4068    buffer-offer-save t
4069    require-final-newline nil
4070    ;; don't let CR's in folders be mashed into LF's because of a
4071    ;; stupid user setting.
4072    selective-display nil
4073    vm-thread-obarray 'bonk
4074    vm-thread-subject-obarray 'bonk
4075    vm-label-obarray (make-vector 29 0)
4076    vm-last-message-pointer nil
4077    vm-modification-counter 0
4078    vm-message-list nil
4079    vm-message-pointer nil
4080    vm-message-order-changed nil
4081    vm-message-order-header-present nil
4082    vm-imap-retrieved-messages nil
4083    vm-pop-retrieved-messages nil
4084    vm-summary-buffer nil
4085    vm-system-state nil
4086    vm-undo-record-list nil
4087    vm-undo-record-pointer nil
4088    vm-virtual-buffers (vm-link-to-virtual-buffers)
4089    vm-folder-type (vm-get-folder-type))
4090    (cond ((eq access-method 'pop)
4091           (setq vm-folder-access-method 'pop
4092                 vm-folder-access-data (make-vector 2 nil)))
4093          ((eq access-method 'imap)
4094           (setq vm-folder-access-method 'imap
4095                 vm-folder-access-data (make-vector 9 nil))))
4096   (use-local-map vm-mode-map)
4097   ;; if the user saves after M-x recover-file, let them get new
4098   ;; mail again.
4099   (make-local-hook 'after-save-hook)
4100   (add-hook 'after-save-hook 'vm-unblock-new-mail)
4101   (and (vm-menu-support-possible-p)
4102        (vm-menu-install-menus))
4103   (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder)
4104   (add-hook 'kill-buffer-hook 'vm-garbage-collect-message)
4105   ;; avoid the XEmacs file dialog box.
4106   (defvar use-dialog-box)
4107   (make-local-variable 'use-dialog-box)
4108   (setq use-dialog-box nil)
4109   ;; mail folders are precious.  protect them by default.
4110   (make-local-variable 'file-precious-flag)
4111   (setq file-precious-flag vm-folder-file-precious-flag)
4112   ;; scroll in place messes with scroll-up and this loses
4113   (make-local-variable 'scroll-in-place)
4114   (setq scroll-in-place nil)
4115   (run-hooks 'vm-mode-hook)
4116   ;; compatibility
4117   (run-hooks 'vm-mode-hooks))
4118
4119 (defun vm-link-to-virtual-buffers ()
4120   (let ((b-list (buffer-list))
4121         (vbuffers nil)
4122         (folder-buffer (current-buffer))
4123         folders clauses)
4124     (save-excursion
4125       (while b-list
4126         (set-buffer (car b-list))
4127         (cond ((eq major-mode 'vm-virtual-mode)
4128                (setq clauses (cdr vm-virtual-folder-definition))
4129                (while clauses
4130                  (setq folders (car (car clauses)))
4131                  (while folders
4132                    (if (eq folder-buffer (vm-get-file-buffer
4133                                           (expand-file-name
4134                                            (car folders)
4135                                            vm-folder-directory)))
4136                        (setq vbuffers (cons (car b-list) vbuffers)
4137                              vm-real-buffers (cons folder-buffer
4138                                                    vm-real-buffers)
4139                              folders nil
4140                              clauses nil))
4141                    (setq folders (cdr folders)))
4142                  (setq clauses (cdr clauses)))))
4143         (setq b-list (cdr b-list)))
4144       vbuffers )))
4145
4146 ;;;###autoload
4147 (defun vm-change-folder-type (type)
4148   "Change folder type to TYPE.
4149 TYPE may be one of the following symbol values:
4150
4151     From_
4152     From_-with-Content-Length
4153     BellFrom_
4154     mmdf
4155     babyl
4156
4157 Interactively TYPE will be read from the minibuffer."
4158   (interactive
4159    (let ((this-command this-command)
4160          (last-command last-command)
4161          (types vm-supported-folder-types))
4162      (vm-select-folder-buffer)
4163      (vm-error-if-virtual-folder)
4164      (setq types (vm-delqual (symbol-name vm-folder-type)
4165                              (copy-sequence types)))
4166      (list (intern (vm-read-string "Change folder to type: " types)))))
4167   (vm-select-folder-buffer)
4168   (vm-check-for-killed-summary)
4169   (vm-error-if-virtual-folder)
4170   (vm-error-if-folder-empty)
4171   (if (not (memq type '(From_ BellFrom_ From_-with-Content-Length mmdf babyl)))
4172       (error "Unknown folder type: %s" type))
4173   (if (or (null vm-folder-type)
4174           (eq vm-folder-type 'unknown))
4175       (error "Current folder's type is unknown, can't change it."))
4176   (let ((mp vm-message-list)
4177         (buffer-read-only nil)
4178         (old-type vm-folder-type)
4179         ;; no interruptions
4180         (inhibit-quit t)
4181         (n 0)
4182         ;; Just for laughs, make the update interval vary.
4183         (modulus (+ (% (vm-abs (random)) 11) 5))
4184         text-end opoint)
4185     (save-excursion
4186       (vm-save-restriction
4187        (widen)
4188        (setq vm-folder-type type)
4189        (goto-char (point-min))
4190        (vm-convert-folder-header old-type type)
4191        (while mp
4192          (goto-char (vm-start-of (car mp)))
4193          (setq opoint (point))
4194          (insert (vm-leading-message-separator type (car mp)))
4195          (if (> (vm-headers-of (car mp)) (vm-start-of (car mp)))
4196              (delete-region (point) (vm-headers-of (car mp)))
4197            (set-marker (vm-headers-of (car mp)) (point))
4198            ;; if headers-of == start-of then so could vheaders-of
4199            ;; and text-of.  clear them to force a recompute.
4200            (vm-set-vheaders-of (car mp) nil)
4201            (vm-set-text-of (car mp) nil))
4202          (vm-convert-folder-type-headers old-type type)
4203          (goto-char (vm-text-end-of (car mp)))
4204          (setq text-end (point))
4205          (insert-before-markers (vm-trailing-message-separator type))
4206          (delete-region (vm-text-end-of (car mp)) (vm-end-of (car mp)))
4207          (set-marker (vm-text-end-of (car mp)) text-end)
4208          (goto-char (vm-headers-of (car mp)))
4209          (vm-munge-message-separators type (vm-headers-of (car mp))
4210                                       (vm-text-end-of (car mp)))
4211          (vm-set-byte-count-of (car mp) nil)
4212          (vm-set-babyl-frob-flag-of (car mp) nil)
4213          (vm-set-message-type-of (car mp) type)
4214          ;; Technically we should mark each message for a
4215          ;; summary update since the message byte counts might
4216          ;; have changed.  But I don't think anyone cares that
4217          ;; much and the summary regeneration would make this
4218          ;; process slower.
4219          (setq mp (cdr mp) n (1+ n))
4220          (if (zerop (% n modulus))
4221              (message "Converting... %d" n))))))
4222   (vm-clear-modification-flag-undos)
4223   (intern (buffer-name) vm-buffers-needing-display-update)
4224   (vm-update-summary-and-mode-line)
4225   (message "Conversion complete.")
4226   ;; message separator strings may have leaked into view
4227   (if (> (point-max) (vm-text-end-of (car vm-message-pointer)))
4228       (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer))))
4229   (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type)))
4230
4231 (defun vm-register-global-garbage-files (files)
4232   (while files
4233     (setq vm-global-garbage-alist
4234           (cons (cons (car files) 'delete-file)
4235                 vm-global-garbage-alist)
4236           files (cdr files))))
4237
4238 (defun vm-register-folder-garbage-files (files)
4239   (vm-register-global-garbage-files files)
4240   (save-excursion
4241     (vm-select-folder-buffer)
4242     (while files
4243       (setq vm-folder-garbage-alist
4244             (cons (cons (car files) 'delete-file)
4245                   vm-folder-garbage-alist)
4246             files (cdr files)))))
4247
4248 (defun vm-register-folder-garbage (action garbage)
4249   (save-excursion
4250     (vm-select-folder-buffer)
4251     (setq vm-folder-garbage-alist
4252           (cons (cons garbage action)
4253                 vm-folder-garbage-alist))))
4254
4255 (defun vm-register-message-garbage-files (files)
4256   (vm-register-folder-garbage-files files)
4257   (save-excursion
4258     (vm-select-folder-buffer)
4259     (while files
4260       (setq vm-message-garbage-alist
4261             (cons (cons (car files) 'delete-file)
4262                   vm-message-garbage-alist)
4263             files (cdr files)))))
4264
4265 (defun vm-register-message-garbage (action garbage)
4266   (vm-register-folder-garbage action garbage)
4267   (save-excursion
4268     (vm-select-folder-buffer)
4269     (setq vm-message-garbage-alist
4270           (cons (cons garbage action)
4271                 vm-message-garbage-alist))))
4272
4273 (defun vm-garbage-collect-global ()
4274   (save-excursion
4275     (while vm-global-garbage-alist
4276       (condition-case nil
4277           (funcall (cdr (car vm-global-garbage-alist))
4278                    (car (car vm-global-garbage-alist)))
4279         (error nil))
4280       (setq vm-global-garbage-alist (cdr vm-global-garbage-alist)))))
4281
4282 (defun vm-garbage-collect-folder ()
4283   (save-excursion
4284     (while vm-folder-garbage-alist
4285       (condition-case nil
4286           (funcall (cdr (car vm-folder-garbage-alist))
4287                    (car (car vm-folder-garbage-alist)))
4288         (error nil))
4289       (setq vm-folder-garbage-alist (cdr vm-folder-garbage-alist)))))
4290
4291 (defun vm-garbage-collect-message ()
4292   (save-excursion
4293     (while vm-message-garbage-alist
4294       (condition-case nil
4295           (funcall (cdr (car vm-message-garbage-alist))
4296                    (car (car vm-message-garbage-alist)))
4297         (error nil))
4298       (setq vm-message-garbage-alist (cdr vm-message-garbage-alist)))))
4299
4300 (if (not (memq 'vm-write-file-hook write-file-hooks))
4301     (setq write-file-hooks
4302           (cons 'vm-write-file-hook write-file-hooks)))
4303
4304 (if (not (memq 'vm-handle-file-recovery find-file-hooks))
4305     (setq find-file-hooks
4306           (nconc find-file-hooks
4307                  '(vm-handle-file-recovery
4308                    vm-handle-file-reversion))))
4309
4310 ;; after-revert-hook is new to FSF v19.23
4311 (defvar after-revert-hook)
4312 (if (boundp 'after-revert-hook)
4313     (setq after-revert-hook
4314           (cons 'vm-after-revert-buffer-hook after-revert-hook))
4315   (setq after-revert-hook (list 'vm-after-revert-buffer-hook)))
4316
4317 (provide 'vm-folder)
4318
4319 ;;; vm-folder.el ends here