viewcvs.cgi/parser/location.ml

type source = [ `None | `File of string | `Stream | `String of string ]
type loc = source * int * int
type viewport = [ `Html | `Text ]

let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
  if s1 = s2 then 
    if i1 = -1 then loc2 else if i2 = -1 then loc1 else 
      (s1, min i1 i2, max j1 j2)
  else loc1

let source = ref `None
let source_stack = ref []
let push_source s = source_stack := !source :: !source_stack; source := s
let pop_source () = 
  match !source_stack with
    | [] -> assert false
    | s::rem -> source_stack := rem; source := s

let warning_ppf = ref Format.std_formatter

exception Location of loc * exn
exception Generic of string

let raise_loc i j exn = raise (Location ((!source,i,j),exn))
let raise_generic s = raise (Generic s)
let raise_loc_generic loc s = raise (Location (loc, Generic s))

let noloc = (`None,-1,-1)
let nopos = (-1,-1)

let viewport = ref `Text
let set_viewport v = viewport := v

let get_line_number src i =
  let ic = open_in_bin src in
  let rec aux pos line start =
    if (pos >= i) 
    then (line,i - start) 
    else
      match input_char ic with
        | '\r' when pos = start -> aux (pos + 1) line (pos + 1)
        | '\r' | '\n' -> aux (pos + 1) (line + 1) (pos + 1)
        | _ -> aux (pos + 1) line start
  in
  let r = aux 0 1 0 in
  close_in ic;
  r

let print_loc ppf (src,i,j) =  
  match src with
    | `None -> Format.fprintf ppf "somewhere (no source defined !)"
    | `Stream | `String _ ->
        Format.fprintf ppf "at chars %i-%i" i j
    | `File fn ->
        let (l1,c1) = get_line_number fn i
        and (l2,c2) = get_line_number fn j in
        if l1 = l2 then
          Format.fprintf ppf "at line %i (chars %i-%i), file %s"
            l1 c1 c2 fn
        else
          Format.fprintf ppf "at lines %i (char %i) - %i (char %i), file %s"
            l1 c1 l2 c2 fn

let extr s i j =
  Netencoding.Html.encode_from_latin1 
    (String.sub s i (j - i))

let dump_loc ppf (src,i,j) =
  match (src, !viewport) with
    | (`String s, `Html) ->
        if (i < 0) then
          Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
        else
          Format.fprintf ppf "<i>%s</i>@." (extr s i j)
    | _ -> ()

let rec beg_of_line s i =
  if (i = 0) || (s.[i-1] = '\n') || (s.[i-1] = '\r')
  then i else beg_of_line s (i - 1)

let rec end_of_line s i =
  if (i = String.length s) || (s.[i] = '\n') || (s.[i] = '\r')
  then i else end_of_line s (i + 1)

let html_hilight ppf (src,i,j) =
  match (src, !viewport) with
    | `String s, `Html ->
        if (i < 0) then
          Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
        else
        let i0 = beg_of_line s i in
        let j0 = end_of_line s j in
        Format.fprintf ppf 
          "<i>%s<font color=\"red\"><b>%s</b></font>%s</i>@." 
            (extr s i0 i)
            (extr s i j)
            (extr s j j0)
    | _ -> ()
        

type 'a located = { loc : loc; descr : 'a }

let mk (i,j) x = { loc = (!source,i,j); descr = x }
let mk_loc loc x = { loc = loc; descr = x }
let mknoloc x = { loc = noloc; descr = x }
let loc_of_pos (i,j) = (!source,i,j)

let protect ppf f =
  match !viewport with
    | `Html ->
        let b = Buffer.create 63 in
        let ppf' = Format.formatter_of_buffer b in
        f ppf';
        Format.pp_print_flush ppf' ();
        let s = Buffer.contents b in
        let s = Netencoding.Html.encode_from_latin1 s in
        Format.fprintf ppf "@[%s@]" s
    | _ -> f ppf


let protected = ref false
let set_protected p = protected := p
let is_protected () = !protected

let protect_op op =
  if (!protected) then
    raise 
      (Generic (op ^ ": operation not authorized in the web prototype"))
