--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+module Str = Netstring_str;;
+
+let cr_or_lf_re = Str.regexp "[\013\n]";;
+
+let trim_right_spaces_re =
+ Str.regexp "[ \t]+$";;
+
+let trim_left_spaces_re =
+ Str.regexp "^[ \t]+";;
+
+let header_re =
+ Str.regexp "\\([^ \t\r\n:]+\\):\\([ \t]*.*\n\\([ \t].*\n\\)*\\)";;
+
+let empty_line_re =
+ Str.regexp "\013?\n";;
+
+let end_of_header_re =
+ Str.regexp "\n\013?\n";;
+
+
+let scan_header ?(unfold=true) parstr ~start_pos:i0 ~end_pos:i1 =
+ let rec parse_header i l =
+ match Str.string_partial_match header_re parstr i with
+ Some r ->
+ let i' = Str.match_end r in
+ if i' > i1 then
+ failwith "Mimestring.scan_header";
+ let name = String.lowercase(Str.matched_group r 1 parstr) in
+ let value_with_crlf =
+ Str.matched_group r 2 parstr in
+ let value =
+ if unfold then begin
+ let value_with_rspaces =
+ Str.global_replace cr_or_lf_re "" value_with_crlf in
+ let value_with_lspaces =
+ Str.global_replace trim_right_spaces_re "" value_with_rspaces in
+ Str.global_replace trim_left_spaces_re "" value_with_lspaces
+ end
+ else value_with_crlf
+ in
+ parse_header i' ( (name,value) :: l)
+ | None ->
+ (* The header must end with an empty line *)
+ begin match Str.string_partial_match empty_line_re parstr i with
+ Some r' ->
+ List.rev l, Str.match_end r'
+ | None ->
+ failwith "Mimestring.scan_header"
+ end
+ in
+ parse_header i0 []
+;;
+
+type s_token =
+ Atom of string
+ | EncodedWord of (string * string * string)
+ | QString of string
+ | Control of char
+ | Special of char
+ | DomainLiteral of string
+ | Comment
+ | End
+;;
+
+type s_option =
+ No_backslash_escaping
+ | Return_comments
+ | Recognize_encoded_words
+;;
+
+type s_extended_token =
+ { token : s_token;
+ token_pos : int;
+ token_line : int;
+ token_linepos : int; (* Position of the beginning of the line *)
+ token_len : int;
+ mutable token_sep : bool; (* separates adjacent encoded words *)
+ }
+;;
+
+let get_token et = et.token;;
+let get_pos et = et.token_pos;;
+let get_line et = et.token_line;;
+let get_column et = et.token_pos - et.token_linepos;;
+let get_length et = et.token_len;;
+let separates_adjacent_encoded_words et = et.token_sep;;
+
+let get_decoded_word et =
+ match et.token with
+ Atom s -> s
+ | QString s -> s
+ | Control c -> String.make 1 c
+ | Special c -> String.make 1 c
+ | DomainLiteral s -> s
+ | Comment -> ""
+ | EncodedWord (_, encoding, content) ->
+ ( match encoding with
+ ("Q"|"q") ->
+ Netencoding.Q.decode content
+ | ("B"|"b") ->
+ Netencoding.Base64.decode
+ ~url_variant:false
+ ~accept_spaces:false
+ content
+ | _ -> failwith "get_decoded_word"
+ )
+ | End ->
+ failwith "get_decoded_word"
+;;
+
+let get_charset et =
+ match et.token with
+ EncodedWord (charset, _, _) -> charset
+ | End -> failwith "get_charset"
+ | _ -> "US-ASCII"
+;;
+
+type scanner_spec =
+ { (* What the user specifies: *)
+ scanner_specials : char list;
+ scanner_options : s_option list;
+ (* Derived from that: *)
+ mutable opt_no_backslash_escaping : bool;
+ mutable opt_return_comments : bool;
+ mutable opt_recognize_encoded_words : bool;
+
+ mutable is_special : bool array;
+ mutable space_is_special : bool;
+ }
+;;
+
+type scanner_target =
+ { scanned_string : string;
+ mutable scanner_pos : int;
+ mutable scanner_line : int;
+ mutable scanner_linepos : int;
+ (* Position of the beginning of the line *)
+ mutable scanned_tokens : s_extended_token Queue.t;
+ (* A queue of already scanned tokens in order to look ahead *)
+ mutable last_token : s_token;
+ (* The last returned token. It is only important whether it is
+ * EncodedWord or not.
+ *)
+ }
+;;
+
+type mime_scanner = scanner_spec * scanner_target
+;;
+
+let get_pos_of_scanner (spec, target) =
+ if spec.opt_recognize_encoded_words then
+ failwith "get_pos_of_scanner"
+ else
+ target.scanner_pos
+;;
+
+let get_line_of_scanner (spec, target) =
+ if spec.opt_recognize_encoded_words then
+ failwith "get_line_of_scanner"
+ else
+ target.scanner_line
+;;
+
+let get_column_of_scanner (spec, target) =
+ if spec.opt_recognize_encoded_words then
+ failwith "get_column_of_scanner"
+ else
+ target.scanner_pos - target.scanner_linepos
+;;
+
+let create_mime_scanner ~specials ~scan_options =
+ let is_spcl = Array.create 256 false in
+ List.iter
+ (fun c -> is_spcl.( Char.code c ) <- true)
+ specials;
+ let spec =
+ { scanner_specials = specials;
+ scanner_options = scan_options;
+ opt_no_backslash_escaping =
+ List.mem No_backslash_escaping scan_options;
+ opt_return_comments =
+ List.mem Return_comments scan_options;
+ opt_recognize_encoded_words =
+ List.mem Recognize_encoded_words scan_options;
+ is_special = is_spcl;
+ space_is_special = is_spcl.(32);
+ }
+ in
+ (* Grab the remaining arguments: *)
+ fun ?(pos=0) ?(line=1) ?(column=0) s ->
+ let target =
+ { scanned_string = s;
+ scanner_pos = pos;
+ scanner_line = line;
+ scanner_linepos = pos - column;
+ scanned_tokens = Queue.create();
+ last_token = Comment; (* Must not be initialized with EncodedWord *)
+ }
+ in
+ spec, target
+;;
+
+
+let encoded_word_re =
+ Str.regexp "=\\?\\([^?]+\\)\\?\\([^?]+\\)\\?\\([^?]+\\)\\?=";;
+
+let scan_next_token ((spec,target) as scn) =
+ let mk_pair t len =
+ { token = t;
+ token_pos = target.scanner_pos;
+ token_line = target.scanner_line;
+ token_linepos = target.scanner_linepos;
+ token_len = len;
+ token_sep = false;
+ },
+ t
+ in
+
+ (* Note: mk_pair creates a new token pair, and it assumes that
+ * target.scanner_pos (and also scanner_line and scanner_linepos)
+ * still contain the position of the beginning of the token.
+ *)
+
+ let s = target.scanned_string in
+ let l = String.length s in
+ let rec scan i =
+ if i < l then begin
+ let c = s.[i] in
+ if spec.is_special.( Char.code c ) then begin
+ let pair = mk_pair (Special c) 1 in
+ target.scanner_pos <- target.scanner_pos + 1;
+ (match c with
+ '\n' ->
+ target.scanner_line <- target.scanner_line + 1;
+ target.scanner_linepos <- target.scanner_pos;
+ | _ -> ()
+ );
+ pair
+ end
+ else
+ match c with
+ '"' ->
+ (* Quoted string: *)
+ scan_qstring (i+1) (i+1) 0
+ | '(' ->
+ (* Comment: *)
+ let i', line, linepos =
+ scan_comment (i+1) 0 target.scanner_line target.scanner_linepos
+ in
+ let advance() =
+ target.scanner_pos <- i';
+ target.scanner_line <- line;
+ target.scanner_linepos <- linepos
+ in
+ if spec.opt_return_comments then begin
+ let pair = mk_pair Comment (i' - i) in
+ advance();
+ pair
+ end
+ else
+ if spec.space_is_special then begin
+ let pair = mk_pair (Special ' ') (i' - i) in
+ advance();
+ pair
+ end
+ else begin
+ advance();
+ scan i'
+ end
+ | (' '|'\t'|'\r') ->
+ (* Ignore whitespace by default: *)
+ target.scanner_pos <- target.scanner_pos + 1;
+ scan (i+1)
+ | '\n' ->
+ (* Ignore whitespace by default: *)
+ target.scanner_pos <- target.scanner_pos + 1;
+ target.scanner_line <- target.scanner_line + 1;
+ target.scanner_linepos <- target.scanner_pos;
+ scan (i+1)
+ | ('\000'..'\031'|'\127'..'\255') ->
+ let pair = mk_pair (Control c) 1 in
+ target.scanner_pos <- target.scanner_pos + 1;
+ pair
+ | '[' ->
+ (* Domain literal: *)
+ scan_dliteral (i+1) (i+1) 0
+ | _ ->
+ scan_atom i i
+ end
+ else
+ mk_pair End 0
+
+ and scan_atom i0 i =
+ let return_atom() =
+ let astring = String.sub s i0 (i-i0) in
+ let r =
+ if spec.opt_recognize_encoded_words then
+ Str.string_match ~groups:4 encoded_word_re astring 0
+ else
+ None
+ in
+ match r with
+ None ->
+ (* An atom contains never a linefeed character, so we can ignore
+ * scanner_line here.
+ *)
+ let pair = mk_pair (Atom astring) (i-i0) in
+ target.scanner_pos <- i;
+ pair
+ | Some mr ->
+ (* Found an encoded word. *)
+ let charset = Str.matched_group mr 1 astring in
+ let encoding = Str.matched_group mr 2 astring in
+ let content = Str.matched_group mr 3 astring in
+ let t = EncodedWord(String.uppercase charset,
+ String.uppercase encoding,
+ content) in
+ let pair = mk_pair t (i-i0) in
+ target.scanner_pos <- i;
+ pair
+ in
+
+ if i < l then
+ let c = s.[i] in
+ match c with
+ ('\000'..'\031'|'\127'..'\255'|'"'|'('|'['|' '|'\t'|'\r'|'\n') ->
+ return_atom()
+ | _ ->
+ if spec.is_special.( Char.code c ) then
+ return_atom()
+ else
+ scan_atom i0 (i+1)
+ else
+ return_atom()
+
+ and scan_qstring i0 i n =
+ if i < l then
+ let c = s.[i] in
+ match c with
+ '"' ->
+ (* Regular end of the quoted string: *)
+ let content, line, linepos = copy_qstring i0 (i-1) n in
+ let pair = mk_pair (QString content) (i-i0+2) in
+ target.scanner_pos <- i+1;
+ target.scanner_line <- line;
+ target.scanner_linepos <- linepos;
+ pair
+ | '\\' when not spec.opt_no_backslash_escaping ->
+ scan_qstring i0 (i+2) (n+1)
+ | _ ->
+ scan_qstring i0 (i+1) (n+1)
+ else
+ (* Missing right double quote *)
+ let content, line, linepos = copy_qstring i0 (l-1) n in
+ let pair = mk_pair (QString content) (l-i0+1) in
+ target.scanner_pos <- l;
+ target.scanner_line <- line;
+ target.scanner_linepos <- linepos;
+ pair
+
+ and copy_qstring i0 i1 n =
+ (* Used for quoted strings and for domain literals *)
+ let r = String.create n in
+ let k = ref 0 in
+ let line = ref target.scanner_line in
+ let linepos = ref target.scanner_linepos in
+ for i = i0 to i1 do
+ let c = s.[i] in
+ match c with
+ '\\' when i < i1 && not spec.opt_no_backslash_escaping -> ()
+ | '\n' ->
+ line := !line + 1;
+ linepos := i+1;
+ r.[ !k ] <- c;
+ incr k
+ | _ ->
+ r.[ !k ] <- c;
+ incr k
+ done;
+ assert (!k = n);
+ r, !line, !linepos
+
+ and scan_dliteral i0 i n =
+ if i < l then
+ let c = s.[i] in
+ match c with
+ ']' ->
+ (* Regular end of the domain literal: *)
+ let content, line, linepos = copy_qstring i0 (i-1) n in
+ let pair = mk_pair (DomainLiteral content) (i-i0+2) in
+ target.scanner_pos <- i+1;
+ target.scanner_line <- line;
+ target.scanner_linepos <- linepos;
+ pair
+ | '\\' when not spec.opt_no_backslash_escaping ->
+ scan_dliteral i0 (i+2) (n+1)
+ | _ ->
+ (* Note: '[' is not allowed by RFC 822; we treat it here as
+ * a regular character (questionable)
+ *)
+ scan_dliteral i0 (i+1) (n+1)
+ else
+ (* Missing right bracket *)
+ let content, line, linepos = copy_qstring i0 (l-1) n in
+ let pair = mk_pair (DomainLiteral content) (l-i0+1) in
+ target.scanner_pos <- l;
+ target.scanner_line <- line;
+ target.scanner_linepos <- linepos;
+ pair
+
+
+ and scan_comment i level line linepos =
+ if i < l then
+ let c = s.[i] in
+ match c with
+ ')' ->
+ (i+1), line, linepos
+ | '(' ->
+ (* nested comment *)
+ let i', line', linepos' =
+ scan_comment (i+1) (level+1) line linepos
+ in
+ scan_comment i' level line' linepos'
+ | '\\' when not spec.opt_no_backslash_escaping ->
+ if (i+1) < l && s.[i+1] = '\n' then
+ scan_comment (i+2) level (line+1) (i+2)
+ else
+ scan_comment (i+2) level line linepos
+ | '\n' ->
+ scan_comment (i+1) level (line+1) (i+1)
+ | _ ->
+ scan_comment (i+1) level line linepos
+ else
+ (* Missing closing ')' *)
+ i, line, linepos
+ in
+
+ scan target.scanner_pos
+;;
+
+
+let scan_token ((spec,target) as scn) =
+ (* This function handles token queueing in order to recognize white space
+ * that separates adjacent encoded words.
+ *)
+
+ let rec collect_whitespace () =
+ (* Scans whitespace tokens and returns them as:
+ * (ws_list, other_tok) if there is some other_tok following the
+ * list (other_tok = End is possible)
+ *)
+ let (et, t) as pair = scan_next_token scn in
+ ( match t with
+ (Special ' '|Special '\t'|Special '\n'|Special '\r') ->
+ let ws_list, tok = collect_whitespace() in
+ pair :: ws_list, tok
+ | _ ->
+ [], pair
+ )
+ in
+
+ try
+ (* Is there an already scanned token in the queue? *)
+ let et = Queue.take target.scanned_tokens in
+ let t = et.token in
+ target.last_token <- t;
+ et, et.token
+ with
+ Queue.Empty ->
+ (* If not: inspect the last token. If that token is an EncodedWord,
+ * the next tokens are scanned in advance to determine if there
+ * are spaces separating two EncodedWords. These tokens are put
+ * into the queue such that it is avoided that they are scanned
+ * twice. (The sole purpose of the queue.)
+ *)
+ match target.last_token with
+ EncodedWord(_,_,_) as ew ->
+ let ws_list, tok = collect_whitespace() in
+ (* If tok is an EncodedWord, too, the tokens in ws_list must
+ * be flagged as separating two adjacent encoded words.
+ *)
+ ( match tok with
+ _, EncodedWord(_,_,_) ->
+ List.iter
+ (fun (et,t) ->
+ et.token_sep <- true)
+ ws_list
+ | _ ->
+ ()
+ );
+ (* Anyway, queue the read tokens but the first up *)
+ ( match ws_list with
+ [] ->
+ (* Nothing to queue *)
+ let et, t = tok in
+ target.last_token <- t;
+ tok
+ | (et,t) as pair :: ws_list' ->
+ List.iter
+ (fun (et',_) ->
+ Queue.add et' target.scanned_tokens)
+ ws_list';
+ ( match tok with
+ | _, End ->
+ ()
+ | (et',_) ->
+ Queue.add et' target.scanned_tokens
+ );
+ (* Return the first scanned token *)
+ target.last_token <- t;
+ pair
+ )
+ | _ ->
+ (* Regular case: Scan one token; do not queue it up *)
+ let (et, t) as pair = scan_next_token scn in
+ target.last_token <- t;
+ pair
+;;
+
+
+let scan_token_list scn =
+ let rec collect() =
+ match scan_token scn with
+ _, End ->
+ []
+ | pair ->
+ pair :: collect()
+ in
+ collect()
+;;
+
+
+let scan_structured_value s specials options =
+ let rec collect scn =
+ match scan_token scn with
+ _, End ->
+ []
+ | _, t ->
+ t :: collect scn
+ in
+ let scn = create_mime_scanner specials options s in
+ collect scn
+;;
+
+
+let specials_rfc822 =
+ [ '<'; '>'; '@'; ','; ';'; ':'; '\\'; '.' ];;
+
+
+let specials_rfc2045 =
+ [ '<'; '>'; '@'; ','; ';'; ':'; '\\'; '/' ];;
+
+
+let scan_encoded_text_value s =
+ let specials = [ ' '; '\t'; '\r'; '\n'; '('; '['; '"' ] in
+ let options = [ Recognize_encoded_words ] in
+ let scn = create_mime_scanner specials options s in
+
+ let rec collect () =
+ match scan_token scn with
+ _, End ->
+ []
+ | et, _ when separates_adjacent_encoded_words et ->
+ collect()
+ | et, (Special _|Atom _|EncodedWord(_,_,_)) ->
+ et :: collect ()
+ | _, _ ->
+ assert false
+ in
+ collect()
+;;
+
+
+let scan_value_with_parameters s options =
+ let rec parse_params tl =
+ match tl with
+ Atom n :: Special '=' :: Atom v :: tl' ->
+ (n,v) :: parse_rest tl'
+ | Atom n :: Special '=' :: QString v :: tl' ->
+ (n,v) :: parse_rest tl'
+ | _ ->
+ failwith "Mimestring.scan_value_with_parameters"
+ and parse_rest tl =
+ match tl with
+ [] -> []
+ | Special ';' :: tl' ->
+ parse_params tl'
+ | _ ->
+ failwith "Mimestring.scan_value_with_parameters"
+ in
+
+ (* Note: Even if not used here, the comma is a very common separator
+ * and should be recognized as being special. You will get a
+ * failure if there is a comma in the scanned string.
+ *)
+ let tl = scan_structured_value s [ ';'; '='; ',' ] options in
+ match tl with
+ [ Atom n ] -> n, []
+ | [ QString n ] -> n, []
+ | Atom n :: Special ';' :: tl' ->
+ n, parse_params tl'
+ | QString n :: Special ';' :: tl' ->
+ n, parse_params tl'
+ | _ ->
+ failwith "Mimestring.scan_value_with_parameters"
+;;
+
+
+let scan_mime_type s options =
+ let n, params = scan_value_with_parameters s options in
+ (String.lowercase n),
+ (List.map (fun (n,v) -> (String.lowercase n, v)) params)
+;;
+
+
+let lf_re = Str.regexp "[\n]";;
+
+let scan_multipart_body s ~start_pos:i0 ~end_pos:i1 ~boundary =
+ let l_s = String.length s in
+ if i0 < 0 or i1 < 0 or i0 > l_s or i1 >l_s then
+ invalid_arg "Mimestring.scan_multipart_body";
+
+ (* First compile the regexps scanning for 'boundary': *)
+ let boundary1_re =
+ Str.regexp ("\n--" ^ Str.quote boundary) in
+ let boundary2_re =
+ Str.regexp ("--" ^ Str.quote boundary) in
+
+ let rec parse i =
+ (* i: Beginning of the current part (position directly after the
+ * boundary line
+ *)
+ (* Search for next boundary at position i *)
+ let i' =
+ try min (fst (Str.search_forward boundary1_re s i) + 1) i1
+ with
+ Not_found -> i1
+ in
+ (* i': Either the position of the first '-' of the boundary line,
+ * or i1 if no boundary has been found
+ *)
+ if i' >= i1 then
+ [] (* Ignore everything after the last boundary *)
+ else
+ let i'' =
+ try min (fst (Str.search_forward lf_re s i') + 1) i1
+ with
+ Not_found -> i1
+ in
+ (* i'': The position after the boundary line *)
+(*
+ print_int i; print_newline();
+ print_int i'; print_newline();
+ print_int i''; print_newline();
+ flush stdout;
+*)
+ let header, k = scan_header s i i' in
+ (* header: the header of the part
+ * k: beginning of the body
+ *)
+
+ let value =
+ (* We know that i'-1 is a linefeed character. i'-2 should be a CR
+ * character. Both characters are not part of the value.
+ *)
+ if i' >= 2 then
+ match s.[i'-2] with
+ '\013' -> String.sub s k (i'-2-k)
+ | _ -> String.sub s k (i'-1-k)
+ else
+ String.sub s k (i'-1-k)
+ in
+
+ let pair =
+ (header, value) in
+
+ if i'' >= i1
+ then
+ [ pair ]
+ else
+ pair :: parse i''
+ in
+
+ (* Find the first boundary. This is a special case, because it may be
+ * right at the beginning of the string (no preceding CRLF)
+ *)
+
+ let i_bnd =
+ if Str.string_partial_match boundary2_re s i0 <> None then
+ i0
+ else
+ try min (fst (Str.search_forward boundary1_re s i0)) i1
+ with
+ Not_found -> i1
+ in
+
+ if i_bnd >= i1 then
+ []
+ else
+ let i_bnd' =
+ try min (fst (Str.search_forward lf_re s (i_bnd + 1)) + 1) i1
+ with
+ Not_found -> i1
+ in
+ if i_bnd' >= i1 then
+ []
+ else
+ parse i_bnd'
+;;
+
+
+let scan_multipart_body_and_decode s ~start_pos:i0 ~end_pos:i1 ~boundary =
+ let parts = scan_multipart_body s i0 i1 boundary in
+ List.map
+ (fun (params, value) ->
+ let encoding =
+ try List.assoc "content-transfer-encoding" params
+ with Not_found -> "7bit"
+ in
+
+ (* NOTE: In the case of "base64" and "quoted-printable", the allocation
+ * of the string "value" could be avoided.
+ *)
+
+ let value' =
+ match encoding with
+ ("7bit"|"8bit"|"binary") -> value
+ | "base64" ->
+ Netencoding.Base64.decode_substring
+ value 0 (String.length value) false true
+ | "quoted-printable" ->
+ Netencoding.QuotedPrintable.decode_substring
+ value 0 (String.length value)
+ | _ ->
+ failwith "Mimestring.scan_multipart_body_and_decode: Unknown content-transfer-encoding"
+ in
+ (params, value')
+ )
+ parts
+;;
+
+
+let scan_multipart_body_from_netstream s ~boundary ~create ~add ~stop =
+
+ (* The block size of s must be at least the length of the boundary + 3.
+ * Otherwise it is not guaranteed that the boundary is always recognized.
+ *)
+ if Netstream.block_size s < String.length boundary + 3 then
+ invalid_arg "Mimestring.scan_multipart_body_from_netstream";
+
+ (* First compile the regexps scanning for 'boundary': *)
+ let boundary1_re =
+ Str.regexp ("\n--" ^ Str.quote boundary) in
+ let boundary2_re =
+ Str.regexp ("--" ^ Str.quote boundary) in
+
+ (* Subtask 1: Search the end of the MIME header: CR LF CR LF
+ * (or LF LF). Enlarge the window until the complete header
+ * is covered by the window.
+ *)
+ let rec search_end_of_header k =
+ (* Search the end of the header beginning at position k of the
+ * current window.
+ * Return the position of the first character of the body.
+ *)
+ try
+ (* Search for LF CR? LF: *)
+ let i, r = Str.search_forward
+ end_of_header_re
+ (Netbuffer.unsafe_buffer (Netstream.window s))
+ k
+ in
+ (* If match_end <= window_length, the search was successful.
+ * Otherwise, we searched in the uninitialized region of the
+ * buffer.
+ *)
+ if Str.match_end r <= Netstream.window_length s then
+ Str.match_end r
+ else
+ raise Not_found
+ with
+ Not_found ->
+ (* If the end of the stream is reached, the end of the header
+ * is missing: Error.
+ * Otherwise, we try to read another block, and continue.
+ *)
+ if Netstream.at_eos s then
+ failwith "Mimestring.scan_multipart_body_from_netstream: Unexpected end of stream";
+ let w0 = Netstream.window_length s in
+ Netstream.want_another_block s;
+ search_end_of_header (max (w0 - 2) 0)
+ in
+
+ (* Subtask 2: Search the first boundary line. *)
+ let rec search_first_boundary() =
+ (* Search boundary per regexp; return the position of the character
+ * immediately following the boundary (on the same line), or
+ * raise Not_found.
+ *)
+ try
+ (* Search boundary per regexp: *)
+ let i, r = Str.search_forward
+ boundary1_re
+ (Netbuffer.unsafe_buffer (Netstream.window s))
+ 0
+ in
+ (* If match_end <= window_length, the search was successful.
+ * Otherwise, we searched in the uninitialized region of the
+ * buffer.
+ *)
+ if Str.match_end r <= Netstream.window_length s then begin
+ Str.match_end r
+ end
+ else raise Not_found
+ with
+ Not_found ->
+ if Netstream.at_eos s then raise Not_found;
+ (* The regexp did not match: Move the window by one block.
+ *)
+ let n =
+ min
+ (Netstream.window_length s)
+ (Netstream.block_size s)
+ in
+ Netstream.move s n;
+ search_first_boundary()
+ in
+
+ (* Subtask 3: Search the next boundary line. Invoke 'add' for every
+ * read chunk
+ *)
+ let rec search_next_boundary p =
+ (* Returns the position directly after the boundary on the same line *)
+ try
+ (* Search boundary per regexp: *)
+ let i,r = Str.search_forward
+ boundary1_re
+ (Netbuffer.unsafe_buffer (Netstream.window s))
+ 0
+ in
+ (* If match_end <= window_length, the search was successful.
+ * Otherwise, we searched in the uninitialized region of the
+ * buffer.
+ *)
+ if Str.match_end r <= Netstream.window_length s then begin
+ (* Add the last chunk of the part. *)
+ let n =
+ (* i is a LF. i - 1 should be CR. Ignore these characters. *)
+ if i >= 1 then
+ match (Netbuffer.unsafe_buffer (Netstream.window s)).[ i - 1 ] with
+ '\013' -> i - 1
+ | _ -> i
+ else
+ i
+ in
+ (* Printf.printf "add n=%d\n" n; *)
+ add p s 0 n;
+ Str.match_end r
+ end
+ else raise Not_found
+ with
+ Not_found ->
+ if Netstream.at_eos s then
+ failwith "Mimestring.scan_multipart_body_from_netstream: next MIME boundary not found";
+ (* The regexp did not match: Add the first block of the window;
+ * and move the window.
+ *)
+ let n =
+ min
+ (Netstream.window_length s)
+ (Netstream.block_size s)
+ in
+ (* Printf.printf "add n=%d\n" n; *)
+ add p s 0 n;
+ Netstream.move s n;
+ search_next_boundary p
+ in
+
+ (* Subtask 4: Search the end of the boundary line *)
+ let rec search_end_of_line k =
+ (* Search LF beginning at position k. Discard any contents until that. *)
+ try
+ let i,r = Str.search_forward
+ lf_re
+ (Netbuffer.unsafe_buffer (Netstream.window s))
+ k
+ in
+ (* If match_end <= window_length, the search was successful.
+ * Otherwise, we searched in the uninitialized region of the
+ * buffer.
+ *)
+ if Str.match_end r <= Netstream.window_length s then begin
+ Str.match_end r
+ end
+ else raise Not_found
+ with
+ Not_found ->
+ if Netstream.at_eos s then
+ failwith "Mimestring.scan_multipart_body_from_netstream: MIME boundary without line end";
+ (* The regexp did not match: move the window.
+ *)
+ let n = Netstream.window_length s in
+ Netstream.move s n;
+ search_end_of_line 0
+ in
+
+ (* Subtask 5: Check whether "--" follows the boundary on the same line *)
+ let check_whether_last_boundary k =
+ (* k: The position directly after the boundary. *)
+ Netstream.want s (k+2);
+ let str = Netbuffer.unsafe_buffer (Netstream.window s) in
+ (Netstream.window_length s >= k+2) && str.[k] = '-' && str.[k+1] = '-'
+ in
+
+ (* Subtask 6: Check whether the buffer begins with a boundary. *)
+ let check_beginning_is_boundary () =
+ let m = String.length boundary + 2 in
+ Netstream.want s m;
+ let str = Netbuffer.unsafe_buffer (Netstream.window s) in
+ (Netstream.window_length s >= m) &&
+ (Str.string_partial_match boundary2_re str 0 <> None)
+ in
+
+ let rec parse_part () =
+ (* The first byte of the current window of s contains the character
+ * directly following the boundary line that starts this part.
+ *)
+ (* Search the end of the MIME header: *)
+ let k_eoh = search_end_of_header 0 in
+ (* Printf.printf "k_eoh=%d\n" k_eoh; *)
+ (* Get the MIME header: *)
+ let str = Netbuffer.unsafe_buffer (Netstream.window s) in
+ let header, k_eoh' = scan_header str 0 k_eoh in
+ assert (k_eoh = k_eoh');
+ (* Move the window over the header: *)
+ Netstream.move s k_eoh;
+ (* Create the part: *)
+ let p = create header in
+ let continue =
+ begin try
+ (* Search the next boundary; add the chunks while searching: *)
+ let k_eob = search_next_boundary p in
+ (* Printf.printf "k_eob=%d\n" k_eob; *)
+ (* Is this the last boundary? *)
+ if check_whether_last_boundary k_eob then begin
+ (* Skip the rest: *)
+ while not (Netstream.at_eos s) do
+ Netstream.move s (Netstream.window_length s)
+ done;
+ Netstream.move s (Netstream.window_length s);
+ false
+ end
+ else begin
+ (* Move to the beginning of the next line: *)
+ let k_eol = search_end_of_line k_eob in
+ Netstream.move s k_eol;
+ true
+ end
+ with
+ any ->
+ (try stop p with _ -> ());
+ raise any
+ end in
+ stop p;
+ if continue then
+ (* Continue with next part: *)
+ parse_part()
+ in
+
+ (* Check whether s directly begins with a boundary: *)
+ if check_beginning_is_boundary() then begin
+ (* Move to the beginning of the next line: *)
+ let k_eol = search_end_of_line 0 in
+ Netstream.move s k_eol;
+ (* Begin with first part: *)
+ parse_part()
+ end
+ else begin
+ (* Search the first boundary: *)
+ try
+ let k_eob = search_first_boundary() in
+ (* Printf.printf "k_eob=%d\n" k_eob; *)
+ (* Move to the beginning of the next line: *)
+ let k_eol = search_end_of_line k_eob in
+ (* Printf.printf "k_eol=%d\n" k_eol; *)
+ Netstream.move s k_eol;
+ (* Begin with first part: *)
+ parse_part()
+ with
+ Not_found ->
+ (* No boundary at all: The body is empty. *)
+ ()
+ end;
+;;
+
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:27 lpadovan
+ * Initial revision
+ *
+ * Revision 1.8 2000/08/13 00:04:36 gerd
+ * Encoded_word -> EncodedWord
+ * Bugfixes.
+ *
+ * Revision 1.7 2000/08/07 00:25:14 gerd
+ * Implemented the new functions for structured field lexing.
+ *
+ * Revision 1.6 2000/06/25 22:34:43 gerd
+ * Added labels to arguments.
+ *
+ * Revision 1.5 2000/06/25 21:15:48 gerd
+ * Checked thread-safety.
+ *
+ * Revision 1.4 2000/05/16 22:30:14 gerd
+ * Added support for some types of malformed MIME messages.
+ *
+ * Revision 1.3 2000/04/15 13:09:01 gerd
+ * Implemented uploads to temporary files.
+ *
+ * Revision 1.2 2000/03/02 01:15:30 gerd
+ * Updated.
+ *
+ * Revision 1.1 2000/02/25 15:21:12 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff