Commits

jhwoodyatt  committed 7a92324

Checkpoint. Migrating to new Cf-0.8, Iom-0.3 and OCaml-3.09 basis.

  • Participants
  • Parent commits c84aacb

Comments (0)

Files changed (13)

File mime/.depend

 mime_lex.cmi: mime_atom.cmi 
 mime_entity.cmi: mime_atom.cmi 
-mime_stream.cmi: mime_entity.cmi 
 mime_atom.cmo: mime_atom.cmi 
 mime_atom.cmx: mime_atom.cmi 
 mime_base64.cmo: mime_base64.cmi 
 mime_lex.cmx: mime_atom.cmx mime_lex.cmi 
 mime_entity.cmo: mime_lex.cmi mime_atom.cmi mime_entity.cmi 
 mime_entity.cmx: mime_lex.cmx mime_atom.cmx mime_entity.cmi 
-mime_stream.cmo: mime_lex.cmi mime_entity.cmi mime_stream.cmi 
-mime_stream.cmx: mime_lex.cmx mime_entity.cmx mime_stream.cmi 
-t/t_mime.cmo: mime_stream.cmi mime_lex.cmi mime_entity.cmi mime_base64.cmi \
-    mime_atom.cmi 
-t/t_mime.cmx: mime_stream.cmx mime_lex.cmx mime_entity.cmx mime_base64.cmx \
-    mime_atom.cmx 
+mime_stream.cmo: mime_entity.cmi mime_stream.cmi 
+mime_stream.cmx: mime_entity.cmx mime_stream.cmi 
+t/t_mime.cmo: mime_lex.cmi mime_entity.cmi mime_base64.cmi mime_atom.cmi 
+t/t_mime.cmx: mime_lex.cmx mime_entity.cmx mime_base64.cmx mime_atom.cmx 

File mime/Makefile

 # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 # OF THE POSSIBILITY OF SUCH DAMAGE. 
 
-DEBUG_OPT = -g -passopt -principal -warn-error A
 REQUIRE = cf iom
 PREDICATES =
 
 OCAMLMKLIB   = ocamlmklib
 OCAMLMKTOP   = ocamlfind ocamlmktop $(OCAMLFINDOPT)
 OCAMLDEP     = ocamldep
+OCAMLLEX     = ocamllex
+OCAMLYACC    = ocamlyacc
+OCAMLDOC     = ocamlfind ocamldoc $(OCAMLFINDOPT)
 
-CC_OPT       = -ccopt -O2 -ccopt -Wall -ccopt -Wno-unused-variable
-CMI_OPT      = $(DEBUG_OPT)
-CMO_OPT      = $(DEBUG_OPT)
-CMX_OPT      = -unsafe -noassert -inline 9
+DEBUG_OPT    = -g
+WARN_ERROR   = -passopt -w -passopt Ae # -warn-error A
+PRINCIPLE    = -principal
+UNSAFE       = -unsafe -noassert
 
-CMA_OPT      =
-CMXA_OPT     =
+ALL_OCAML_OPT = $(WARN_ERROR) $(PRINCIPLE)
+
+CC_OPT  = -ccopt -fPIC -ccopt -O2 -ccopt -Wall -ccopt -Wno-unused-variable
+CMI_OPT = $(ALL_OCAML_OPT) $(DEBUG_OPT)
+CMO_OPT = $(ALL_OCAML_OPT) $(DEBUG_OPT)
+CMX_OPT = $(ALL_OCAML_OPT) $(UNSAFE) -inline 9
 
 .SUFFIXES: .ml .mli .mll .mly .cmo .cmi .cma .cmx .cmxa
 
 MIME_YACC_MODULES = $(MIME_LEXYACC_MODULES:%=mime_yacc_%)
 MIME_LEX_MODULES = $(MIME_LEXYACC_MODULES:%=mime_lex_%)
 
-clean::
-	rm -rf $(MIME_LEX_ML_FILES)
-	rm -rf $(MIME_YACC_ML_FILES)
-	rm -rf $(MIME_YACC_MLI_FILES)
+#clean::
+#	rm -rf $(MIME_LEX_ML_FILES)
+#	rm -rf $(MIME_YACC_ML_FILES)
+#	rm -rf $(MIME_YACC_MLI_FILES)
 
 mime_lex_%.cmo : mime_yacc_%.cmi mime_lex_%.cmi
 mime_lex_%.cmx : mime_yacc_%.cmi mime_lex_%.cmi
 
 opt:: $(TEST_OPT_PROGRAMS)
 
-t.% : t/t_%.ml mime.cma
-	$(OCAMLC) $(DEBUG_OPT) -o $@ $(TEST_LINKOPT) $(TEST_LIBS:%=%.cma) $<
+t.% : t/t_%.ml $(TEST_LIBS:%=%.cma)
+	$(OCAMLC) -o $@ $(CMO_OPT) $(DEBUG_OPT) $(TEST_LINKOPT) \
+        $(TEST_LIBS:%=%.cma) $<
 
-t-opt.% : t/t_%.ml mime.cmxa
-	$(OCAMLOPT) -o $@ $(TEST_LINKOPT) $(TEST_LIBS:%=%.cmxa) $<
+t-opt.% : t/t_%.ml $(TEST_LIBS:%=%.cmxa)
+	$(OCAMLOPT) -o $@ $(CMX_OPT) $(TEST_LINKOPT) $(TEST_LIBS:%=%.cmxa) $<
 
 test:: $(TEST_PROGRAMS)
 	@for i in $(TEST_PROGRAMS); do echo; echo $$i; ./$$i; done
 
 default:: ocamltop
 
-ocamltop: mime.cma
-	$(OCAMLMKTOP) -o $@ $(TEST_LINKOPT) $(TEST_LIBS:%=%.cma)
+ocamltop: $(TEST_LIBS:%=%.cma)
+	$(OCAMLMKTOP) -o $@ $(CMO_OPT) $(TEST_LINKOPT) $(TEST_LIBS:%=%.cma)
 
 clean::
 	rm -f ocamltop
 DOC_SOURCES = $(MIME_MLI_FILES) $(MIME_ML_FILES)
 
 DOC_INCLUDE_CF = `ocamlfind query cf`
