Index: rfc2388.lisp
===================================================================
--- rfc2388.lisp	(revision 497)
+++ rfc2388.lisp	(working copy)
@@ -23,7 +23,11 @@
 
 (in-package :rfc2388)
 
+
+;;; Special variables
 
+(defvar *read-char* #'read-char
+  "Dynamic scoped var containing the read-char function.")
 
 ;;; Utility functions
 
@@ -81,7 +85,7 @@
                  
                  (if leave-char
                      (setq leave-char nil)
-                     (setq char (read-char stream nil nil)))
+                     (setq char (funcall *read-char* stream nil nil)))
                  
                  (unless char
                    (setq closed t)
@@ -248,7 +252,7 @@
     
     (labels ((skip-lwsp (next-state)
                (loop
-                 do (setq char (read-char stream nil nil))
+                 do (setq char (funcall *read-char* stream nil nil))
                  while (and char (lwsp-char-p char)))
                (setq leave-char t
                      state next-state))
@@ -268,14 +272,14 @@
         
         (if leave-char
             (setq leave-char nil)
-            (setq char (read-char stream nil nil)))
+            (setq char (funcall *read-char* stream nil nil)))
         
         ;; end of stream
         (unless char
           (return))
         
         (when (char= #\return char)
-          (setq char (read-char stream nil nil))
+          (setq char (funcall *read-char* stream nil nil))
           (cond ((or (null char)
                      (char= #\linefeed char))
                  ;; CRLF ends the input
@@ -364,12 +368,14 @@
 ;;; _The_ MIME parsing
 
 
-(defgeneric parse-mime (source boundary &key recursive-p write-content-to-file)
+(defgeneric parse-mime (source boundary &key recursive-p write-content-to-file progress-tracking)
   (:documentation
-   "Parses MIME entities, returning them as a list.  Each element in the
-    list is of form: (body headers), where BODY is the contents of MIME
-    part, and HEADERS are all headers for that part.  BOUNDARY is a string
-    used to separate MIME entities."))
+   "Parses MIME entities, returning them as a list.  Each element in
+the list is of form: (body headers), where BODY is the contents of
+MIME part, and HEADERS are all headers for that part.  BOUNDARY is a
+string used to separate MIME entities. If progress-tracking callback
+is supplied, the parsing engine will periodically invoke the callback
+with a single argument (number of bytes read since last called)."))
 
 
 (defstruct (content-type (:type list)
@@ -407,58 +413,74 @@
   headers)
 
 
-(defmethod parse-mime ((input string) separator &key (recursive-p t) (write-content-to-file t))
+(defmethod parse-mime ((input string) separator &key (recursive-p t) (write-content-to-file t) progress-tracking)
   (with-input-from-string (stream input)
-    (parse-mime stream separator :recursive-p recursive-p :write-content-to-file write-content-to-file)))
+    (parse-mime stream separator :recursive-p recursive-p :write-content-to-file write-content-to-file
+                :progress-tracking progress-tracking)))
 
 
-(defmethod parse-mime ((input stream) boundary &key (recursive-p t) (write-content-to-file t))
+(defmethod parse-mime ((input stream) boundary &key (recursive-p t) (write-content-to-file t) progress-tracking)
   ;; Find the first boundary.  Return immediately if it is also the last
   ;; one.
-  (unless (nth-value 1 (read-until-next-boundary input boundary t))
-    (return-from parse-mime nil))
+  (let* ((bytes-read 0)
+         ;; dynamically bind the *read-char* function, depending on
+         ;; whether we need to report the progress to the caller
+         (*read-char* (if progress-tracking
+                          #'(lambda (&rest args)
+                              (incf bytes-read)
+                              (when (> bytes-read 4096) ; a reasonable block size on most OSes
+                                (funcall progress-tracking bytes-read)
+                                (setq bytes-read 0))
+                              (apply #'read-char args))
+                          #'read-char)))
+    (unless (nth-value 1 (read-until-next-boundary input boundary t))
+      (when (and progress-tracking (> bytes-read 0))
+        (funcall progress-tracking bytes-read))
+      (return-from parse-mime nil))
   
-  (let ((result ())
-	content-type-header)
-    (loop
-      (let ((headers (loop
-		      for header = (parse-header input)
-		      while header
-		      when (string-equal "CONTENT-TYPE" (header-name header))
-		      do (setf content-type-header header 
-			       (header-value header) (parse-content-type (header-value header)))
-		      collect header)))
-	(if (and recursive-p 
-		 (string-equal "MULTIPART" (content-type-super (header-value content-type-header))))
-	    (let ((boundary (cdr (find-parameter "BOUNDARY" (header-parameters content-type-header)))))
-	      (push (make-mime-part (parse-mime input boundary) headers) result))
-            (let ((file-name (get-file-name headers)))
-              (cond ((and write-content-to-file
-                          file-name)
-                     (let ((temp-file (make-tmp-file-name)))
-                       (multiple-value-bind (text more)
-                           (with-open-file (out-file (ensure-directories-exist temp-file)
-                                                     :direction :output
-                                                     ;; external format for faithful I/O
-                                                     ;; see <http://cl-cookbook.sourceforge.net/io.html#faith>
-                                                     #+(or :lispworks :allegro)
-                                                     :external-format
-                                                     #+:lispworks '(:latin-1 :eol-style :lf)
-                                                     #+:allegro (excl:crlf-base-ef :latin1))
-                             (read-until-next-boundary input boundary nil out-file))
-                         (declare (ignore text))
-                         (when (and (stringp file-name)
-                                    (plusp (length file-name)))
-                           (push (make-mime-part temp-file headers) result))
-                         (when (not more)
-                           (return)))))
-                    (t
-                     (multiple-value-bind (text more)
-                         (read-until-next-boundary input boundary)
-                       (push (make-mime-part text headers) result)
-                       (when (not more)
-                         (return)))))))))
-    (nreverse result)))
+    (let ((result ())
+          content-type-header)
+      (loop
+       (let ((headers (loop
+                       for header = (parse-header input)
+                       while header
+                       when (string-equal "CONTENT-TYPE" (header-name header))
+                       do (setf content-type-header header 
+                                (header-value header) (parse-content-type (header-value header)))
+                       collect header)))
+         (if (and recursive-p 
+                  (string-equal "MULTIPART" (content-type-super (header-value content-type-header))))
+             (let ((boundary (cdr (find-parameter "BOUNDARY" (header-parameters content-type-header)))))
+               (push (make-mime-part (parse-mime input boundary) headers) result))
+             (let ((file-name (get-file-name headers)))
+               (cond ((and write-content-to-file
+                           file-name)
+                      (let ((temp-file (make-tmp-file-name)))
+                        (multiple-value-bind (text more)
+                            (with-open-file (out-file (ensure-directories-exist temp-file)
+                                                      :direction :output
+                                                      ;; external format for faithful I/O
+                                                      ;; see <http://cl-cookbook.sourceforge.net/io.html#faith>
+                                                      #+(or :lispworks :allegro)
+                                                      :external-format
+                                                      #+:lispworks '(:latin-1 :eol-style :lf)
+                                                      #+:allegro (excl:crlf-base-ef :latin1))
+                              (read-until-next-boundary input boundary nil out-file))
+                          (declare (ignore text))
+                          (when (and (stringp file-name)
+                                     (plusp (length file-name)))
+                            (push (make-mime-part temp-file headers) result))
+                          (when (not more)
+                            (return)))))
+                     (t
+                      (multiple-value-bind (text more)
+                          (read-until-next-boundary input boundary)
+                        (push (make-mime-part text headers) result)
+                        (when (not more)
+                          (return)))))))))
+      (when (and progress-tracking (> bytes-read 0))
+        (funcall progress-tracking bytes-read))
+      (nreverse result))))
 
 
 (defun find-header (label headers)
