home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / vm / vm-summary.el < prev    next >
Encoding:
Text File  |  1989-09-11  |  15.8 KB  |  468 lines
  1. ;;; Summary gathering and formatting routines for VM
  2. ;;; Copyright (C) 1989 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. (require 'vm)
  19.  
  20. (defun vm-summary-mode ()
  21.   "Major mode for VM folder summaries.
  22. This major mode use the same keymap as vm-mode.  See the vm-mode documentation
  23. for a list of available commands."
  24.   (setq mode-name "VM Summary"
  25.     major-mode 'vm-summary-mode
  26.     mode-line-buffer-identification    '("VM " vm-version ": %b")
  27.     buffer-read-only t
  28.     overlay-arrow-string "->"
  29.     overlay-arrow-position nil
  30.     truncate-lines t)
  31.   (use-local-map vm-mode-map)
  32.   (save-excursion
  33.     (set-buffer vm-mail-buffer)
  34.     (vm-set-summary-pointer (car vm-message-pointer))))
  35.  
  36. (put 'vm-summary-mode 'mode-class 'special)
  37.  
  38. (defun vm-summarize (&optional dont-redo)
  39.   "Summarize the contents of the folder in a summary buffer. 
  40. The format is as described by the variable vm-summary-format.  Generally
  41. one line per message is most pleasing to the eye but this is not
  42. mandatory."
  43.   (interactive "p")
  44.   (if vm-mail-buffer
  45.       (set-buffer vm-mail-buffer))
  46.   (vm-error-if-folder-empty)
  47.   (if (or (null vm-summary-buffer) (not dont-redo))
  48.       (let ((b (current-buffer))
  49.         (inhibit-quit t))
  50.     (setq vm-summary-buffer
  51.           (get-buffer-create (format "%s Summary" (buffer-name))))
  52.     (save-excursion
  53.       (set-buffer vm-summary-buffer)
  54.       (abbrev-mode 0)
  55.       (auto-fill-mode 0)
  56.       (setq vm-mail-buffer b))
  57.     (vm-do-summary)
  58.     (save-excursion
  59.       (set-buffer vm-summary-buffer)
  60.       (vm-summary-mode))))
  61.   (if vm-mutable-windows
  62.       (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
  63.     (display-buffer vm-summary-buffer))
  64.     (switch-to-buffer vm-summary-buffer))
  65.   (if (eq vm-mutable-windows t)
  66.       (vm-proportion-windows))
  67.   (if vm-mail-buffer
  68.       (set-buffer vm-mail-buffer))
  69.   (vm-set-summary-pointer (car vm-message-pointer)))
  70.  
  71. (defun vm-do-summary ()
  72.   (let ((mp vm-message-list)
  73.     (n 0)
  74.     ;; Just for laughs, make the update interval variable.
  75.     (modulus (+ (% (vm-abs (random)) 7) 10))
  76.     summary)
  77.     (message "Generating summary...")
  78.     (save-excursion
  79.       (set-buffer vm-summary-buffer)
  80.       (let ((buffer-read-only nil))
  81.     (erase-buffer)
  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 to make room for the overlay-arrow-string
  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-update-message-summary (mp)
  96.   (if vm-summary-buffer
  97.       (let ((summary (vm-sprintf 'vm-summary-format (car mp))))
  98.     (save-excursion
  99.       (set-buffer vm-summary-buffer)
  100.       (let ((inhibit-quit t) buffer-read-only)
  101.         (goto-char (vm-su-start-of (car mp)))
  102.         ;; We insert a char here and delete it later to avoid
  103.         ;; markers clumping at the beginning of the summary,
  104.         (insert "*")
  105.         (delete-region (point) (vm-su-end-of (car mp)))
  106.         (insert-before-markers "  " summary)
  107.         (goto-char (vm-su-start-of (car mp)))
  108.         (delete-char 1))))))
  109.  
  110. (defun vm-set-summary-pointer (m)
  111.   (setq overlay-arrow-position (vm-su-start-of m))
  112.   (cond (vm-summary-buffer
  113.      (let ((w (get-buffer-window vm-summary-buffer)))
  114.        (save-excursion
  115.          (set-buffer vm-summary-buffer)
  116.          (goto-char overlay-arrow-position)
  117.          (and w (set-window-point w overlay-arrow-position)))))))
  118.  
  119. (defun vm-follow-summary-cursor ()
  120.   (and vm-follow-summary-cursor (eq major-mode 'vm-summary-mode)
  121.        (let ((point (point))
  122.          message-pointer message-list)
  123.      (save-excursion
  124.        (set-buffer vm-mail-buffer)
  125.        (setq message-pointer vm-message-pointer
  126.          message-list vm-message-list))
  127.      (if (or (null message-pointer)
  128.          (and (>= point (vm-su-start-of (car message-pointer)))
  129.               (< point (vm-su-end-of (car message-pointer)))))
  130.          ()
  131.        (if (< point (vm-su-start-of (car message-pointer)))
  132.            (setq mp message-list)
  133.          (setq mp (cdr message-pointer) message-pointer nil))
  134.        (while (and (not (eq mp message-pointer))
  135.                (>= point (vm-su-end-of (car mp))))
  136.          (setq mp (cdr mp)))
  137.        (if (not (eq mp message-pointer))
  138.            (save-excursion
  139.          (set-buffer vm-mail-buffer)
  140.          (setq vm-last-message-pointer vm-message-pointer
  141.                vm-message-pointer mp)
  142.          (vm-set-summary-pointer (car vm-message-pointer))
  143.          (vm-preview-current-message)
  144.          ;; return non-nil so the caller will know the
  145.          ;; a new message was selected.
  146.          t ))))))
  147.  
  148. (defun vm-sprintf (format-variable message)
  149.   (if (not (eq (get format-variable 'vm-compiled-format)
  150.            (symbol-value format-variable)))
  151.       (vm-compile-format format-variable))
  152.   ;; The local variable name `vm-su-message' is mandatory here for
  153.   ;; the format s-expression to work.
  154.   (let ((vm-su-message message))
  155.     (eval (get format-variable 'vm-format-sexp))))
  156.  
  157. (defun vm-compile-format (format-variable)
  158.   (let ((format (symbol-value format-variable))
  159.     sexp sexp-fmt conv-spec last-match-end case-fold-search)
  160.     (store-match-data nil)
  161.     (while (string-match
  162. "%\\(-\\)?\\([0-9]\\)*\\(\\.\\([0-9]+\\)\\)?\\([acdfFhilmnswyz%]\\)"
  163.         format (match-end 0))
  164.       (setq conv-spec (aref format (match-beginning 5)))
  165.       (if (memq conv-spec '(?a ?c ?d ?f ?F ?h ?i ?l ?m ?n ?s ?w ?y ?z))
  166.       (progn
  167.         (cond ((= conv-spec ?a)
  168.            (setq sexp (cons (list 'vm-su-attribute-indicators
  169.                       'vm-su-message) sexp)))
  170.           ((= conv-spec ?c)
  171.            (setq sexp (cons (list 'vm-su-byte-count
  172.                       'vm-su-message) sexp)))
  173.           ((= conv-spec ?d)
  174.            (setq sexp (cons (list 'vm-su-monthday
  175.                       'vm-su-message) sexp)))
  176.           ((= conv-spec ?f)
  177.            (setq sexp (cons (list 'vm-su-from
  178.                       'vm-su-message) sexp)))
  179.           ((= conv-spec ?F)
  180.            (setq sexp (cons (list 'vm-su-full-name
  181.                       'vm-su-message) sexp)))
  182.           ((= conv-spec ?h)
  183.            (setq sexp (cons (list 'vm-su-hour
  184.                       'vm-su-message) sexp)))
  185.           ((= conv-spec ?i)
  186.            (setq sexp (cons (list 'vm-su-message-id
  187.                       'vm-su-message) sexp)))
  188.           ((= conv-spec ?l)
  189.            (setq sexp (cons (list 'vm-su-line-count
  190.                       'vm-su-message) sexp)))
  191.           ((= conv-spec ?m)
  192.            (setq sexp (cons (list 'vm-su-month
  193.                       'vm-su-message) sexp)))
  194.           ((= conv-spec ?n)
  195.            (setq sexp (cons (list 'vm-su-message-number
  196.                       'vm-su-message) sexp)))
  197.           ((= conv-spec ?s)
  198.            (setq sexp (cons (list 'vm-su-subject
  199.                       'vm-su-message) sexp)))
  200.           ((= conv-spec ?w)
  201.            (setq sexp (cons (list 'vm-su-weekday
  202.                       'vm-su-message) sexp)))
  203.           ((= conv-spec ?y)
  204.            (setq sexp (cons (list 'vm-su-year
  205.                       'vm-su-message) sexp)))
  206.           ((= conv-spec ?z)
  207.            (setq sexp (cons (list 'vm-su-zone
  208.                       'vm-su-message) sexp))))
  209.         (cond ((match-beginning 1)
  210.            (setcar sexp
  211.                (list 'vm-left-justify-string (car sexp)
  212.                  (string-to-int (substring format
  213.                                (match-beginning 2)
  214.                                (match-end 2))))))
  215.           ((match-beginning 2)
  216.            (setcar sexp
  217.                (list 'vm-right-justify-string (car sexp)
  218.                  (string-to-int (substring format
  219.                                (match-beginning 2)
  220.                                (match-end 2)))))))
  221.         (cond ((match-beginning 3)
  222.            (setcar sexp
  223.                (list 'vm-truncate-string (car sexp)
  224.                  (string-to-int (substring format
  225.                                (match-beginning 4)
  226.                                (match-end 4)))))))
  227.         (setq sexp-fmt
  228.           (cons "%s"
  229.             (cons (substring format
  230.                      (or last-match-end 0)
  231.                      (match-beginning 0))
  232.                   sexp-fmt))))
  233.     (setq sexp-fmt
  234.           (cons "%%"
  235.             (cons (substring format
  236.                      (or last-match-end 0)
  237.                      (match-beginning 0))
  238.               sexp-fmt))))
  239.       (setq last-match-end (match-end 0)))
  240.     (setq sexp-fmt 
  241.       (cons (substring format
  242.                (or last-match-end 0)
  243.                (length format))
  244.         sexp-fmt)
  245.       sexp-fmt (apply 'concat (nreverse sexp-fmt))
  246.       sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
  247.     (put format-variable 'vm-format-sexp sexp)
  248.     (put format-variable 'vm-compiled-format format)))
  249.  
  250. (defun vm-get-header-contents (message header-name)
  251.   (let (contents regexp)
  252.     (setq regexp (format vm-header-regexp-format header-name))
  253.     (save-excursion
  254.       (set-buffer (marker-buffer (vm-start-of message)))
  255.       (save-restriction
  256.     (widen)
  257.     (goto-char (vm-start-of message))
  258.     (while (re-search-forward regexp (vm-text-of message) t)
  259.       (if contents
  260.           (setq contents
  261.             (concat
  262.              contents ",\n\t"
  263.              (buffer-substring (match-beginning 1) (match-end 1))))
  264.         (setq contents
  265.           (buffer-substring (match-beginning 1) (match-end 1)))))
  266.     contents))))
  267.  
  268. (defun vm-left-justify-string (string width)
  269.   (if (>= (length string) width)
  270.       string
  271.     (concat string (make-string (- width (length string)) ?\ ))))
  272.  
  273. (defun vm-right-justify-string (string width)
  274.   (if (>= (length string) width)
  275.       string
  276.     (concat (make-string (- width (length string)) ?\ ) string)))
  277.  
  278. (defun vm-truncate-string (string width)
  279.   (if (<= (length string) width)
  280.       string
  281.     (substring string 0 width)))
  282.  
  283. (defun vm-su-attribute-indicators (m)
  284.   (concat
  285.    (cond ((vm-deleted-flag m) "D")
  286.      ((vm-new-flag m) "N")
  287.      ((vm-unread-flag m) "U")
  288.      (t " "))
  289.    (cond ((vm-filed-flag m) "F")
  290.      (t " "))
  291.    (cond ((vm-replied-flag m) "R")
  292.      (t " "))))
  293.  
  294. (defun vm-su-byte-count (m)
  295.   (or (vm-byte-count-of m)
  296.       (vm-set-byte-count-of m (int-to-string
  297.                    (- (vm-text-end-of m) (vm-text-of m))))))
  298.  
  299. (defun vm-su-weekday (m)
  300.   (or (vm-weekday-of m)
  301.       (progn (vm-su-do-date m) (vm-weekday-of m))))
  302.  
  303. (defun vm-su-monthday (m)
  304.   (or (vm-monthday-of m)
  305.       (progn (vm-su-do-date m) (vm-monthday-of m))))
  306.  
  307. (defun vm-su-month (m)
  308.   (or (vm-month-of m)
  309.       (progn (vm-su-do-date m) (vm-month-of m))))
  310.  
  311. (defun vm-su-year (m)
  312.   (or (vm-year-of m)
  313.       (progn (vm-su-do-date m) (vm-year-of m))))
  314.  
  315. (defun vm-su-hour (m)
  316.   (or (vm-hour-of m)
  317.       (progn (vm-su-do-date m) (vm-hour-of m))))
  318.  
  319. (defun vm-su-zone (m)
  320.   (or (vm-zone-of m)
  321.       (progn (vm-su-do-date m) (vm-zone-of m))))
  322.  
  323. ;; Some yogurt-headed delivery agents don't even provide a Date: header.
  324. (defun vm-grok-From_-date (message)
  325.   ;; If this is MMDF, forget it.
  326.   (if (eq vm-folder-type 'mmdf)
  327.       nil
  328.     (save-excursion
  329.       (set-buffer (marker-buffer (vm-start-of message)))
  330.       (save-restriction
  331.     (widen)
  332.     (goto-char (vm-start-of message))
  333.     (if (looking-at "From [^ \t\n]+[ \t]+\\([^ \t\n].*\\)")
  334.         (buffer-substring (match-beginning 1) (match-end 1)))))))
  335.  
  336. (defun vm-su-do-date (m)
  337.   (let (date)
  338.     (setq date (or (vm-get-header-contents m "Date") (vm-grok-From_-date m)))
  339.     (cond
  340.      ((null date)
  341.       (vm-set-weekday-of m "")
  342.       (vm-set-monthday-of m "")
  343.       (vm-set-month-of m "")
  344.       (vm-set-year-of m "")
  345.       (vm-set-hour-of m "")
  346.       (vm-set-zone-of m ""))
  347.      ((string-match
  348. ;; The date format recognized here is the one specified in RFC 822.
  349. ;; Some slop is allowed e.g. dashes between the monthday, month and year
  350. ;; because such malformed headers headers have been observed.
  351. "\\(\\([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]\\)"
  352.        date)
  353.       (if (match-beginning 2)
  354.       (vm-set-weekday-of m (substring date (match-beginning 2)
  355.                       (match-end 2)))
  356.     (vm-set-weekday-of m ""))
  357.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  358.       (vm-set-month-of m (substring date (match-beginning 4) (match-end 4)))
  359.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  360.       (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
  361.       (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7))))
  362.      ((string-match
  363. ;; UNIX ctime(3) format with slop allowed in the whitespace and we allow for
  364. ;; the possibility of a timezone at the end.
  365. "\\([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]\\)?"
  366.        date)
  367.       (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
  368.       (vm-set-month-of m (substring date (match-beginning 2) (match-end 2)))
  369.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  370.       (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
  371.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  372.       (if (match-beginning 6)
  373.       (vm-set-zone-of m (substring date (match-beginning 6)
  374.                        (match-end 6)))))
  375.      (t
  376.       (vm-set-weekday-of m "")
  377.       (vm-set-monthday-of m "")
  378.       (vm-set-month-of m "")
  379.       (vm-set-year-of m "")
  380.       (vm-set-hour-of m "")
  381.       (vm-set-zone-of m "")))))
  382.  
  383. (defun vm-su-full-name (m)
  384.   (or (vm-full-name-of m)
  385.       (progn (vm-su-do-author m) (vm-full-name-of m))))
  386.  
  387. (defun vm-su-from (m)
  388.   (or (vm-from-of m)
  389.       (progn (vm-su-do-author m) (vm-from-of m))))
  390.  
  391. ;; Some yogurt-headed delivery agents don't even provide a From: header.
  392. (defun vm-grok-From_-author (message)
  393.   ;; If this is MMDF, forget it.
  394.   (if (eq vm-folder-type 'mmdf)
  395.       nil
  396.     (save-excursion
  397.       (set-buffer (marker-buffer (vm-start-of message)))
  398.       (save-restriction
  399.     (widen)
  400.     (goto-char (vm-start-of message))
  401.     (if (looking-at "From \\([^ \t\n]+\\)")
  402.         (buffer-substring (match-beginning 1) (match-end 1)))))))
  403.  
  404. (defun vm-su-do-author (m)
  405.   (let (full-name from)
  406.     (setq full-name (vm-get-header-contents m "Full-Name"))
  407.     (setq from (or (vm-get-header-contents m "From") (vm-grok-From_-author m)))
  408.     (cond ((null from)
  409.        (setq from "???")
  410.        (if (null full-name)
  411.            (setq full-name "???")))
  412.       ((string-match "^\\(\\([^<]+[^ \t\n]\\)[ \t\n]+\\)?<\\([^>]+\\)>"
  413.              from)
  414.        (if (and (match-beginning 2) (null full-name))
  415.            (setq full-name
  416.              (substring from (match-beginning 2) (match-end 2))))
  417.        (setq from (substring from (match-beginning 3) (match-end 3))))
  418.       ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" from)
  419.        (if (null full-name)
  420.            (setq full-name (substring from (match-beginning 1)
  421.                       (match-end 1))))
  422.        (setq from
  423.          (concat
  424.           (substring from (match-beginning 0) (1- (match-beginning 1)))
  425.           (substring from (1+ (match-end 1)) (match-end 0))))))
  426.     ;; ewe ewe see pee...
  427.     (if (and vm-gargle-uucp (string-match
  428. "\\([^!@:.]+\\)\\(\\.[^!@:]+\\)?!\\([^!@: \t\n]+\\)\\(@\\([^!@:. \t\n]+\\)\\(.[^ \t\n]+\\)?\\)?[ \t\n]*$"
  429.                  from))
  430.     (setq from
  431.           (concat
  432.            (substring from (match-beginning 3) (match-end 3)) "@"
  433.            (if (and (match-beginning 5) (match-beginning 2)
  434.             (not (match-beginning 6)))
  435.            (concat (substring from (match-beginning 5) (match-end 5))
  436.                ".")
  437.          "")
  438.            (substring from (match-beginning 1)
  439.               (or (match-end 2) (match-end 1)))
  440.            (if (match-end 2) "" ".UUCP"))))
  441.     (if (or (null full-name) (string-match "^[ \t\n]*$" full-name))
  442.     (setq full-name from))
  443.     (vm-set-full-name-of m full-name)
  444.     (vm-set-from-of m from)))
  445.  
  446. (defun vm-su-message-id (m)
  447.   (or (vm-message-id-of m)
  448.       (vm-set-message-id-of m
  449.                 (or (vm-get-header-contents m "Message-Id")
  450.                 ""))))
  451.  
  452. (defun vm-su-line-count (m)
  453.   (or (vm-line-count-of m)
  454.       (vm-set-line-count-of
  455.        m
  456.        (save-restriction
  457.      (widen)
  458.      (int-to-string
  459.       (count-lines (vm-text-of m) (vm-text-end-of m)))))))
  460.  
  461. (defun vm-su-message-number (m)
  462.   (vm-number-of m))
  463.  
  464. (defun vm-su-subject (m)
  465.   (or (vm-subject-of m)
  466.       (vm-set-subject-of m
  467.              (or (vm-get-header-contents m "Subject") ""))))
  468.