evaluator.ml 1.59 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
open Netcgi
exception Timeout

let header = "Content-Type: text/plain\n\n"

let cut w s =
  let b= Buffer.create 1024 in
  let rec aux i x =
    if i < String.length s then
      match s.[i] with
	| '\n' -> Buffer.add_char b '\n'; aux (i + 1) 0
	| '\r' -> aux (i + 1) 0
	| '<' ->
	    let rec tag i =
	      Buffer.add_char b s.[i];
	      if (s.[i] = '>') then aux (i + 1) x else tag (i + 1) in
	    tag i
	| c -> 
	    let x = 
	      if x = w then (Buffer.add_string b "\\\n:"; 2) 
	      else (x + 1) in
	    Buffer.add_char b c; 
	    if c = '&' then
	      let rec ent i =
		Buffer.add_char b s.[i];
		if (s.[i] = ';') then aux (i + 1) x else ent (i + 1) in
	      ent (i + 1)
	    else
	      aux (i + 1) x
  in
  aux 0 0;
  Buffer.contents b

let () =
  let exec src =
    ignore (Unix.alarm 10);
    Sys.set_signal Sys.sigalrm 
      (Sys.Signal_handle (fun _ -> raise (Cduce.Escape Timeout)));
    let ppf = Format.str_formatter
    and input = Stream.of_string src in
    Location.push_source (`String src);
    Location.set_protected true;
    Location.warning_ppf := ppf;
    let ok = Cduce.script ppf ppf input in
    if ok then Format.fprintf ppf "@\nOk.@\n";
    Format.flush_str_formatter ()
  in

  Location.set_viewport `Html;
  let prog = Buffer.create 1024 in
  (try while true do Buffer.add_string prog (read_line ()); Buffer.add_string prog "\n" done;
   with End_of_file -> ());
  let prog = Buffer.contents prog in
  let res = try exec prog with Timeout -> "Timeout reached !" in
  let res = cut 80 res in
  print_string header;
57 58 59 60
  print_endline "<pre>";
  print_endline res;
  print_endline "</pre>"