Commits

Anonymous committed 116b89e

Obsolete.

  • Participants
  • Parent commits 7e2d557

Comments (0)

Files changed (4)

File mime/mime_emitter.ml

-(*---------------------------------------------------------------------------*
-  IMPLEMENTATION  mime_emitter.ml
-
-  Copyright (c) 2004-2005, James H. Woodyatt
-  All rights reserved.
-
-  Redistribution and use in source and binary forms, with or without
-  modification, are permitted provided that the following conditions
-  are met:
-
-    Redistributions of source code must retain the above copyright
-    notice, this list of conditions and the following disclaimer.
-
-    Redistributions in binary form must reproduce the above copyright
-    notice, this list of conditions and the following disclaimer in
-    the documentation and/or other materials provided with the
-    distribution
-
-  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
-  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
-  OF THE POSSIBILITY OF SUCH DAMAGE. 
- *---------------------------------------------------------------------------*)
-
-open Mime_common
-
-module L = Mime_parser.Lexer
-open Cf_lex.X.Op
-open Cf_parser.Op
-
-(*
-module J = Cf_journal;;
-J.stdout#setlimit `Debug;;
-*)
-
-let crlf_string_ = "\r\n"
-
-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 to_seq_ =
-    let weave = Cf_parser.X.weave ~c:(new Cf_parser.cursor 0) in
-    fun s -> weave (Cf_seq.of_string s)
-
-let print_char_with_folding_ pp = function
-    | '\128'..'\255' as c ->
-        Format.pp_print_char pp '%';
-        Format.pp_print_int pp (Char.code c)
-    | '\n' -> 
-        Format.pp_print_char pp '\092';
-        Format.pp_print_newline pp ();
-        Format.pp_print_space pp ()
-    | ' ' ->
-        Format.pp_print_space pp ()
-    | '\t' ->
-        Format.pp_print_tab pp ()
-    | '\\' ->
-        Format.pp_print_char pp '\092';
-        Format.pp_print_char pp '\092'
-    | c ->
-        Format.pp_print_char pp c
-    
-let comment pp s =
-    Format.pp_print_char pp '(';
-    for i = 0 to String.length s - 1 do
-        print_char_with_folding_ pp (String.unsafe_get s i)
-    done;
-    Format.pp_print_char pp ')'
-
-let print_char_in_quoted_string_ pp = function
-    | ('\034' | '\092' as c) ->
-        Format.pp_print_char pp '\092';
-        Format.pp_print_char pp c
-    | c ->
-        print_char_with_folding_ pp c
-
-let quoted_string pp s =
-    Format.pp_print_char pp '"';
-    for i = 0 to String.length s - 1 do
-        print_char_in_quoted_string_ pp (String.unsafe_get s i)
-    done;
-    Format.pp_print_char pp '"'
-
-let atom_lexer_ =
-    Cf_lex.X.create (L.raw_atom $= ()) >>= fun () ->
-    Cf_parser.fin
-
-let word pp s =
-    match atom_lexer_ (to_seq_ s) with
-    | Some ((), _) -> Format.pp_print_string pp s
-    | None -> quoted_string pp s
-
-let token_lexer_ =
-    Cf_lex.X.create (L.raw_token $= ()) >>= fun () ->
-    Cf_parser.fin
-
-let token pp s =
-    match token_lexer_ (to_seq_ s) with
-    | Some ((), _) -> Format.pp_print_string pp s
-    | None -> quoted_string pp s
-
-let print_char_in_domain_literal_ pp = function
-    | ('\091'..'\093' as c) ->
-        Format.pp_print_char pp '\092';
-        Format.pp_print_char pp c
-    | c ->
-        print_char_with_folding_ pp c
-
-let dot_atom_lexer_ =
-    Cf_lex.X.create (L.raw_dot_atom $= ()) >>= fun () ->
-    Cf_parser.fin
-
-let domain_literal pp s =
-    Format.pp_print_char pp '[';
-    for i = 0 to String.length s - 1 do
-        print_char_in_domain_literal_ pp (String.unsafe_get s i)
-    done;
-    Format.pp_print_char pp ']'
-
-let addr_local pp s =
-    match dot_atom_lexer_ (to_seq_ s) with
-    | Some ((), _) -> Format.pp_print_string pp s
-    | None -> quoted_string pp s
-
-let addr_domain pp s =
-    match dot_atom_lexer_ (to_seq_ s) with
-    | Some ((), _) -> Format.pp_print_string pp s
-    | None -> domain_literal pp s
-
-let parameter_value_ pp s =
-	match token_lexer_ (to_seq_ s) with
-	| Some ((), _) -> Format.pp_print_string pp s
-	| None -> quoted_string pp s
-
-let date_time =
-    let err_ = "ERR" in
-    let month = function
-        | 1 -> "Jan"
-        | 2 -> "Feb"
-        | 3 -> "Mar"
-        | 4 -> "Apr"
-        | 5 -> "May"
-        | 6 -> "Jun"
-        | 7 -> "Jul"
-        | 8 -> "Aug"
-        | 9 -> "Sep"
-        | 10 -> "Oct"
-        | 11 -> "Nov"
-        | 12 -> "Dec"
-        | _ -> assert (not true); err_
-    in
-    let weekday = function
-        | 0 -> "Sun"
-        | 1 -> "Mon"
-        | 2 -> "Tue"
-        | 3 -> "Wed"
-        | 4 -> "Thu"
-        | 5 -> "Fri"
-        | 6 -> "Sat"
-        | _ -> assert (not true); err_
-    in
-    let zone = function
-        | None ->
-            '-', 0
-        | Some dmin ->
-            let ch, n = if dmin < 0 then '-', (-dmin) else '+', dmin in
-            let hr = n / 60 and min = n mod 60 in
-            ch, (hr * 100 + min)
-    in
-    fun pp (t, zopt) ->
-        if not (Cf_gregorian.is_valid
-            ~year:t.Cf_stdtime.year ~month:t.Cf_stdtime.month
-            ~day:t.Cf_stdtime.day)
-        then
-            invalid_arg "Mime_emitter.data_time: not valid gregorian date";
-        let wday = ref 0 in
-        let cjd =
-            Cf_gregorian.to_cjd_unsafe
-                ~year:t.Cf_stdtime.year ~month:t.Cf_stdtime.month
-                ~day:t.Cf_stdtime.day
-        in
-        let _ = Cf_gregorian.of_cjd ~wday cjd in
-        let wday = weekday !wday in
-        let month = month t.Cf_stdtime.month in
-        let zch, zn = zone zopt in
-        Format.fprintf pp "%s, %u %s %02d %02u:%02u:%02u %c%04u"
-            wday t.Cf_stdtime.day month t.Cf_stdtime.year t.Cf_stdtime.hour
-            t.Cf_stdtime.minute t.Cf_stdtime.second zch zn
-
-let parameters =
-    let rec loop pp (a, v) =
-        Format.fprintf pp "; %s=" a;
-        parameter_value_ pp v
-    in
-    fun pp map ->
-        Atom_map.iterate (loop pp) map
-
-class ['field] t =
-    object(self)
-        constraint 'field = [> `F_unstructured of string * string ]
-
-        method private unstructured pp (fname, fvalue) =
-            Format.pp_print_string pp fname;
-            Format.pp_print_string pp ": ";
-            for i = 0 to String.length fvalue - 1 do
-                print_char_with_folding_ pp (String.unsafe_get fvalue i)
-            done
-                
-        method private field pp = function
-            | `F_unstructured x ->
-                self#unstructured pp x
-            | (_ : 'field) ->
-                failwith "Mime_emitter.t#field: not handled by subclass!"
-        
-        method private field_list_ pp = function
-            | [] ->
-                Format.pp_print_newline pp ()
-            | hd :: tl ->
-                Format.pp_open_box pp 1;
-                self#field pp hd;
-                Format.pp_print_newline pp ();
-                Format.pp_close_box pp ();
-                self#field_list_ pp tl
-        
-        method header flist =
-            let b = Buffer.create 256 in
-            let pp = formatter b in
-            self#field_list_ pp flist;
-            Cf_message.create (Buffer.contents b)
-    end
-
-(*--- End of File [ mime_emitter.ml ] ---*)

File mime/mime_emitter.mli

-(*---------------------------------------------------------------------------*
-  INTERFACE  mime_emitter.mli
-
-  Copyright (c) 2004-2005, James H. Woodyatt
-  All rights reserved.
-
-  Redistribution and use in source and binary forms, with or without
-  modification, are permitted provided that the following conditions
-  are met:
-
-    Redistributions of source code must retain the above copyright
-    notice, this list of conditions and the following disclaimer.
-
-    Redistributions in binary form must reproduce the above copyright
-    notice, this list of conditions and the following disclaimer in
-    the documentation and/or other materials provided with the
-    distribution
-
-  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
-  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
-  OF THE POSSIBILITY OF SUCH DAMAGE. 
- *---------------------------------------------------------------------------*)
-
-open Mime_common
-
-val formatter: Buffer.t -> Format.formatter
-
-val comment: Format.formatter -> string -> unit
-val quoted_string: Format.formatter -> string -> unit
-val word: Format.formatter -> string -> unit
-val token: Format.formatter -> string -> unit
-val domain_literal: Format.formatter -> string -> unit
-val addr_local: Format.formatter -> string -> unit
-val addr_domain: Format.formatter -> string -> unit
-val date_time: Format.formatter -> (Cf_stdtime.t * int option) -> unit
-val parameters: Format.formatter -> string Atom_map.t -> unit
-
-class ['field] t:
-    object
-        constraint 'field = [> `F_unstructured of string * string ]
-                
-        method private unstructured:
-            Format.formatter -> (string * string) -> unit
-        
-        method private field: Format.formatter -> 'field -> unit
-
-        method header: 'field list -> Cf_message.t
-    end
-
-(*--- End of File [ mime_emitter.mli ] ---*)