1	type source = [ `None \| `File of string \| `Stream \| `String of string ]
2	type loc = source * int * int
3	type viewport = [ `Html \| `Text ]
4
5	let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
6	if s1 = s2 then
7	if i1 = -1 then loc2 else if i2 = -1 then loc1 else
8	(s1, min i1 i2, max j1 j2)
9	else loc1
10
11	let source = ref `None
12	let source_stack = ref []
13	let push_source s = source_stack := !source :: !source_stack; source := s
14	let pop_source () =
15	match !source_stack with
16	\| [] -> assert false
17	\| s::rem -> source_stack := rem; source := s
18
19	let warning_ppf = ref Format.std_formatter
20
21	exception Location of loc * exn
22	exception Generic of string
23
24	let raise_loc i j exn = raise (Location ((!source,i,j),exn))
25	let raise_generic s = raise (Generic s)
26	let raise_loc_generic loc s = raise (Location (loc, Generic s))
27
28	let noloc = (`None,-1,-1)
29	let nopos = (-1,-1)
30
31	let viewport = ref `Text
32	let set_viewport v = viewport := v
33
34	let get_line_number src i =
35	let ic = open_in_bin src in
36	let rec aux pos line start =
37	if (pos >= i)
38	then (line,i - start)
39	else
40	match input_char ic with
41	\| '\r' when pos = start -> aux (pos + 1) line (pos + 1)
42	\| '\r' \| '\n' -> aux (pos + 1) (line + 1) (pos + 1)
43	\| _ -> aux (pos + 1) line start
44	in
45	let r = aux 0 1 0 in
46	close_in ic;
47	r
48
49	let print_loc ppf (src,i,j) =
50	match src with
51	\| `None -> Format.fprintf ppf "somewhere (no source defined !)"
52	\| `Stream \| `String _ ->
53	Format.fprintf ppf "at chars %i-%i" i j
54	\| `File fn ->
55	let (l1,c1) = get_line_number fn i
56	and (l2,c2) = get_line_number fn j in
57	if l1 = l2 then
58	Format.fprintf ppf "at line %i (chars %i-%i), file %s"
59	l1 c1 c2 fn
60	else
61	Format.fprintf ppf "at lines %i (char %i) - %i (char %i), file %s"
62	l1 c1 l2 c2 fn
63
64	let extr s i j =
65	Netencoding.Html.encode_from_latin1
66	(String.sub s i (j - i))
67
68	let dump_loc ppf (src,i,j) =
69	match (src, !viewport) with
70	\| (`String s, `Html) ->
71	if (i < 0) then
72	Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
73	else
74	Format.fprintf ppf "<i>%s</i>@." (extr s i j)
75	\| _ -> ()
76
77	let rec beg_of_line s i =
78	if (i = 0) \|\| (s.[i-1] = '\n') \|\| (s.[i-1] = '\r')
79	then i else beg_of_line s (i - 1)
80
81	let rec end_of_line s i =
82	if (i = String.length s) \|\| (s.[i] = '\n') \|\| (s.[i] = '\r')
83	then i else end_of_line s (i + 1)
84
85	let html_hilight ppf (src,i,j) =
86	match (src, !viewport) with
87	\| `String s, `Html ->
88	if (i < 0) then
89	Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
90	else
91	let i0 = beg_of_line s i in
92	let j0 = end_of_line s j in
93	Format.fprintf ppf
94	"<i>%s<font color=\"red\"><b>%s</b></font>%s</i>@."
95	(extr s i0 i)
96	(extr s i j)
97	(extr s j j0)
98	\| _ -> ()
99
100
101	type 'a located = { loc : loc; descr : 'a }
102
103	let mk (i,j) x = { loc = (!source,i,j); descr = x }
104	let mk_loc loc x = { loc = loc; descr = x }
105	let mknoloc x = { loc = noloc; descr = x }
106	let loc_of_pos (i,j) = (!source,i,j)
107
108	let protect ppf f =
109	match !viewport with
110	\| `Html ->
111	let b = Buffer.create 63 in
112	let ppf' = Format.formatter_of_buffer b in
113	f ppf';
114	Format.pp_print_flush ppf' ();
115	let s = Buffer.contents b in
116	let s = Netencoding.Html.encode_from_latin1 s in
117	Format.fprintf ppf "@[%s@]" s
118	\| _ -> f ppf
119
120
121
122	let protected = ref false
123	let set_protected p = protected := p
124	let is_protected () = !protected
125
126	let protect_op op =
127	if (!protected) then
128	raise
129	(Generic (op ^ ": operation not authorized in the web prototype"))