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-util.scm < prev    next >
Text File  |  2001-06-08  |  19KB  |  564 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-util.scm,v 1.39 2001/06/09 00:29:48 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: utilities
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (guarantee-index index procedure)
  27.   (if (not (index-fixnum? index))
  28.       (error:wrong-type-argument index "index" procedure)))
  29.  
  30. (define (source->list source)
  31.   (let ((item (source)))
  32.     (if (eof-object? item)
  33.     '()
  34.     (let ((head (list item)))
  35.       (let loop ((prev head))
  36.         (let ((item (source)))
  37.           (if (eof-object? item)
  38.           head
  39.           (let ((this (list item)))
  40.             (set-cdr! prev this)
  41.             (loop this)))))))))
  42.  
  43. (define (list->source items)
  44.   (lambda ()
  45.     (if (pair? items)
  46.     (let ((item (car items)))
  47.       (set! items (cdr items))
  48.       item)
  49.     (make-eof-object #f))))
  50.  
  51. (define (cut-list! items predicate)
  52.   (if (or (not (pair? items)) (predicate (car items)))
  53.       (values '() items)
  54.       (let loop ((prev items) (this (cdr items)))
  55.     (if (or (not (pair? this)) (predicate (car this)))
  56.         (begin
  57.           (set-cdr! prev '())
  58.           (values items this))
  59.         (loop this (cdr this))))))
  60.  
  61. (define (burst-list items predicate)
  62.   (let loop ((items items) (groups '()))
  63.     (if (pair? items)
  64.     (let find-next ((items (cdr items)) (group (list (car items))))
  65.       (if (and (pair? items) (not (predicate (car items))))
  66.           (find-next (cdr items) (cons (car items) group))
  67.           (loop items (cons (reverse! group) groups))))
  68.     (reverse! groups))))
  69.  
  70. (define (count-matching-items items predicate)
  71.   (let loop ((items items) (count 0))
  72.     (if (pair? items)
  73.     (loop (cdr items)
  74.           (if (predicate (car items))
  75.           (fix:+ count 1)
  76.           count))
  77.     count)))
  78.  
  79. (define (remove-duplicates items predicate)
  80.   (let loop ((items items) (items* '()))
  81.     (if (pair? items)
  82.     (loop (cdr items)
  83.           (if (let loop ((items* (cdr items)))
  84.             (and (pair? items*)
  85.              (or (predicate (car items) (car items*))
  86.                  (loop (cdr items*)))))
  87.           items*
  88.           (cons (car items) items*)))
  89.     (reverse! items*))))
  90.  
  91. (define (remove-duplicates! items predicate)
  92.   (define (trim-initial-segment items)
  93.     (cond ((pair? items)
  94.        (if (test-item items)
  95.            (trim-initial-segment (cdr items))
  96.            (begin
  97.          (locate-initial-segment items (cdr items))
  98.          items)))
  99.       ((null? items) items)
  100.       (else (lose))))
  101.  
  102.   (define (locate-initial-segment prev this)
  103.     (cond ((pair? this)
  104.        (if (test-item this)
  105.            (set-cdr! prev (trim-initial-segment (cdr this)))
  106.            (locate-initial-segment this (cdr this))))
  107.       ((not (null? this)) (lose))))
  108.  
  109.   (define (test-item items)
  110.     (let loop ((items* (cdr items)))
  111.       (and (pair? items*)
  112.        (or (predicate (car items) (car items*))
  113.            (loop (cdr items*))))))
  114.  
  115.   (define (lose)
  116.     (error:wrong-type-argument items "list" 'REMOVE-DUPLICATES!))
  117.  
  118.   (trim-initial-segment items))
  119.  
  120. ;; The cryptic LWSP means Linear White SPace.  We use it because it
  121. ;; is the terminology from RFC 822.
  122.  
  123. (define (char-lwsp? char)
  124.   (or (char=? #\space char)
  125.       (char=? #\tab char)))
  126.  
  127. (define char-set:lwsp
  128.   (char-set #\space #\tab))
  129.  
  130. (define (skip-lwsp-backwards string start end)
  131.   (let loop ((end end))
  132.     (if (and (fix:< start end)
  133.          (char-lwsp? (string-ref string (fix:- end 1))))
  134.     (loop (fix:- end 1))
  135.     end)))
  136.  
  137. (define (quote-lines lines)
  138.   (map (lambda (line)
  139.      (string-append "\t" line))
  140.        lines))
  141.  
  142. (define (unquote-lines lines)
  143.   (map (lambda (line)
  144.      (if (and (fix:> (string-length line) 0)
  145.           (char=? #\tab (string-ref line 0)))
  146.          (string-tail line 1)
  147.          (error "Unquoted line:" line)))
  148.        lines))
  149.  
  150. (define (string->lines string #!optional line-ending)
  151.   (substring->lines string 0 (string-length string)
  152.             (if (default-object? line-ending) "\n" line-ending)))
  153.  
  154. (define (substring->lines string start end #!optional line-ending)
  155.   (let ((line-ending (if (default-object? line-ending) "\n" line-ending))
  156.     (n (string-length line-ending)))
  157.     (let ((indexes (substring-search-all line-ending string start end)))
  158.       (if (pair? indexes)
  159.       (begin
  160.         (let loop ((start start) (indexes indexes))
  161.           (let ((start* (fix:+ (car indexes) n)))
  162.         (set-car! indexes (substring string start (car indexes)))
  163.         (cond ((pair? (cdr indexes))
  164.                (loop start* (cdr indexes)))
  165.               ((fix:< start* end)
  166.                (set-cdr! indexes
  167.                  (list (substring string start* end)))))))
  168.         indexes)
  169.       (list (if (and (fix:= start 0)
  170.              (fix:= end (string-length string)))
  171.             string
  172.             (substring string start end)))))))
  173.  
  174. (define (lines->string lines #!optional line-ending)
  175.   (decorated-string-append "" ""
  176.                (if (default-object? line-ending) "\n" line-ending)
  177.                lines))
  178.  
  179. (define (check-file-prefix pathname magic)
  180.   (let* ((n-to-read (string-length magic))
  181.      (buffer (make-string n-to-read))
  182.      (n-read
  183.       (catch-file-errors (lambda (condition) condition #f)
  184.         (lambda ()
  185.           (call-with-input-file pathname
  186.         (lambda (port)
  187.           (read-string! buffer port)))))))
  188.     (and n-read
  189.      (fix:= n-to-read n-read)
  190.      (string=? buffer magic))))
  191.  
  192. (define (read-required-char port)
  193.   (let ((char (read-char port)))
  194.     (if (eof-object? char)
  195.     (error "Premature end of file:" port))
  196.     char))
  197.  
  198. (define (peek-required-char port)
  199.   (let ((char (peek-char port)))
  200.     (if (eof-object? char)
  201.     (error "Premature end of file:" port))
  202.     char))
  203.  
  204. (define (read-required-line port)
  205.   (let ((line (read-line port)))
  206.     (if (eof-object? line)
  207.     (error "Premature end of file:" port))
  208.     line))
  209.  
  210. (define (skip-to-line-start port)
  211.   (input-port/discard-chars port char-set:newline)
  212.   (input-port/discard-char port))
  213.  
  214. (define (skip-past-blank-line port)
  215.   (let loop ()
  216.     (if (not (char=? (read-required-char port) #\newline))
  217.     (begin
  218.       (skip-to-line-start port)
  219.       (loop)))))
  220.  
  221. (define (parse-header-field-date field-value)
  222.   (let ((t
  223.      (ignore-errors
  224.       (lambda ()
  225.         (string->universal-time
  226.          (rfc822:tokens->string
  227.           (rfc822:strip-comments
  228.            (rfc822:string->tokens field-value))))))))
  229.     (and (not (condition? t))
  230.      t)))
  231.  
  232. (define (abbreviate-exact-nonnegative-integer n k)
  233.   (if (< n (expt 10 (- k 1)))
  234.       (string-append (string-pad-left (number->string n) (- k 1)) " ")
  235.       (let ((s
  236.          (fluid-let ((flonum-unparser-cutoff `(RELATIVE ,k ENGINEERING)))
  237.            (number->string (exact->inexact n)))))
  238.     (let ((regs (re-string-match "\\([0-9.]+\\)e\\([0-9]+\\)" s)))
  239.       (let ((mantissa (re-match-extract s regs 1))
  240.         (exponent (string->number (re-match-extract s regs 2))))
  241.         (if (> exponent 12)
  242.         (make-string k #\+)
  243.         (string-append
  244.          (let ((l (string-length mantissa))
  245.                (k (- k 1)))
  246.            (cond ((< l k)
  247.               (string-pad-left mantissa k))
  248.              ((= l k)
  249.               mantissa)
  250.              ((char=? #\. (string-ref mantissa (- k 1)))
  251.               (string-append " " (string-head mantissa (- k 1))))
  252.              (else
  253.               (string-head mantissa k))))
  254.          (case exponent
  255.            ((0) " ")
  256.            ((3) "k")
  257.            ((6) "M")
  258.            ((9) "G")
  259.            ((12) "T")))))))))
  260.  
  261. (define (exact-nonnegative-integer-digits n)
  262.   (let loop ((j 1) (k 10))
  263.     (if (< n k)
  264.     j
  265.     (loop (+ j 1) (* k 10)))))
  266.  
  267. (define (burst-comma-list-string string)
  268.   (list-transform-negative (map string-trim (burst-string string #\, #f))
  269.     string-null?))
  270.  
  271. (define (string-greatest-common-prefix strings)
  272.   (let loop
  273.       ((strings (cdr strings))
  274.        (string (car strings))
  275.        (index (string-length (car strings))))
  276.     (if (null? strings)
  277.     (substring string 0 index)
  278.     (let ((string* (car strings)))
  279.       (let ((index* (string-match-forward string string*)))
  280.         (if (< index* index)
  281.         (loop (cdr strings) string* index*)
  282.         (loop (cdr strings) string index)))))))
  283.  
  284. (define (string-greatest-common-prefix-ci strings)
  285.   (let loop
  286.       ((strings (cdr strings))
  287.        (string (car strings))
  288.        (index (string-length (car strings))))
  289.     (if (null? strings)
  290.     (substring string 0 index)
  291.     (let ((string* (car strings)))
  292.       (let ((index* (string-match-forward-ci string string*)))
  293.         (if (< index* index)
  294.         (loop (cdr strings) string* index*)
  295.         (loop (cdr strings) string index)))))))
  296.  
  297. (define (string-n-newlines string)
  298.   (substring-n-newlines string 0 (string-length string)))
  299.  
  300. (define (substring-n-newlines string start end)
  301.   (let loop ((start start) (n 0))
  302.     (let ((index (substring-find-next-char string start end #\newline)))
  303.       (if index
  304.       (loop (fix:+ index 1) (fix:+ n 1))
  305.       n))))
  306.  
  307. ;;;; Broken-pipe handler
  308.  
  309. (define (handle-broken-pipe handler thunk)
  310.   (bind-condition-handler (list condition-type:system-call-error
  311.                 condition-type:derived-port-error)
  312.       (lambda (condition)
  313.     (if (broken-pipe? condition)
  314.         (handler condition)))
  315.     thunk))
  316.  
  317. (define (broken-pipe? condition)
  318.   (cond ((eq? (condition/type condition) condition-type:system-call-error)
  319.      (and (eq? (system-call-name condition) 'WRITE)
  320.           (eq? (system-call-error condition) 'BROKEN-PIPE)))
  321.     ((eq? (condition/type condition) condition-type:derived-port-error)
  322.      (broken-pipe? (derived-port-condition condition)))
  323.     (else #f)))
  324.  
  325. (define system-call-name
  326.   (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
  327.  
  328. (define system-call-error
  329.   (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
  330.  
  331. (define derived-port-condition
  332.   (condition-accessor condition-type:derived-port-error 'CONDITION))
  333.  
  334. ;;;; Filename Completion
  335.  
  336. (define (pathname-complete-string pathname filter
  337.                   if-unique if-not-unique if-not-found)
  338.   (let ((pathname (merge-pathnames pathname))
  339.     (if-directory
  340.      (lambda (pathname)
  341.        (if-not-unique pathname
  342.          (lambda ()
  343.            (simple-directory-read pathname (result-filter filter)))))))
  344.     (cond ((not (safe-file-directory? (directory-pathname pathname)))
  345.        (if-not-found))
  346.       ((directory-pathname? pathname)
  347.        (if-directory pathname))
  348.       (else
  349.        (let ((pathnames (filtered-completions pathname filter)))
  350.          (cond ((not (pair? pathnames))
  351.             (if-not-found))
  352.            ((pair? (cdr pathnames))
  353.             (if-not-unique (->pathname
  354.                     (string-greatest-common-prefix
  355.                      (map ->namestring pathnames)))
  356.                    (lambda () pathnames)))
  357.            ((directory-pathname? (car pathnames))
  358.             (if-directory (car pathnames)))
  359.            (else
  360.             (if-unique (car pathnames)))))))))
  361.  
  362. (define (pathname-completions-list pathname filter)
  363.   (filtered-completions (merge-pathnames pathname) filter))
  364.  
  365. (define (filtered-completions pathname filter)
  366.   (simple-directory-read-matching pathname (result-filter filter)))
  367.  
  368. (define (simple-directory-read-matching pathname accumulator)
  369.   (let* ((directory (directory-namestring pathname))
  370.      (prefix (file-namestring pathname))
  371.      (channel (directory-channel-open directory)))
  372.     (let loop ((result '()))
  373.       (let ((name (directory-channel-read-matching channel prefix)))
  374.     (if name
  375.         (loop (accumulator name directory result))
  376.         (begin
  377.           (directory-channel-close channel)
  378.           result))))))
  379.  
  380. (define (simple-directory-read pathname accumulator)
  381.   (let* ((directory (directory-namestring pathname))
  382.      (channel (directory-channel-open directory)))
  383.     (let loop ((result '()))
  384.       (let ((name (directory-channel-read channel)))
  385.     (if name
  386.         (loop (accumulator name directory result))
  387.         (begin
  388.           (directory-channel-close channel)
  389.           result))))))
  390.  
  391. (define ((result-filter filter) name directory result)
  392.   (if (or (string=? name ".") (string=? name ".."))
  393.       result
  394.       (let ((pathname (parse-namestring (string-append directory name) #f #f)))
  395.     (cond ((safe-file-directory? pathname)
  396.            (cons (pathname-as-directory pathname) result))
  397.           ((filter pathname) (cons pathname result))
  398.           (else result)))))
  399.  
  400. (define (safe-file-directory? pathname)
  401.   (catch-file-errors (lambda (condition) condition #f)
  402.     (lambda ()
  403.       (file-directory? pathname))))
  404.  
  405. ;;;; Extended-string input port
  406.  
  407. (define (read-file-into-xstring pathname)
  408.   (call-with-binary-input-file pathname
  409.     (lambda (port)
  410.       (let ((n-bytes ((port/operation port 'LENGTH) port)))
  411.     (let ((xstring (allocate-external-string n-bytes)))
  412.       (let loop ((start 0))
  413.         (if (< start n-bytes)
  414.         (let ((n-read (read-substring! xstring 0 n-bytes port)))
  415.           (if (= n-read 0)
  416.               (error "Failed to read complete file:"
  417.                  (+ start n-read) n-bytes pathname))
  418.           (loop (+ start n-read)))))
  419.       xstring)))))
  420.  
  421. (define (call-with-input-xstring xstring position receiver)
  422.   (let ((port (open-xstring-input-port xstring position)))
  423.     (let ((value (receiver port)))
  424.       (close-port port)
  425.       value)))
  426.  
  427. (define (open-xstring-input-port xstring position)
  428.   (if (not (<= 0 position (external-string-length xstring)))
  429.       (error:bad-range-argument position 'OPEN-XSTRING-INPUT-PORT))
  430.   (let ((state (make-xstring-input-state xstring position)))
  431.     (read-xstring-buffer state)
  432.     (make-port xstring-input-type state)))
  433.  
  434. (define-structure (xstring-input-state
  435.            (constructor make-xstring-input-state (xstring position))
  436.            (conc-name xstring-input-state/))
  437.   xstring
  438.   position
  439.   (buffer (make-string 65536) read-only #t)
  440.   (buffer-start position)
  441.   (buffer-end position))
  442.  
  443. (define (xstring-port/xstring port)
  444.   (xstring-input-state/xstring (port/state port)))
  445.  
  446. (define (xstring-port/position port)
  447.   (xstring-input-state/position (port/state port)))
  448.  
  449. (define (read-xstring-buffer state)
  450.   (let ((xstring (xstring-input-state/xstring state))
  451.     (start (xstring-input-state/position state)))
  452.     (let ((xend (external-string-length xstring)))
  453.       (and (< start xend)
  454.        (let* ((buffer (xstring-input-state/buffer state))
  455.           (end (min (+ start (string-length buffer)) xend)))
  456.          (without-interrupts
  457.           (lambda ()
  458.         (set-xstring-input-state/buffer-start! state start)
  459.         (set-xstring-input-state/buffer-end! state end)
  460.         (xsubstring-move! xstring start end buffer 0)))
  461.          #t)))))
  462.  
  463. (define (xsubstring xstring start end)
  464.   (let ((buffer (make-string (- end start))))
  465.     (xsubstring-move! xstring start end buffer 0)
  466.     buffer))
  467.  
  468. (define (xstring-input-port/discard-chars port delimiters)
  469.   (let ((state (port/state port)))
  470.     (if (or (< (xstring-input-state/position state)
  471.            (xstring-input-state/buffer-end state))
  472.         (read-xstring-buffer state))
  473.     (let loop ()
  474.       (let* ((start (xstring-input-state/buffer-start state))
  475.          (index
  476.           (substring-find-next-char-in-set
  477.            (xstring-input-state/buffer state)
  478.            (- (xstring-input-state/position state) start)
  479.            (- (xstring-input-state/buffer-end state) start)
  480.            delimiters)))
  481.         (if index
  482.         (set-xstring-input-state/position! state (+ start index))
  483.         (begin
  484.           (set-xstring-input-state/position!
  485.            state
  486.            (xstring-input-state/buffer-end state))
  487.           (if (read-xstring-buffer state)
  488.               (loop)))))))))
  489.  
  490. (define (xstring-input-port/read-string port delimiters)
  491.   (let ((state (port/state port)))
  492.     (if (or (< (xstring-input-state/position state)
  493.            (xstring-input-state/buffer-end state))
  494.         (read-xstring-buffer state))
  495.     (let loop ((prefix #f))
  496.       (let* ((start (xstring-input-state/buffer-start state))
  497.          (b (xstring-input-state/buffer state))
  498.          (si (- (xstring-input-state/position state) start))
  499.          (ei (- (xstring-input-state/buffer-end state) start))
  500.          (index (substring-find-next-char-in-set b si ei delimiters)))
  501.         (if index
  502.         (begin
  503.           (set-xstring-input-state/position! state (+ start index))
  504.           (let ((s (make-string (fix:- index si))))
  505.             (substring-move! b si index s 0)
  506.             (if prefix (string-append prefix s) s)))
  507.         (begin
  508.           (set-xstring-input-state/position!
  509.            state
  510.            (xstring-input-state/buffer-end state))
  511.           (let ((s (make-string (fix:- ei si))))
  512.             (substring-move! b si ei s 0)
  513.             (let ((p (if prefix (string-append prefix s) s)))
  514.               (if (read-xstring-buffer state)
  515.               (loop p)
  516.               p)))))))
  517.     (make-eof-object port))))
  518.  
  519. (define xstring-input-type
  520.   (make-port-type
  521.    (let ((read
  522.       (lambda (port discard?)
  523.         (let ((state (port/state port)))
  524.           (let ((position (xstring-input-state/position state)))
  525.         (if (or (< position (xstring-input-state/buffer-end state))
  526.             (read-xstring-buffer state))
  527.             (let ((char
  528.                (string-ref
  529.                 (xstring-input-state/buffer state)
  530.                 (- position
  531.                    (xstring-input-state/buffer-start state)))))
  532.               (if discard?
  533.               (set-xstring-input-state/position!
  534.                state (+ position 1)))
  535.               char)
  536.             (make-eof-object port))))))
  537.      (xlength
  538.       (lambda (state)
  539.         (external-string-length (xstring-input-state/xstring state)))))
  540.      `((READ-CHAR ,(lambda (port) (read port #t)))
  541.        (PEEK-CHAR ,(lambda (port) (read port #f)))
  542.        (DISCARD-CHAR
  543.     ,(lambda (port)
  544.        (let* ((state (port/state port))
  545.           (position (xstring-input-state/position state)))
  546.          (if (< position (xlength state))
  547.          (set-xstring-input-state/position! state (+ position 1))))))
  548.        (DISCARD-CHARS ,xstring-input-port/discard-chars)
  549.        (READ-STRING ,xstring-input-port/read-string)
  550.        (LENGTH ,(lambda (port) (xlength (port/state port))))
  551.        (EOF?
  552.     ,(lambda (port)
  553.        (let ((state (port/state port)))
  554.          (>= (xstring-input-state/position state) (xlength state)))))
  555.        (CLOSE
  556.     ,(lambda (port)
  557.        (let ((state (port/state port)))
  558.          (without-interrupts
  559.           (lambda ()
  560.         (set-xstring-input-state/xstring! state #f)
  561.         (set-xstring-input-state/position! state 0)
  562.         (set-xstring-input-state/buffer-start! state 0)
  563.         (set-xstring-input-state/buffer-end! state 0))))))))
  564.    #f))