Source file commands.ml

(*********************************************************************************)
(*                Chamo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2003-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(* $Id: cam_commands.ml 758 2011-01-13 07:53:27Z zoggy $ *)

type command = string array -> unit Lwt.t

type command_desc =
  { com_name : string ;
    com_args : string array ;
    com_more_args : string option ;
    com_f : command ;
  }

let commands = Hashtbl.create 937

let get_com ?(table=commands) name = Hashtbl.find table name

let get_com_or_fail ?table com =
  try get_com ?table com
  with Not_found ->
      failwith (Printf.sprintf "Command %s not available." com)

let register ?(table=commands) ?(replace=false) com =
  try
    ignore (Hashtbl.find table com.com_name);
    if replace then
      Hashtbl.replace table com.com_name com
    else
      failwith (Printf.sprintf "Command %s already registered." com.com_name)
  with
    Not_found ->
      Hashtbl.add table com.com_name com

let register_before ?table com =
  try
    let prev = get_com ?table com.com_name in
    let new_com =
      { com with
        com_f =
          (fun args ->
             let%lwt () = com.com_f args in
             prev.com_f args) ;
      }
    in
    register ?table ~replace: true new_com
  with
    Not_found -> register ?table com

let register_after ?table com =
  try
    let prev = get_com ?table com.com_name in
    let new_com =
      { com with
        com_f = (fun args ->
           let%lwt () = prev.com_f args in
           com.com_f args) ;
      }
    in
    register ?table ~replace: true new_com
  with
    Not_found -> register ?table com

let unit_com_lwt name f =
  { com_name = name ;
    com_args = [| |] ;
    com_more_args = None ;
    com_f = (fun _ -> f ()) ;
  }
let unit_com name f =
  let f _ = f (); Lwt.return_unit in
  unit_com_lwt name f

let create_com name ?more args f =
  { com_name = name ;
    com_args = args ;
    com_more_args = more ;
    com_f = f ;
  }


let string_of_char c = String.make 1 c
let concat char string =
  string_of_char char ^ string

    (* tools to handle locations in lexbuf *)

let pos ?(file="") ~line ~bol ~char () =
  Lexing.{ pos_lnum = line ; pos_bol = bol ; pos_cnum = char ; pos_fname = file }

type loc = { loc_start: Lexing.position; loc_stop: Lexing.position }
type 'a with_loc = 'a * loc option

type error = loc * string
exception Error of error
let error ?(msg="Parse error") loc = raise (Error (loc, msg))
let string_of_loc loc =
  let open Lexing in
  let start = loc.loc_start in
  let stop = loc.loc_stop in
  let line = start.pos_lnum in
  let char = start.pos_cnum - start.pos_bol in
  let len =
    if start.pos_fname = stop.pos_fname then
      stop.pos_cnum - start.pos_cnum
    else
      1
  in
  let file = start.pos_fname in
  Printf.sprintf "%sline %d, character%s %d%s"
    (match file with
     | "" -> ""
     | _ -> Printf.sprintf "File %S, " file)
    line
    (if len > 1 then "s" else "")
    char
    (if len > 1 then Printf.sprintf "-%d" (char + len) else "")

let loc_sprintf loc fmt =
  match loc with
  | None -> Printf.sprintf fmt
  | Some loc -> Printf.ksprintf
      (fun s -> Printf.sprintf "%s:\n%s" (string_of_loc loc) s)
        fmt

let string_of_error (loc, str) =
  Printf.sprintf "%s: %s" (string_of_loc loc) str

let loc loc_start loc_stop = { loc_start ; loc_stop }
let loc_of_pos pos len =
  { loc_start = pos ;
    loc_stop = Lexing.{ pos with pos_cnum = pos.pos_cnum + len } ;
  }
let error_pos ?msg pos = error ?msg (loc_of_pos pos 1)

let nl_char = Uchar.of_char '\n'

let update_pos pos str =
  let open Lexing in
  let f pos i = function
  | `Malformed msg -> error ~msg (loc_of_pos pos 1)
  | `Uchar c when Uchar.equal c nl_char ->
      let bol = pos.pos_cnum in
      { pos with
        pos_lnum = pos.pos_lnum + 1;
        pos_bol = bol ;
        pos_cnum = pos.pos_cnum + 1 ;
      }
  | _ -> { pos with pos_cnum = pos.pos_cnum + 1}
  in
  Uutf.String.fold_utf_8 f pos str

let lexeme pos lexbuf =
  try Sedlexing.Utf8.lexeme lexbuf
  with Sedlexing.MalFormed ->
      error_pos ~msg:"Malformed character in lexeme" pos

let upd pos lexbuf = update_pos pos (lexeme pos lexbuf)

  (* parsing commands *)

let htab = [%sedlex.regexp? 0x09] (* horizontal tab *)
let sp = [%sedlex.regexp? ' '] (* space, \x20 *)
let wsp = [%sedlex.regexp? sp | htab] (* white space *)

let escaped_char = function
| 'n' -> "\n"
| 't' -> "\t"
| '\\' -> "\\"
| '\'' -> "'"
| '"' -> "\""
| ' ' -> " "
| c -> Printf.sprintf "\\%c" c

let rec parse_dquote acc w pos lb =
  match%sedlex lb with
  | "\"" -> parse_words acc w (upd pos lb) lb
  | "\\", any ->
      let lexeme = lexeme pos lb in
      let c = String.get lexeme 1 in
      let pos = upd pos lb in
      Buffer.add_string w (escaped_char c);
      parse_dquote acc w pos lb
  | any ->
      let s = lexeme pos lb in
      Buffer.add_string w s;
      parse_dquote acc w (upd pos lb) lb
  | eof -> error_pos ~msg:"Unterminated quoted string" pos
  | _ -> assert false

and parse_squote acc w pos lb =
  match%sedlex lb with
  | "'" -> parse_words acc w (upd pos lb) lb
  | "\\", any ->
      let lexeme = lexeme pos lb in
      let c = String.get lexeme 1 in
      let pos = upd pos lb in
      Buffer.add_string w (escaped_char c);
      parse_squote acc w pos lb
  | any ->
      let s = lexeme pos lb in
      Buffer.add_string w s;
      parse_squote acc w (upd pos lb) lb
  | eof ->
      error_pos ~msg:"Unterminated single-quoted string" pos
  | _ -> assert false

and parse_words acc w pos lb =
  match%sedlex lb with
  | Star wsp
  | "\\\n" ->
      let b = Buffer.contents w in
      let acc = match b with
        | "" -> acc
        | word -> Buffer.reset w; word :: acc
      in
      parse_words acc w (upd pos lb) lb
  | "\\", any ->
      let lexeme = lexeme pos lb in
      let c = String.get lexeme 1 in
      let pos = upd pos lb in
      Buffer.add_string w (escaped_char c);
      parse_words acc w pos lb
  | "\"" -> parse_dquote acc w (upd pos lb) lb
  | "'" -> parse_squote acc w (upd pos lb) lb
  | any ->
      let s = lexeme pos lb in
      Buffer.add_string w s;
      parse_words acc w (upd pos lb) lb
  | eof ->
      let acc = match Buffer.contents w with
        | "" -> acc
        | s -> s :: acc
      in
      List.rev acc
  | _ -> assert false

let list_of_string str =
  let lexbuf = Sedlexing.Utf8.from_string str in
  let pos = pos ~line:1 ~bol:0 ~char:1 () in
  try parse_words [] (Buffer.create 128) pos lexbuf
  with Error e -> failwith (string_of_error e)

let string_to_argv s = Array.of_list (list_of_string s)
let argv_to_string a =
  String.concat " " (Array.to_list (Array.map Filename.quote a))

let prev_command = ref ""
let same_previous_command = ref false
let launch_command ?(history=true) ?table com args =
  try
    let com = get_com_or_fail ?table com in
    let s_com = Printf.sprintf "%s %s" com.com_name (argv_to_string args) in
    try
      same_previous_command := s_com = !prev_command;
      if history then Com_history.add s_com;
      Log.app (fun m -> m "Executing %s" (*Misc.pp_to_utf8*) s_com);
      let%lwt () = com.com_f (Array.copy args) in
      Log.app (fun m -> m "%s returned" s_com);
      prev_command := s_com;
      Lwt.return_unit
    with
      e ->
        Log.info (fun m -> m "%s failed with %s" s_com (Printexc.to_string e));
        prev_command := s_com;
        raise e
  with
  | e ->
      let err =
        match e with
          Failure s | Sys_error s -> s
        | Invalid_argument s ->
            Printf.sprintf "Invalid_argument(\"%s\")" s
        | e -> Printexc.to_string e
      in
      Log.err (fun m -> m "command %s: %s" com err);
      Lwt.return_unit

let async_launch_command ?history ?table com args =
  Lwt.async (fun () -> launch_command ?history ?table com args)

let same_previous_command () = !same_previous_command

let ask_launch_command ?history ?table ?(width=300) com args =
  try
    let dialog = Stk.Dialog.dialog com in
    let com = get_com_or_fail ?table com in
    let args =
      let lenv = Array.length args in
      let lend = Array.length com.com_args in
      let len = Array.length com.com_args +
        (if com.com_more_args = None then 0 else 1)
      in
      Array.init len
        (fun i ->
           if i >= lend then
             let v =
               let d = lenv - lend in
               if d > 0 then
                 let l = Array.to_list
                   (Array.map Filename.quote
                    (Array.sub args i d))
                 in
                 String.concat " " l
               else
                 ""
             in
             match com.com_more_args with
               None -> assert false
             | Some s -> (s, v)
           else
             let v =
               if i < lenv then
                 args.(i)
               else
                 ""
             in
             (com.com_args.(i), v)
        )
    in
    let f i (label, v) =
      let hbox = Stk.Pack.hbox ~pack:dialog#content_area#set_child () in
      let _label = Stk.Text.label ~pack:(hbox#pack ~hexpand:0) ~text:(label^":") () in
      Stk.Edit.entry ~pack:hbox#pack ~text:v ()
      (*Configwin.string ~f: (fun s -> args.(i) <- (label, s)) label v*)
    in
    let params = List.mapi f (Array.to_list args) in
    dialog#run (function
     | None -> Lwt.return_unit
     | Some `Ok ->
        let args =
          let len = Array.length args in
          let args = Array.map
             (fun (e:Stk.Edit.entry) -> e#text()) (Array.of_list params)
           in
          match com.com_more_args with
            None -> args
          | Some _ ->
              let s_args =
                (String.concat " "
                 (Array.to_list
                  (Array.map Filename.quote
                   (Array.sub args 0 (len - 1))))
                ) ^ " " ^
                  args.(len - 1)
              in
              string_to_argv s_args
        in
        launch_command ?history ?table com.com_name args
    )
  with
    Failure s ->
      Log.err (fun m -> m "%s" s)

let _external_command args =
  let len = Array.length args in
  if len < 1 then
    Lwt.return_unit
  else
    (
     let name = args.(0) in
     let params = Array.sub args 1 (len - 1) in
     let%lwt _ = Lwt_process.exec (name, params) in
     Lwt.return_unit
    )

let _ask_command args =
  let len = Array.length args in
  if len < 1 then
    ()
  else
    let name = args.(0) in
    let params = Array.sub args 1 (len - 1) in
    ask_launch_command name params

let _system args =
  let len = Array.length args in
  if len < 1 then
    Lwt.return_unit
  else
    (
     let com = String.concat " "
       (Array.to_list (Array.map Filename.quote args))
     in
     let com = Lwt_process.shell com in
     let%lwt _ = Lwt_process.exec com in
     Lwt.return_unit
    )

let eval_command ?history ?table com =
  let args = string_to_argv com in
  let len = Array.length args in
  if len < 1 then
    Lwt.return_unit
  else
    let name = args.(0) in
    let params = Array.sub args 1 (len - 1) in
    launch_command ?history ?table name params

let async_command ?history ?table com =
  Lwt.async (fun () -> eval_command ?history ?table com)

let _eval args =
  let com = String.concat " " (Array.to_list (Array.map Filename.quote args)) in
  eval_command com

let _ =
  register
    { com_name = "external" ;
      com_args = [| "program" |] ;
      com_more_args = Some "arguments" ;
      com_f = _external_command ;
    };
  register
    { com_name = "ask" ;
      com_args = [| |] ;
      com_more_args = Some "command and args" ;
      com_f = (fun args -> _ask_command args; Lwt.return_unit) ;
    };
  register
    { com_name = "system" ;
      com_args = [| |] ;
      com_more_args = Some "command and arguments" ;
      com_f = _system ;
    };
  register
    { com_name = "command" ;
      com_args = [| |] ;
      com_more_args = Some "command and arguments" ;
      com_f = _eval ;
    } ;
  register
    { com_name = Constant.com_log_window ;
      com_args = [| |] ;
      com_more_args = None ;
      com_f = (fun _ -> Log.show_log_window (); Lwt.return_unit) ;
    }


let available_command_names ?(table=commands) () =
  List.sort
    compare
    (Hashtbl.fold (fun k c acc -> k :: acc) table [])

    (** {2 Global variables} *)

let global_variables = Hashtbl.create 691

let set_global = Hashtbl.replace global_variables
let get_global = Hashtbl.find global_variables
let safe_get_global name =
  try get_global name
  with Not_found -> ""

let _ =
  let f args =
    if Array.length args < 2 then
      ()
    else
      set_global args.(0) args.(1);
    Lwt.return_unit
  in
  register (create_com "set_global" [| "name" ; "value" |] f)

let trees_for_window additional =
  Stk.Wkey.trees_of_list
    (List.map (fun (x,s) -> (x, fun () -> async_command s))
       (Ocf.get Gui_rc.window_key_bindings @ additional))

let create_add_binding_commands
  (option:(Stk.Key.keystate list * string) list Ocf.conf_option)
    name =
  let f_add = fun key_state command ->
    let l = (key_state, command) :: Ocf.get option in
    Ocf.set option l
  in
  let f_add_string = fun key_state_string ->
    let key_state =
      Config.keystates_wrappers.Ocf.Wrapper.from_json
        (Yojson.Safe.from_string key_state_string)
    in
    f_add key_state
  in
  let com_name = Printf.sprintf "add_%s_key_binding" name in
  let f_com args =
    let len = Array.length args in
    if len < 2 then
      failwith (Printf.sprintf "Usage: %s <list of keys> <command>" com_name);
    f_add_string args.(0) args.(1);
    Lwt.return_unit
  in
  let com =
    { com_name = com_name;
      com_args = [| "list of keys" ; "command" |] ;
      com_more_args = None ;
      com_f = f_com ;
    }
  in
  register com;
  (f_add, f_add_string)

let (add_window_key_binding, add_window_key_binding_string) =
  create_add_binding_commands Gui_rc.window_key_bindings "window"