+DOC_INCLUDE_IOM = `ocamlfind query iom`
 
 doc::
 	@mkdir -p doc
 	ocamldoc.opt -v -d doc -html -colorize-code -m A \
-	  -I $(DOC_INCLUDE_CF) $(DOC_SOURCES)
+	  -I $(DOC_INCLUDE_CF) -I $(DOC_INCLUDE_IOM) $(DOC_SOURCES)
 
 ###############################################################################
 

File mime/mime_atom.ml

 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  mime_atom.ml
 
-  Copyright (c) 2004-2005, James H. Woodyatt
+  Copyright (c) 2004-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without

File mime/mime_atom.mli

 (*---------------------------------------------------------------------------*
   INTERFACE  mime_atom.mli
 
-  Copyright (c) 2004-2005, James H. Woodyatt
+  Copyright (c) 2004-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without

File mime/mime_base64.ml

 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  mime_base64.ml
 
-  Copyright (c) 2003-2005, James H. Woodyatt
+  Copyright (c) 2003-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without

File mime/mime_base64.mli

 (*---------------------------------------------------------------------------*
   INTERFACE  mime_base64.mli
 
-  Copyright (c) 2003-2005, James H. Woodyatt
+  Copyright (c) 2003-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without

File mime/mime_entity.ml

 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  mime_entity.ml
 
-  Copyright (c) 2003-2005, James H. Woodyatt
+  Copyright (c) 2003-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
     cd_parameters: string Mime_atom.Map.t;
 }
 
-class type t =
+class type headers =
     object
         method content_type: ct_t option
         method content_disposition: cd_t option
         method content_length: int64 option
         method content_id: (string * string) option
         method unstructured: (string * string) list
-        method body: Cf_message.t
     end
 
 module S = struct
     let content_id = "Content-Id"
 end
 
-class parsing =
+class headers_parser =
     let p_end_of_field =
         L.parse_optcfws >>= fun () ->
         L.parse_crlf >>= fun () ->
         | Some cte -> p_end_of_field >>= fun () -> ~:cte
     and p_content_length =
         L.parse_optcfws >>= fun () ->
-		L.parse_atom >>= fun atom ->
-		let n = Int64.of_string atom in
+    	L.parse_atom >>= fun atom ->
+    	let n = Int64.of_string atom in
         p_end_of_field >>= fun () ->
         ~:n
     and p_content_id =
         p_end_of_field >>= fun () ->
         ~:addr
     in
-    fun ?h:fields body ->
-		let fields, body =
-			match fields with
-			| None ->
-				Mime_lex.split_into_fields body
-			| Some fields ->
-				fields, body
-		in
+    fun fields ->
         let ctz, fields =
             L.select_opt_field S.content_type p_content_type fields
         in
             end
         in
         object(_:'self)
-            constraint 'self = #t
-			
-			val body_ = body
-            
+            constraint 'self = #headers
+    		            
             method content_type = Lazy.force ctz
             method content_disposition = Lazy.force cdiz
             method content_transfer_encoding = Lazy.force ctez            
             method content_id = Lazy.force cidz
 
             method unstructured = Lazy.force unstructured
-            method body = body_
-			
-			method put_body m = {< body_ = body_ @ m >}
             
             method force =
                 let _ = Lazy.force ctz in
                 let _ = Lazy.force clz in
                 let _ = Lazy.force cidz in
                 ()
-            			
-			initializer
-				List.iter begin fun (name, body) ->
-					jout#info "Mime_entity.parsing: name=%s body='%s'"
-						name (Cf_seq.to_string body)
-				end fields
         end
 
-let parse msg =
-	let p = new parsing msg in
-	p#force;
-	p
+let parse_headers msg =
+    let headers, body = Mime_lex.split_into_fields msg in
+    let hp = new headers_parser headers in
+    hp#force;
+    hp, body
 
-class emitting =
+class headers_emitter =
     let e_content_type pp ct =
         Format.fprintf pp "%s/%s" (ct_type_to_string ct.ct_type) ct.ct_subtype;
         L.emit_parameters pp ct.ct_parameters
         L.emit_addr_domain pp domain;
         Format.pp_print_char pp '>'
     in
-    fun ?ct ?cdi ?cte ?cde ?cl ?cid ?(u = []) body ->
+    fun ?ct ?cdi ?cte ?cde ?cl ?cid u ->
     object(self)
-        constraint 'self = #t
+        constraint 'self = #headers
 
         method content_type = ct
         method content_disposition = cdi
         method content_length = cl
         method content_id = cid
         method unstructured = u
-        method body = body
 
         method private emit_structured pp =
             L.emit_optional_field e_content_type pp S.content_type
             Format.pp_print_newline pp ();
             let str = Buffer.contents b in
             let len = String.length str in
-            (str, 0, len) :: body
+            [ str, 0, len ]
     end
 
-let emit ?ct ?cdi ?cte ?cde ?cl ?cid ?u body =
+let emit_headers ?ct ?cdi ?cte ?cde ?cl ?cid u =
     object
-		inherit emitting ?ct ?cdi ?cte ?cde ?cl ?cid ?u body as super
-		val mutable text_ = lazy (raise Lazy.Undefined)
-		method emit = Lazy.force text_
-		initializer text_ <- Lazy.lazy_from_val super#emit
-	end
+    	inherit headers_emitter ?ct ?cdi ?cte ?cde ?cl ?cid u as super
+    	val mutable text_ = lazy (raise Lazy.Undefined)
+    	method emit = Lazy.force text_
+    	initializer text_ <- Lazy.lazy_from_val super#emit
+    end
 
 (*--- End of File [ mime_entity.ml ] ---*)

File mime/mime_entity.mli

 (*---------------------------------------------------------------------------*
   INTERFACE  mime_entity.mli
 
-  Copyright (c) 2003-2005, James H. Woodyatt
+  Copyright (c) 2003-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
     cd_parameters: string Mime_atom.Map.t;
 }
 
-class type t =
+class type headers =
     object
         method content_type: ct_t option
         method content_disposition: cd_t option
         method content_length: int64 option
         method content_id: (string * string) option
         method unstructured: (string * string) list
-        method body: Cf_message.t
     end
 
-class parsing:
-    ?h:(string * char Cf_seq.t) list -> Cf_message.t ->
-    object('self)
-        inherit t
-		val body_: Cf_message.t        
+class headers_parser:
+    (string * char Cf_seq.t) list ->
+    object
+        inherit headers
         method force: unit
-		method put_body: Cf_message.t -> 'self
     end
 
-val parse: Cf_message.t -> parsing
+val parse_headers: Cf_message.t -> headers_parser * Cf_message.t
 
-class emitting:
+class headers_emitter:
     ?ct:ct_t -> ?cdi:cd_t -> ?cte:cte_t -> ?cde:string -> ?cl:int64 ->
-    ?cid:(string * string) -> ?u:(string * string) list -> Cf_message.t ->
+    ?cid:(string * string) -> (string * string) list ->
     object
-        inherit t
+        inherit headers
         
         method private emit_structured: Format.formatter -> unit
         method private emit_unstructured: Format.formatter -> unit
         method emit: Cf_message.t
     end
 
-val emit:
+val emit_headers:
     ?ct:ct_t -> ?cdi:cd_t -> ?cte:cte_t -> ?cde:string -> ?cl:int64 ->
-    ?cid:(string * string) -> ?u:(string * string) list -> Cf_message.t ->
-    emitting
+    ?cid:(string * string) -> (string * string) list -> headers_emitter
 
 (*--- End of File [ mime_entity.mli ] ---*)

File mime/mime_lex.ml

 
 let parse_crlf =
     parse_optcfws >>= fun () ->
-	cr_ >>= fun _ ->
-	lf_ >>= fun _ ->
-	~:()
+    cr_ >>= fun _ ->
+    lf_ >>= fun _ ->
+    ~:()
 
 let parse_raw_atom_ = Cf_lex.create (E.raw_atom $> identity_)
 let parse_raw_dot_atom_ = Cf_lex.create (E.raw_dot_atom $> identity_)
 let crlf_string_ = "\r\n"
 
 exception Bad_field_name of int * Cf_message.t
-exception Incomplete_headers
 
 let split_at_body =
     let rec loop pos z =
         match Lazy.force z with
         | Cf_seq.Z ->
-            raise Incomplete_headers
+            raise End_of_file
         | Cf_seq.P (hd, tl) when hd <> '\013' ->
             loop (succ pos) tl
-        | Cf_seq.P (hd, tl) ->
+        | Cf_seq.P (_, tl) ->
             match Lazy.force tl with
             | Cf_seq.Z ->
-                raise Incomplete_headers
+                raise End_of_file
             | Cf_seq.P (hd, tl) when hd <> '\010' ->
                 loop (pos + 2) tl
-            | Cf_seq.P (hd, tl) ->
+            | Cf_seq.P (_, tl) ->
                 match Lazy.force tl with
                 | Cf_seq.Z ->
-                    raise Incomplete_headers
+                    raise End_of_file
                 | Cf_seq.P (hd, tl) when hd <> '\013' ->
                     loop (pos + 3) tl
-                | Cf_seq.P (hd, tl) ->
+                | Cf_seq.P (_, tl) ->
                     match Lazy.force tl with
                     | Cf_seq.Z ->
-                        raise Incomplete_headers
+                        raise End_of_file
                     | Cf_seq.P (hd, tl) when hd <> '\010' ->
                         loop (pos + 4) tl
-                    | Cf_seq.P (hd, tl) ->
+                    | Cf_seq.P _ ->
                         pos + 4
     in
     fun m ->
 let rec split_into_fields_scan_ pos rows z =
     match Lazy.force z with
     | Cf_seq.Z ->
-        raise Incomplete_headers
+        raise End_of_file
     | Cf_seq.P (c, z) when c <> '\r' ->
         split_into_fields_scan_ (succ pos) rows z
     | Cf_seq.P (_, z) ->
         match Lazy.force z with
         | Cf_seq.Z ->
-            raise Incomplete_headers
+            raise End_of_file
         | Cf_seq.P (c, z) when c <> '\n' ->
             split_into_fields_scan_ (pos + 2) rows z
         | Cf_seq.P (_, z) ->
     let pos, rows, tl = split_into_fields_scan_ 0 0 z in
     let field, m = Cf_message.split ~pos m in
     if pos = 2 then
-		(List.rev_map f) acc, m
-	else
-		match parse_field_name (Cf_message.to_seq field) with
-		| None ->
-			raise (Bad_field_name (line, field))
-		| Some (name, z) ->
-			let acc = (line, name, z) :: acc in
-			split_into_fields_loop_ f (line + rows) acc m tl
+    	(List.rev_map f) acc, m
+    else
+    	match parse_field_name (Cf_message.to_seq field) with
+    	| None ->
+    		raise (Bad_field_name (line, field))
+    	| Some (name, z) ->
+    		let acc = (line, name, z) :: acc in
+    		split_into_fields_loop_ f (line + rows) acc m tl
 
 let split_into_fields_and_map f m =
     split_into_fields_loop_ f 0 [] m (Cf_message.to_seq m)
         lazy (List.map g h1), h2
 
 let formatter b =
-	let pp = Format.formatter_of_buffer b in
-	let out, flush, _, spaces =
-		Format.pp_get_all_formatter_output_functions pp ()
-	in
-	let newline () = out crlf_string_ 0 2 in
-	let pp = Format.make_formatter out flush in
-	Format.pp_set_all_formatter_output_functions
-		pp ~out ~flush ~newline ~spaces;
-	Format.pp_set_margin pp 75;
-	pp
+    let pp = Format.formatter_of_buffer b in
+    let out, flush, _, spaces =
+    	Format.pp_get_all_formatter_output_functions pp ()
+    in
+    let newline () = out crlf_string_ 0 2 in
+    let pp = Format.make_formatter out flush in
+    Format.pp_set_all_formatter_output_functions
+    	pp ~out ~flush ~newline ~spaces;
+    Format.pp_set_margin pp 75;
+    pp
 
 let emit_folding_char pp = function
     | '\128'..'\255' as c -> Format.fprintf pp "%%%02X" (Char.code c)

File mime/mime_lex.mli

 (* Message splitting and field selecting *)
 
 exception Bad_field_name of int * Cf_message.t
-exception Incomplete_headers
 
 val split_at_body: Cf_message.t -> Cf_message.t * Cf_message.t
 

File mime/mime_stream.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-(*
+(**)
 let jout = Cf_journal.stdout
-*)
+(**)
 
 open Cf_cmonad.Op
 
 exception Header_too_long
 
-class ['header] fragment more octets header =
+(*---------------------------------------------------------------------------*
+let rec mqPush n q = function
+    | (_, _, len as hd) :: tl -> mqPush (n + len) (Cf_deque.A.push hd q) tl
+    | [] -> n, q
+
+let rec mqPop m x n q =
+    if x > 0 then
+        match Cf_deque.B.pop q with
+        | Some ((buf, pos, len), tl) when len > x ->
+            let hd1 = buf, pos + x, len - x and hd0 = buf, pos, x in
+            mqPop (hd0 :: m) 0 (n - x) (Cf_deque.B.push hd1 tl)
+        | Some ((_, _, len as hd), tl) ->
+            mqPop (hd :: m) (x - len) (n - len) tl
+        | None ->
+    		List.rev m, n, q
+    else
+        List.rev m, n, q
+
+let mqDrain = Cf_deque.A.fold (fun m s -> s :: m) []
+
+(*
+type Iom_file.rd_binding = {
+    rd_ctrlTx: reader_control_t Iom_gadget.tx;
+    rd_sigRx: signal_t Iom_gadget.rx;
+    rd_dataRx: octets Iom_gadget.rx;
+}
+*)
+
+type 'headers rd_signal =
+    [ Iom_reactor.signal | `Headers of 'headers ]
+    constraint 'headers = #Mime_entity.headers_parser
+
+class ['headers] rd ctrlRx sigTx dataTx fileBind = object(self)
+    inherit Iom_machine.initial
+    
+    val ctrlRx_ = (ctrlRx :> Iom_file.reader_control_t Iom_gadget.rx)
+    val sigTx_ = (sigTx :> 'headers rd_signal Iom_gadget.tx)
+    val dataTx_ = (dataTx :> Iom_file.octets Iom_gadget.tx)
+
+    val ctrlTx_ = fileBind.Iom_file.rd_ctrlTx;
+    val sigRx_ = fileBind.Iom_file.rd_sigRx;
+    val dataRx_ = fileBind.Iom_file.rd_sigRx;
+    
+    method private control = function
+    	| `Ready -> self#ready
+    	| `Wait -> self#wait
+    	| `Close -> self#close
+    	| `Unlink -> self#unlink
+    
+    method private error x = sigTx#put (`Error x)
+    
+    method private signal (`Error x) = self#error x
+    
+    method private guard =
+    	sigRx_#get self#signal >>= fun () ->
+    	ctrlRx_#get self#control >>= fun () ->
+    	dataRx_#get self#receive
+end
+ *---------------------------------------------------------------------------*)
+
+(*---------------------------------------------------------------------------*
+class ['headers] fragment ?h:headers more octets =
     object
         inherit Iom_file.octets more octets
-        constraint 'header = #Mime_entity.t
-        method header: 'header = header
+        constraint 'headers = #Mime_entity.headers
+        method headers: 'headers option = headers
     end
 
 (*---
   val pushQ_:
-	int -> (string * int * int) Cf_deque.t -> Cf_message.t ->
-	int * (string * int * int) Cf_deque.t
-	
-	Given a queue Q, with N bytes total in it, push the contents of the message
-	onto the B end the queue, and increment N by the size of the message.
+    int -> (string * int * int) Cf_deque.t -> Cf_message.t ->
+    int * (string * int * int) Cf_deque.t
+    
+    Given a queue Q, with N bytes total in it, push the contents of the message
+    onto the B end the queue, and increment N by the size of the message.
   ---*)
 let rec pushQ_ n q = function
     | (_, _, len as hd) :: tl ->
-		pushQ_ (n + len) (Cf_deque.A.push hd q) tl
+    	pushQ_ (n + len) (Cf_deque.A.push hd q) tl
     | [] ->
-		n, q
+    	n, q
 
 (*---
   val popQLoop_:
-	Cf_message.t -> int -> int -> (string * int * int) Cf_deque.t ->
-	Cf_message.t * int * (string * int * int) Cf_deque.t
+    Cf_message.t -> int -> int -> (string * int * int) Cf_deque.t ->
+    Cf_message.t * int * (string * int * int) Cf_deque.t
 
-	Given an accumulator M (assumed empty), a requested length X, a length N
-	and a queue Q, pop up to X bytes off the queue into the (reversing)
-	accumulator.
+    Given an accumulator M (assumed empty), a requested length X, a length N
+    and a queue Q, pop up to X bytes off the queue into the (reversing)
+    accumulator.
   ---*)
 
 let rec popQLoop_ m x n q =
         | Some ((_, _, len as hd), tl) ->
             popQLoop_ (hd :: m) (x - len) (n - len) tl
         | None ->
-			popQLoop_ m 0 n q
+    		popQLoop_ m 0 n q
     else
         List.rev m, n, q
 
 
         constraint 'w = [> Iom_file.ready_t ]
         constraint 'd = #Iom_file.octets
-        constraint 'h = #Mime_entity.t
+        constraint 'h = #Mime_entity.headers
         
         val queue_ = Cf_deque.nil
         val ready_ = false
         val more_ = Iom_file.More
         val length_ = 0
-        val header_ = None
-        
-        method private virtual send:
-            Iom_file.more_t -> 'h -> Cf_message.t -> ('self, unit) Iom_gadget.t
+        val headers_ = None
 
         method private virtual receive: 'd -> ('self, unit) Iom_gadget.t
-		
-		(*---
-		  We drain the buffer [e] bytes at a time until there are no more bytes
-		  in the stream, or a transmission exception is raised, or there's less
-		  than [d] bytes left.  If we the stream is still in progress, then
-		  construct a new object and invoke #next on it.
-		  ---*)
+
+        method private virtual send:
+            ?h:'h -> Iom_file.more_t -> Cf_message.t ->
+    		('self, unit) Iom_gadget.t
+    	
+    	(*---
+    	  We drain the buffer [e] bytes at a time until there are no more bytes
+    	  in the stream, or a transmission exception is raised, or there's less
+    	  than [d] bytes left.  If we the stream is still in progress, then
+    	  construct a new object and invoke #next on it.
+    	  ---*)
         method private drain r more n q h =
-			let m, n, q = popQ_ ~e n q in
-			match h, m with
-			| None, _	(* no header yet [ingesting] *)
-			| _, [] ->	(* queue is empty *)
-				(*
-				assert (jout#debug
-					"Mime_stream.buffer#drain: done! h=%s n=%d m='%s'"
-					(match h with None -> "None" | _ -> "Some") n
-					(Cf_message.contents m));
-				*)
-				let obj = {<
-					queue_ = q; ready_ = r; more_ = more; length_ = n;
-					header_ = h;
-				>} in
-				obj#next
-			| Some h0, _ ->
-				let txmore = if n > 0 then Iom_file.More else more in
-				(*
-				assert (jout#debug
-					"Mime_stream.buffer#drain: sending... n=%d d=%d %s'%s'"
-					n d (if txmore = Iom_file.More then "+" else ".")
-					(Cf_message.contents m));
-				*)
-				self#send txmore h0 m >>= fun () ->
-				match txmore with
-				| Iom_file.More ->
-					if n < d && more = Iom_file.More then
-						let obj = {<
-							queue_ = q; ready_ = r; more_ = more;
-							length_ = n; header_ = h;
-						>} in
-						obj#next
-					else
-						self#drain r more n q h
-				| _ ->
-					self#drain r more n q h
+    		let m, n, q = popQ_ ~e n q in
+    		match h, m with
+    		| None, _	(* no headers yet [ingesting] *)
+    		| _, [] ->	(* queue is empty *)
+    			assert (jout#debug
+    				"Mime_stream.buffer#drain: done! h=%s n=%d m='%s'"
+    				(match h with None -> "None" | _ -> "Some") n
+    				(Cf_message.contents m));
+    			let obj = {<
+    				queue_ = q; ready_ = r; more_ = more; length_ = n;
+    				headers_ = h;
+    			>} in
+    			obj#next
+    		| Some _, _ ->
+    			let txmore = if n > 0 then Iom_file.More else more in
+    			assert (jout#debug
+    				"Mime_stream.buffer#drain: sending... n=%d d=%d %s'%s'"
+    				n d (if txmore = Iom_file.More then "+" else ".")
+    				(Cf_message.contents m));
+    			self#send ?h txmore m >>= fun () ->
+    			match txmore with
+    			| Iom_file.More ->
+    				if n < d && more = Iom_file.More then
+    					let obj = {<
+    						queue_ = q; ready_ = r; more_ = more;
+    						length_ = n; headers_ = h;
+    					>} in
+    					obj#next
+    				else
+    					self#drain r more n q None
+    			| _ ->
+    				self#drain r more n q h
         
         method private wait = {< ready_ = false >}#next
         
         method private ready =
             begin
-                if length_ < e then readyTx#put `Ready else Cf_cmonad.return ()
+                if length_ < e then readyTx#put `Ready else Cf_cmonad.nil 
             end >>= fun () ->
-            self#drain true more_ length_ queue_ header_
+            self#drain true more_ length_ queue_ headers_
         
         method private flow = function
             | `Wait when ready_ -> self#wait
         constraint 'c = Iom_file.reader_control_t
         constraint 's = Iom_file.signal_t
         constraint 'd = Iom_file.octets
-        constraint 'h = #Mime_entity.parsing
-		
-		method private error x =
-			sigTx#put (`Error x) >>= fun () ->
-			ctrlTx#put `Close
-		
-		method private receive data =
-			let more = data#more and m = data#octets in
-			let n = length_ + Cf_message.length m in
-			let m = Cf_deque.fold (fun m s -> s :: m) data#octets queue_ in
-			if n < e && more = Iom_file.More then
-				let n, q = pushQ_ 0 Cf_deque.nil m in
-				{< length_ = n; queue_ = q >}#next
-			else
-				match header_ with
-				| Some _ ->
-					let n, q = pushQ_ 0 Cf_deque.nil m in
-					self#drain ready_ more n q header_
-				| None ->
-					match
-						try
-							let m0, m1 = Mime_lex.split_at_body m in
-							Cf_exnopt.U (Some (p m0, m1))
-						with
-						| Mime_lex.Incomplete_headers ->
-							Cf_exnopt.U None
-						| x ->
-							Cf_exnopt.X x
-					with
-					| Cf_exnopt.X x ->
-						self#error x
-					| Cf_exnopt.U (Some (h, m)) ->
-						let n, q = pushQ_ 0 Cf_deque.nil m in
-						self#drain ready_ more n q (Some h)
-					| Cf_exnopt.U None when n < e ->
-						let n, q = pushQ_ n Cf_deque.nil m in
-						{< length_ = n; queue_ = q >}#next
-					| Cf_exnopt.U None ->
-						self#error Header_too_long
-					
-        method private send more h m = dataTx#put (new fragment more m h)
-		
+        constraint 'h = #Mime_entity.headers_parser
+    	
+    	method private error x =
+    		sigTx#put (`Error x) >>= fun () ->
+    		ctrlTx#put `Close
+    	
+    	method private receive data =
+    		let more = data#more and m = data#octets in
+    		let n = length_ + Cf_message.length m in
+    		let m = Cf_deque.fold (fun m s -> s :: m) data#octets queue_ in
+    		if n < e && more = Iom_file.More then
+    			let n, q = pushQ_ 0 Cf_deque.nil m in
+    			{< length_ = n; queue_ = q >}#next
+    		else
+    			match headers_ with
+    			| Some _ ->
+    				let n, q = pushQ_ 0 Cf_deque.nil m in
+    				self#drain ready_ more n q headers_
+    			| None ->
+    				match
+    					try
+    						Cf_exnopt.U (Some (p m))
+    					with
+    					| End_of_file ->
+    						Cf_exnopt.U None
+    					| x ->
+    						Cf_exnopt.X x
+    				with
+    				| Cf_exnopt.X x ->
+    					self#error x
+    				| Cf_exnopt.U (Some (h, m)) ->
+    					let n, q = pushQ_ 0 Cf_deque.nil m in
+    					self#drain ready_ more n q (Some h)
+    				| Cf_exnopt.U None when n < e ->
+    					let n, q = pushQ_ n Cf_deque.nil m in
+    					{< length_ = n; queue_ = q >}#next
+    				| Cf_exnopt.U None ->
+    					self#error Header_too_long
+    				
+        method private send ?h more m = dataTx#put (new fragment ?h more m)
+    	
         method private signal x = sigTx#put x
         
         method private flow = function
             super#guard >>= fun () ->
             match more_ with
             | Iom_file.More -> dataRx#get self#receive
-            | _ -> Cf_cmonad.return ()
+            | _ -> Cf_cmonad.nil 
 
     end
 
 
         constraint 'c = Iom_file.control_t
         constraint 's = Iom_file.writer_signal_t
-        constraint 'h = #Mime_entity.emitting
+        constraint 'h = #Mime_entity.headers_emitter
         constraint 'd = 'h fragment
         
         method private receive (data : 'd) =
             let more = data#more in
             let h, m =
-                match header_ with
+                match headers_ with
                 | Some _ ->
-                    (Some data#header), data#octets
+                    data#headers, data#octets
                 | None ->
-                    let h = data#header in
+                    let h = data#headers in
                     let m = data#octets in
-                    Some h, (h#emit @ m)
+                    h, m
             in
-			(*
-			assert (jout#debug "Mime_stream.renderer#receive: %s'%s'"
-				(if more = Iom_file.More then "+" else ".")
-				(Cf_message.contents m));
-			*)
+    		assert (jout#debug "Mime_stream.renderer#receive: %s'%s'"
+    			(if more = Iom_file.More then "+" else ".")
+    			(Cf_message.contents m));
             let n, q = pushQ_ length_ queue_ m in
             match more with
             | Iom_file.More when n < e -> 
-                {< length_ = n; queue_ = q; header_ = h >}#next
+                {< length_ = n; queue_ = q; headers_ = h >}#next
             | _ ->
                 self#drain ready_ more n q h
 
-        method private send more _ m =
-			dataTx#put (new Iom_file.octets more m) >>= fun () ->
-			if more = Iom_file.Last then
-				sigTx#put `Final
-			else
-				Cf_cmonad.return ()
-			
+        method private send ?h more m =
+    		let m =
+    			match h with
+    			| None -> m
+    			| Some h -> h#emit @ m
+    		in
+    		dataTx#put (new Iom_file.octets more m) >>= fun () ->
+    		if more = Iom_file.Last then
+    			sigTx#put `Final
+    		else
+    			Cf_cmonad.nil 
+    		
         method private control x = ctrlTx#put x
         
         method private flow = function
             super#guard >>= fun () ->
             match more_ with
             | Iom_file.More -> dataRx#get self#receive
-            | _ -> Cf_cmonad.return ()
+            | _ -> Cf_cmonad.nil 
     end
 
 type 'p rd_t = {
-	rd_ctrlTx: Iom_file.reader_control_t Iom_gadget.tx;
-	rd_sigRx: Iom_file.signal_t Iom_gadget.rx;
-	rd_dataRx: 'p fragment Iom_gadget.rx;
-} constraint 'p = #Mime_entity.parsing
+    rd_ctrlTx: Iom_file.reader_control_t Iom_gadget.tx;
+    rd_sigRx: Iom_file.signal_t Iom_gadget.rx;
+    rd_dataRx: 'p fragment Iom_gadget.rx;
+} constraint 'p = #Mime_entity.headers
 
 let ingest ~e ?d ~p rd =
-	Iom_gadget.simplex >>= fun (ctrlRx, ctrlTx) ->
-	Iom_gadget.simplex >>= fun (sigRx, sigTx) ->
-	Iom_gadget.simplex >>= fun (dataRx, dataTx) ->
-	let ctrlIO = ctrlRx, rd.Iom_file.rd_ctrlTx in
-	let sigIO = rd.Iom_file.rd_sigRx, sigTx in
-	let i =
-		new ingestor ~e ?d ~p ~c:ctrlIO ~s:sigIO rd.Iom_file.rd_dataRx dataTx
-	in
-	i#start >>= fun () ->
-	Cf_cmonad.return {
-		rd_ctrlTx = ctrlTx;
-		rd_sigRx = sigRx;
-		rd_dataRx = dataRx;
-	}
+    Iom_gadget.simplex >>= fun (ctrlRx, ctrlTx) ->
+    Iom_gadget.simplex >>= fun (sigRx, sigTx) ->
+    Iom_gadget.simplex >>= fun (dataRx, dataTx) ->
+    let ctrlIO = ctrlRx, rd.Iom_file.rd_ctrlTx in
+    let sigIO = rd.Iom_file.rd_sigRx, sigTx in
+    let i =
+    	new ingestor ~e ?d ~p ~c:ctrlIO ~s:sigIO rd.Iom_file.rd_dataRx dataTx
+    in
+    i#start >>= fun () ->
+    Cf_cmonad.return {
+    	rd_ctrlTx = ctrlTx;
+    	rd_sigRx = sigRx;
+    	rd_dataRx = dataRx;
+    }
 
 type 'e wr_t = {
-	wr_ctrlTx: Iom_file.control_t Iom_gadget.tx;
-	wr_sigRx: Iom_file.writer_signal_t Iom_gadget.rx;
-	wr_dataTx: 'e fragment Iom_gadget.tx;
-} constraint 'e = #Mime_entity.emitting
+    wr_ctrlTx: Iom_file.control_t Iom_gadget.tx;
+    wr_sigRx: Iom_file.writer_signal_t Iom_gadget.rx;
+    wr_dataTx: 'e fragment Iom_gadget.tx;
+} constraint 'e = #Mime_entity.headers
 
 let render ~e ?d wr =
-	Iom_gadget.simplex >>= fun (ctrlRx, ctrlTx) ->
-	Iom_gadget.simplex >>= fun (sigRx, sigTx) ->
-	Iom_gadget.simplex >>= fun (dataRx, dataTx) ->
-	let ctrlIO = ctrlRx, wr.Iom_file.wr_ctrlTx in
-	let sigIO = wr.Iom_file.wr_sigRx, sigTx in
-	let r =
-		new renderer ~e ?d ~c:ctrlIO ~s:sigIO dataRx wr.Iom_file.wr_dataTx
-	in
-	r#start >>= fun () ->
-	Cf_cmonad.return {
-		wr_ctrlTx = ctrlTx;
-		wr_sigRx = sigRx;
-		wr_dataTx = dataTx;
-	}
+    Iom_gadget.simplex >>= fun (ctrlRx, ctrlTx) ->
+    Iom_gadget.simplex >>= fun (sigRx, sigTx) ->
+    Iom_gadget.simplex >>= fun (dataRx, dataTx) ->
+    let ctrlIO = ctrlRx, wr.Iom_file.wr_ctrlTx in
+    let sigIO = wr.Iom_file.wr_sigRx, sigTx in
+    let r =
+    	new renderer ~e ?d ~c:ctrlIO ~s:sigIO dataRx wr.Iom_file.wr_dataTx
+    in
+    r#start >>= fun () ->
+    Cf_cmonad.return {
+    	wr_ctrlTx = ctrlTx;
+    	wr_sigRx = sigRx;
+    	wr_dataTx = dataTx;
+    }
+ *---------------------------------------------------------------------------*)
 
 (*--- End of File [ mime_stream.ml ] ---*)

File mime/mime_stream.mli

 
 exception Header_too_long
 
-class ['header] fragment:
-    Iom_file.more_t -> Cf_message.t -> 'header ->
+(*---------------------------------------------------------------------------*
+class ['headers] fragment:
+    ?h:'headers -> Iom_file.more_t -> Cf_message.t ->
     object
         inherit Iom_file.octets
-        constraint 'header = #Mime_entity.t
-        method header: 'header
+        constraint 'headers = #Mime_entity.headers
+        method headers: 'headers option
     end
 
 class virtual ['w, 'd, 'h] buffer:
         
         constraint 'w = [> Iom_file.ready_t ]
         constraint 'd = #Iom_file.octets
-        constraint 'h = #Mime_entity.t
+        constraint 'h = #Mime_entity.headers
 
         val queue_: (string * int * int) Cf_deque.t
         val ready_: bool
         val more_: Iom_file.more_t
         val length_: int
-        val header_: 'h option
+        val headers_: 'h option
 
         method private drain:
             bool -> Iom_file.more_t -> int ->
         method private virtual receive: 'd -> ('self, unit) Iom_gadget.t
 
         method private virtual send:
-            Iom_file.more_t -> 'h -> Cf_message.t -> ('self, unit) Iom_gadget.t
+            ?h:'h -> Iom_file.more_t -> Cf_message.t ->
+    		('self, unit) Iom_gadget.t
         
         method private ready: ('self, unit) Iom_gadget.t
         method private wait : ('self, unit) Iom_gadget.t
     end
 
 class ['h] ingestor:
-    e:int -> ?d:int -> p:(Cf_message.t -> 'h) ->
-	c:('c #Iom_gadget.rx * 'c #Iom_gadget.tx) ->
-	s:('s #Iom_gadget.rx * 's #Iom_gadget.tx) ->
-	'd #Iom_gadget.rx -> 'h fragment #Iom_gadget.tx ->
+    e:int -> ?d:int -> p:(Cf_message.t -> 'h * Cf_message.t) ->
+    c:('c #Iom_gadget.rx * 'c #Iom_gadget.tx) ->
+    s:('s #Iom_gadget.rx * 's #Iom_gadget.tx) ->
+    'd #Iom_gadget.rx -> 'h fragment #Iom_gadget.tx ->
     object('self)
         inherit ['c, 'd, 'h] buffer
 
         constraint 'c = Iom_file.reader_control_t
         constraint 's = Iom_file.signal_t
         constraint 'd = Iom_file.octets
-        constraint 'h = #Mime_entity.parsing
+        constraint 'h = #Mime_entity.headers_parser
 
         method private receive: 'd -> ('self, unit) Iom_gadget.t
 
         method private send:
-            Iom_file.more_t -> 'h -> Cf_message.t -> ('self, unit) Iom_gadget.t
+    		 ?h:'h -> Iom_file.more_t -> Cf_message.t ->
+    		 ('self, unit) Iom_gadget.t
     end
 
 class ['h] renderer:
 
         constraint 'c = Iom_file.control_t
         constraint 's = Iom_file.writer_signal_t
-        constraint 'h = #Mime_entity.emitting
+        constraint 'h = #Mime_entity.headers_emitter
         constraint 'd = 'h fragment
 
         method private receive: 'd -> ('self, unit) Iom_gadget.t
 
         method private send:
-            Iom_file.more_t -> 'h -> Cf_message.t -> ('self, unit) Iom_gadget.t
+            ?h:'h -> Iom_file.more_t -> Cf_message.t ->
+    		('self, unit) Iom_gadget.t
     end
 
 type 'h rd_t = {
-	rd_ctrlTx: Iom_file.reader_control_t Iom_gadget.tx;
-	rd_sigRx: Iom_file.signal_t Iom_gadget.rx;
-	rd_dataRx: 'h fragment Iom_gadget.rx;
-} constraint 'h = #Mime_entity.parsing
+    rd_ctrlTx: Iom_file.reader_control_t Iom_gadget.tx;
+    rd_sigRx: Iom_file.signal_t Iom_gadget.rx;
+    rd_dataRx: 'h fragment Iom_gadget.rx;
+} constraint 'h = #Mime_entity.headers
 
 val ingest:
-	e:int -> ?d:int -> p:(Cf_message.t -> 'h) -> Iom_file.rd_t ->
-	('s, 'h rd_t) Iom_gadget.t
+    e:int -> ?d:int ->
+    p:(Cf_message.t -> (#Mime_entity.headers_parser as 'h) * Cf_message.t) ->
+    Iom_file.rd_t -> ('s, 'h rd_t) Iom_gadget.t
 
 type 'h wr_t = {
-	wr_ctrlTx: Iom_file.control_t Iom_gadget.tx;
-	wr_sigRx: Iom_file.writer_signal_t Iom_gadget.rx;
-	wr_dataTx: 'h fragment Iom_gadget.tx;
-} constraint 'h = #Mime_entity.emitting
+    wr_ctrlTx: Iom_file.control_t Iom_gadget.tx;
+    wr_sigRx: Iom_file.writer_signal_t Iom_gadget.rx;
+    wr_dataTx: 'h fragment Iom_gadget.tx;
+} constraint 'h = #Mime_entity.headers
 
-val render: e:int -> ?d:int -> Iom_file.wr_t -> ('s, 'h wr_t) Iom_gadget.t
+val render:
+    e:int -> ?d:int -> Iom_file.wr_t ->
+    ('s, #Mime_entity.headers_emitter wr_t) Iom_gadget.t
+ *---------------------------------------------------------------------------*)
 
 (*--- End of File [ mime_stream.mli ] ---*)

File mime/t/t_mime.ml

 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  t_mime.ml
 
-  Copyright (c) 2003-2005, James H. Woodyatt
+  Copyright (c) 2003-2006, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
               ("X-Unstructured", " foo\r\n") ::
               [] ->
                 ()
-            | x ->
+            | _ ->
                 jout#fail "T2: split_into_fields error"
         with
-        | Incomplete_headers ->
-            jout#fail "T2: Incomplete_headers"
+        | End_of_file ->
+            jout#fail "T2: End_of_file"
         | Bad_field_name (line, m) ->
             let str = Cf_message.contents m in
             jout#fail "T2: Bad_field_name (%u, \"%s\")" line str
         body
     
     let test () =
-        let e = emit ~cte ~ct ~cid ~cl (Cf_message.create body) in
-        let m = e#emit in
+        let e = emit_headers ~cte ~ct ~cid ~cl [] in
+        let m = e#emit @ (Cf_message.create body) in
         let h' = Cf_message.contents m in
         if h' <> h then jout#fail "emit error [%s][%s]" h' h;
-        let p = parse m in
+        let p, body' = parse_headers m in
         let g s f =
             try
                 match f () with
             jout#fail "Parameter match error [Content-Length]";
         if p#unstructured <> [] then
             jout#fail "Parse error [<unstructured>]";
-        let body' = Cf_message.contents p#body in
+        let body' = Cf_message.contents body' in
         if body <> body' then
             jout#fail "Body match error"
 end
+
+(*
 module T4 = struct
     module G = Iom_gadget
     open Cf_cmonad.Op
 
     let reader_ fd k =
         Iom_file.read ~e:8 ~fd k >>= fun rd ->
-        let p = Mime_entity.parse in
+        let p = Mime_entity.parse_headers in
         Mime_stream.ingest ~e:1500 ~p rd >>= fun rd ->
         let rec loop () =
             G.guard begin
         and do_sigRx (`Error x) =
             raise x
         and do_dataRx m =
-            G.load >>= fun s ->
+            G.load >>= fun (h, s) ->
+            let h = match m#headers with Some _ as h -> h | _ -> h in
+            begin
+                match h with
+                | None -> jout#info "no header..."
+                | Some _ -> jout#info "header!"
+            end;
             let s = s @ m#octets in
             let str = Cf_message.contents s in
             match m#more with
             | Iom_file.More ->
-                G.store s >>= fun () ->
+                jout#info "more...";
+                G.store (h, s) >>= fun () ->
                 loop ()
             | Iom_file.Last ->
+                jout#info "last...";
                 okay := begin
-                    let h = m#header in
-                    h#content_transfer_encoding = Some cte &&
-                    h#content_type = Some ct &&
-                    (Cf_message.contents body) = str
+                    match h with
+                    | Some h ->
+                        jout#info "body... '%s' = '%s'"
+                            (Cf_message.contents body) str;
+                        h#content_transfer_encoding = Some cte &&
+                        h#content_type = Some ct &&
+                        (Cf_message.contents body) = str
+                    | None ->
+                        jout#fail "No header!"
                 end;
-                Cf_cmonad.return ()
+                Cf_cmonad.nil 
         in
-        G.start (loop ()) [] >>= fun () ->
+        G.start (loop ()) (None, []) >>= fun () ->
         rd.Mime_stream.rd_ctrlTx#put `Ready
 
     let writer_ fd k =
             G.guard begin
                 wr.Mime_stream.wr_sigRx#get begin function
                     | `Error x -> raise x
-                    | `Final -> Cf_cmonad.return ()
+                    | `Final -> Cf_cmonad.nil 
                     | _ -> loop ()
                 end
             end
         in
         G.start (loop ()) () >>= fun () ->
-        let h = Mime_entity.emit ~ct ~cte [] in
-        let frag = new Mime_stream.fragment Iom_file.Last body h in
+        let h = Mime_entity.emit_headers ~ct ~cte [] in
+        let frag = new Mime_stream.fragment ~h Iom_file.Last body in
         wr.Mime_stream.wr_dataTx#put frag
     
     let reactor_ k = 
         Unix.set_nonblock wr;
         reader_ rd k >>= fun () ->
         writer_ wr k >>= fun () ->
-        Cf_cmonad.return ()
+        Cf_cmonad.nil 
 
     let test () =
         try
         | x ->
             raise x
 end
+*)
+
+module T4 = struct
+    open Cf_cmonad.Op
+    
+    let finished = ref false
+    
+    let reactor _ =
+        finished := true;
+        Cf_cmonad.nil 
+    
+    let test () =
+        Iom_gadget.run reactor;
+        if not !finished then jout#fail "T4: reaction incomplete!"
+end
 
 let main () =
     let tests = [
                 f ();
                 Printf.printf "ok %d\n" i
             with
+            | Unix.Unix_error (error, fname, arg) ->
+                let error = Unix.error_message error in
+                Printf.printf "not ok %d (Unix error \"%s\" in %s[%s])\n"
+                    i error fname arg
             | Failure(s) ->
                 Printf.printf "not ok %d (Failure \"%s\")\n" i s
             | x ->