let file_exists f =
try let _ = Unix.stat f in true
with _ -> false
let is_prefix f1 f2 =
let len1 = String.length f1 in
let len2 = String.length f2 in
(len1 < len2) &&
(String.sub f2 0 len1) = f1
class ['a] box (behav : 'a Ocvs_behav.tree_behaviour) =
let vbox = GPack.vbox () in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (vbox#pack ~expand: true)
()
in
let cols = new GTree.column_list in
let col_dir = cols#add Gobject.Data.string in
let col_complete = cols#add Gobject.Data.string in
let store = GTree.tree_store cols in
let view = GTree.view ~model: store ~packing: wscroll#add_with_viewport () in
let col = GTree.view_column ()
~renderer:(GTree.cell_renderer_text [], ["text", col_dir]) in
let () = ignore (view#append_column col) in
object(self)
val mutable selection = (None : string option)
method selection = selection
method box = vbox
method select_dir dir =
selection <- Some dir ;
behav#select dir
method unselect_dir dir =
selection <- None ;
behav#unselect dir
method insert_node ?parent dirname basename =
let complete_name = Filename.concat dirname basename in
let row = store#append ?parent () in
store#set row col_dir basename;
store#set row col_complete complete_name;
let subdirs = Ocvs_misc.get_cvs_directories complete_name in
match subdirs with
[] ->
()
| l ->
let rr = store#get_row_reference (store#get_path row) in
List.iter
(self#insert_node ~parent: row complete_name)
(List.sort compare l);
if behav#expand_dir complete_name then
view#expand_row rr#path
method update =
(
match selection with
None -> ()
| Some dir ->
selection <- None ;
self#unselect_dir dir
);
store#clear ();
List.iter (self#insert_node "") behav#roots
method update_selected_dir =
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
while store#iter_has_child it do
match Gstuff.find_first_child store it with
None -> ()
| Some iter -> ignore (store#remove iter)
done;
let dir = store#get ~row: it ~column: col_complete in
let subdirs = Ocvs_misc.get_cvs_directories dir in
(
match subdirs with
[] ->
()
| l ->
List.iter
(self#insert_node ~parent: it dir)
(List.sort compare l)
);
self#select_dir dir
method cvs_update_dir =
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
let dir = store#get ~row: it ~column: col_complete in
(
try let _ = behav#cvs_update_dir dir in ()
with Failure s -> GToolbox.message_box Ocvs_messages.error s
);
self#update_selected_dir
method cvs_commit_dir =
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
let dir = store#get ~row: it ~column: col_complete in
(
let com_opt = GToolbox.input_text
Ocvs_messages.enter_comment
(Ocvs_messages.enter_comment_commit^" : ")
in
match com_opt with
None -> ()
| Some comment ->
(
try let _ = behav#cvs_commit_dir ~comment: comment dir in ()
with Failure s ->
GToolbox.message_box Ocvs_messages.error s
);
self#update_selected_dir
)
method cvs_tag_dir =
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
let dir = store#get ~row: it ~column: col_complete in
let tag_opt = GToolbox.input_string
Ocvs_messages.m_tag_dir
(Ocvs_messages.enter_tag_for_dir dir)
in
match tag_opt with
None -> ()
| Some tag ->
let confirm s =
(GToolbox.question_box
~title: Ocvs_messages.mConfirm
~buttons: [ Ocvs_messages.mYes ; Ocvs_messages.mNo ]
s) = 1
in
try behav#cvs_tag_dir confirm tag dir
with Failure s -> GToolbox.message_box Ocvs_messages.error s
method cvs_add_dir =
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
let dir = store#get ~row: it ~column: col_complete in
(
match GToolbox.select_file ~dir: (ref dir) ~title: Ocvs_messages.add_dir () with
Some new_d ->
(
try
if file_exists new_d then
(
behav#cvs_add_dir new_d;
if is_prefix dir new_d then
self#update_selected_dir
else
self#update
)
else
match GToolbox.question_box
~title: Ocvs_messages.add_dir
~buttons: [ Ocvs_messages.mYes ; Ocvs_messages.mNo ]
(Ocvs_messages.should_create_dir new_d)
with
1 ->
behav#cvs_create_and_add_dir new_d;
if is_prefix dir new_d then
self#update_selected_dir
else
self#update
| _ ->
()
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s
)
| None ->
()
)
method private real_cvs_add_files binary =
let start_dir =
match selection with
None ->
(
match behav#roots with
[] -> Unix.getcwd ()
| s :: _ -> s
)
| Some d -> d
in
let add f =
let (ok, ko) = behav#cvs_add_files ~binary: binary [f] in
match ok with
[] ->
GToolbox.message_box Ocvs_messages.error
(Ocvs_messages.error_add_files ko)
| _ ->
()
in
(
match GToolbox.select_file
~dir: (ref start_dir)
~title: Ocvs_messages.add_files
()
with
Some f -> add f
| None -> ()
);
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
let dir = store#get ~row: it ~column: col_complete in
self#unselect_dir dir;
self#select_dir dir
method cvs_add_files = self#real_cvs_add_files false
method cvs_add_binary_files = self#real_cvs_add_files true
initializer
view#selection#set_mode `SINGLE;
ignore
(view#connect#row_expanded
(fun it _ ->
let dir = store#get ~row: it ~column: col_complete in
behav#add_expanded_dir dir
)
);
ignore
(view#connect#row_collapsed
(fun it _ ->
let dir = store#get ~row: it ~column: col_complete in
behav#remove_expanded_dir dir
)
);
ignore
(view#selection#connect#changed
(fun () ->
(
match selection with
None -> ()
| Some d -> self#unselect_dir d
);
let sel = view#selection in
match sel#get_selected_rows with
[] -> ()
| row :: _ ->
let it = store#get_iter row in
let dir = store#get ~row: it ~column: col_complete in
self#select_dir dir
)
);
let _ = view#event#connect#button_press ~callback:
(
fun ev ->
GdkEvent.Button.button ev = 3 &&
GdkEvent.get_type ev = `BUTTON_PRESS &&
(
match behav#menu_ctx self#selection with
[] -> true
| l ->
GToolbox.popup_menu
~button: 3
~time: (Int32.of_int 0)
~entries: l;
true
)
)
in
self#update
end