This is an automated email from the git hooks/post-receive script. treinen pushed a commit to branch master in repository hevea.
commit e986efff98c24408126c32e42d49a4f8724e602b Author: Ralf Treinen <trei...@free.fr> Date: Sat May 3 08:56:59 2014 +0200 Imported Upstream version 2.14 --- CHANGES | 2 ++ buff.ml | 43 ------------------------------------ buff.mli | 18 --------------- cross.ml | 6 ++--- cutOut.ml | 3 ++- esp.ml | 11 ++++----- esp.mli | 6 ++--- esponja.ml | 19 ++++++++++++++-- hevea.ml | 1 + htmllex.mli | 14 +++++++----- htmllex.mll | 71 ++++++++++++++++++++++++++++++++--------------------------- htmlparse.ml | 57 +++++++++++++++++++++++++++-------------------- htmlparse.mli | 11 +++++---- infoRef.mll | 18 +++++++-------- tagout.mll | 10 +++++---- version.ml | 4 ++-- 16 files changed, 135 insertions(+), 159 deletions(-) diff --git a/CHANGES b/CHANGES index ac61280..d02aa22 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,5 @@ +version 2.14 + * Rationalize buffer usage and suppress private buff module. version 2.13 * More effort to skip comments in arguments. version 2.12 diff --git a/buff.ml b/buff.ml deleted file mode 100644 index 2a4fa1e..0000000 --- a/buff.ml +++ /dev/null @@ -1,43 +0,0 @@ -(***********************************************************************) -(* *) -(* HEVEA *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) -type t = {mutable t : string ; mutable p : int} -;; - -let create () = {t = String.create 64 ; p = 0} - -let rec realloc d b = - let l = String.length b.t in - if b.p + d-1 >= l then begin - let new_t = String.create (2*l) in - String.blit b.t 0 new_t 0 b.p ; - b.t <- new_t ; - realloc d b - end - - -let put_char b c = - realloc 1 b ; - b.t.[b.p] <- c ; - b.p <- b.p + 1 - -let put b s = - let l = String.length s in - realloc l b ; - String.blit s 0 b.t b.p l ; - b.p <- b.p + l - -let to_string b = - let r = String.sub b.t 0 b.p in - b.p <- 0 ; - r - -let reset b = b.p <- 0 - diff --git a/buff.mli b/buff.mli deleted file mode 100644 index 6ed0afc..0000000 --- a/buff.mli +++ /dev/null @@ -1,18 +0,0 @@ -(***********************************************************************) -(* *) -(* HEVEA *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(* $Id: buff.mli,v 1.4 2001-05-28 17:28:55 maranget Exp $ *) -(***********************************************************************) -type t - -val create : unit -> t -val put_char : t -> char -> unit -val put : t -> string -> unit -val to_string : t -> string -val reset : t -> unit diff --git a/cross.ml b/cross.ml index c1c617d..de1d888 100644 --- a/cross.ml +++ b/cross.ml @@ -29,9 +29,9 @@ let add name file = let decode_fragment frag = - let buff = Buff.create () in - Url.decode_fragment (Buff.put_char buff) (Buff.put buff) frag ; - Buff.to_string buff + let buff = Buffer.create 32 in + Url.decode_fragment (Buffer.add_char buff) (Buffer.add_string buff) frag ; + Buffer.contents buff let fullname change myfilename name = if !verbose > 1 then diff --git a/cutOut.ml b/cutOut.ml index 98c3394..497b94c 100644 --- a/cutOut.ml +++ b/cutOut.ml @@ -15,7 +15,8 @@ module type Config = sig end module Make(C:Config) = struct -module Out = DoOut.Make(struct let small_length = 256 end) + +module Out = DoOut.Make(C) type t = { out : Out.t ; name : string } diff --git a/esp.ml b/esp.ml index ee5212b..3ab1fb1 100644 --- a/esp.ml +++ b/esp.ml @@ -17,6 +17,7 @@ exception Failed module type Config = sig val pess : bool val move : bool + val small_length : int end module Make(C:Config) = struct @@ -98,10 +99,10 @@ let lex_this_out vdef f name_in name_out = Location.restore () ; raise e - +module Parse = Htmlparse.Make(C) let process cls in_name input output = - let rec do_rec lexbuf = match Htmlparse.main cls lexbuf with + let rec do_rec lexbuf = match Parse.main cls lexbuf with | [] -> () | ts -> if C.pess then @@ -129,8 +130,8 @@ let process cls in_name input output = output_char stderr '\n' ; Location.print_fullpos () ; Printf.fprintf stderr "Parser error: %s\n" s ; - Htmllex.ptop () ; - Htmllex.reset () ; + Parse.ptop () ; + Parse.reset () ; Location.restore () ; false | e -> @@ -142,7 +143,7 @@ let classes in_name input = let lexbuf = Lexing.from_channel input in Location.set in_name lexbuf ; Emisc.reset () ; - let cls = Htmllex.classes lexbuf in + let cls = Parse.classes lexbuf in Location.restore () ; Some cls with diff --git a/esp.mli b/esp.mli index 2c4f3fe..040dcf8 100644 --- a/esp.mli +++ b/esp.mli @@ -15,12 +15,10 @@ exception Failed module type Config = sig val pess : bool val move : bool + val small_length : int end module Make(C:Config) : sig -val file : string -> unit + val file : string -> unit end -(* -val process : Emisc.Strings.t option -> string -> in_channel -> out_channel -> bool -*) diff --git a/esponja.ml b/esponja.ml index f57a916..8108135 100644 --- a/esponja.ml +++ b/esponja.ml @@ -9,16 +9,30 @@ (* *) (***********************************************************************) +open Printf + let arg = ref [] let pess = ref false let move = ref true +let small_length = ref 1024 let () = Arg.parse - ["-u", Arg.Set pess, "pessimize" ; + [ + ("-version", Arg.Unit + (fun () -> + print_endline ("esponja "^Version.version) ; + print_endline ("library directory: "^Mylib.static_libdir) ; + exit 0), + "show version and exit") ; + ("-rsz", Arg.Int (fun i -> small_length := i), + (sprintf + "size of leaves in rope implementation (default %i)" + !small_length)) ; + "-u", Arg.Set pess, "pessimize" ; "-v", Arg.Unit (fun () -> incr Emisc.verbose),"be verbose" ; "-n", Arg.Unit (fun () -> move := false ; incr Emisc.verbose), - "do not change files"] + "do not change files"; ] (fun s -> arg := s :: !arg) ("Usage: esponja [option*] files\noptions are:") ;; @@ -28,6 +42,7 @@ module E = (struct let pess = !pess let move = !move + let small_length = !small_length end) let process name = try E.file name with Esp.Failed -> () diff --git a/hevea.ml b/hevea.ml index f31c8e1..1ce9720 100644 --- a/hevea.ml +++ b/hevea.ml @@ -190,6 +190,7 @@ let main () = (struct let pess = false let move = true + let small_length = !small_length end) in begin try E.file name_out with Esp.Failed -> diff --git a/htmllex.mli b/htmllex.mli index 6585cdd..ce6c60b 100644 --- a/htmllex.mli +++ b/htmllex.mli @@ -7,13 +7,15 @@ (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) -(* $Id: htmllex.mli,v 1.6 2006-10-09 08:25:16 maranget Exp $ *) (***********************************************************************) -val ptop : unit -> unit val to_string : Lexeme.token -> string val cost : Lexeme.style -> int * int -val reset : unit -> unit -val next_token : Lexing.lexbuf -> Lexeme.token -val styles : Lexing.lexbuf -> Css.id list -val classes : Lexing.lexbuf -> Emisc.Strings.t + +module Make(C:DoOut.Config) : sig + val ptop : unit -> unit + val reset : unit -> unit + val next_token : Lexing.lexbuf -> Lexeme.token + val styles : Lexing.lexbuf -> Css.id list + val classes : Lexing.lexbuf -> Emisc.Strings.t +end diff --git a/htmllex.mll b/htmllex.mll index a727bb1..1e29d40 100644 --- a/htmllex.mll +++ b/htmllex.mll @@ -7,14 +7,27 @@ (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) -(* $Id: htmllex.mll,v 1.15 2012-06-05 14:55:39 maranget Exp $ *) (***********************************************************************) + + { -open Lexing + open Lexeme -open Buff + +let to_string = function + | Open (_,_,txt) | Close (_,txt) | Text txt | Blanks txt -> txt + | Eof -> "Eof" + +let cost = function + | {tag=FONT ; attrs=attrs;_} -> (1,List.length attrs) + | _ -> (1,0) +module Make(C:DoOut.Config) = struct +open Lexing + +module Out = DoOut.Make(C) + let txt_level = ref 0 and txt_stack = MyStack.create "htmllex" @@ -170,13 +183,13 @@ and ferme _lb name txt = with | Not_found -> Text txt -let buff = Buff.create () -and abuff = Buff.create () +let buff = Out.create_buff () +and abuff = Out.create_buff () -let put s = Buff.put buff s -and putc c = Buff.put_char buff c +let put s = Out.put buff s +and putc c = Out.put_char buff c -let aput s = Buff.put abuff s +let aput s = Out.put abuff s @@ -193,24 +206,24 @@ rule main = parse | "<!--" {put (lexeme lexbuf) ; in_comment lexbuf ; - Text (Buff.to_string buff)} + Text (Out.to_string buff)} | "<!" {put (lexeme lexbuf) ; in_tag lexbuf ; - Text (Buff.to_string buff)} + Text (Out.to_string buff)} | '<' (tag as tag) as lxm {put lxm ; if is_textlevel tag then begin let attrs = read_attrs lexbuf in - ouvre lexbuf tag attrs (Buff.to_string buff) + ouvre lexbuf tag attrs (Out.to_string buff) end else if is_basefont tag then begin let attrs = read_attrs lexbuf in set_basefont attrs lexbuf ; - Text (Buff.to_string buff) + Text (Out.to_string buff) end else begin check_nesting lexbuf tag ; in_tag lexbuf ; - let txt = Buff.to_string buff in + let txt = Out.to_string buff in if is_br tag then Blanks txt else @@ -219,12 +232,12 @@ rule main = parse | "</" (tag as tag) as lxm {put lxm ; in_tag lexbuf ; - ferme lexbuf tag (Buff.to_string buff)} + ferme lexbuf tag (Out.to_string buff)} | eof {Eof} | _ as c {putc c ; text lexbuf ; - Text (Buff.to_string buff)} + Text (Out.to_string buff)} and text = parse | [^'<'] as c @@ -237,10 +250,10 @@ and read_attrs = parse | attr_name as name {aput name ; let v = read_avalue lexbuf in - let atxt = Buff.to_string abuff in + let atxt = Out.to_string abuff in put atxt ; (name,v,atxt)::read_attrs lexbuf} -| '>' {put_char buff '>' ; []} +| '>' {Out.put_char buff '>' ; []} | "" {error "Attribute syntax (read_attrs)" lexbuf} and read_avalue = parse @@ -353,27 +366,19 @@ and extract_attrs cls = parse { -let to_string = function - | Open (_,_,txt) | Close (_,txt) | Text txt | Blanks txt -> txt - | Eof -> "Eof" - -let cost = function - | {tag=FONT ; attrs=attrs;_} -> (1,List.length attrs) - | _ -> (1,0) - let tok_buff = ref None ;; -let txt_buff = Buff.create () +let txt_buff = Out.create_buff () ;; let rec read_tokens blanks lb = let t = main lb in match t with - | Text txt -> Buff.put txt_buff txt ; read_tokens false lb - | Blanks txt -> Buff.put txt_buff txt ; read_tokens blanks lb + | Text txt -> Out.put txt_buff txt ; read_tokens false lb + | Blanks txt -> Out.put txt_buff txt ; read_tokens blanks lb | _ -> - let txt = Buff.to_string txt_buff in + let txt = Out.to_string txt_buff in match txt with | "" -> t | _ -> @@ -386,9 +391,9 @@ let rec read_tokens blanks lb = let reset () = txt_level := 0 ; MyStack.reset txt_stack ; - Buff.reset txt_buff ; - Buff.reset buff ; - Buff.reset abuff + Out.reset txt_buff ; + Out.reset buff ; + Out.reset abuff let next_token lb = try match !tok_buff with @@ -402,5 +407,5 @@ let next_token lb = let classes lexbuf = let r = extract_classes Emisc.Strings.empty lexbuf in r - +end } diff --git a/htmlparse.ml b/htmlparse.ml index 73c1b04..f48bbb8 100644 --- a/htmlparse.ml +++ b/htmlparse.ml @@ -11,35 +11,38 @@ (***********************************************************************) open Lexeme -open Htmllex open Tree exception Error of string +module Make(C:DoOut.Config) = struct let error msg _lb = raise (Error msg) ;; +module Out = DoOut.Make(C) +module Lex = Htmllex.Make(C) + let buff = ref None let next_token lexbuf = match !buff with | Some tok -> buff := None ; tok -| None -> Htmllex.next_token lexbuf +| None -> Lex.next_token lexbuf and put_back lexbuf tok = match !buff with | None -> buff := Some tok | _ -> error "Put back" lexbuf -let txt_buff = Buff.create () +let txt_buff = Out.create_buff () let rec to_close tag lb = match next_token lb with | Close (t,_) as tok when t=tag -> tok | Open (t,_,txt) when t=tag -> - Buff.put txt_buff txt ; - Buff.put txt_buff (Htmllex.to_string (to_close tag lb)) ; + Out.put txt_buff txt ; + Out.put txt_buff (Htmllex.to_string (to_close tag lb)) ; to_close tag lb | Eof -> error ("Eof in to_close") lb | tok -> - Buff.put txt_buff (Htmllex.to_string tok); + Out.put txt_buff (Htmllex.to_string tok); to_close tag lb let rec tree cls lexbuf = @@ -48,38 +51,38 @@ let rec tree cls lexbuf = | Open (STYLE,_,txt) -> let otxt = txt and ctxt = Htmllex.to_string (to_close STYLE lexbuf) in - let txt = Buff.to_string txt_buff in + let txt = Out.to_string txt_buff in let txt = match cls with | None -> txt | Some cls -> - let css = Htmllex.styles (MyLexing.from_string txt) in - let buff = Buff.create () in - Buff.put_char buff '\n' ; + let css = Lex.styles (MyLexing.from_string txt) in + let buff = Out.create_buff () in + Out.put_char buff '\n' ; List.iter (fun cl -> match cl with | Css.Other txt -> - Buff.put buff txt ; - Buff.put_char buff '\n' + Out.put buff txt ; + Out.put_char buff '\n' | Css.Class (name, addname, txt) -> if Emisc.Strings.mem name cls then begin - Buff.put_char buff '.' ; - Buff.put buff name ; + Out.put_char buff '.' ; + Out.put buff name ; begin match addname with | None -> () | Some n -> - Buff.put_char buff ' ' ; - Buff.put buff n + Out.put_char buff ' ' ; + Out.put buff n end ; - Buff.put buff txt ; - Buff.put_char buff '\n' + Out.put buff txt ; + Out.put_char buff '\n' end) css ; - Buff.to_string buff in + Out.to_string buff in Some (Text (otxt^txt^ctxt)) | Open (SCRIPT,_,txt) -> - Buff.put txt_buff txt ; - Buff.put txt_buff (Htmllex.to_string (to_close SCRIPT lexbuf)) ; - Some (Text (Buff.to_string txt_buff)) + Out.put txt_buff txt ; + Out.put txt_buff (Htmllex.to_string (to_close SCRIPT lexbuf)) ; + Some (Text (Out.to_string txt_buff)) | Open (tag,attrs,txt) -> let fils = trees cls lexbuf in begin match next_token lexbuf with @@ -105,12 +108,16 @@ let rec do_main cls lexbuf = match tree cls lexbuf with | None -> begin match next_token lexbuf with | Eof -> [] - | tok -> error ("Unexpected " ^ to_string tok) lexbuf + | tok -> error ("Unexpected " ^ Htmllex.to_string tok) lexbuf end | Some (Text _ as last) -> [last] | Some t -> t :: do_main cls lexbuf -let reset () = Buff.reset txt_buff +let ptop () = Lex.ptop () + +let reset () = + Lex.reset() ; + Out.reset txt_buff let main cls lexbuf = try @@ -118,3 +125,5 @@ let main cls lexbuf = with | e -> reset () ; raise e +let classes = Lex.classes +end diff --git a/htmlparse.mli b/htmlparse.mli index 59ca654..a1fc612 100644 --- a/htmlparse.mli +++ b/htmlparse.mli @@ -11,7 +11,10 @@ (***********************************************************************) exception Error of string -val reset : unit -> unit -val main : - Emisc.Strings.t option -> Lexing.lexbuf -> Lexeme.style Tree.t list - +module Make(C:DoOut.Config) : sig + val ptop : unit -> unit + val reset : unit -> unit + val main : + Emisc.Strings.t option -> Lexing.lexbuf -> Lexeme.style Tree.t list + val classes : Lexing.lexbuf -> Emisc.Strings.t +end diff --git a/infoRef.mll b/infoRef.mll index 8e124cc..9f44eca 100644 --- a/infoRef.mll +++ b/infoRef.mll @@ -124,16 +124,14 @@ let ajoute_node_dans_menu n m = let verifie name = - let nom = String.copy name in - for i = 0 to String.length name -1 do - match nom.[i] with - | '\t' -> nom.[i] <- ' ' - | ',' -> nom.[i] <- ' ' - | '.' -> nom.[i] <- '-' - | '\n' -> nom.[i] <- ' ' - | _ -> () - done; - nom + String.map + (fun c -> match c with + | '\t' + | ',' + | '\n' -> ' ' + | '.' -> '-' + | _ -> c) + name ;; diff --git a/tagout.mll b/tagout.mll index e866d98..997fce5 100644 --- a/tagout.mll +++ b/tagout.mll @@ -14,7 +14,7 @@ { exception Error - let buff = Buff.create () + let buff = Buffer.create 32 } let blank = [' ''\t''\n''\r'] @@ -25,8 +25,8 @@ let attr_name = ['a'-'z''A'-'Z''-''0'-'9']+ rule tagout = parse | ('<' | "</") tag { skiptag lexbuf ; tagout lexbuf } | [^'<']+ as lxm - { Buff.put buff lxm ; tagout lexbuf } -| eof { Buff.to_string buff } + { Buffer.add_string buff lxm ; tagout lexbuf } +| eof { Buffer.contents buff } | "" { raise Error } and skiptag = parse @@ -41,5 +41,7 @@ and skiptag = parse | "" { raise Error } { -let tagout s = tagout (MyLexing.from_string s) +let tagout s = + Buffer.reset buff ; + tagout (MyLexing.from_string s) } diff --git a/version.ml b/version.ml index 762439d..8d2b103 100644 --- a/version.ml +++ b/version.ml @@ -9,8 +9,8 @@ (* *) (***********************************************************************) -let real_version = "2.13" -let release_date = "2014-03-18" +let real_version = "2.14" +let release_date = "2014-04-16" let version = -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ocaml-maint/packages/hevea.git _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits