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