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-file.scm < prev    next >
Text File  |  2001-06-11  |  21KB  |  622 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-file.scm,v 1.78 2001/06/12 00:47:24 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: file-based folder support
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; URL
  27.  
  28. (define-class <pathname-url> (<url>)
  29.   (pathname define accessor))
  30.  
  31. (define-url-protocol "file" <pathname-url>)
  32.  
  33. (define (pathname-url-constructor class)
  34.   (let ((procedure
  35.      (let ((constructor (instance-constructor class '(PATHNAME))))
  36.        (lambda (pathname)
  37.          (intern-url (constructor (merge-pathnames pathname))
  38.              pathname-container-url)))))
  39.     (register-pathname-url-constructor class procedure)
  40.     procedure))
  41.  
  42. (define (register-pathname-url-constructor class constructor)
  43.   (hash-table/put! pathname-url-constructors class constructor))
  44.  
  45. (define (get-pathname-url-constructor class)
  46.   (or (hash-table/get pathname-url-constructors class #f)
  47.       (error "Unknown pathname-url class:" class)))
  48.  
  49. (define pathname-url-constructors
  50.   (make-eq-hash-table))
  51.  
  52. (define (pathname-container-url url)
  53.   (make-directory-url (pathname-container (pathname-url-pathname url))))
  54.  
  55. (define-method container-url-for-prompt ((url <pathname-url>))
  56.   (make-directory-url (pathname-container (pathname-url-pathname url))))
  57.  
  58. (define-method url-content-name ((url <pathname-url>))
  59.   (let ((pathname (pathname-url-pathname url)))
  60.     (enough-namestring pathname (pathname-container pathname))))
  61.  
  62. (define (pathname-container pathname)
  63.   (directory-pathname (directory-pathname-as-file pathname)))
  64.  
  65. (define (define-pathname-url-predicates class
  66.       file-predicate
  67.       directory-predicate
  68.       pathname-predicate)
  69.   (let ((constructor (get-pathname-url-constructor class)))
  70.     (let loop ((entries pathname-url-predicates))
  71.       (if (pair? entries)
  72.       (if (eq? class (vector-ref (car entries) 0))
  73.           (begin
  74.         (vector-set! (car entries) 1 file-predicate)
  75.         (vector-set! (car entries) 2 directory-predicate)
  76.         (vector-set! (car entries) 3 pathname-predicate)
  77.         (vector-set! (car entries) 4 constructor))
  78.           (loop (cdr entries)))
  79.       (begin
  80.         (set! pathname-url-predicates
  81.           (cons (vector class
  82.                 file-predicate
  83.                 directory-predicate
  84.                 pathname-predicate
  85.                 constructor)
  86.             pathname-url-predicates))
  87.         unspecific)))))
  88.  
  89. (define (find-pathname-url-constructor pathname must-exist? if-not-found)
  90.   (let ((type (file-type-indirect pathname))
  91.     (search
  92.      (lambda (index)
  93.        (let loop ((entries pathname-url-predicates))
  94.          (and (pair? entries)
  95.           (if ((vector-ref (car entries) index) pathname)
  96.               (vector-ref (car entries) 4)
  97.               (loop (cdr entries))))))))
  98.     (or (case type
  99.       ((REGULAR) (search 1))
  100.       ((DIRECTORY) (search 2))
  101.       ((#F) (and (not must-exist?) (search 3)))
  102.       (else #f))
  103.     (and if-not-found
  104.          (if-not-found pathname type)))))
  105.  
  106. (define pathname-url-predicates '())
  107.  
  108. (define-method parse-url-body ((string <string>) (default-url <pathname-url>))
  109.   (let ((pathname
  110.      (parse-pathname-url-body string (pathname-url-pathname default-url))))
  111.     ((standard-pathname-url-constructor pathname) pathname)))
  112.  
  113. (define (standard-pathname-url-constructor pathname)
  114.   (find-pathname-url-constructor pathname #f
  115.     (lambda (pathname type)
  116.       (case type
  117.     ((REGULAR) make-file-url)
  118.     ((DIRECTORY) make-directory-url)
  119.     ((#F)
  120.      (if (directory-pathname? pathname)
  121.          make-directory-url
  122.          ;; Default for non-existent files:
  123.          make-umail-url))
  124.     (else
  125.      (error "Pathname refers to illegal file type:" pathname))))))
  126.  
  127. (define (parse-pathname-url-body string default-pathname)
  128.   (let ((finish
  129.      (lambda (string)
  130.        (merge-pathnames
  131.         (let ((s
  132.            (decorated-string-append
  133.             "" "/" ""
  134.             (map url:decode-string (burst-string string #\/ #f)))))
  135.           (if (and (eq? (host/type-name (pathname-host default-pathname))
  136.                 'DOS)
  137.                (re-string-match "/[a-z]:" s #t))
  138.           (string-tail s 1)
  139.           s))
  140.         (directory-pathname default-pathname)))))
  141.     (cond ((string-prefix? "//localhost/" string)
  142.        (finish (string-tail string (string-length "//localhost"))))
  143.       ((string-prefix? "///" string)
  144.        (finish (string-tail string (string-length "//"))))
  145.       ((string-prefix? "//" string)
  146.        (error:bad-range-argument string 'PARSE-PATHNAME-URL-BODY))
  147.       (else
  148.        (finish string)))))
  149.  
  150. (define-method url-body ((url <pathname-url>))
  151.   (pathname->url-body (pathname-url-pathname url)))
  152.  
  153. (define (pathname->url-body pathname)
  154.   (string-append (let ((device (pathname-device pathname)))
  155.            (if (string? device)
  156.                (string-append "/" device ":")
  157.                ""))
  158.          (let ((directory (pathname-directory pathname)))
  159.            (if (pair? directory)
  160.                (string-append
  161.             (if (eq? (car directory) 'ABSOLUTE) "/" "")
  162.             (decorated-string-append
  163.              "" "" "/"
  164.              (map (lambda (string)
  165.                 (url:encode-string
  166.                  (if (eq? string 'UP) ".." string)))
  167.                   (cdr directory))))
  168.                ""))
  169.          (url:encode-string (file-namestring pathname))))
  170.  
  171. ;;;; File URLs
  172.  
  173. (define-class <file-url> (<folder-url> <pathname-url>))
  174. (define make-file-url (pathname-url-constructor <file-url>))
  175.  
  176. (define-method url-exists? ((url <file-url>))
  177.   (file-exists? (pathname-url-pathname url)))
  178.  
  179. (define-method folder-url-is-selectable? ((url <file-url>))
  180.   (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t))
  181.  
  182. (define-method url-corresponding-container ((url <file-url>))
  183.   url
  184.   #f)
  185.  
  186. (define-method url-base-name ((url <file-url>))
  187.   (pathname-name (pathname-url-pathname url)))
  188.  
  189. ;;;; Directory URLs
  190.  
  191. (define-class <directory-url> (<container-url> <pathname-url>))
  192.  
  193. (define make-directory-url
  194.   (let ((constructor (instance-constructor <directory-url> '(PATHNAME))))
  195.     (lambda (pathname)
  196.       (intern-url
  197.        (constructor (pathname-as-directory (merge-pathnames pathname)))
  198.        pathname-container-url))))
  199.  
  200. (register-pathname-url-constructor <directory-url> make-directory-url)
  201.  
  202. (define-method url-exists? ((url <directory-url>))
  203.   (file-directory? (pathname-url-pathname url)))
  204.  
  205. (define-method make-content-url ((url <directory-url>) name)
  206.   (let ((pathname (merge-pathnames name (pathname-url-pathname url))))
  207.     ((standard-pathname-url-constructor pathname) pathname)))
  208.  
  209. (define-method container-url-contents ((url <directory-url>))
  210.   (simple-directory-read (pathname-url-pathname url)
  211.     (lambda (name directory result)
  212.       (if (or (string=? name ".") (string=? name ".."))
  213.       result
  214.       (let* ((pathname
  215.           (parse-namestring (string-append directory name) #f #f))
  216.          (constructor (pathname-url-filter pathname)))
  217.         (if constructor
  218.         (cons (constructor pathname) result)
  219.         result))))))
  220.  
  221. ;;;; Server operations
  222.  
  223. (define-method %url-complete-string
  224.     ((string <string>) (default-url <pathname-url>)
  225.                if-unique if-not-unique if-not-found)
  226.   (pathname-complete-string
  227.    (parse-pathname-url-body
  228.     string
  229.     (directory-pathname (pathname-url-pathname default-url)))
  230.    pathname-url-filter
  231.    (lambda (string)
  232.      (if-unique (pathname->url-body string)))
  233.    (lambda (prefix get-completions)
  234.      (if-not-unique (pathname->url-body prefix)
  235.             (lambda () (map pathname->url-body (get-completions)))))
  236.    if-not-found))
  237.  
  238. (define-method %url-string-completions
  239.     ((string <string>) (default-url <pathname-url>))
  240.   (map pathname->url-body
  241.        (pathname-completions-list
  242.     (parse-pathname-url-body
  243.      string
  244.      (directory-pathname (pathname-url-pathname default-url)))
  245.     pathname-url-filter)))
  246.  
  247. (define (pathname-url-filter pathname)
  248.   (find-pathname-url-constructor pathname #t
  249.     (lambda (pathname type)
  250.       pathname
  251.       (and (eq? type 'DIRECTORY)
  252.        make-directory-url))))
  253.  
  254. (define-method %create-resource ((url <directory-url>))
  255.   (make-directory (pathname-url-pathname url)))
  256.  
  257. (define-method %delete-resource ((url <file-url>))
  258.   (delete-file (pathname-url-pathname url)))
  259.  
  260. (define-method %delete-resource ((url <directory-url>))
  261.   (delete-directory (pathname-url-pathname url)))
  262.  
  263. (define-method %rename-resource ((url <pathname-url>) (new-url <pathname-url>))
  264.   (rename-file (pathname-url-pathname url) (pathname-url-pathname new-url)))
  265.  
  266. (define-method with-open-connection ((url <file-url>) thunk)
  267.   url
  268.   (thunk))
  269.  
  270. ;;;; Folder
  271.  
  272. (define-class (<file-folder> (predicate)) (<folder>)
  273.   (messages define standard
  274.         accessor %file-folder-messages
  275.         initial-value 'UNKNOWN)
  276.   (file-modification-time define standard
  277.               initial-value #f)
  278.   (file-modification-count define standard
  279.                initial-value #f)
  280.   (xstring define standard))
  281.  
  282. (define (file-folder-messages folder)
  283.   (if (eq? 'UNKNOWN (%file-folder-messages folder))
  284.       (revert-file-folder folder))
  285.   (%file-folder-messages folder))
  286.  
  287. (define-generic revert-file-folder (folder))
  288.  
  289. (define (file-folder-pathname folder)
  290.   (pathname-url-pathname (resource-locator folder)))
  291.  
  292. (define-method close-resource ((folder <file-folder>) no-defer?)
  293.   no-defer?
  294.   (save-resource folder)
  295.   (discard-file-folder-messages folder)
  296.   (discard-file-folder-xstring folder))
  297.  
  298. (define (discard-file-folder-messages folder)
  299.   (without-interrupts
  300.    (lambda ()
  301.      (let ((messages (%file-folder-messages folder)))
  302.        (if (not (eq? 'UNKNOWN messages))
  303.        (begin
  304.          (set-file-folder-messages! folder 'UNKNOWN)
  305.          (for-each-vector-element messages detach-message!)))))))
  306.  
  307. (define (discard-file-folder-xstring folder)
  308.   (without-interrupts
  309.    (lambda ()
  310.      (set-file-folder-xstring! folder #f)
  311.      (set-file-folder-file-modification-time! folder #f)
  312.      (set-file-folder-file-modification-count! folder #f))))
  313.  
  314. (define-method folder-length ((folder <file-folder>))
  315.   (vector-length (file-folder-messages folder)))
  316.  
  317. (define-method %get-message ((folder <file-folder>) index)
  318.   (vector-ref (file-folder-messages folder) index))
  319.  
  320. (define-method %append-message ((message <message>) (url <file-url>))
  321.   (let ((folder (get-memoized-resource url)))
  322.     (if folder
  323.     (let ((message (make-message-copy message folder))
  324.           (exists?
  325.            (or (file-folder-file-modification-time folder)
  326.            (file-exists? (file-folder-pathname folder)))))
  327.       (without-interrupts
  328.        (lambda ()
  329.          (set-file-folder-messages!
  330.           folder
  331.           (let ((messages (file-folder-messages folder)))
  332.         (let ((n (vector-length messages)))
  333.           (let ((messages (vector-grow messages (fix:+ n 1))))
  334.             (attach-message! message folder n)
  335.             (vector-set! messages n message)
  336.             messages))))))
  337.       (not exists?))
  338.     (append-message-to-file message url))))
  339.  
  340. (define-generic make-message-copy (message folder))
  341. (define-generic append-message-to-file (message url))
  342.  
  343. (define-method expunge-deleted-messages ((folder <file-folder>))
  344.   (without-interrupts
  345.    (lambda ()
  346.      (let ((messages (file-folder-messages folder)))
  347.        (let ((n (vector-length messages)))
  348.      (let ((n-deleted
  349.         (let loop ((i 0) (n-deleted 0))
  350.           (if (fix:< i n)
  351.               (loop (fix:+ i 1)
  352.                 (if (message-deleted? (vector-ref messages i))
  353.                 (fix:+ n-deleted 1)
  354.                 n-deleted))
  355.               n-deleted))))
  356.        (if (fix:> n-deleted 0)
  357.            (let ((messages* (make-vector (- n n-deleted))))
  358.          (let loop ((i 0) (i* 0))
  359.            (if (fix:< i n)
  360.                (let ((m (vector-ref messages i)))
  361.              (if (message-deleted? m)
  362.                  (begin
  363.                    (detach-message! m)
  364.                    (object-modified! folder 'EXPUNGE i*)
  365.                    (loop (fix:+ i 1) i*))
  366.                  (begin
  367.                    (set-message-index! m i*)
  368.                    (vector-set! messages* i* m)
  369.                    (loop (fix:+ i 1) (fix:+ i* 1)))))))
  370.          (set-file-folder-messages! folder messages*)))))))))
  371.  
  372. (define-method search-folder ((folder <file-folder>) criteria)
  373.   (cond ((string? criteria)
  374.      (let ((n (folder-length folder)))
  375.        (let loop ((index 0) (winners '()))
  376.          (if (< index n)
  377.          (loop (+ index 1)
  378.                (if (let ((message (get-message folder index)))
  379.                  (or (string-search-forward
  380.                   criteria
  381.                   (header-fields->string
  382.                    (message-header-fields message)))
  383.                  (string-search-forward
  384.                   criteria
  385.                   (file-message-body message))))
  386.                (cons index winners)
  387.                winners))
  388.          (reverse! winners)))))
  389.     (else
  390.      (error:wrong-type-argument criteria
  391.                     "search criteria"
  392.                     'SEARCH-FOLDER))))
  393.  
  394. (define-method folder-sync-status ((folder <file-folder>))
  395.   (let ((sync-time (file-folder-file-modification-time folder))
  396.     (sync-count (file-folder-file-modification-count folder))
  397.     (current-count (object-modification-count folder))
  398.     (current-time (file-modification-time (file-folder-pathname folder))))
  399.     (if (and sync-time sync-count)
  400.     (if current-time
  401.         (if (= sync-time current-time)
  402.         (if (= sync-count current-count)
  403.             'SYNCHRONIZED
  404.             'CACHE-MODIFIED)
  405.         (if (= sync-count current-count)
  406.             'PERSISTENT-MODIFIED
  407.             'BOTH-MODIFIED))
  408.         'PERSISTENT-DELETED)
  409.     'UNSYNCHRONIZED)))
  410.  
  411. (define-method save-resource ((folder <file-folder>))
  412.   (and (let ((status (folder-sync-status folder)))
  413.      (or (memq status '(FOLDER-MODIFIED PERSISTENT-DELETED))
  414.          (and (eq? status 'BOTH-MODIFIED)
  415.           (imail-ui:prompt-for-yes-or-no?
  416.            "Disk file has changed since last read.  Save anyway"))))
  417.        (begin
  418.      (synchronize-file-folder-write folder write-file-folder)
  419.      #t)))
  420.  
  421. (define-generic write-file-folder (folder pathname))
  422.  
  423. (define (synchronize-file-folder-write folder writer)
  424.   (let ((pathname (file-folder-pathname folder)))
  425.     (let loop ()
  426.       (let ((count (object-modification-count folder)))
  427.     (writer folder pathname)
  428.     (let ((t (file-modification-time pathname)))
  429.       (if (and t (= count (object-modification-count folder)))
  430.           (begin
  431.         (set-file-folder-file-modification-count! folder count)
  432.         (set-file-folder-file-modification-time! folder t))
  433.           (loop)))))))
  434.  
  435. (define (read-file-folder-contents folder reader)
  436.   (discard-file-folder-messages folder)
  437.   (let ((t (file-folder-file-modification-time folder))
  438.     (pathname (file-folder-pathname folder)))
  439.     (if (not (and t (= t (file-modification-time pathname))))
  440.     (begin
  441.       (if t (discard-file-folder-xstring folder))
  442.       (let loop ()
  443.         (let ((t (file-modification-time pathname)))
  444.           ((imail-ui:message-wrapper "Reading file "
  445.                      (->namestring pathname))
  446.            (lambda ()
  447.          (set-file-folder-xstring! folder
  448.                        (read-file-into-xstring pathname))))
  449.           (if (= t (file-modification-time pathname))
  450.           (begin
  451.             (set-file-folder-file-modification-time! folder t)
  452.             (set-file-folder-file-modification-count!
  453.              folder
  454.              (object-modification-count folder)))
  455.           (loop)))))))
  456.   (set-file-folder-messages!
  457.    folder
  458.    ((imail-ui:message-wrapper "Parsing messages")
  459.     (lambda ()
  460.       (call-with-input-xstring (file-folder-xstring folder) 0 reader)))))
  461.  
  462. (define-method discard-folder-cache ((folder <file-folder>))
  463.   (close-resource folder #f))
  464.  
  465. (define-method probe-folder ((folder <file-folder>))
  466.   folder
  467.   unspecific)
  468.  
  469. (define-method folder-connection-status ((folder <file-folder>))
  470.   folder
  471.   'NO-SERVER)
  472.  
  473. (define-method disconnect-folder ((folder <file-folder>))
  474.   folder
  475.   unspecific)
  476.  
  477. (define-method folder-supports-mime? ((folder <file-folder>))
  478.   folder
  479.   #f)
  480.  
  481. (define-method preload-folder-outlines ((folder <file-folder>))
  482.   folder
  483.   unspecific)
  484.  
  485. (define-method first-unseen-message-index ((folder <file-folder>))
  486.   folder
  487.   0)
  488.  
  489. ;;;; Container
  490.  
  491. (define-class (<file-container> (constructor (locator))) (<container>))
  492.  
  493. (define-method open-resource ((url <directory-url>))
  494.   (maybe-make-resource url make-file-container))
  495.  
  496. (define-method close-resource ((container <file-container>) no-defer?)
  497.   container no-defer?
  498.   unspecific)
  499.  
  500. (define-method save-resource ((container <file-container>))
  501.   container
  502.   #f)
  503.  
  504. ;;;; Message
  505.  
  506. (define-class <file-message> (<message>)
  507.   body)
  508.  
  509. (define (file-message-xstring message)
  510.   (file-folder-xstring (message-folder message)))
  511.  
  512. (define (file-external-ref? object)
  513.   (and (pair? object)
  514.        (exact-nonnegative-integer? (car object))
  515.        (exact-nonnegative-integer? (cdr object))))
  516.  
  517. (define (make-file-external-ref start end) (cons start end))
  518. (define (file-external-ref/start ref) (car ref))
  519. (define (file-external-ref/end ref) (cdr ref))
  520.  
  521. (define (define-file-external-message-method procedure class slot operator)
  522.   (let ((accessor (slot-accessor class slot)))
  523.     (define-method procedure ((message class))
  524.       (let ((item (accessor message)))
  525.     (if (file-external-ref? item)
  526.         (operator
  527.          (xsubstring (file-message-xstring message)
  528.              (file-external-ref/start item)
  529.              (file-external-ref/end item)))
  530.         (call-next-method message))))))
  531.  
  532. (define-file-external-message-method message-header-fields
  533.   <file-message>
  534.   'HEADER-FIELDS
  535.   string->header-fields)
  536.  
  537. (define-generic file-message-body (message))
  538.  
  539. (define-file-external-message-method file-message-body
  540.   <file-message>
  541.   'BODY
  542.   (lambda (s) s))
  543.  
  544. (define-method file-message-body ((message <message>))
  545.   (with-string-output-port
  546.     (lambda (port)
  547.       (write-message-body message port))))
  548.  
  549. (define-method write-message-body ((message <file-message>) port)
  550.   (write-string (file-message-body message) port))
  551.  
  552. (define-method set-message-flags! ((message <file-message>) flags)
  553.   (%set-message-flags! message flags))
  554.  
  555. (let ((get-header-fields (slot-accessor <file-message> 'HEADER-FIELDS))
  556.       (get-body (slot-accessor <file-message> 'BODY)))
  557.   (define-method message-length ((message <file-message>))
  558.     (+ (let ((headers (get-header-fields message)))
  559.      (if (file-external-ref? headers)
  560.          (- (file-external-ref/end headers)
  561.         (file-external-ref/start headers))
  562.          (apply +
  563.             (map header-field-length
  564.              (message-header-fields message)))))
  565.        1
  566.        (let ((body (get-body message)))
  567.      (if (file-external-ref? body)
  568.          (- (file-external-ref/end body)
  569.         (file-external-ref/start body))
  570.          (string-length (file-message-body message)))))))
  571.  
  572. (define-method message-internal-time ((message <file-message>))
  573.   (or (let loop
  574.       ((headers (get-all-header-fields message "received")) (winner #f))
  575.     (if (pair? headers)
  576.         (loop (cdr headers)
  577.           (let ((time
  578.              (ignore-errors
  579.               (lambda ()
  580.                 (call-with-values
  581.                 (lambda ()
  582.                   (rfc822:received-header-components
  583.                    (header-field-value (car headers))))
  584.                   (lambda (from by via with id for time)
  585.                 from by via with id for    ;ignored
  586.                 time))))))
  587.             (if (and time
  588.                  (not (condition? time))
  589.                  (or (not winner) (< time winner)))
  590.             time
  591.             winner)))
  592.         winner))
  593.       (message-time message)
  594.       (file-folder-modification-time (message-folder message))))
  595.  
  596. (define (file-folder-modification-time folder)
  597.   (or (let ((t
  598.          (or (file-folder-file-modification-time folder)
  599.          (file-modification-time (file-folder-pathname folder)))))
  600.     (and t
  601.          (file-time->universal-time t)))
  602.       (get-universal-time)))
  603.  
  604. (define (file-folder-strip-internal-headers folder ref)
  605.   (call-with-input-xstring (file-folder-xstring folder)
  606.                (file-external-ref/start ref)
  607.     (lambda (port)
  608.       (let loop ((header-lines '()))
  609.     (let ((line (read-line port))
  610.           (finish
  611.            (lambda (offset)
  612.          (values (make-file-external-ref
  613.               (- (xstring-port/position port)
  614.                  offset)
  615.               (file-external-ref/end ref))
  616.              (lines->header-fields (reverse! header-lines))))))
  617.       (cond ((eof-object? line)
  618.          (finish 0))
  619.         ((re-string-match "X-IMAIL-[^:]+:\\|[ \t]" line)
  620.          (loop (cons line header-lines)))
  621.         (else
  622.          (finish (+ (string-length line) 1)))))))))