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
