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-umail.scm < prev    next >
Text File  |  2001-06-11  |  9KB  |  263 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-umail.scm,v 1.49 2001/06/12 00:47:39 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1999-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: RMAIL back end
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; URL
  27.  
  28. (define-class <umail-url> (<file-url>))
  29. (define make-umail-url (pathname-url-constructor <umail-url>))
  30.  
  31. (define-pathname-url-predicates <umail-url>
  32.   (lambda (pathname) (check-file-prefix pathname "From "))
  33.   (lambda (pathname) pathname #f)
  34.   (lambda (pathname) (equal? (pathname-type pathname) "mail")))
  35.  
  36. ;;;; Server operations
  37.  
  38. (define-method %create-resource ((url <umail-url>))
  39.   (if (file-exists? (pathname-url-pathname url))
  40.       (error:bad-range-argument url 'CREATE-RESOURCE))
  41.   (let ((folder (make-umail-folder url)))
  42.     (set-file-folder-messages! folder '#())
  43.     (set-file-folder-file-modification-time! folder (get-universal-time))
  44.     (set-file-folder-file-modification-count!
  45.      folder
  46.      (object-modification-count folder))
  47.     (save-resource folder)))
  48.  
  49. ;;;; Folder
  50.  
  51. (define-class (<umail-folder> (constructor (locator))) (<file-folder>))
  52.  
  53. (define-method open-resource ((url <umail-url>))
  54.   (if (file-readable? (pathname-url-pathname url))
  55.       (maybe-make-resource url make-umail-folder)
  56.       (begin
  57.     (unmemoize-resource url)
  58.     (error:bad-range-argument url 'OPEN-RESOURCE))))
  59.  
  60. ;;;; Message
  61.  
  62. (define-class (<umail-message>
  63.            (constructor (header-fields body flags from-line)))
  64.     (<file-message>)
  65.   (from-line define accessor))
  66.  
  67. (define-method umail-message-from-line ((message <message>))
  68.   (string-append "From "
  69.          (or (let ((from
  70.                 (get-first-header-field-value message "from" #f)))
  71.                (and from
  72.                 (rfc822:first-address from)))
  73.              "unknown")
  74.          " "
  75.          (universal-time->local-ctime-string
  76.           (message-internal-time message))))
  77.  
  78. (define-method make-message-copy ((message <message>) (folder <umail-folder>))
  79.   folder
  80.   (make-umail-message (message-header-fields message)
  81.               (file-message-body message)
  82.               (list-copy (message-flags message))
  83.               (umail-message-from-line message)))
  84.  
  85. (define-method message-internal-time ((message <umail-message>))
  86.   (or (extract-umail-from-time (umail-message-from-line message))
  87.       (call-next-method message)))
  88.  
  89. ;;;; Read unix mail file
  90.  
  91. (define-method revert-file-folder ((folder <umail-folder>))
  92.   (read-file-folder-contents folder
  93.     (lambda (port)
  94.       (let ((from-line (read-line port)))
  95.     (if (eof-object? from-line)
  96.         '#()
  97.         (begin
  98.           (if (not (umail-delimiter? from-line))
  99.           (error "Malformed unix mail file:" port))
  100.           (let loop ((from-line from-line) (index 0) (messages '()))
  101.         (if (= 0 (remainder index 10))
  102.             (imail-ui:progress-meter index #f))
  103.         (call-with-values
  104.             (lambda ()
  105.               (read-umail-message folder
  106.                       from-line
  107.                       port
  108.                       umail-delimiter?))
  109.           (lambda (message from-line)
  110.             (attach-message! message folder index)
  111.             (let ((messages (cons message messages)))
  112.               (if from-line
  113.               (loop from-line (+ index 1) messages)
  114.               (list->vector (reverse! messages)))))))))))))
  115.  
  116. (define (read-umail-message folder from-line port delimiter?)
  117.   (let ((h-start (xstring-port/position port)))
  118.     (skip-past-blank-line port)
  119.     (let ((b-start (xstring-port/position port)))
  120.       (let ((finish
  121.          (lambda (b-end line)
  122.            (values
  123.         (read-umail-message-1
  124.          folder
  125.          from-line
  126.          (make-file-external-ref h-start (- b-start 1))
  127.          (make-file-external-ref b-start b-end))
  128.         line))))
  129.     (let loop ()
  130.       (let ((line (read-line port)))
  131.         (cond ((eof-object? line)
  132.            (finish (xstring-port/position port) #f))
  133.           ((delimiter? line)
  134.            (finish (- (xstring-port/position port)
  135.                   (+ (string-length line) 1))
  136.                line))
  137.           (else
  138.            (loop)))))))))
  139.  
  140. (define (read-umail-message-1 folder from-line headers body)
  141.   (call-with-values
  142.       (lambda () (file-folder-strip-internal-headers folder headers))
  143.     (lambda (headers internal-headers)
  144.       (call-with-values
  145.       (lambda ()
  146.         (parse-imail-header-fields internal-headers))
  147.     (lambda (internal-headers flags)
  148.       internal-headers
  149.       (make-umail-message headers body flags from-line))))))
  150.  
  151. (define (umail-delimiter? line)
  152.   (re-string-match unix-mail-delimiter line))
  153.  
  154. ;;;; Write unix mail file
  155.  
  156. (define-method write-file-folder ((folder <umail-folder>) pathname)
  157.   (call-with-binary-output-file pathname
  158.     (lambda (port)
  159.       (for-each-vector-element (file-folder-messages folder)
  160.     (lambda (message)
  161.       (write-umail-message message #t port))))))
  162.  
  163. (define-method append-message-to-file ((message <message>) (url <umail-url>))
  164.   (let ((pathname (pathname-url-pathname url)))
  165.     (let ((exists? (file-exists? pathname)))
  166.       (call-with-binary-append-file pathname
  167.     (lambda (port)
  168.       (write-umail-message message #t port)))
  169.       (not exists?))))
  170.  
  171. (define (write-umail-message message output-flags? port)
  172.   (write-string (umail-message-from-line message) port)
  173.   (newline port)
  174.   (if output-flags?
  175.       (write-header-field (message-flags->header-field (message-flags message))
  176.               port))
  177.   (write-header-fields (message-header-fields message) port)
  178.   (for-each (lambda (line)
  179.           (if (string-prefix-ci? "From " line)
  180.           (write-string ">" port))
  181.           (write-string line port)
  182.           (newline port))
  183.         (string->lines (file-message-body message))))
  184.  
  185. ;;;; Detection of unix "from" lines.
  186.  
  187. (define (extract-umail-from-time string)
  188.   (let ((regs (re-string-search-forward unix-from-time-regexp string)))
  189.     (and regs
  190.      (let ((t
  191.         (ignore-errors
  192.          (lambda ()
  193.            (ctime-string->universal-time
  194.             (string-append
  195.              (re-match-extract string regs 1)
  196.              " "
  197.              (re-match-extract string regs 2)
  198.              " "
  199.              (re-match-extract string regs 3)
  200.              " "
  201.              (re-match-extract string regs 4)
  202.              " "
  203.              (re-match-extract string regs 8))
  204.             (let ((tz1 (re-match-extract string regs 6))
  205.               (tz2 (re-match-extract string regs 9)))
  206.               (cond ((not (string-null? tz1)) (string->time-zone tz1))
  207.                 ((not (string-null? tz2)) (string->time-zone tz2))
  208.                 (else #f))))))))
  209.        (and (not (condition? t))
  210.         t)))))
  211.  
  212. (define unix-from-time-regexp
  213.   ;; This very complex regular expression taken from Emacs 20.
  214.   (let ((time-zone-regexp
  215.      (string-append
  216.       (regexp-group "[A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
  217.             "[-+]?[0-9][0-9][0-9][0-9]"
  218.             "")
  219.       " *")))
  220.     (string-append
  221.      ;; The time the message was sent.
  222.      "\\([^\000-\r \177]+\\) +"                ; day of the week
  223.      "\\([^\000-\r \177]+\\) +"                ; month
  224.      "\\([0-3]?[0-9]\\) +"                ; day of month
  225.      "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *"    ; time of day
  226.  
  227.      ;; Perhaps a time zone, specified by an abbreviation, or by a
  228.      ;; numeric offset.
  229.      time-zone-regexp
  230.  
  231.      ;; The year.
  232.      " \\([0-9][0-9]+\\) *"
  233.  
  234.      ;; On some systems the time zone can appear after the year, too.
  235.      time-zone-regexp
  236.  
  237.      ;; Old uucp cruft.
  238.      "\\(remote from .*\\)?"
  239.  
  240.      "$")))
  241.  
  242. (define unix-mail-delimiter
  243.   ;; This very complex regular expression taken from Emacs 20.
  244.   ;; Many things can happen to an RFC 822 mailbox before it is put into
  245.   ;; a `From' line.  The leading phrase can be stripped, e.g.
  246.   ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'.  The <> can be stripped, e.g.
  247.   ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'.  Everything starting with a CRLF
  248.   ;; can be removed, e.g.
  249.   ;;        From: joe@y.z (Joe    K
  250.   ;;            User)
  251.   ;; can yield `From joe@y.z (Joe     K Fri Mar 22 08:11:15 1996', and
  252.   ;;        From: Joe User
  253.   ;;            <joe@y.z>
  254.   ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
  255.   ;; The mailbox can be removed or be replaced by white space, e.g.
  256.   ;;        From: "Joe User"{space}{tab}
  257.   ;;            <joe@y.z>
  258.   ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996',
  259.   ;; where {space} and {tab} represent the Ascii space and tab characters.
  260.   ;; We want to match the results of any of these manglings.
  261.   ;; The following regexp rejects names whose first characters are
  262.   ;; obviously bogus, but after that anything goes.
  263.   (string-append "^From \\([^\000-\b\n-\r\177].*\\)? " unix-from-time-regexp))