home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / imail / imail-summary.scm < prev    next >
Text File  |  2001-05-23  |  29KB  |  794 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-summary.scm,v 1.42 2001/05/23 05:05:16 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. ;;; 02111-1307, USA.
  21.  
  22. ;;;; IMAIL mail reader: summary buffer
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-variable imail-summary-pop-up-message
  27.   "If true, selecting a message in the IMAIL summary buffer pops up the
  28.  message buffer in a separate window.
  29. If false, the message buffer is updated but not popped up."
  30.   #t
  31.   boolean?)
  32.  
  33. (define-variable imail-summary-auto-select
  34.   "If true, some cursor motion commands cause automatic message selection.
  35. If false, these commands move the cursor but don't select messages.
  36. The commands affected are:
  37.     \\[imail-summary-next-message]
  38.     \\[imail-summary-previous-message]
  39.     \\[imail-summary-first-message]
  40.     \\[imail-summary-last-message]"
  41.   #t
  42.   boolean?)
  43.  
  44. (define-variable imail-summary-highlight-message
  45.   "If true, the selected message is highlighted in the summary buffer."
  46.   #t
  47.   boolean?)
  48.  
  49. (define-variable imail-summary-show-date
  50.   "If true, an abbreviated date field is shown."
  51.   #f
  52.   boolean?)
  53.  
  54. (define-variable imail-summary-subject-width
  55.   "Width of the subject field, in characters."
  56.   35
  57.   exact-nonnegative-integer?)
  58.  
  59. (define-variable imail-summary-height
  60.   "Height of the summary window, either in lines or as a fraction.
  61. An exact positive integer means a fixed number of lines.
  62. A real number between 0 and 1 exclusive means a fraction of the screen height."
  63.   1/4
  64.   (lambda (x)
  65.     (or (and (exact-integer? x) (positive? x))
  66.     (and (real? x) (< 0 x 1)))))
  67.  
  68. (define-variable imail-summary-fixed-layout
  69.   "If true, summary buffer is linked to folder buffer in fixed layout.
  70. Selecting either buffer causes both to be selected,
  71.  in a standard window configuration.
  72. Once selected, selecting another buffer causes the window configuration
  73.  to be restored to a single window."
  74.   #f
  75.   boolean?)
  76.  
  77. (define-command imail-summary
  78.   "Display a summary of the selected folder, one line per message."
  79.   ()
  80.   (lambda () (imail-summary "All" #f)))
  81.  
  82. (define-command imail-summary-by-flags
  83.   "Display a summary of all messages with one or more FLAGS.
  84. FLAGS is a string containing the desired labels, separated by commas."
  85.   (lambda ()
  86.     (list (imail-prompt-for-flags "Flags to summarize by")))
  87.   (lambda (flags-string)
  88.     (imail-summary (string-append "Flags " flags-string)
  89.            (let ((flags (burst-comma-list-string flags-string)))
  90.              (lambda (m)
  91.                (there-exists? (message-flags m)
  92.              (lambda (flag)
  93.                (flags-member? flag flags))))))))
  94.  
  95. (define-command imail-summary-by-recipients
  96.   "Display a summary of all messages with the given RECIPIENTS.
  97. Normally checks the To, From and Cc fields of headers;
  98. but if prefix arg is given, only look in the To and From fields.
  99. RECIPIENTS is a string of regexps separated by commas."
  100.   "sRecipients to summarize by\nP"
  101.   (lambda (recipients-string primary-only?)
  102.     (imail-summary
  103.      (string-append "Recipients " recipients-string)
  104.      (let ((regexp
  105.         (apply regexp-group (burst-comma-list-string recipients-string))))
  106.        (let ((try
  107.           (lambda (s)
  108.         (and s
  109.              (re-string-search-forward regexp s #t)))))
  110.      (lambda (m)
  111.        (or (try (get-first-header-field-value m "from" #f))
  112.            (try (get-first-header-field-value m "to" #f))
  113.            (and (not primary-only?)
  114.             (try (get-first-header-field-value m "cc" #f))))))))))
  115.  
  116. (define-command imail-summary-by-regexp
  117.   "Display a summary of all messages according to regexp REGEXP.
  118. If the regular expression is found in the header of the message
  119. \(including in the date and other lines, as well as the subject line),
  120. Edwin will list the header line in the summary."
  121.   "sRegexp to summarize by"
  122.   (lambda (regexp)
  123.     (imail-summary
  124.      (string-append "Regular expression " regexp)
  125.      (let ((case-fold? (ref-variable case-fold-search)))
  126.        (lambda (m)
  127.      (re-string-search-forward regexp
  128.                    (header-fields->string
  129.                     (message-header-fields m))
  130.                    case-fold?))))))
  131.  
  132. (define-command imail-summary-by-topic
  133.   "Display a summary of all messages with the given SUBJECT.
  134. Checks the Subject field of headers.
  135. SUBJECT is a string of regexps separated by commas."
  136.   "sTopics to summarize by"
  137.   (lambda (regexps-string)
  138.     (imail-summary
  139.      (string-append "About " regexps-string)
  140.      (let ((regexp
  141.         (apply regexp-group (burst-comma-list-string regexps-string)))
  142.        (case-fold? (ref-variable case-fold-search)))
  143.        (lambda (m)
  144.      (let ((s (get-first-header-field-value m "subject" #f)))
  145.        (and s
  146.         (re-string-search-forward regexp s case-fold?))))))))
  147.  
  148. (define (imail-summary description predicate)
  149.   (let* ((folder (selected-folder))
  150.      (folder-buffer (imail-folder->buffer folder #t))
  151.      (buffer
  152.       (let ((buffer (buffer-get folder-buffer 'IMAIL-SUMMARY-BUFFER #f)))
  153.         (or (and buffer
  154.              (if (buffer-alive? buffer)
  155.              buffer
  156.              (begin
  157.                (buffer-remove! folder-buffer 'IMAIL-SUMMARY-BUFFER)
  158.                #f)))
  159.         (let ((buffer
  160.                (new-buffer
  161.             (string-append (buffer-name folder-buffer)
  162.                        "-summary"))))
  163.           (without-interrupts
  164.            (lambda ()
  165.              (add-kill-buffer-hook buffer imail-summary-detach)
  166.              (receive-modification-events
  167.               folder
  168.               imail-summary-modification-event)
  169.              (buffer-put! folder-buffer 'IMAIL-SUMMARY-BUFFER buffer)
  170.              (associate-buffer-with-imail-buffer folder-buffer buffer)
  171.              (buffer-put! buffer 'IMAIL-NAVIGATORS
  172.                   (imail-summary-navigators buffer))
  173.              (if (ref-variable imail-summary-fixed-layout buffer)
  174.              (create-buffer-layout imail-summary-layout-selector
  175.                            (list buffer folder-buffer)))))
  176.           buffer)))))
  177.     (buffer-put! buffer 'IMAIL-SUMMARY-DESCRIPTION description)
  178.     (buffer-put! buffer 'IMAIL-SUMMARY-PREDICATE predicate)
  179.     (if (not (selected-buffer? buffer))
  180.     (let ((windows (buffer-windows buffer)))
  181.       (if (pair? windows)
  182.           (select-window (car windows))
  183.           (select-buffer buffer))))
  184.     (preload-folder-outlines folder)
  185.     (rebuild-imail-summary-buffer buffer)))
  186.  
  187. (define (imail-summary-detach buffer)
  188.   (let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f)))
  189.     (if folder-buffer
  190.     (begin
  191.       (buffer-remove! folder-buffer 'IMAIL-SUMMARY-BUFFER)
  192.       (let ((folder (buffer-get folder-buffer 'IMAIL-FOLDER #f)))
  193.         (if folder
  194.         (ignore-modification-events
  195.          folder
  196.          imail-summary-modification-event)))))))
  197.  
  198. (define (imail-folder->summary-buffer folder error?)
  199.   (or (let ((buffer (imail-folder->buffer folder error?)))
  200.     (and buffer
  201.          (buffer-get buffer 'IMAIL-SUMMARY-BUFFER #f)))
  202.       (and error?
  203.        (error:bad-range-argument folder 'IMAIL-FOLDER->SUMMARY-BUFFER))))
  204.  
  205. (define (imail-summary-buffer->folder buffer error?)
  206.   (or (let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f)))
  207.     (and folder-buffer
  208.          (buffer-get folder-buffer 'IMAIL-FOLDER #f)))
  209.       (and error?
  210.        (error:bad-range-argument buffer 'IMAIL-SUMMARY-BUFFER->FOLDER))))
  211.  
  212. (define (imail-summary-layout-selector window buffers)
  213.   (let ((summary-buffer (car buffers))
  214.     (folder-buffer (cadr buffers)))
  215.     (select-buffer summary-buffer window)
  216.     (let ((w (window-split-vertically! window (imail-summary-height window))))
  217.       (if w
  218.       (select-buffer folder-buffer w)))))
  219.  
  220. (define (imail-summary-modification-event folder type parameters)
  221.   (let ((buffer (imail-folder->summary-buffer folder #f)))
  222.     (if buffer
  223.     (case type
  224.       ((FLAGS)
  225.        (let ((message (car parameters)))
  226.          (call-with-values
  227.          (lambda () (imail-summary-find-message buffer message))
  228.            (lambda (mark approximate?)
  229.          (if (and mark (not approximate?))
  230.              (begin
  231.                (let ((mark (mark+ mark 1 'ERROR)))
  232.              (with-read-only-defeated mark
  233.                (lambda ()
  234.                  (group-replace-string!
  235.                   (mark-group mark)
  236.                   (mark-index mark)
  237.                   (message-flag-markers message)))))
  238.                (buffer-not-modified! buffer)))))))
  239.       ((SELECT-MESSAGE)
  240.        (let ((message (car parameters)))
  241.          (if message
  242.          (imail-summary-select-message buffer message))))
  243.       ((EXPUNGE INCREASE-LENGTH SET-LENGTH)
  244.        (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer))))))
  245.  
  246. ;;;; Summary content generation
  247.  
  248. (define (rebuild-imail-summary-buffer buffer)
  249.   (let ((folder (selected-folder #f buffer)))
  250.     (if folder
  251.     (begin
  252.       (buffer-widen! buffer)
  253.       (with-read-only-defeated (buffer-start buffer)
  254.         (lambda ()
  255.           (region-delete! (buffer-region buffer))
  256.           (fill-imail-summary-buffer! buffer
  257.                       folder
  258.                       (buffer-get buffer
  259.                               'IMAIL-SUMMARY-PREDICATE
  260.                               #f))))
  261.       (set-buffer-major-mode! buffer (ref-mode-object imail-summary))
  262.       (buffer-not-modified! buffer)
  263.       (set-buffer-point! buffer (imail-summary-first-line buffer))
  264.       (let ((message
  265.          (selected-message #f
  266.                    (buffer-get buffer
  267.                            'IMAIL-FOLDER-BUFFER #f))))
  268.         (if message
  269.         (imail-summary-select-message buffer message)))))))
  270.  
  271. (define (fill-imail-summary-buffer! buffer folder predicate)
  272.   (let ((end (folder-length folder)))
  273.     (let ((messages
  274.        (let loop ((i 0) (messages '()))
  275.          (if (< i end)
  276.          (loop (+ i 1) (cons (get-message folder i) messages))
  277.          (reverse! messages))))
  278.       (index-digits (exact-nonnegative-integer-digits end))
  279.       (show-date? (ref-variable imail-summary-show-date buffer))
  280.       (subject-width (imail-summary-subject-width buffer)))
  281.       (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
  282.     (insert-string " Flags" mark)
  283.     (insert-string " " mark)
  284.     (insert-chars #\# index-digits mark)
  285.     (insert-string " Length" mark)
  286.     (if show-date? (insert-string "  Date " mark))
  287.     (insert-string "  " mark)
  288.     (insert-string-pad-right "Subject" subject-width #\space mark)
  289.     (insert-string "  " mark)
  290.     (insert-string "From" mark)
  291.     (insert-newline mark)
  292.     (insert-string " -----" mark)
  293.     (insert-string " " mark)
  294.     (insert-chars #\- index-digits mark)
  295.     (insert-string " ------" mark)
  296.     (if show-date? (insert-string " ------" mark))
  297.     (insert-string "  " mark)
  298.     (insert-chars #\- subject-width mark)
  299.     (insert-string "  " mark)
  300.     (insert-chars #\-
  301.               (max 4 (- (mark-x-size mark) (+ (mark-column mark) 1)))
  302.               mark)
  303.     (insert-newline mark)
  304.     (for-each (lambda (message)
  305.             (if (or (not predicate) (predicate message))
  306.             (write-imail-summary-line! message index-digits mark)))
  307.           messages)
  308.     (mark-temporary! mark)))))
  309.  
  310. (define (write-imail-summary-line! message index-digits mark)
  311.   (insert-char #\space mark)
  312.   (insert-string (message-flag-markers message) mark)
  313.   (insert-char #\space mark)
  314.   (insert-string-pad-left (number->string (+ (message-index message) 1))
  315.               index-digits #\space mark)
  316.   (insert-string "  " mark)
  317.   (insert-string (message-summary-length-string message) mark)
  318.   (if (ref-variable imail-summary-show-date mark)
  319.       (begin
  320.     (insert-string " " mark)
  321.     (insert-string (message-summary-date-string message) mark)))
  322.   (insert-string "  " mark)
  323.   (let ((target-column
  324.      (+ (mark-column mark) (imail-summary-subject-width mark))))
  325.     (insert-string (message-summary-subject-string message) mark)
  326.     (if (> (mark-column mark) target-column)
  327.     (delete-string (move-to-column mark target-column) mark))
  328.     (if (< (mark-column mark) target-column)
  329.     (insert-chars #\space (- target-column (mark-column mark)) mark)))
  330.   (insert-string "  " mark)
  331.   (insert-string (message-summary-from-string message) mark)
  332.   (insert-newline mark))
  333.  
  334. (define (imail-summary-subject-width mark)
  335.   (max (ref-variable imail-summary-subject-width mark)
  336.        (string-length "Subject")))
  337.  
  338. (define (message-flag-markers message)
  339.   (let ((s (make-string 5 #\space)))
  340.     (let ((do-flag
  341.        (lambda (index char boolean)
  342.          (if boolean
  343.          (string-set! s index char)))))
  344.       (do-flag 0 #\D (message-deleted? message))
  345.       (do-flag 1 #\U (message-unseen? message))
  346.       (do-flag 2 #\A (message-answered? message))
  347.       (do-flag 3 #\R
  348.            (or (message-resent? message)
  349.            (message-forwarded? message)))
  350.       (do-flag 4 #\F (message-filed? message)))
  351.     s))
  352.  
  353. (define (message-summary-length-string message)
  354.   (abbreviate-exact-nonnegative-integer (message-length message) 5))
  355.  
  356. (define (message-summary-date-string message)
  357.   (let ((t (message-time message)))
  358.     (if t
  359.     (let ((dt (universal-time->local-decoded-time t)))
  360.       (string-append
  361.        (string-pad-left (number->string (decoded-time/day dt)) 2)
  362.        " "
  363.        (month/short-string (decoded-time/month dt))))
  364.     (make-string 6 #\space))))
  365.  
  366. (define (message-summary-from-string message)
  367.   (let* ((s
  368.       (decorated-string-append
  369.        "" " " ""
  370.        (map string-trim
  371.         (string->lines
  372.          (or (get-first-header-field-value message "from" #f) "")))))
  373.      (field (lambda (n) (lambda (regs) (re-match-extract s regs n)))))
  374.     (cond ((re-string-search-forward "[ \t\"]*\\<\\(.*\\)\\>[\" \t]*<.*>" s)
  375.        => (field 1))
  376.       ;; Chris VanHaren (Athena User Consultant) <vanharen>
  377.       ((re-string-search-forward "[ \t\"]*\\<\\(.*\\)\\>.*(.*).*<.*>.*" s)
  378.        => (field 1))
  379.       ((re-string-search-forward ".*(\\(.*\\))" s)
  380.        => (field 1))
  381.       ((re-string-search-forward ".*<\\(.*\\)>.*" s)
  382.        => (field 1))
  383.       ((re-string-search-forward " *\\<\\(.*\\)\\> *" s)
  384.        => (field 1))
  385.       (else s))))
  386.  
  387. (define (message-summary-subject-string message)
  388.   (let ((s
  389.      (let ((s (or (get-first-header-field-value message "subject" #f) "")))
  390.        (let ((regs (re-string-match "\\(re:[ \t]*\\)+" s #t)))
  391.          (if regs
  392.          (string-tail s (re-match-end-index 0 regs))
  393.          s)))))
  394.     (let ((i (string-find-next-char s #\newline)))
  395.       (if i
  396.       (string-head s i)
  397.       s))))
  398.  
  399. ;;;; Navigation
  400.  
  401. (define (imail-summary-navigators buffer)
  402.  
  403.   (define (first-unseen-message folder)
  404.     (let loop ((message (first-message folder)))
  405.       (and message
  406.        (if (message-unseen? message)
  407.            message
  408.            (loop (next-message message #f))))))
  409.  
  410.   (define (first-message folder)
  411.     (imail-summary-navigator/edge buffer folder
  412.                   (imail-summary-first-line buffer)))
  413.  
  414.   (define (last-message folder)
  415.     (imail-summary-navigator/edge buffer folder
  416.                   (imail-summary-last-line buffer)))
  417.  
  418.   (define (next-message message predicate)
  419.     (imail-summary-navigator/delta buffer message predicate 1))
  420.  
  421.   (define (previous-message message predicate)
  422.     (imail-summary-navigator/delta buffer message predicate -1))
  423.  
  424.   (make-imail-navigators first-unseen-message
  425.              first-message
  426.              last-message
  427.              next-message
  428.              previous-message
  429.              imail-summary-navigator/selected-message))
  430.  
  431. (define (imail-summary-navigator/edge buffer folder mark)
  432.   (and folder
  433.        (eq? folder (imail-summary-buffer->folder buffer #f))
  434.        (let ((index (imail-summary-selected-message-index mark)))
  435.      (and index
  436.           (< index (folder-length folder))
  437.           (get-message folder index)))))
  438.  
  439. (define (imail-summary-navigator/delta buffer message predicate delta)
  440.   (let ((folder (message-folder message)))
  441.     (and folder
  442.      (eq? folder (imail-summary-buffer->folder buffer #f))
  443.      (let loop
  444.          ((m
  445.            (call-with-values
  446.            (lambda () (imail-summary-find-message buffer message))
  447.          (lambda (m approximate?)
  448.            (if (and approximate?
  449.                 ((if (< delta 0) < >)
  450.                  (imail-summary-selected-message-index m)
  451.                  (message-index message)))
  452.                m
  453.                (and m (line-start m delta #f)))))))
  454.        (and m
  455.         (let ((index (imail-summary-selected-message-index m)))
  456.           (and index
  457.                (< index (folder-length folder))
  458.                (let ((message (get-message folder index)))
  459.              (if (or (not predicate) (predicate message))
  460.                  message
  461.                  (loop (line-start m delta #f)))))))))))
  462.  
  463. (define (imail-summary-navigator/selected-message buffer)
  464.   (or (let ((index
  465.          (let ((point (buffer-point buffer)))
  466.            (let loop ((offset 0))
  467.          (let ((next (line-start point offset #f))
  468.                (prev (line-start point (- offset) #f)))
  469.            (or (and next (imail-summary-selected-message-index next))
  470.                (and prev (imail-summary-selected-message-index prev))
  471.                (and (or next prev)
  472.                 (loop (+ offset 1)))))))))
  473.     (and index
  474.          (let ((folder (imail-summary-buffer->folder buffer #t)))
  475.            (and (< index (folder-length folder))
  476.             (get-message folder index)))))
  477.       (selected-message #f (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f))))
  478.  
  479. (define (imail-summary-selected-message-index mark)
  480.   (and (imail-summary-match-line mark)
  481.        (- (string->number
  482.        (extract-string (re-match-start 1) (re-match-end 1)))
  483.       1)))
  484.  
  485. (define (imail-summary-match-line mark)
  486.   (re-match-forward
  487.    (string-append
  488.     "[* ][D ][U ][A ][R ][F ] +\\([0-9]+\\)  +\\([0-9.]+[a-zA-Z ]\\)"
  489.     (if (ref-variable imail-summary-show-date mark)
  490.     " \\([ 123][0-9] [a-zA-Z]+\\)"
  491.     "")
  492.     "  ")
  493.    (line-start mark 0)
  494.    (line-end mark 0)
  495.    #f))
  496.  
  497. (define (imail-summary-select-message buffer message)
  498.   (highlight-region (buffer-unclipped-region buffer) #f)
  499.   (call-with-values (lambda () (imail-summary-find-message buffer message))
  500.     (lambda (mark approximate?)
  501.       (if mark
  502.       (begin
  503.         (set-buffer-point! buffer mark)
  504.         (if (and (not approximate?)
  505.              (ref-variable imail-summary-highlight-message buffer))
  506.         (begin
  507.           (highlight-region
  508.            (make-region (if (imail-summary-match-line mark)
  509.                     (or (re-match-start 3)
  510.                     (re-match-end 0))
  511.                     mark)
  512.                 (line-end mark 0))
  513.            #t)
  514.           (buffer-not-modified! buffer)))))))
  515.   (if (ref-variable imail-summary-pop-up-message buffer)
  516.       (imail-summary-pop-up-message-buffer buffer)))
  517.  
  518. (define (imail-summary-pop-up-message-buffer summary-buffer)
  519.   (let ((folder-buffer (buffer-get summary-buffer 'IMAIL-FOLDER-BUFFER #f)))
  520.     (if (and folder-buffer
  521.          (not (buffer-visible? folder-buffer))
  522.          (selected-buffer? summary-buffer))
  523.     (pop-up-buffer
  524.      folder-buffer #f
  525.      `((HEIGHT ,(imail-summary-height (selected-window))))))))
  526.  
  527. (define (imail-summary-height window)
  528.   (let ((height (ref-variable imail-summary-height window)))
  529.     (if (exact-integer? height)
  530.     height
  531.     (round->exact (* (window-y-size window) height)))))
  532.  
  533. (define (imail-summary-find-message buffer message)
  534.   (let ((index (message-index message)))
  535.     (if index
  536.     (let ((m (imail-summary-first-line buffer)))
  537.       (let ((index* (imail-summary-selected-message-index m)))
  538.          (cond ((not index*)
  539.             (values #f #f))
  540.            ((< index* index)
  541.             (let loop ((last m))
  542.               (let ((m (line-start last 1 #f)))
  543.             (if m
  544.                 (let ((index*
  545.                    (imail-summary-selected-message-index m)))
  546.                    (cond ((or (not index*)
  547.                       (> index* index))
  548.                       (values last #t))
  549.                      ((= index index*)
  550.                       (values m #f))
  551.                      (else
  552.                       (loop m))))
  553.                 (values last #t)))))
  554.            (else
  555.             (values m (> index* index))))))
  556.     (values #f #f))))
  557.  
  558. (define (imail-summary-first-line buffer)
  559.   (line-start (buffer-start buffer) 2 'LIMIT))
  560.  
  561. (define (imail-summary-last-line buffer)
  562.   (let ((end (buffer-end buffer)))
  563.     (let ((last (line-start end -1 #f)))
  564.       (if (and last
  565.            (mark>= last (imail-summary-first-line buffer)))
  566.       last
  567.       end))))
  568.  
  569. ;;;; IMAIL Summary mode
  570.  
  571. (define-major-mode imail-summary imail "IMAIL Summary"
  572.   "Major mode in effect in IMAIL summary buffer.
  573. Each line summarizes a single mail message.
  574. The columns describing the message are, left to right:
  575.  
  576. 1. Several flag characters, each indicating whether the message is
  577.    marked with the corresponding flag.  The characters are, in order,
  578.    `D' (deleted), `U' (unseen), `A' (answered), `R' (re-sent or
  579.    forwarded), and `F' (filed).
  580.  
  581. 2. The message index number.
  582.  
  583. 3. The approximate length of the message in bytes.  Large messages are
  584.    abbreviated using the standard metric suffixes (`k'=1,000,
  585.    `M'=1,000,000, etc.)  The length includes all of the header fields,
  586.    including those that aren't normally shown.  (In IMAP folders, the
  587.    length is slightly higher because the server counts line endings as
  588.    two characters whereas Edwin counts them as one.)
  589.  
  590. 4. The date the message was sent, abbreviated by the day and month.
  591.    The date field is optional; see imail-summary-show-date.
  592.  
  593. 5. The subject line from the message, truncated if it is too long to
  594.    fit in the available space.  The width of the subject area is
  595.    controlled by the variable imail-summary-subject-width.
  596.  
  597. 6. The sender of the message, from the message's `From:' header.
  598.  
  599. Additional variables controlling this mode:
  600.  
  601. imail-summary-pop-up-message       keep message buffer visible
  602. imail-summary-highlight-message    highlight line for current message
  603. imail-summary-show-date            show date message sent
  604. imail-summary-subject-width        width of subject field
  605.  
  606. The commands in this buffer are mostly the same as those for IMAIL
  607. mode (the mode used by the buffer that shows the message contents),
  608. with some additions to make navigation more natural.
  609.  
  610. \\{imail-summary}"
  611.   (lambda (buffer)
  612.     (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-summary-revert-buffer)
  613.     (remove-kill-buffer-hook buffer imail-kill-buffer)
  614.     (local-set-variable! truncate-lines #t buffer)
  615.     (local-set-variable! mode-line-process
  616.              imail-summary-mode-line-summary-string
  617.              buffer)
  618.     (event-distributor/invoke! (ref-variable imail-summary-mode-hook buffer)
  619.                    buffer)))
  620.  
  621. (define-variable imail-summary-mode-hook
  622.   "An event distributor that is invoked when entering IMAIL Summary mode."
  623.   (make-event-distributor))
  624.  
  625. (define (imail-summary-revert-buffer buffer dont-use-auto-save? dont-confirm?)
  626.   dont-use-auto-save?
  627.   (if (or dont-confirm? (prompt-for-yes-or-no? "Revert summary buffer"))
  628.       (rebuild-imail-summary-buffer buffer)))
  629.  
  630. (define (imail-summary-mode-line-summary-string window)
  631.   (let* ((buffer (window-buffer window))
  632.      (folder (selected-folder #f buffer)))
  633.     (if folder
  634.     (string-append
  635.      (let ((status (folder-connection-status folder)))
  636.        (if (eq? status 'NO-SERVER)
  637.            ""
  638.            (string-append " " (symbol->string status))))
  639.      ": "
  640.      (buffer-get buffer 'IMAIL-SUMMARY-DESCRIPTION "All"))
  641.     "")))
  642.  
  643. (define-key 'imail-summary #\space    'imail-summary-scroll-msg-up)
  644. (define-key 'imail-summary #\rubout    'imail-summary-scroll-msg-down)
  645. (define-key 'imail-summary #\c-n    'imail-summary-next-message)
  646. (define-key 'imail-summary #\c-p    'imail-summary-previous-message)
  647. (define-key 'imail-summary #\.        'imail-summary-beginning-of-buffer)
  648. (define-key 'imail-summary #\e        'imail-summary-select-message)
  649. (define-key 'imail-summary #\u        'imail-undelete-forward)
  650. (define-key 'imail-summary #\m-<    'imail-summary-first-message)
  651. (define-key 'imail-summary #\m->    'imail-summary-last-message)
  652.  
  653. (define-key 'imail-summary (make-special-key 'down 0) '(imail-summary . #\c-n))
  654. (define-key 'imail-summary (make-special-key 'up 0) '(imail-summary . #\c-p))
  655.  
  656. (define-key 'imail-summary button1-down 'imail-summary-mouse-select-message)
  657. (define-key 'imail-summary button4-down '(imail-summary . #\c-p))
  658. (define-key 'imail-summary button5-down '(imail-summary . #\c-n))
  659.  
  660. (define-command imail-summary-select-message
  661.   "Select the message that point is on and show it in another window."
  662.   ()
  663.   (lambda ()
  664.     (select-message (selected-folder)
  665.             (or (selected-message #f)
  666.             (editor-error "No message on this line."))
  667.             #t)
  668.     (imail-summary-pop-up-message-buffer (selected-buffer))))
  669.  
  670. (define-command imail-summary-mouse-select-message
  671.   "Select the message that mouse is on and show it in another window."
  672.   ()
  673.   (lambda ()
  674.     (let ((button-event (current-button-event)))
  675.       (let ((window (button-event/window button-event)))
  676.     (select-window window)
  677.     (set-current-point!
  678.      (line-start (or (window-coordinates->mark
  679.               window
  680.               (button-event/x button-event)
  681.               (button-event/y button-event))
  682.              (buffer-end (window-buffer window)))
  683.              0))))
  684.     ((ref-command imail-summary-select-message))))
  685.  
  686. (define-command imail-summary-beginning-of-message
  687.   "Show current message from the beginning."
  688.   ()
  689.   (lambda ()
  690.     (let ((buffer (imail-folder->buffer (selected-folder) #t)))
  691.       (set-buffer-point! buffer (buffer-start buffer))
  692.       (imail-summary-pop-up-message-buffer (selected-buffer)))))
  693.  
  694. (define-command imail-summary-scroll-msg-up
  695.   "Scroll the IMAIL window forward.
  696. If the IMAIL window is displaying the end of a message,
  697. advance to the next message."
  698.   "P"
  699.   (lambda (argument)
  700.     (if (command-argument-negative-only? argument)
  701.     ((ref-command imail-summary-scroll-msg-down) #f)
  702.     (let ((buffer (imail-folder->buffer (selected-folder) #t)))
  703.       (if (eq? (selected-message #f) (selected-message #f buffer))
  704.           (let ((windows (buffer-windows buffer)))
  705.         (if (pair? windows)
  706.             (let ((window (car windows)))
  707.               (if (window-mark-visible? window (buffer-end buffer))
  708.               ((ref-command imail-next-message)
  709.                (if argument
  710.                    (command-argument-numeric-value argument)
  711.                    1))
  712.               (scroll-window
  713.                window
  714.                (standard-scroll-window-argument window
  715.                                 argument
  716.                                 1))))
  717.             ((ref-command imail-summary-beginning-of-message))))
  718.           ((ref-command imail-summary-select-message)))))))
  719.  
  720. (define-command imail-summary-scroll-msg-down
  721.   "Scroll the IMAIL window backward.
  722. If the IMAIL window is displaying the beginning of a message,
  723. advance to the previous message."
  724.   "P"
  725.   (lambda (argument)
  726.     (if (command-argument-negative-only? argument)
  727.     ((ref-command imail-summary-scroll-msg-up) #f)
  728.     (let ((buffer (imail-folder->buffer (selected-folder) #t)))
  729.       (if (eq? (selected-message #f) (selected-message #f buffer))
  730.           (let ((windows (buffer-windows buffer)))
  731.         (if (pair? windows)
  732.             (let ((window (car windows)))
  733.               (if (window-mark-visible? window (buffer-start buffer))
  734.               ((ref-command imail-previous-message)
  735.                (if argument
  736.                    (command-argument-numeric-value argument)
  737.                    1))
  738.               (scroll-window
  739.                window
  740.                (standard-scroll-window-argument window
  741.                                 argument
  742.                                 -1))))
  743.             ((ref-command imail-summary-beginning-of-message))))
  744.           ((ref-command imail-summary-select-message)))))))
  745.  
  746. (define-command imail-summary-next-message
  747.   (lambda ()
  748.     (command-description
  749.      (if (ref-variable imail-summary-auto-select)
  750.      (ref-command-object imail-next-message)
  751.      (ref-command-object next-line))))
  752.   "p"
  753.   (lambda (delta)
  754.     ((if (ref-variable imail-summary-auto-select)
  755.      (ref-command imail-next-message)
  756.      (ref-command next-line))
  757.      delta)))
  758.  
  759. (define-command imail-summary-previous-message
  760.   (lambda ()
  761.     (command-description
  762.      (if (ref-variable imail-summary-auto-select)
  763.      (ref-command-object imail-previous-message)
  764.      (ref-command-object previous-line))))
  765.   "p"
  766.   (lambda (delta)
  767.     ((if (ref-variable imail-summary-auto-select)
  768.      (ref-command imail-previous-message)
  769.      (ref-command previous-line))
  770.      delta)))
  771.  
  772. (define-command imail-summary-first-message
  773.   (lambda ()
  774.     (command-description
  775.      (if (ref-variable imail-summary-auto-select)
  776.      (ref-command-object imail-first-message)
  777.      (ref-command-object beginning-of-buffer))))
  778.   ()
  779.   (lambda ()
  780.     (if (ref-variable imail-summary-auto-select)
  781.     ((ref-command imail-first-message))
  782.     ((ref-command beginning-of-buffer) #f))))
  783.  
  784. (define-command imail-summary-last-message
  785.   (lambda ()
  786.     (command-description
  787.      (if (ref-variable imail-summary-auto-select)
  788.      (ref-command-object imail-last-message)
  789.      (ref-command-object end-of-buffer))))
  790.   ()
  791.   (lambda ()
  792.     (if (ref-variable imail-summary-auto-select)
  793.     ((ref-command imail-last-message))
  794.     ((ref-command end-of-buffer) #f))))