type ressource_kind = [ `None | `Dir | `File ]
type ressource_name = string
type view_name = string
class type view =
object
method name : view_name
method refresh : unit
method close : bool
method changed : bool
method ressource : ressource_name
method ressource_kind : ressource_kind
end
class type view_factory =
object
method name : view_name
method create : ressource_name -> string array -> (view * GWindow.window)
method create_no_window : GWindow.window -> ressource_name -> string array -> view * GObj.widget
method known_ressource_kinds : ressource_kind list
end
let factories = ref ([] : view_factory list)
let register_factory f =
if List.exists (fun o -> o#name = f#name) !factories then
Cam_dbg.print (Printf.sprintf "A view factory called \"%s\" is already registered." f#name)
else
factories := f :: !factories
let views : (string, (view * GWindow.window * [`Top | `Embedded]) list) Hashtbl.t = Hashtbl.create 13
let remove_view res_name v =
try
let l = Hashtbl.find views res_name in
Hashtbl.replace views res_name (List.filter (fun (v2,_,_) -> Oo.id v2 <> Oo.id v) l)
with Not_found ->
()
let add_view res_name (v,w,k) =
try
let l = Hashtbl.find views res_name in
Hashtbl.replace views res_name ((v,w,k) :: l)
with Not_found ->
Hashtbl.add views res_name [(v,w,k)]
let view_window_name vname res_name =
Printf.sprintf "%s:%s" vname res_name
let _open_ressource ?fpack res_name v_name args =
let f =
try List.find (fun f -> f#name = v_name) !factories
with Not_found ->
failwith (Printf.sprintf "No factory \"%s\"" v_name)
in
match fpack with
None ->
begin
try
let l = Hashtbl.find views res_name in
match List.filter (fun (v,w,k) -> v#name = v_name && k=`Top) l with
[] -> raise Not_found
| (v,w,_) :: _ ->
w#iconify () ;
Cam_misc.treat_gtk_events ();
w#deiconify ();
v
with
Not_found ->
let (v,w) = f#create res_name args in
add_view res_name (v,w,`Top);
v
end
| Some (w,fpack) ->
let (v,widget) = f#create_no_window w res_name args in
fpack widget;
add_view res_name (v,w,`Embedded);
v
let open_ressource res_name v_name args =
_open_ressource res_name v_name args
let open_ressource_no_window res_name v_name args window fpack =
_open_ressource ~fpack:(window,fpack) res_name v_name args
let iter_views f res_name =
try
let l = Hashtbl.find views res_name in
List.iter
(fun (v, w, _) ->
try f (v, w)
with _ -> ()
)
l
with Not_found -> ()
let refresh_ressource_views = iter_views (fun (v, w) -> v#refresh)
let close_ressource_views = iter_views (fun (v, w) -> if v#close then w#destroy ())
let available_views ?kind () =
match kind with
None -> List.map (fun f -> f#name) !factories
| Some k ->
List.fold_left
(fun acc f ->
if List.mem k f#known_ressource_kinds then
f#name :: acc
else
acc
)
[]
!factories
let current_focused_view_window = ref None
let current_view () = !current_focused_view_window
class view_window ?(allow_shrink=true)
?(width=400) ?(height=400) ~title (v:view) =
let vname = v#name in
let res_name = v#ressource in
let window_name = view_window_name vname res_name in
let w = GWindow.window ~allow_shrink ~width ~height ~title () in
let vbox = GPack.vbox ~packing: w#add () in
object
method window = w
method vbox = vbox
initializer
Cam_rc.handle_window w window_name;
ignore (w#connect#destroy
(fun _ -> remove_view v#ressource v));
ignore (w#event#connect#focus_in
(fun _ -> current_focused_view_window := Some (v,w); true));
ignore (w#event#connect#focus_out
(fun _ -> current_focused_view_window := None; true));
Cam_keymaps.set_window_common_keymaps w
end
let create_view_window ?width ?height ~title view =
new view_window ?width ?height ~title view
let _command_refresh_view args =
match current_view () with
None -> ()
| Some (v,_) ->
Cam_dbg.print ~level: 3
(Printf.sprintf "Refreshing view %s on %s" v#name v#ressource);
v#refresh
let _ = Cam_commands.register
{ Cam_commands.com_name = Cam_constant.com_refresh_view ;
Cam_commands.com_args = [| |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _command_refresh_view ;
}
let _command_close_view args =
match current_view () with
None -> ()
| Some (v,w) ->
Cam_dbg.print ~level: 3
(Printf.sprintf "Closing view %s on %s" v#name v#ressource);
if v#close then
w#destroy ()
let _ = Cam_commands.register
{ Cam_commands.com_name = Cam_constant.com_close_view ;
Cam_commands.com_args = [| |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _command_close_view ;
}
let _command_open_view args =
if Array.length args < 2 then
()
else
let len = Array.length args in
let res_name = args.(0) in
let v_name = args.(1) in
let args = if len > 2 then Array.sub args 2 (len - 2) else [| |] in
ignore (open_ressource res_name v_name args)
let _ = Cam_commands.register
{ Cam_commands.com_name = "open_view" ;
Cam_commands.com_args = [| "ressource name" ; "view name" |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _command_open_view ;
}
let _command_popup_view_directory_menu args =
if Array.length args < 1 then
()
else
let root = args.(0) in
let view_names = available_views ~kind: `Dir () in
match view_names with
[] -> ()
| _ ->
let rec entries dir =
let l =
List.map
(fun s -> `I (Printf.sprintf "%s view" s, fun () -> ignore (open_ressource dir s [| |])))
view_names
in
match Cam_misc.subdirs dir with
[] -> l
| subs ->
l @ (`S :: (List.map (fun d -> `M (Filename.basename d, entries d)) subs))
in
match entries root with
[] -> ()
| entries -> GToolbox.popup_menu
~button: 1 ~time: Int32.zero
~entries
let _ = Cam_commands.register
{ Cam_commands.com_name = "popup_view_directory_menu" ;
Cam_commands.com_args = [| "root directory" |] ;
Cam_commands.com_more_args = None ;
Cam_commands.com_f = _command_popup_view_directory_menu ;
}