module O = Config_file
type file_type = string
type rule =
{
rule_name : string ;
rule_f : string array -> string -> bool ;
}
let ft_unknown = "unknown"
let rc_ft = Filename.concat Cam_rc.rc_dir "file_types.ini"
let ft_ini = new O.group
let save_ft () = ft_ini#write rc_ft
let load_ft () = ft_ini#read rc_ft
let value_to_ft_handler v =
match v with
O.Raw.Tuple [O.Raw.String name ; O.Raw.List l] ->
let f acc = function
O.Raw.String s -> s :: acc
| _ -> acc
in
(name, List.rev (List.fold_left f [] l))
| _ ->
prerr_endline "value_to_ft_handler";
raise Not_found
let ft_handler_to_value (ft, handlers) =
O.Raw.Tuple
[ O.Raw.String ft ;
O.Raw.List (List.map (fun s -> O.Raw.String s) handlers);
]
let ft_handler_cp_wrapper =
{ O.to_raw = ft_handler_to_value ;
O.of_raw = value_to_ft_handler ;
}
let value_to_rule v =
match v with
O.Raw.Tuple [O.Raw.String ft; O.Raw.String rule] ->
(ft, rule)
| _ ->
prerr_endline "value_to_rules";
raise Not_found
let rule_to_value (ft, rule) =
O.Raw.Tuple
[ O.Raw.String ft ;
O.Raw.String rule ;
]
let rule_cp_wrapper =
{ O.to_raw = rule_to_value ;
O.of_raw = value_to_rule ;
}
let default_editor_command = "chamo_open_file"
let default_ft_rules_and_handlers =
[
"regexp \".*\\\\.ml[ily]?$\"", "OCaml source", [default_editor_command] ;
"regexp \".*[mM]akefile$\"", "Makefile", [default_editor_command] ;
"regexp \".*\\\\.in$\"", "Autoconf input file", [default_editor_command] ;
"regexp \".*\\\\.txt$\"", "Text file", [default_editor_command] ;
"regexp \".*\\\\.htm[l]?$\"", "HTML file", [default_editor_command] ;
"regexp \".*\\\\.cvsignore$\"", "CVS ignore file", [default_editor_command] ;
"regexp \".*\\\\.sch$\"", "DBForge schema", [Printf.sprintf "system %s" Cam_installation.dbforge_gui] ;
"regexp \".*\\\\.rep$\"", "Report template", [Printf.sprintf "system %s" Cam_installation.report_gui] ;
"regexp \".*\\\\.rss$\"", "RSS feed", ["open_rss_file"];
]
let default_ft_rules = List.map
(fun (r,ft,_) -> (ft,r))
default_ft_rules_and_handlers
let default_ft_handlers = List.map
(fun (_,ft,com) -> (ft,com))
default_ft_rules_and_handlers
let ft_rules = new O.list_cp rule_cp_wrapper
~group: ft_ini ["file_type_rules"]
default_ft_rules
""
let ft_handlers = new O.list_cp ft_handler_cp_wrapper
~group: ft_ini ["file_type_handlers"]
default_ft_handlers
""
let default_open_file_command = new O.string_cp ~group: Cam_rc.gui_ini
["file_types_view" ; "open_file_command"] default_editor_command ""
module C = Configwin
let file_type_choices () =
List.sort compare
(Cam_misc.list_remove_doubles (List.map fst ft_rules#get))
type conf_ft = { mutable conf_ft : string ; mutable conf_rule : string ; }
let params_for_ft_rule available_rules ft =
let param_ft = C.combo
~new_allowed:true
~blank_allowed:false
~f:(fun s -> ft.conf_ft <- Glib.Convert.locale_from_utf8 s)
Cam_messages.file_type
(file_type_choices ())
(Glib.Convert.locale_to_utf8 ft.conf_ft)
in
let param_rule = C.combo
~new_allowed:true
~blank_allowed:false
~f: (fun s -> ft.conf_rule <- Glib.Convert.locale_from_utf8 s)
Cam_messages.rule
(List.map (fun r -> r.rule_name) available_rules)
(Glib.Convert.locale_to_utf8 ft.conf_rule)
in
[ param_ft ; param_rule ]
let edit_ft_rules available_rules =
let l = List.map
(fun (ft, rule) -> { conf_ft = ft ; conf_rule = rule })
ft_rules#get
in
let apply l =
ft_rules#set
(List.map (fun c -> (c.conf_ft, c.conf_rule)) l);
save_ft ()
in
let edit c =
let params = params_for_ft_rule available_rules c in
ignore (C.simple_get Cam_messages.edit
~width: 300
~height: 100
params
);
c
in
let add () =
let c = { conf_ft = "" ; conf_rule = "" } in
let params = params_for_ft_rule available_rules c in
match C.simple_get Cam_messages.add
~width: 300
~height: 100
params
with
C.Return_ok -> [c]
| _ -> []
in
let display c =
[ Glib.Convert.locale_to_utf8 c.conf_ft ;
Glib.Convert.locale_to_utf8 c.conf_rule ;
]
in
let param = C.list
~f: apply
~edit
~add
~titles: [Cam_messages.file_type ; Cam_messages.rule ]
""
display l
in
ignore
(C.simple_get Cam_messages.file_types_rules
~width: 400
~height: 500
[param]
)
type conf_fth =
{ mutable conf_ft : string ;
mutable conf_hdls : string list;
}
let params_for_ft ft =
let param_ft = C.combo
~new_allowed:false
~blank_allowed:false
~f:(fun s -> ft.conf_ft <- Glib.Convert.locale_from_utf8 s)
Cam_messages.file_type
(file_type_choices ())
(Glib.Convert.locale_to_utf8 ft.conf_ft)
in
let param_hdl r = C.combo
~new_allowed:true
~blank_allowed:false
~f: (fun s -> r := Glib.Convert.locale_from_utf8 s)
Cam_messages.command
(Cam_commands.available_command_names ())
(Glib.Convert.locale_to_utf8 !r)
in
let param_hdl_list =
let apply l = ft.conf_hdls <- l in
let edit com =
let r = ref com in
let param = param_hdl r in
ignore (C.simple_get Cam_messages.edit
~width: 300
~height: 100
[param]
);
!r
in
let add () =
let com = ref "" in
let param = param_hdl com in
match C.simple_get Cam_messages.add
~width: 300
~height: 100
[param]
with
C.Return_ok -> [!com]
| _ -> []
in
let display com = [ Glib.Convert.locale_to_utf8 com ] in
C.list
~f: apply
~edit
~add
~titles: [Cam_messages.commands ]
""
display ft.conf_hdls
in
[ param_ft ; param_hdl_list ]
let edit_ft_handlers () =
let l = List.map
(fun (ft, coms) -> { conf_ft = ft ; conf_hdls = coms })
ft_handlers#get
in
let apply l =
ft_handlers#set
(List.map (fun c -> (c.conf_ft, c.conf_hdls)) l);
save_ft ()
in
let edit c =
let params = params_for_ft c in
ignore (C.simple_get Cam_messages.edit
~width: 300
~height: 300
params
);
c
in
let add () =
let c = { conf_ft = "" ; conf_hdls = [] } in
let params = params_for_ft c in
match C.simple_get Cam_messages.add
~width: 300
~height: 300
params
with
C.Return_ok -> [c]
| _ -> []
in
let display c =
[ Glib.Convert.locale_to_utf8 c.conf_ft ;
Glib.Convert.locale_to_utf8
(match c.conf_hdls with h :: _ -> h | _ -> "") ;
]
in
let param = C.list
~f: apply
~edit
~add
~titles: [Cam_messages.file_type ; Cam_messages.default_command ]
""
display l
in
ignore
(C.simple_get Cam_messages.file_types_handlers
~width: 400
~height: 500
[param]
)
let rules : (string, rule) Hashtbl.t = Hashtbl.create 13
let register_rule r =
try
ignore(Hashtbl.find rules r.rule_name);
failwith (Printf.sprintf "Rule %s already registered." r.rule_name)
with
Not_found ->
Hashtbl.add rules r.rule_name r
let file_types () = (List.map fst ft_rules#get) @ [ft_unknown]
let file_type_of_file filename =
let rec iter = function
[] -> ft_unknown
| (ft,command) :: q ->
let args = Cam_commands.string_to_argv command in
let len = Array.length args in
if len < 1 then
iter q
else
let rule_name = args.(0) in
let params = Array.sub args 1 (len - 1) in
try
let r = Hashtbl.find rules rule_name in
if r.rule_f params filename then ft else iter q
with
Not_found ->
prerr_endline (Printf.sprintf "Unknown file type rule %s" rule_name);
iter q
in
iter ft_rules#get
let _regexp_rule args f =
let len = Array.length args in
if len < 1 then
false
else
(
let re = Str.regexp args.(0) in
Str.string_match re f 0
)
let _ = register_rule
{ rule_name = "regexp" ;
rule_f = _regexp_rule ;
}
let file_type_handlers : (file_type, string list) Hashtbl.t = Hashtbl.create 13
let associate_handler ft com =
try
let l = Hashtbl.find file_type_handlers ft in
Hashtbl.replace file_type_handlers ft
(l @ [com])
with
Not_found ->
Hashtbl.add file_type_handlers ft [com]
let command_on_files com files =
let s = Printf.sprintf
"%s %s"
com
(String.concat " " (List.map Filename.quote files))
in
Cam_commands.eval_command s
let edition_commands_menu_entries ?line f : GToolbox.menu_entry list =
let ftype = file_type_of_file f in
let l =
try Hashtbl.find file_type_handlers ftype
with Not_found -> []
in
let f_com com =
fun () ->
command_on_files com
(f :: (match line with None -> [] | Some n -> [string_of_int n]))
in
match l with
[] ->
Cam_dbg.print ~level: 3 (Printf.sprintf "no handlers found for file type %s" ftype);
let com = default_open_file_command#get in
[
`I (Cam_misc.escape_menu_label com, f_com com)
]
| [com] ->
[`I (Cam_misc.escape_menu_label com, f_com com)]
| com::q ->
let entries = List.map
(fun com -> `I (Cam_misc.escape_menu_label com, f_com com))
q
in
[ `I (Cam_misc.escape_menu_label com, f_com com) ;
`M (Cam_messages.use_, entries) ;
]
let popup_file_commands_menu f =
match edition_commands_menu_entries f with
[] -> ()
| entries ->
GToolbox.popup_menu
~button: 3 ~time: Int32.zero
~entries
let _configure_ft_rules args =
let available_rules = Hashtbl.fold
(fun _ r acc -> r :: acc)
rules
[]
in
edit_ft_rules available_rules
let _ = Cam_commands.register
{ Cam_commands.com_name = Cam_constant.com_configure_ft_rules ;
Cam_commands.com_args = [| |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _configure_ft_rules;
}
let _configure_ft_handlers args =
edit_ft_handlers ();
Hashtbl.clear file_type_handlers ;
List.iter
(fun (ft, l) -> List.iter (associate_handler ft) l)
ft_handlers#get
let _ = Cam_commands.register
{ Cam_commands.com_name = Cam_constant.com_configure_ft_handlers ;
Cam_commands.com_args = [| |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _configure_ft_handlers;
}
let _ = load_ft ()
let _ = List.iter
(fun (ft, l) -> List.iter (associate_handler ft) l)
ft_handlers#get