File mime/mime_parser.ml

-(*---------------------------------------------------------------------------*
-  IMPLEMENTATION  mime_parser.ml
-
-  Copyright (c) 2004-2005, James H. Woodyatt
-  All rights reserved.
-
-  Redistribution and use in source and binary forms, with or without
-  modification, are permitted provided that the following conditions
-  are met:
-
-    Redistributions of source code must retain the above copyright
-    notice, this list of conditions and the following disclaimer.
-
-    Redistributions in binary form must reproduce the above copyright
-    notice, this list of conditions and the following disclaimer in
-    the documentation and/or other materials provided with the
-    distribution
-
-  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
-  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
-  OF THE POSSIBILITY OF SUCH DAMAGE. 
- *---------------------------------------------------------------------------*)
-
-open Cf_flow.Op
-open Cf_parser.Op
-open Cf_lex.X.Op
-open Mime_common
-
-(*
-module J = Cf_journal;;
-J.stdout#setlimit `Debug;;
-*)
-
-module Int_map = Cf_rbtree.Map(Cf_ordered.Int_order)
-
-module Lexer = struct
-    let wsp = !^(function ' ' | '\009' -> true | _ -> false)
-    let crlf = !:'\013' $& !:'\010'
-
-    let no_ws_ctl =
-        !^ begin function
-            | '\001'..'\008' | '\011' | '\012' | '\014'..'\031' | '\127' ->
-                true
-            | _ ->
-                false
-        end
-        
-    let specials_f_ = function
-        | '(' | ')' | '<' | '>' | '[' | ']' | ':' | ';' | '@'
-        | '\\' | ',' | '.' | '"' -> true
-        | _ -> false
-    
-    let specials = !^specials_f_
-
-    let tspecials_f_ = function
-        | '(' | ')' | '<' | '>' | '[' | ']' | ':' | ';' | '@'
-        | '/' | '\\' | ',' | '?' | '=' | '"' -> true
-        | _ -> false
-    
-    let tspecials = !^tspecials_f_
-
-    let ch_any_ = !^ (function '\000'..'\127' -> true | _ -> false)    
-    let ch_BS_ = !:'\\'
-    let ch_star_LF_ = !* !:'\010'
-    let ch_star_CR_ = !* !:'\013'
-    let ch_star_WSP_ = !* wsp
-        
-    let obs_char_ =
-        !^ begin function
-            | '\010' | '\013' | '\128'..'\255' -> false
-            | _ -> true
-        end
-    
-    let utext =
-        ch_star_LF_ $& ch_star_CR_ $&
-        !*(obs_char_ $& ch_star_LF_ $& ch_star_CR_)
-
-    let quoted_pair = ch_BS_ $& ch_any_
-
-    let fws = !+wsp $& !*(crlf $& !+wsp)
-    let optfws = !?fws
-    
-    let ch_ctext_printable_ =
-        !^ begin function
-            | '\033'..'\039' | '\042'..'\091' | '\093'..'\126' -> true
-            | _ -> false
-        end
-    
-    let ctext = no_ws_ctl $| ch_ctext_printable_
-    
-    let cbegin = !:'('
-    let cend = !:')'
-    
-    let atext =
-        !^ begin function
-            | '\000'..'\032' -> false
-            | '\128'..'\255' -> false
-            | x -> not (specials_f_ x)
-        end
-    
-    let raw_atom = !+atext
-    
-    let raw_dot_atom = raw_atom $& !*(!:'.' $& raw_atom)
-    
-    let ttext =
-        !^ begin function
-            | '\000'..'\032' -> false
-            | '\128'..'\255' -> false
-            | x -> not (tspecials_f_ x)
-        end
-
-    let raw_token = !+ttext
-
-    let dquote = !:'"'
-    
-    let qtext =
-        no_ws_ctl $|
-        !^ begin function
-            | '\033' | '\035'..'\091' | '\092'..'\126' -> true
-            | _ -> false
-        end
-    
-    let qcontent = qtext $| quoted_pair
-    
-    let raw_quoted_string =
-        dquote $& !*(optfws $& qcontent) $& optfws $& dquote
-    
-    let dtext =
-        no_ws_ctl $|
-        !^ begin function
-            | '\033' | '\035'..'\091' | '\092'..'\126' -> true
-            | _ -> false
-        end
-    
-    let dcontent = dtext $| quoted_pair
-
-    let raw_domain_literal =
-        !:'[' $& !*(optfws $& dcontent) $& optfws $& !:']'
-
-    let ftext =
-        !^ begin function
-            | '\033'..'\057' | '\059'..'\126' -> true
-            | _ -> false
-        end
-    
-    let field_name = !+ftext
-    
-    let unstructured = !*(optfws $& utext) $& optfws
-
-    type comment_token_t = C_push | C_pop | C_run
-
-    let rec comment_parser_ n s =
-        match Lazy.force s with
-        | Cf_seq.Z ->
-            None
-        | Cf_seq.P ((token, cursor), s) ->
-            match token with
-            | C_push ->
-                comment_parser_ (succ n) s
-            | C_pop ->
-                if n > 0 then
-                    comment_parser_ (pred n) s
-                else
-                    Some ((), s)
-            | C_run when n > 0 ->
-                comment_parser_ n s
-            | C_run ->
-                None
-
-    let ccontent_aux_ = ctext $| quoted_pair
-    let comment_aux_ = !*(optfws $& ccontent_aux_) $& optfws
-
-    let comment_lexer_ () =
-        Cf_lex.X.create !@[
-            comment_aux_ $= C_run;
-            !:'(' $= C_push;
-            !:')' $= C_pop;
-        ]
-
-    let optunit_ p s = match p s with | None -> Some ((), s) | x -> x
-
-    let quoted_pair_normalize_rule_ s =
-        assert (String.length s = 2);
-        String.unsafe_get s 1
-
-    let chx_normalize_rule_ n z =
-        match Lazy.force z with
-        | Cf_seq.P ((hd, _), tl) -> Some (hd, tl)
-        | _ -> assert (not true); None
-
-    let normalize_ cons p n z =
-        let z' = Cf_seq.shift n z in
-        let z = Cf_seq.limit (n - 2) (Cf_seq.shift 1 z) in
-        let s = Cf_seq.to_string (Cf_seq.first (Cf_parser.X.unfold p z)) in
-        Some (cons s, z')
-
-    let month_names_ =
-        let z =
-            Cf_seq.of_list [
-                "jan", 1;
-                "feb", 2;
-                "mar", 3;
-                "apr", 4;
-                "may", 5;
-                "jun", 6;
-                "jul", 7;
-                "aug", 8;
-                "sep", 9;
-                "oct", 10;
-                "nov", 11;
-                "dec", 12;
-            ]
-        in
-        Atom_map.of_seq z
-
-    let weekday_names_ =
-        let z =
-            Cf_seq.of_list [
-                "sun", 0;
-                "mon", 1;
-                "tue", 2;
-                "wed", 3;
-                "thu", 4;
-                "fri", 5;
-                "sat", 6;
-            ]
-        in
-        Atom_map.of_seq z
-
-    let zone_names_ =
-        let z =
-            Cf_seq.of_list [
-                "UT",       0;
-                "GMT",      0;
-                "EDT",      (-4);
-                "EST",      (-5);
-                "CDT",      (-5);
-                "CST",      (-6);
-                "MDT",      (-6);
-                "MST",      (-7);
-                "PDT",      (-7);
-                "PST",      (-8);
-                "A",        1;
-                "B",        2;
-                "C",        3;
-                "D",        4;
-                "E",        5;
-                "F",        6;
-                "G",        7;
-                "H",        8;
-                "I",        9;
-                "K",        10;
-                "L",        11;
-                "M",        12;
-                "N",        (-1);
-                "O",        (-2);
-                "P",        (-3);
-                "Q",        (-4);
-                "R",        (-5);
-                "S",        (-6);
-                "T",        (-7);
-                "U",        (-8);
-                "V",        (-9);
-                "W",        (-10);
-                "X",        (-11);
-                "Y",        (-12);
-                "Z",        0
-            ]
-        in
-        Atom_map.of_seq z
-
-    let identity_ x = x
-
-    type parameter_element_t =
-        | P_complete of string
-        | P_partial of string Int_map.t
-
-    class virtual ['cursor] parser_core () (* : ['cursor] parser_core_t *) =
-        let optwsprun_ = Cf_lex.X.create (!* wsp $= ()) in
-        let raw_field_name_ = Cf_lex.X.create (field_name $> (fun x -> x)) in
-        let colon_ = ?:':' in
-        let comma_ = ?:',' in
-        let field_name_ =
-            raw_field_name_ >>= fun name ->
-            optwsprun_ >>= fun () ->
-            colon_ >>= fun _ ->
-            ~:name
-        in
-        let unstructured_ =
-            let rule n z =
-                assert (n > 2);
-                let hd = Cf_seq.limit (n - 2) z in
-                let tl = Cf_seq.shift n z in
-                Some (Cf_seq.to_string (Cf_seq.first hd), tl)
-            in
-            Cf_lex.X.create (unstructured $@ rule)
-        in
-        let crlf_ = Cf_parser.X.lit "\013\010" () in
-        let fws_ = Cf_lex.X.create (fws $= ()) in
-        let optfws_ = optunit_ fws_ in
-        let cfws_ =
-            let comment_ = comment_lexer_ () %= comment_parser_ 0 in
-            let aux = optfws_ >>= fun () -> comment_ in
-            let rec loop s =
-                match aux s with
-                | None -> Some ((), s)
-                | Some ((), s) -> loop s
-            in
-            loop >>= fun () ->
-            Cf_parser.alt [ aux; fws_ ]
-        in
-        let optcfws_ = optunit_ cfws_ in
-        let cfws_enclosed_ p =
-            optcfws_ >>= fun () ->
-            p >>= fun x ->
-            optcfws_ >>= fun () ->
-            ~:x
-        in
-        let raw_atom_ = Cf_lex.X.create (raw_atom $> identity_) in
-        let raw_dot_atom_ = Cf_lex.X.create (raw_dot_atom $> identity_) in
-        let raw_token_ = Cf_lex.X.create (raw_token $> identity_) in
-        let atom_ = cfws_enclosed_ raw_atom_ in
-        let dot_atom_ = cfws_enclosed_ raw_dot_atom_ in
-        let token_ = cfws_enclosed_ raw_token_ in
-        let normalize_lexer_ chx =
-            Cf_lex.X.create !@[
-                fws $= ' ';
-                quoted_pair $> quoted_pair_normalize_rule_;
-                chx $@ chx_normalize_rule_;
-            ]
-        in
-        let raw_quoted_string_ =
-            Cf_lex.X.create begin
-                raw_quoted_string $@
-                normalize_ identity_ (normalize_lexer_ qtext)
-            end
-        in
-        let raw_domain_literal_ =
-            Cf_lex.X.create begin
-                raw_domain_literal $@
-                normalize_ identity_ (normalize_lexer_ dtext)
-            end
-        in
-        let quoted_string_ = cfws_enclosed_ raw_quoted_string_ in
-        let domain_literal_ = cfws_enclosed_ raw_domain_literal_ in
-        let raw_word_ = Cf_parser.alt [ atom_; quoted_string_] in
-        let word_ = cfws_enclosed_ raw_word_ in
-        let obs_phrase_aux_ =
-            Cf_parser.alt [
-                word_;
-                Cf_parser.X.tok (function '.' -> Some "." | _ -> None);
-                cfws_ >>= fun () -> ~:" ";
-            ]
-        in
-        let obs_phrase_ =
-            word_ >>= fun hd ->
-            ?* obs_phrase_aux_ >>= fun tl ->
-            let wl = List.rev (hd :: tl) in
-            let f a w = (w, 0, String.length w) :: a in
-            let m = List.fold_left f [] wl in
-            ~:(Cf_message.contents m)
-        in
-        let number_ = cfws_enclosed_ (Cf_scan_parser.scanfx "%d" identity_) in
-        let addr_spec_ =
-            let obs_local_part_ =
-                word_ >>= fun hd ->
-                ?* (?:'.' >>= fun _ -> word_) >>= fun tl ->
-                let b = Buffer.create 80 in
-                Buffer.add_string b hd;
-                List.iter begin fun s ->
-                    Buffer.add_char b '.';
-                    Buffer.add_string b s
-                end tl;
-                ~:(Buffer.contents b)
-            in
-            let obs_domain_ =
-                atom_ >>= fun hd ->
-                ?* (?:'.' >>= fun _ -> atom_) >>= fun tl ->
-                let b = Buffer.create 80 in
-                Buffer.add_string b hd;
-                List.iter begin fun s ->
-                    Buffer.add_char b '.';
-                    Buffer.add_string b s
-                end tl;
-                ~:(Buffer.contents b)
-            in
-            let local_part_ =
-                Cf_parser.alt [ quoted_string_; dot_atom_; obs_local_part_ ]
-            in
-            let domain_ =
-                Cf_parser.alt [ domain_literal_; dot_atom_; obs_domain_ ]
-            in
-            local_part_ >>= fun loc ->
-            ?:'@' >>= fun _ ->
-            domain_ >>= fun dom ->
-            ~:(loc, dom)
-        in
-        let date_time_ =
-            let weekday_ =
-                atom_ >>= fun atom ->
-                let atom = String.lowercase atom in
-                if Atom_map.member atom weekday_names_ then
-                    ~:()
-                else
-                    Cf_parser.nil
-            in
-            let monthname_ =
-                atom_ >>= fun atom ->
-                let atom = String.lowercase atom in
-                try ~:(Atom_map.search atom month_names_) with
-                | Not_found -> Cf_parser.nil
-            in
-            let named_zone_ =
-                atom_ >>= fun atom ->
-                let atom = String.lowercase atom in
-                ~:begin
-                    try Some (Atom_map.search atom zone_names_) with
-                    Not_found -> None
-                end
-            and numbered_zone_ =
-                Cf_parser.alt [ ?:'+'; ?:'-' ] >>= fun sign ->
-                Cf_scan_parser.scanfx "%4u" identity_ >>= fun n ->
-                let hr = n / 100 and min = n mod 100 in
-                if hr > 99 || min > 59 then
-                    Cf_parser.nil
-                else
-                    let n = ((hr * 60) + min) * 60 in
-                    ~:begin
-                        match sign with
-                        | '-' when n = 0 -> None
-                        | '-' -> Some (-n)
-                        | _ -> Some n
-                    end
-            in
-            let timezone_ = Cf_parser.alt [ numbered_zone_; named_zone_; ] in
-            ?/ (weekday_ >>= fun () -> comma_) >>= fun _ ->
-            number_ >>= fun day ->
-            monthname_ >>= fun month ->
-            number_ >>= fun year ->
-            number_ >>= fun hour ->
-            colon_ >>= fun _ ->
-            number_ >>= fun minute ->
-            colon_ >>= fun _ ->
-            number_ >>= fun second ->
-            timezone_ >>= fun tz ->
-            let tm = {
-                Cf_stdtime.year = year;
-                Cf_stdtime.month = month;
-                Cf_stdtime.day = day;
-                Cf_stdtime.hour = hour;
-                Cf_stdtime.minute = minute;
-                Cf_stdtime.second = second;
-            } in
-            ~:(tm, tz)
-        in
-        let parameter_ =
-            let raw_value_ =
-                Cf_parser.alt [ raw_quoted_string_; raw_token_ ]
-            in
-            let value_ = cfws_enclosed_ raw_value_ in
-            token_ >>= fun tag ->
-            ?:'=' >>= fun _ ->
-            value_ >>= fun v ->
-            ~:(String.lowercase tag, v)
-        in
-        let parameters_ =
-            let element = 
-                ?:';' >>= fun _ ->
-                optcfws_ >>= fun () ->
-                parameter_ >>= fun (a, v) ->
-                ~:begin
-                    try
-                        let n = String.index a '*' in
-                        let len = String.length a in
-                        if n > 0 && n < len - 1 then begin
-                            let a = String.sub a 0 n in
-                            let b = String.sub a (n + 1) (len - n - 1) in
-                            let n = int_of_string b in
-                            a, Some n, v
-                        end
-                        else
-                            a, None, v
-                    with
-                    | Not_found ->
-                        a, None, v
-                end
-            in
-            let insert_loop r (a, n_opt, v) =
-                let p =
-                    match n_opt with
-                    | None ->
-                        P_complete v
-                    | Some n ->
-                        let rr =
-                            try
-                                match Atom_map.search a r with
-                                | P_partial rr -> rr
-                                | _ -> Int_map.nil
-                            with
-                            | Not_found ->
-                                Int_map.nil
-                        in
-                        P_partial (Int_map.replace (n, v) rr)
-                in
-                Atom_map.replace (a, p) r
-            in
-            let iterate_loop b (_, s) = Buffer.add_string b s in
-            let map_loop (a, p : string * parameter_element_t) =
-                match p with
-                | P_complete s -> a, s
-                | P_partial rr ->
-                    let b = Buffer.create 32 in
-                    let z = Int_map.to_seq_incr rr in
-                    Cf_seq.iterate (iterate_loop b) z;
-                    a, Buffer.contents b
-            in
-            let reconstruct_loop r pair = Atom_map.replace pair r in
-            ?* element >>= fun z ->
-            let r = List.fold_left insert_loop Atom_map.nil z in
-            let z = Atom_map.to_seq_incr r in
-            let z = Cf_seq.map map_loop z in
-            ~:(Cf_seq.fold reconstruct_loop Atom_map.nil z)
-        in
-        object
-			val crlf_: ('cursor, unit) Cf_lex.X.t = crlf_
-			val field_name_: ('cursor, string) Cf_lex.X.t = field_name_
-			val unstructured_: ('cursor, string) Cf_lex.X.t = unstructured_
-
-			val fws_: ('cursor, unit) Cf_lex.X.t = fws_
-			val cfws_: ('cursor, unit) Cf_lex.X.t = cfws_
-			val optfws_: ('cursor, unit) Cf_lex.X.t = optfws_
-			val optcfws_: ('cursor, unit) Cf_lex.X.t = optcfws_
-
-			val dot_atom_: ('cursor, string) Cf_lex.X.t = dot_atom_
-			val atom_: ('cursor, string) Cf_lex.X.t = atom_
-			val quoted_string_: ('cursor, string) Cf_lex.X.t = quoted_string_
-			val domain_literal_: ('cursor, string) Cf_lex.X.t = domain_literal_
-
-			val token_: ('cursor, string) Cf_lex.X.t = token_
-			val word_: ('cursor, string) Cf_lex.X.t = word_
-			val phrase_: ('cursor, string) Cf_lex.X.t = obs_phrase_
-			
-			val date_time_: ('cursor, Cf_stdtime.t * int option) Cf_lex.X.t =
-				date_time_
-			
-			val addr_spec_: ('cursor, string * string) Cf_lex.X.t = addr_spec_
-			val parameters_: ('cursor, string Atom_map.t) Cf_lex.X.t =
-				parameters_
-        end
-end
-
-class virtual ['code] error z =
-    let z = (z :> (char * char Cf_parser.cursor) Cf_seq.t) in
-    object
-        method virtual code: 'code
-        method virtual text: string
-
-        method position =
-            match Lazy.force z with
-            | Cf_seq.Z -> assert (not true); -1
-            | Cf_seq.P ((_, c), _) -> c#position
-    end
-
-class virtual ['cursor] core =
-	object(self)
-        inherit ['cursor] Lexer.parser_core ()
-        
-        method private error:
-            'a. ('cursor, 'a) Cf_lex.X.t = fun _ -> raise Cf_parser.Error
-
-        method private require:
-			'a. ('cursor, 'a) Cf_lex.X.t -> ('cursor, 'a) Cf_lex.X.t =
-            fun p s ->
-                match p s with
-                | None -> self#error s
-                | x -> x
-    end
-
-class ['cursor, 'field] t =
-    object(self)
-        inherit ['cursor] core
-        
-        method private field_body name =
-            unstructured_ >>= fun text ->
-            ~:(`F_unstructured (name, text))
-        
-        method field: ('cursor, 'field) Cf_lex.X.t =
-            field_name_ >>= fun name ->
-            self#require begin
-                self#field_body name >>= fun field ->
-                crlf_ >>= fun () ->
-                ~:field
-            end
-        
-        method private header_aux_ =
-            ?* (self#field) >>= fun flist ->
-            crlf_ >>= fun () ->
-            ~:flist
-
-        method header m c =
-            let z = Cf_parser.X.weave ~c (Cf_message.to_seq m) in
-            match self#header_aux_ z with
-            | None ->
-                None
-            | Some (header, z) ->
-                let body =
-                    match Lazy.force z with
-                    | Cf_seq.Z ->
-                        None
-                    | Cf_seq.P ((_, c1), _) ->
-                        let pos = c1#position - c#position in
-                        Some (Cf_message.shift ~pos m, c)
-                in
-                Some (header, body)
-    end
-
-let split_header_and_body =
-    let rec loop n seq =
-        match Lazy.force seq with
-        | Cf_seq.Z ->
-            0
-        | Cf_seq.P (hd, tl) when hd <> '\013' ->
-            loop (succ n) tl
-        | Cf_seq.P (hd, tl) ->
-            match Lazy.force tl with
-            | Cf_seq.Z ->
-                0
-            | Cf_seq.P (hd, tl) when hd <> '\010' ->
-                loop (succ n) tl
-            | Cf_seq.P (hd, tl) ->
-                match Lazy.force tl with
-                | Cf_seq.Z ->
-                    0
-                | Cf_seq.P (hd, tl) when hd <> '\013' ->
-                    loop (succ n) tl
-                | Cf_seq.P (hd, tl) ->
-                    match Lazy.force tl with
-                    | Cf_seq.Z ->
-                        0
-                    | Cf_seq.P (hd, tl) when hd <> '\010' ->
-                        loop (succ n) tl
-                    | Cf_seq.P (hd, tl) ->
-                        n
-    in
-    fun m ->
-        let pos = loop 0 (Cf_message.to_seq m) in
-        if pos > 0 then Some (Cf_message.split ~pos m) else None
-
-let initial_cursor = new Cf_lex.line_cursor ~c:Cf_lex.counter_zero "\r\n"
-
-(*--- End of File [ mime_parser.ml ] ---*)

File mime/mime_parser.mli

-(*---------------------------------------------------------------------------*
-  INTERFACE  mime_parser.mli
-
-  Copyright (c) 2004-2005, James H. Woodyatt
-  All rights reserved.
-
-  Redistribution and use in source and binary forms, with or without
-  modification, are permitted provided that the following conditions
-  are met:
-
-    Redistributions of source code must retain the above copyright
-    notice, this list of conditions and the following disclaimer.
-
-    Redistributions in binary form must reproduce the above copyright
-    notice, this list of conditions and the following disclaimer in
-    the documentation and/or other materials provided with the
-    distribution
-
-  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
-  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
-  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
-  OF THE POSSIBILITY OF SUCH DAMAGE. 
- *---------------------------------------------------------------------------*)
-
-open Mime_common
-
-module Lexer: sig
-    val wsp: Cf_lex.x
-    val crlf: Cf_lex.x
-    val no_ws_ctl: Cf_lex.x
-    val specials: Cf_lex.x
-    val tspecials: Cf_lex.x
-    val quoted_pair: Cf_lex.x
-    val fws: Cf_lex.x
-    val optfws: Cf_lex.x
-    val ctext: Cf_lex.x
-    val cbegin: Cf_lex.x
-    val cend: Cf_lex.x
-    val atext: Cf_lex.x
-    val raw_atom: Cf_lex.x
-    val raw_dot_atom: Cf_lex.x
-    val dquote: Cf_lex.x
-    val qtext: Cf_lex.x
-    val raw_quoted_string: Cf_lex.x
-    val qcontent: Cf_lex.x
-    val dtext: Cf_lex.x
-    val dcontent: Cf_lex.x
-    val raw_domain_literal: Cf_lex.x
-    val ttext: Cf_lex.x
-    val raw_token: Cf_lex.x
-    val ftext: Cf_lex.x
-    val field_name: Cf_lex.x
-    val utext: Cf_lex.x
-    val unstructured: Cf_lex.x
-end
-
-class virtual ['code] error:
-    (char * char #Cf_parser.cursor) Cf_seq.t ->
-    object
-        method virtual code: 'code
-        method virtual text: string
-        method position: int
-    end
-
-class virtual ['cursor] core:
-	object
-        val crlf_: ('cursor, unit) Cf_lex.X.t
-        val field_name_: ('cursor, string) Cf_lex.X.t
-        val unstructured_: ('cursor, string) Cf_lex.X.t
-
-        val fws_: ('cursor, unit) Cf_lex.X.t
-        val cfws_: ('cursor, unit) Cf_lex.X.t
-        val optfws_: ('cursor, unit) Cf_lex.X.t
-        val optcfws_: ('cursor, unit) Cf_lex.X.t
-
-        val dot_atom_: ('cursor, string) Cf_lex.X.t
-        val atom_: ('cursor, string) Cf_lex.X.t
-        val quoted_string_: ('cursor, string) Cf_lex.X.t
-        val domain_literal_: ('cursor, string) Cf_lex.X.t
-
-        val token_: ('cursor, string) Cf_lex.X.t
-        val word_: ('cursor, string) Cf_lex.X.t
-        val phrase_: ('cursor, string) Cf_lex.X.t
-        
-        val date_time_: ('cursor, Cf_stdtime.t * int option) Cf_lex.X.t
-        val addr_spec_: ('cursor, string * string) Cf_lex.X.t
-        val parameters_: ('cursor, string Atom_map.t) Cf_lex.X.t
-
-        method private error: 'a. ('cursor, 'a) Cf_lex.X.t
-
-        method private require:
-			'a. ('cursor, 'a) Cf_lex.X.t -> ('cursor, 'a) Cf_lex.X.t
-	end
-
-class ['cursor, 'field] t:
-    object
-		inherit ['cursor] core
-		
-        constraint 'field = [> `F_unstructured of string * string ]
-
-        method private field_body: string -> ('cursor, 'field) Cf_lex.X.t
-
-        method field: ('cursor, 'field) Cf_lex.X.t
-
-        method header:
-            Cf_message.t -> 'cursor ->
-            ('field list * (Cf_message.t * 'cursor) option) option
-    end
-
-val split_header_and_body:
-    Cf_message.t -> (Cf_message.t * Cf_message.t) option
-
-val initial_cursor: Cf_lex.line_cursor
-
-(*--- End of File [ mime_parser.mli ] ---*)