home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-summary.el < prev    next >
Encoding:
Text File  |  1991-10-21  |  23.5 KB  |  698 lines
  1. ;;; Summary gathering and formatting routines for VM
  2. ;;; Copyright (C) 1989, 1990 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-summary-mode ()
  19.   "Major mode for VM folder summaries.
  20. This major mode uses the same keymap as vm-mode.  See the vm-mode documentation
  21. for a list of available commands."
  22.   (setq mode-name "VM Summary"
  23.     major-mode 'vm-summary-mode
  24.     mode-line-format vm-mode-line-format
  25.     buffer-read-only t
  26.     vm-summary-pointer nil
  27.     truncate-lines t)
  28.   (use-local-map vm-mode-map))
  29.  
  30. (put 'vm-summary-mode 'mode-class 'special)
  31.  
  32. (defun vm-summarize (&optional display)
  33.   "Summarize the contents of the folder in a summary buffer. 
  34. The format is as described by the variable vm-summary-format.  Generally
  35. one line per message is most pleasing to the eye but this is not
  36. mandatory."
  37.   (interactive "p")
  38.   (vm-select-folder-buffer)
  39.   (vm-check-for-killed-summary)
  40.   (vm-error-if-folder-empty)
  41.   (if (null vm-summary-buffer)
  42.       (let ((b (current-buffer))
  43.         (inhibit-quit t))
  44.     (setq vm-summary-buffer
  45.           (get-buffer-create (format "%s Summary" (buffer-name))))
  46.     (save-excursion
  47.       (set-buffer vm-summary-buffer)
  48.       (abbrev-mode 0)
  49.       (auto-fill-mode 0)
  50.       (setq vm-mail-buffer b)
  51.       (vm-summary-mode))
  52.     (setq vm-summary-redo-start-point t)))
  53.   (if display
  54.       (if vm-mutable-windows
  55.       (if (not (vm-set-window-configuration 'summarize))
  56.           (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
  57.         (display-buffer vm-summary-buffer)
  58.         (if (eq vm-mutable-windows t)
  59.             (vm-proportion-windows))))
  60.     (switch-to-buffer vm-summary-buffer)))
  61.   (vm-select-folder-buffer)
  62.   (vm-update-summary-and-mode-line))
  63.  
  64. (defun vm-do-summary (&optional start-point)
  65.   (let ((mp (or start-point vm-message-list))
  66.     (n 0)
  67.     ;; Just for laughs, make the update interval vary.
  68.     (modulus (+ (% (vm-abs (random)) 11) 10))
  69.     summary)
  70.     (message "Generating summary...")
  71.     (save-excursion
  72.       (set-buffer vm-summary-buffer)
  73.       (let ((buffer-read-only nil))
  74.     (if start-point
  75.         (if (vm-su-start-of (car mp))
  76.         (progn
  77.           (goto-char (vm-su-start-of (car mp)))
  78.           (delete-region (point) (point-max)))
  79.           (goto-char (point-max)))
  80.       (erase-buffer)
  81.       (setq vm-summary-pointer nil))
  82.     (while mp
  83.       (set-buffer vm-mail-buffer)
  84.       (setq summary (vm-sprintf 'vm-summary-format (car mp)))
  85.       (set-buffer vm-summary-buffer)
  86.       (vm-set-su-start-of (car mp) (point-marker))
  87.       ;; the leading spaces are for the summary arrow
  88.       (insert "  " summary)
  89.       (vm-set-su-end-of (car mp) (point-marker))
  90.       (setq mp (cdr mp) n (1+ n))
  91.       (if (zerop (% n modulus))
  92.           (message "Generating summary... %d" n)))))
  93.     (message "Generating summary... done")))
  94.  
  95. (defun vm-do-needed-summary-rebuild ()
  96.   (if (and vm-summary-redo-start-point vm-summary-buffer)
  97.       (progn
  98.     (vm-do-summary (and (consp vm-summary-redo-start-point)
  99.                 vm-summary-redo-start-point))
  100.     (setq vm-summary-redo-start-point nil)
  101.     (and vm-message-pointer
  102.          (vm-set-summary-pointer (car vm-message-pointer)))
  103.     (setq vm-need-summary-pointer-update nil))
  104.     (and vm-need-summary-pointer-update
  105.      vm-summary-buffer
  106.      vm-message-pointer
  107.      (progn
  108.        (vm-set-summary-pointer (car vm-message-pointer))
  109.        (setq vm-need-summary-pointer-update nil)))))
  110.  
  111. (defun vm-update-message-summary (m)
  112.   (let ((m-list (cons m
  113.               (and (eq (vm-attributes-of m)
  114.                    (vm-attributes-of (vm-real-message-of m)))
  115.                (vm-virtual-messages-of m))))
  116.     summary)
  117.     (while m-list
  118.       (if (and (vm-su-start-of (car m-list))
  119.            (buffer-name (marker-buffer (vm-su-start-of (car m-list)))))
  120.     (save-excursion
  121.       (setq summary (vm-sprintf 'vm-summary-format (car m-list)))
  122.       (set-buffer (marker-buffer (vm-su-start-of (car m-list))))
  123.       (let ((inhibit-quit t) buffer-read-only)
  124.         (save-excursion
  125.           (goto-char (vm-su-start-of (car m-list)))
  126.           (insert (if (= (following-char) ?\ ) "  " "->") summary)
  127.           (delete-region (point) (vm-su-end-of (car m-list)))))))
  128.       (setq m-list (cdr m-list)))))
  129.  
  130. (defun vm-set-summary-pointer (m)
  131.   (if vm-summary-buffer
  132.       (let ((w (get-buffer-window vm-summary-buffer))
  133.         (old-window nil)
  134.         (inhibit-quit t))
  135.     (vm-save-buffer-excursion
  136.       (unwind-protect
  137.           (progn
  138.         (set-buffer vm-summary-buffer)
  139.         (if w
  140.             (progn
  141.               (setq old-window (selected-window))
  142.               (select-window w)))
  143.         (let ((buffer-read-only nil))
  144.           (if vm-summary-pointer
  145.               (progn
  146.             (goto-char (vm-su-start-of vm-summary-pointer))
  147.             (insert "  ")
  148.             (delete-char 2)))
  149.           (setq vm-summary-pointer m)
  150.           (goto-char (vm-su-start-of m))
  151.           (insert "->")
  152.           (delete-char 2)
  153.           (forward-char -2)
  154.           (and w vm-auto-center-summary (vm-auto-center-summary))))
  155.         (and old-window (select-window old-window)))))))
  156.  
  157. (defun vm-mark-for-display-update (message)
  158.   (setq vm-messages-needing-display-update
  159.     (cons message vm-messages-needing-display-update)))
  160.  
  161. (defun vm-force-mode-line-update ()
  162.   (save-excursion
  163.     (set-buffer (other-buffer))
  164.     (set-buffer-modified-p (buffer-modified-p))))
  165.  
  166. (defun vm-update-summary-and-mode-line ()
  167.   (vm-do-needed-renumbering)
  168.   (vm-do-needed-summary-rebuild)
  169.   (if (null vm-message-pointer)
  170.       ()
  171.     (setq vm-ml-message-number (vm-number-of (car vm-message-pointer)))
  172.     (cond ((vm-new-flag (car vm-message-pointer))
  173.        (setq vm-ml-attributes-string "new"))
  174.       ((vm-unread-flag (car vm-message-pointer))
  175.        (setq vm-ml-attributes-string "unread"))
  176.       (t (setq vm-ml-attributes-string "read")))
  177.     (cond ((vm-edited-flag (car vm-message-pointer))
  178.        (setq vm-ml-attributes-string
  179.          (concat vm-ml-attributes-string " edited"))))
  180.     (cond ((vm-filed-flag (car vm-message-pointer))
  181.        (setq vm-ml-attributes-string
  182.          (concat vm-ml-attributes-string " filed"))))
  183.     (cond ((vm-written-flag (car vm-message-pointer))
  184.        (setq vm-ml-attributes-string
  185.          (concat vm-ml-attributes-string " written"))))
  186.     (cond ((vm-replied-flag (car vm-message-pointer))
  187.        (setq vm-ml-attributes-string
  188.          (concat vm-ml-attributes-string " replied"))))
  189.     (cond ((vm-forwarded-flag (car vm-message-pointer))
  190.        (setq vm-ml-attributes-string
  191.          (concat vm-ml-attributes-string " forwarded"))))
  192.     (cond ((vm-deleted-flag (car vm-message-pointer))
  193.        (setq vm-ml-attributes-string
  194.          (concat vm-ml-attributes-string " deleted"))))
  195.     (cond ((vm-mark-of (car vm-message-pointer))
  196.        (setq vm-ml-attributes-string
  197.          (concat vm-ml-attributes-string " MARKED")))))
  198.   (if (and vm-summary-buffer (not vm-real-buffers))
  199.       (vm-copy-local-variables vm-summary-buffer
  200.                    'vm-ml-attributes-string
  201.                    'vm-ml-message-number
  202.                    'vm-ml-highest-message-number
  203.                    'vm-buffer-modified-p
  204.                    'vm-message-list))
  205.   (while vm-messages-needing-display-update
  206.     (vm-update-message-summary (car vm-messages-needing-display-update))
  207.     (setq vm-messages-needing-display-update
  208.       (cdr vm-messages-needing-display-update)))
  209.   (and vm-deferred-message
  210.        (progn
  211.      (message vm-deferred-message)
  212.      (setq vm-deferred-message nil)))
  213.   (vm-force-mode-line-update))
  214.  
  215. (defun vm-auto-center-summary ()
  216.   (if vm-auto-center-summary
  217.       (if (or (eq vm-auto-center-summary t) (not (one-window-p t)))
  218.       (recenter '(4)))))
  219.  
  220. (defun vm-follow-summary-cursor ()
  221.   (and vm-follow-summary-cursor (eq major-mode 'vm-summary-mode)
  222.        (let ((point (point))
  223.          message-pointer message-list)
  224.      (save-excursion
  225.        (set-buffer vm-mail-buffer)
  226.        (setq message-pointer vm-message-pointer
  227.          message-list vm-message-list))
  228.      (if (or (null message-pointer)
  229.          (and (>= point (vm-su-start-of (car message-pointer)))
  230.               (< point (vm-su-end-of (car message-pointer)))))
  231.          ()
  232.        (if (< point (vm-su-start-of (car message-pointer)))
  233.            (setq mp message-list)
  234.          (setq mp (cdr message-pointer) message-pointer nil))
  235.        (while (and (not (eq mp message-pointer))
  236.                (>= point (vm-su-end-of (car mp))))
  237.          (setq mp (cdr mp)))
  238.        (if (not (eq mp message-pointer))
  239.            (save-excursion
  240.          (set-buffer vm-mail-buffer)
  241.          (vm-record-and-change-message-pointer
  242.           vm-message-pointer mp)
  243.          (setq vm-need-summary-pointer-update t)
  244.          (vm-preview-current-message)
  245.          ;; return non-nil so the caller will know that
  246.          ;; a new message was selected.
  247.          t ))))))
  248.  
  249. (defun vm-sprintf (format-variable message)
  250.   (if (not (eq (get format-variable 'vm-compiled-format)
  251.            (symbol-value format-variable)))
  252.       (vm-compile-format format-variable))
  253.   ;; The local variable name `vm-su-message' is mandatory here for
  254.   ;; the format s-expression to work.
  255.   (let ((vm-su-message message))
  256.     (eval (get format-variable 'vm-format-sexp))))
  257.  
  258. (defun vm-compile-format (format-variable)
  259.   (let ((format (symbol-value format-variable))
  260.     sexp sexp-fmt conv-spec last-match-end case-fold-search)
  261.     (store-match-data nil)
  262.     (while (string-match
  263. "%\\(-\\)?\\([0-9]\\)*\\(\\.\\([0-9]+\\)\\)?\\([aAcdfFhilmMnstTwyz*%]\\)"
  264.         format (match-end 0))
  265.       (setq conv-spec (aref format (match-beginning 5)))
  266.       (if (memq conv-spec '(?a ?A ?c ?d ?f ?F ?h ?i ?l ?M
  267.                 ?m ?n ?s ?t ?T ?w ?y ?z ?*))
  268.       (progn
  269.         (cond ((= conv-spec ?a)
  270.            (setq sexp (cons (list 'vm-su-attribute-indicators
  271.                       'vm-su-message) sexp)))
  272.           ((= conv-spec ?A)
  273.            (setq sexp (cons (list 'vm-su-attribute-indicators-long
  274.                       'vm-su-message) sexp)))
  275.           ((= conv-spec ?c)
  276.            (setq sexp (cons (list 'vm-su-byte-count
  277.                       'vm-su-message) sexp)))
  278.           ((= conv-spec ?d)
  279.            (setq sexp (cons (list 'vm-su-monthday
  280.                       'vm-su-message) sexp)))
  281.           ((= conv-spec ?f)
  282.            (setq sexp (cons (list 'vm-su-from
  283.                       'vm-su-message) sexp)))
  284.           ((= conv-spec ?F)
  285.            (setq sexp (cons (list 'vm-su-full-name
  286.                       'vm-su-message) sexp)))
  287.           ((= conv-spec ?h)
  288.            (setq sexp (cons (list 'vm-su-hour
  289.                       'vm-su-message) sexp)))
  290.           ((= conv-spec ?i)
  291.            (setq sexp (cons (list 'vm-su-message-id
  292.                       'vm-su-message) sexp)))
  293.           ((= conv-spec ?l)
  294.            (setq sexp (cons (list 'vm-su-line-count
  295.                       'vm-su-message) sexp)))
  296.           ((= conv-spec ?m)
  297.            (setq sexp (cons (list 'vm-su-month
  298.                       'vm-su-message) sexp)))
  299.           ((= conv-spec ?M)
  300.            (setq sexp (cons (list 'vm-su-month-number
  301.                       'vm-su-message) sexp)))
  302.           ((= conv-spec ?n)
  303.            (setq sexp (cons (list 'vm-su-message-number
  304.                       'vm-su-message) sexp)))
  305.           ((= conv-spec ?s)
  306.            (setq sexp (cons (list 'vm-su-subject
  307.                       'vm-su-message) sexp)))
  308.           ((= conv-spec ?T)
  309.            (setq sexp (cons (list 'vm-su-to-names
  310.                       'vm-su-message) sexp)))
  311.           ((= conv-spec ?t)
  312.            (setq sexp (cons (list 'vm-su-to
  313.                       'vm-su-message) sexp)))
  314.           ((= conv-spec ?w)
  315.            (setq sexp (cons (list 'vm-su-weekday
  316.                       'vm-su-message) sexp)))
  317.           ((= conv-spec ?y)
  318.            (setq sexp (cons (list 'vm-su-year
  319.                       'vm-su-message) sexp)))
  320.           ((= conv-spec ?z)
  321.            (setq sexp (cons (list 'vm-su-zone
  322.                       'vm-su-message) sexp)))
  323.           ((= conv-spec ?*)
  324.            (setq sexp (cons (list 'vm-su-mark
  325.                       'vm-su-message) sexp))))
  326.         (cond ((match-beginning 1)
  327.            (setcar sexp
  328.                (list 'vm-left-justify-string (car sexp)
  329.                  (string-to-int (substring format
  330.                                (match-beginning 2)
  331.                                (match-end 2))))))
  332.           ((match-beginning 2)
  333.            (setcar sexp
  334.                (list 'vm-right-justify-string (car sexp)
  335.                  (string-to-int (substring format
  336.                                (match-beginning 2)
  337.                                (match-end 2)))))))
  338.         (cond ((match-beginning 3)
  339.            (setcar sexp
  340.                (list 'vm-truncate-string (car sexp)
  341.                  (string-to-int (substring format
  342.                                (match-beginning 4)
  343.                                (match-end 4)))))))
  344.         (setq sexp-fmt
  345.           (cons "%s"
  346.             (cons (substring format
  347.                      (or last-match-end 0)
  348.                      (match-beginning 0))
  349.                   sexp-fmt))))
  350.     (setq sexp-fmt
  351.           (cons "%%"
  352.             (cons (substring format
  353.                      (or last-match-end 0)
  354.                      (match-beginning 0))
  355.               sexp-fmt))))
  356.       (setq last-match-end (match-end 0)))
  357.     (setq sexp-fmt 
  358.       (cons (substring format
  359.                (or last-match-end 0)
  360.                (length format))
  361.         sexp-fmt)
  362.       sexp-fmt (apply 'concat (nreverse sexp-fmt))
  363.       sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
  364.     (put format-variable 'vm-format-sexp sexp)
  365.     (put format-variable 'vm-compiled-format format)))
  366.  
  367. (defun vm-get-header-contents (message header-name)
  368.   (let (contents regexp)
  369.     (setq regexp (format vm-header-regexp-format header-name))
  370.     (save-excursion
  371.       (set-buffer (marker-buffer (vm-start-of message)))
  372.       (save-restriction
  373.     (widen)
  374.     (goto-char (vm-start-of message))
  375.     (while (re-search-forward regexp (vm-text-of message) t)
  376.       (if contents
  377.           (setq contents
  378.             (concat
  379.              contents ", "
  380.              (buffer-substring (match-beginning 1) (match-end 1))))
  381.         (setq contents
  382.           (buffer-substring (match-beginning 1) (match-end 1)))))
  383.     contents))))
  384.  
  385. (defun vm-left-justify-string (string width)
  386.   (if (>= (length string) width)
  387.       string
  388.     (concat string (make-string (- width (length string)) ?\ ))))
  389.  
  390. (defun vm-right-justify-string (string width)
  391.   (if (>= (length string) width)
  392.       string
  393.     (concat (make-string (- width (length string)) ?\ ) string)))
  394.  
  395. (defun vm-truncate-string (string width)
  396.   (if (<= (length string) width)
  397.       string
  398.     (substring string 0 width)))
  399.  
  400. (defun vm-su-attribute-indicators (m)
  401.   (concat
  402.    (cond ((vm-deleted-flag m) "D")
  403.      ((vm-new-flag m) "N")
  404.      ((vm-unread-flag m) "U")
  405.      (t " "))
  406.    (cond ((vm-filed-flag m) "F")
  407.      ((vm-written-flag m) "W")
  408.      (t " "))
  409.    (cond ((vm-replied-flag m) "R")
  410.      ((vm-forwarded-flag m) "Z")
  411.      (t " "))
  412.    (cond ((vm-edited-flag m) "E")
  413.      (t " "))))
  414.  
  415. (defun vm-su-attribute-indicators-long (m)
  416.   (concat
  417.    (cond ((vm-deleted-flag m) "D")
  418.      ((vm-new-flag m) "N")
  419.      ((vm-unread-flag m) "U")
  420.      (t " "))
  421.    (if (vm-replied-flag m) "r" " ")
  422.    (if (vm-forwarded-flag m) "z" " ")
  423.    (if (vm-filed-flag m) "f" " ")
  424.    (if (vm-written-flag m) "w" " ")
  425.    (if (vm-edited-flag m) "e" " ")))
  426.  
  427. (defun vm-su-byte-count (m)
  428.   (or (vm-byte-count-of m)
  429.       (vm-set-byte-count-of m (int-to-string
  430.                    (- (vm-text-end-of m) (vm-text-of m))))))
  431.  
  432. (defun vm-su-weekday (m)
  433.   (or (vm-weekday-of m)
  434.       (progn (vm-su-do-date m) (vm-weekday-of m))))
  435.  
  436. (defun vm-su-monthday (m)
  437.   (or (vm-monthday-of m)
  438.       (progn (vm-su-do-date m) (vm-monthday-of m))))
  439.  
  440. (defun vm-su-month (m)
  441.   (or (vm-month-of m)
  442.       (progn (vm-su-do-date m) (vm-month-of m))))
  443.  
  444. (defun vm-su-month-number (m)
  445.   (or (vm-month-number-of m)
  446.       (progn (vm-su-do-date m) (vm-month-number-of m))))
  447.  
  448. (defun vm-su-year (m)
  449.   (or (vm-year-of m)
  450.       (progn (vm-su-do-date m) (vm-year-of m))))
  451.  
  452. (defun vm-su-hour (m)
  453.   (or (vm-hour-of m)
  454.       (progn (vm-su-do-date m) (vm-hour-of m))))
  455.  
  456. (defun vm-su-zone (m)
  457.   (or (vm-zone-of m)
  458.       (progn (vm-su-do-date m) (vm-zone-of m))))
  459.  
  460. (defun vm-su-mark (m) (if (vm-mark-of m) "*" " "))
  461.  
  462. ;; Some yogurt-headed delivery agents don't provide a Date: header.
  463. (defun vm-grok-From_-date (message)
  464.   ;; If this is MMDF, forget it.
  465.   (if (eq vm-folder-type 'mmdf)
  466.       nil
  467.     (save-excursion
  468.       (set-buffer (marker-buffer (vm-start-of message)))
  469.       (save-restriction
  470.     (widen)
  471.     (goto-char (vm-start-of message))
  472.     (if (looking-at "From [^ \t\n]+[ \t]+\\([^ \t\n].*\\)")
  473.         (buffer-substring (match-beginning 1) (match-end 1)))))))
  474.  
  475. (defun vm-su-do-date (m)
  476.   (let (date)
  477.     (setq date (or (vm-get-header-contents m "Date") (vm-grok-From_-date m)))
  478.     (cond
  479.      ((null date)
  480.       (vm-set-weekday-of m "")
  481.       (vm-set-monthday-of m "")
  482.       (vm-set-month-of m "")
  483.       (vm-set-month-number-of m "")
  484.       (vm-set-year-of m "")
  485.       (vm-set-hour-of m "")
  486.       (vm-set-zone-of m ""))
  487.      ((string-match
  488. ;; The date format recognized here is the one specified in RFC 822.
  489. ;; Some slop is allowed e.g. dashes between the monthday, month and year
  490. ;; because such malformed headers have been observed.
  491. "\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)"
  492.        date)
  493.       (if (match-beginning 2)
  494.       (vm-set-weekday-of m (substring date (match-beginning 2)
  495.                       (match-end 2)))
  496.     (vm-set-weekday-of m ""))
  497.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  498.       (vm-su-do-month m (substring date (match-beginning 4) (match-end 4)))
  499.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  500.       (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
  501.       (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7))))
  502.      ((string-match
  503. ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for
  504. ;; the possibility of a timezone at the end.
  505. "\\([a-z][a-z][a-z]\\)[ \t\n]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*[0-9][0-9]\\([0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?"
  506.        date)
  507.       (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
  508.       (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
  509.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  510.       (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
  511.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  512.       (if (match-beginning 6)
  513.       (vm-set-zone-of m (substring date (match-beginning 6)
  514.                        (match-end 6)))))
  515.      (t
  516.       (vm-set-weekday-of m "")
  517.       (vm-set-monthday-of m "")
  518.       (vm-set-month-of m "")
  519.       (vm-set-month-number-of m "")
  520.       (vm-set-year-of m "")
  521.       (vm-set-hour-of m "")
  522.       (vm-set-zone-of m "")))))
  523.  
  524. (defun vm-su-do-month (m month-abbrev)
  525.   (if (not (boundp 'vm-su-month-sym-jan))
  526.       (setq vm-su-month-sym-jan '("January" "1")
  527.         vm-su-month-sym-feb '("February" "2")
  528.         vm-su-month-sym-mar '("March" "3")
  529.         vm-su-month-sym-apr '("April" "4")
  530.         vm-su-month-sym-may '("May" "5")
  531.         vm-su-month-sym-jun '("June" "6")
  532.         vm-su-month-sym-jul '("July" "7")
  533.         vm-su-month-sym-aug '("August" "8")
  534.         vm-su-month-sym-sep '("September" "9")
  535.         vm-su-month-sym-oct '("October" "10")
  536.         vm-su-month-sym-nov '("November" "11")
  537.         vm-su-month-sym-dec '("December" "12")))
  538.   (condition-case ()
  539.       (let ((val (symbol-value (intern (concat "vm-su-month-sym-"
  540.                            (downcase month-abbrev))))))
  541.     (vm-set-month-of m (car val))
  542.     (vm-set-month-number-of m (car (cdr val))))
  543.     (error (vm-set-month-of m "???")
  544.        (vm-set-month-number-of m "?"))))
  545.  
  546.  
  547. (defun vm-su-full-name (m)
  548.   (or (vm-full-name-of m)
  549.       (progn (vm-su-do-author m) (vm-full-name-of m))))
  550.  
  551. (defun vm-su-from (m)
  552.   (or (vm-from-of m)
  553.       (progn (vm-su-do-author m) (vm-from-of m))))
  554.  
  555. ;; Some yogurt-headed delivery agents don't even provide a From: header.
  556. (defun vm-grok-From_-author (message)
  557.   ;; If this is MMDF, forget it.
  558.   (if (eq vm-folder-type 'mmdf)
  559.       nil
  560.     (save-excursion
  561.       (set-buffer (marker-buffer (vm-start-of message)))
  562.       (save-restriction
  563.     (widen)
  564.     (goto-char (vm-start-of message))
  565.     (if (looking-at "From \\([^ \t\n]+\\)")
  566.         (buffer-substring (match-beginning 1) (match-end 1)))))))
  567.  
  568. (defun vm-su-do-author (m)
  569.   (let (full-name from)
  570.     (setq full-name (vm-get-header-contents m "Full-Name"))
  571.     (setq from (or (vm-get-header-contents m "From") (vm-grok-From_-author m)))
  572.     (cond ((null from)
  573.        (setq from "???")
  574.        (if (null full-name)
  575.            (setq full-name "???")))
  576.       ((string-match "^\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*\\(<\\([^>]+\\)>\\)"
  577.              from)
  578.        (if (and (match-beginning 1) (null full-name))
  579.            (setq full-name
  580.              (substring from (match-beginning 1) (match-end 1))))
  581.        (setq from (substring from (match-beginning 4) (match-end 4))))
  582.       ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" from)
  583.        (if (null full-name)
  584.            (setq full-name (substring from (match-beginning 1)
  585.                       (match-end 1))))
  586.        (setq from
  587.          (concat
  588.           (substring from (match-beginning 0) (1- (match-beginning 1)))
  589.           (substring from (1+ (match-end 1)) (match-end 0))))))
  590.     ;; ewe ewe see pee...
  591.     (if (and vm-gargle-uucp (string-match
  592. "\\([^!@:.]+\\)\\(\\.[^!@:]+\\)?!\\([^!@: \t\n]+\\)\\(@\\([^!@:. \t\n]+\\)\\(.[^ \t\n]+\\)?\\)?[ \t\n]*$"
  593.                  from))
  594.     (setq from
  595.           (concat
  596.            (substring from (match-beginning 3) (match-end 3)) "@"
  597.            (if (and (match-beginning 5) (match-beginning 2)
  598.             (not (match-beginning 6)))
  599.            (concat (substring from (match-beginning 5) (match-end 5))
  600.                ".")
  601.          "")
  602.            (substring from (match-beginning 1)
  603.               (or (match-end 2) (match-end 1)))
  604.            (if (match-end 2) "" ".UUCP"))))
  605.     (if (or (null full-name) (string-match "^[ \t\n]*$" full-name))
  606.     (setq full-name from))
  607.     (vm-set-full-name-of m full-name)
  608.     (vm-set-from-of m from)))
  609.  
  610. (autoload 'rfc822-addresses "rfc822")
  611.  
  612. (defun vm-su-do-recipients (m)
  613.   (let ((mail-use-rfc822 t) names addresses to cc all list)
  614.     (setq to (or (vm-get-header-contents m "To")
  615.          (vm-get-header-contents m "Apparently-To")
  616.          ;; desperation....
  617.          (user-login-name))
  618.       cc (vm-get-header-contents m "Cc")
  619.       all to
  620.       all (if all (concat all ", " cc) cc)
  621.       addresses (rfc822-addresses all))
  622.     (setq list (vm-parse-addresses all))
  623.     (while list
  624.       (cond ((string= (car list) ""))
  625.         ((string-match "^\\(\\([^<]+[^ \t\n]\\)[ \t\n]+\\)?<\\([^>]+\\)>"
  626.                (car list))
  627.          (if (match-beginning 2)
  628.          (setq names
  629.                (cons
  630.             (substring (car list) (match-beginning 2)
  631.                    (match-end 2))
  632.             names))
  633.            (setq names
  634.              (cons
  635.               (substring (car list) (match-beginning 3)
  636.                  (match-end 3))
  637.               names))))
  638.         ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list))
  639.          (setq names
  640.            (cons (substring (car list) (match-beginning 1)
  641.                     (match-end 1))
  642.              names)))
  643.         (t (setq names (cons (car list) names))))
  644.       (setq list (cdr list)))
  645.     (if vm-gargle-uucp
  646.     (while list
  647.       (if (string-match
  648. "\\([^!@:.]+\\)\\(\\.[^!@:]+\\)?!\\([^!@: \t\n]+\\)\\(@\\([^!@:. \t\n]+\\)\\(.[^ \t\n]+\\)?\\)?[ \t\n]*$"
  649.            (car list))
  650.           (setcar
  651.            list
  652.            (concat
  653.         (substring (car list) (match-beginning 3)
  654.                (match-end 3))
  655.         "@"
  656.         (if (and (match-beginning 5) (match-beginning 2)
  657.              (not (match-beginning 6)))
  658.             (concat (substring (car list) (match-beginning 5)
  659.                        (match-end 5))
  660.                 ".")
  661.           "")
  662.         (substring (car list) (match-beginning 1)
  663.                (or (match-end 2) (match-end 1)))
  664.         (if (match-end 2) "" ".UUCP"))))
  665.       (setq list (cdr list))))
  666.     (vm-set-to-of m (mapconcat 'identity addresses ", "))
  667.     (vm-set-to-names-of m (mapconcat 'identity names ", "))))
  668.  
  669. (defun vm-su-to (m)
  670.   (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m))))
  671.  
  672. (defun vm-su-to-names (m)
  673.   (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m))))
  674.                   
  675. (defun vm-su-message-id (m)
  676.   (or (vm-message-id-of m)
  677.       (vm-set-message-id-of m
  678.                 (or (vm-get-header-contents m "Message-Id")
  679.                 ""))))
  680.  
  681. (defun vm-su-line-count (m)
  682.   (or (vm-line-count-of m)
  683.       (vm-set-line-count-of
  684.        m
  685.        (vm-within-current-message-buffer
  686.        (save-restriction
  687.      (widen)
  688.      (int-to-string
  689.       (count-lines (vm-text-of m) (vm-text-end-of m))))))))
  690.  
  691. (defun vm-su-message-number (m)
  692.   (vm-number-of m))
  693.  
  694. (defun vm-su-subject (m)
  695.   (or (vm-subject-of m)
  696.       (vm-set-subject-of m
  697.              (or (vm-get-header-contents m "Subject") ""))))
  698.