let display_string_list_list ?(modal=false)
?(width=500) ?(height=500) title titles lists =
let window = GWindow.window
~title: title
~width: width
~height: height
~modal: modal
()
in
let _ =
if modal then
let _ = window #connect#destroy ~callback: (GMain.Main.quit) in ()
in
let vbox = GPack.vbox ~packing: window#add () in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (vbox#pack ~expand: true)
()
in
let wlist = GList.clist
~titles: titles
~titles_show: true
~packing: wscroll#add
()
in
let hbox_boutons = GPack.hbox ~packing: (vbox#pack ~expand: false) () in
let wb_ok = GButton.button
~label: Ocvs_messages.mOk
~packing: (hbox_boutons#pack ~expand: true ~padding: 3) ()
in
let _ = wb_ok#connect#clicked window#destroy in
let _ = window#event#connect#key_press
~callback:(fun ev -> if (GdkEvent.Key.keyval ev = GdkKeysyms._Return) then window#destroy (); true)
in
List.iter
(fun l -> let _ = wlist#append l in ())
lists;
GToolbox.autosize_clist wlist ;
window#show ();
if modal then GMain.Main.main () else ()
let display_log ?(modal=false) ?(width=400) ?(height=600) ~title ~log () =
let window = GWindow.window
~title
~allow_shrink: true
~width: width
~height: height
~modal: modal
()
in
let vbox = GPack.vbox ~packing: window#add () in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (vbox#pack ~expand: true ~padding: 2) ()
in
let wview = GText.view
~editable: false
~packing: wscroll#add
()
in
let wb = GButton.button ~label: Ocvs_messages.close
~packing: (vbox#pack ~expand: false)
()
in
let sep = "----------------------------\n" in
let l = Str.split (Str.regexp_string sep) log in
let tag = wview#buffer#create_tag [`FONT "fixed"] in
let rec iter = function
[] -> ()
| [h] ->wview#buffer#insert ~tags: [tag] h
| h :: q ->
wview#buffer#insert ~tags: [tag] h;
let tag2 = wview#buffer#create_tag [`FOREGROUND "Blue"] in
wview#buffer#insert ~tags: [tag ; tag2] sep;
iter q
in
iter l;
ignore (wb#connect#clicked window#destroy);
window#show ();
if modal then
(
ignore (window#connect#destroy GMain.Main.quit);
GMain.Main.main ()
)
else
()
class ['a] box ?(display_dir=true)
(behav : 'a Ocvs_behav.list_behaviour) =
let vbox = GPack.vbox () in
let hbox_dir = GPack.hbox () in
let _ =
if display_dir then
ignore (vbox#pack ~expand: false hbox_dir#coerce)
else
()
in
let _wl_dir = GMisc.label
~text: (Ocvs_messages.directory^" : ")
~packing: (hbox_dir#pack ~expand: false ~padding: 3)
()
in
let we_dir = GEdit.entry
~editable: false
~packing: (hbox_dir#pack ~expand: true ~padding: 3)
()
in
let wscroll = GBin.scrolled_window
~vpolicy: `AUTOMATIC
~hpolicy: `AUTOMATIC
~packing: (vbox#pack ~expand: true)
()
in
let wlist = GList.clist
~titles: behav#titles
~titles_show: true
~selection_mode: `MULTIPLE
~packing: wscroll#add
()
in
object (self)
val mutable selection = ([] : 'a list)
val mutable elements = ([] : 'a list)
val mutable dir = (None : string option)
val mutable compare_function = (None : ('a -> 'a -> int) option)
method box = vbox
method selection = selection
method display_dir ?(force=behav#needs_cvs_status) dir_opt =
dir <- dir_opt ;
self#update force
method private sort_elements l =
match compare_function with
None -> l
| Some f -> List.sort f l
method private click_column col =
compare_function <- Some (behav#comparison_function col) ;
self#update behav#needs_cvs_status
method update update_status =
wlist#freeze ();
selection <- [] ;
wlist#clear () ;
we_dir#set_text "";
let _ =
match dir with
None ->
elements <- []
| Some d ->
let _ =
if update_status then
try behav#cvs_status_dir d
with Failure s -> prerr_endline s
else
()
in
we_dir#set_text d;
elements <- self#sort_elements (behav#elements d) ;
List.iter
(fun t ->
let (color_opt, strings) = behav#display_strings t in
let _ = wlist#append strings in
match color_opt with
None -> ()
| Some c ->
let _ = wlist#set_row ~foreground: (`NAME c)
(wlist#rows -1)
in
()
)
elements;
GToolbox.autosize_clist wlist
in
wlist#thaw ()
method cvs_commit_selected_files =
let files_ok =
try
let f acc file =
match behav#autorize_file file with
Ocvs_behav.Skip -> acc
| Ocvs_behav.Continue -> acc @ [file]
| Ocvs_behav.Stop -> raise Not_found
in
List.fold_left f [] selection
with
Not_found -> []
in
match files_ok with
[] -> ()
| l ->
let files = List.map (fun t -> (behav#cvs_info_of_t t).Ocvs_types.cvs_file) l in
let comment_opt = GToolbox.input_text
Ocvs_messages.enter_comment
(Ocvs_messages.enter_comment_commit^" : ")
in
match comment_opt with
None ->
()
| Some s ->
(
try behav#cvs_commit_files ~comment: s files
with Failure s -> GToolbox.message_box Ocvs_messages.error s
);
self#update behav#needs_cvs_status
method cvs_tag_selected_files =
match selection with
[] ->
()
| l ->
let files = List.map (fun t -> (behav#cvs_info_of_t t).Ocvs_types.cvs_file) l in
match GToolbox.input_string
Ocvs_messages.m_tag_files
(Ocvs_messages.enter_tag_for_files files)
with
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_files confirm tag files
with Failure s -> GToolbox.message_box Ocvs_messages.error s
)
| None ->
()
method cvs_tags_of_file =
match self#selection with
[] -> ()
| file :: _ ->
try
let filename = (behav#cvs_info_of_t file).Ocvs_types.cvs_file in
let tags_revs = behav#cvs_tags_file filename in
display_string_list_list
~width: 300 ~height: 400
(Ocvs_messages.tags_of filename)
[ Ocvs_messages.tag ; Ocvs_messages.revision ]
(List.map (fun (t,r) -> [t ; r]) tags_revs)
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s
method cvs_remove_selected_files =
match selection with
[] ->
()
| l ->
let files = List.map (fun t -> (behav#cvs_info_of_t t).Ocvs_types.cvs_file) l in
match GToolbox.question_box
~title: Ocvs_messages.remove_files
~buttons: [ Ocvs_messages.mOk ; Ocvs_messages.mCancel ]
(Ocvs_messages.confirm_remove_files files)
with
1 ->
(
let (ok, ko) = behav#cvs_remove_files files in
match ok with
[] ->
GToolbox.message_box Ocvs_messages.error
(Ocvs_messages.error_remove_files ko)
| _ ->
self#update behav#needs_cvs_status
)
| _ ->
()
method cvs_log_file =
match selection with
[] ->
()
| f :: _ ->
try
let cvsi = behav#cvs_info_of_t f in
let log = behav#cvs_log_file cvsi.Ocvs_types.cvs_file in
display_log ~title: cvsi.Ocvs_types.cvs_file ~log ()
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s
method cvs_lastdiff_file =
match selection with
[] ->
()
| f :: _ ->
try
let cvsi = behav#cvs_info_of_t f in
match cvsi.Ocvs_types.cvs_status with
Ocvs_types.Up_to_date
| Ocvs_types.Locally_added
| Ocvs_types.Locally_removed
| Ocvs_types.Needs_checkout
| Ocvs_types.Needs_Patch
| Ocvs_types.Unknown ->
raise (Failure Ocvs_messages.no_diff_to_display)
| Ocvs_types.Conflicts_on_merge ->
raise (Failure Ocvs_messages.resolve_conflicts_first)
| Ocvs_types.Locally_modified
| Ocvs_types.Needs_Merge ->
let filename = cvsi.Ocvs_types.cvs_file in
let (diffs, _ ) = behav#cvs_diff_file filename in
let w = Odiff_gui.diffs_window
~title: (filename^" : "^Ocvs_messages.m_last_diff)
~file: filename
diffs
in
w#window#show ()
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s
method cvs_revisions_file file =
try
let filename = (behav#cvs_info_of_t file).Ocvs_types.cvs_file in
let revs = behav#cvs_revisions_file filename in
revs
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s ;
[]
method cvs_select_revision file =
try
let revs = self#cvs_revisions_file file in
match revs with
[] -> None
| _ ->
let filename = (behav#cvs_info_of_t file).Ocvs_types.cvs_file in
match Ocvs_revision.first_revision revs with
None -> None
| Some first_rev ->
let rec build_tree rev =
match Ocvs_revision.children_revisions revs rev with
[] -> `L rev
| subs -> `N (rev, List.map build_tree subs)
in
let tree = build_tree first_rev in
let f_label rev = Ocvs_revision.string_of_revision_number rev.Ocvs_types.rev_number in
let f_string rev = Glib.Convert.locale_to_utf8 (Ocvs_revision.string_of_revision rev) in
GToolbox.tree_selection_dialog ~title: filename
~tree: tree
~label: f_label
~info: f_string
()
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s ;
None
method cvs_differences_with =
match self#selection with
[] -> ()
| file :: _ ->
match self#cvs_select_revision file with
None -> ()
| Some rev ->
try
let filename = (behav#cvs_info_of_t file).Ocvs_types.cvs_file in
let (diffs, _) = behav#cvs_diff_file
~rev: rev filename
in
let title = Printf.sprintf "%s : %s -> %s"
filename
(Ocvs_revision.string_of_revision_number rev.Ocvs_types.rev_number)
Ocvs_messages.working_rev
in
let w = Odiff_gui.diffs_window ~title ~file: filename diffs in
w#window#show ()
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s
method cvs_differences_between =
match self#selection with
[] -> ()
| file :: _ ->
match self#cvs_select_revision file with
None -> ()
| Some rev ->
match self#cvs_select_revision file with
None -> ()
| Some rev2 ->
try
let filename = (behav#cvs_info_of_t file).Ocvs_types.cvs_file in
let (diffs, archive) = behav#cvs_diff_file
~rev: rev ~rev2: rev2 filename
in
let temp_file = behav#rcs_revision rev2 archive in
let title = Printf.sprintf "%s : %s -> %s"
filename
(Ocvs_revision.string_of_revision_number rev.Ocvs_types.rev_number)
(Ocvs_revision.string_of_revision_number rev2.Ocvs_types.rev_number)
in
let w = Odiff_gui.diffs_window ~title ~file: temp_file diffs in
let _ = w#window#connect#destroy (fun () -> Ocvs_commands.delete_file temp_file) in
w#window#show ()
with
Failure s ->
GToolbox.message_box Ocvs_messages.error s
method cvs_resolve_conflicts =
match self#selection with
[] -> ()
| t :: _ ->
let file = behav#cvs_info_of_t t in
match file.Ocvs_types.cvs_status with
Ocvs_types.Conflicts_on_merge ->
(
try
let info = Odiff_merge.build_info file.Ocvs_types.cvs_file in
ignore (new Odiff_merge.window "test" file.Ocvs_types.cvs_file info)
with Failure s ->
GToolbox.message_box Ocvs_messages.error s
)
| _ -> ()
initializer
let check_double_click event d =
(
match event with
None -> ()
| Some ev ->
let t = GdkEvent.get_type ev in
match t with
`TWO_BUTTON_PRESS -> behav#double_click d
| _ -> ()
)
in
let f_select ~row ~column ~event =
try
let ele = List.nth elements row in
selection <- ele :: selection ;
behav#select ele;
check_double_click event ele;
with Failure _ -> ()
in
let f_unselect ~row ~column ~event =
try
let ele_unselected = List.nth elements row in
let new_selection = List.filter (fun ele -> ele <> ele_unselected) selection in
selection <- new_selection ;
behav#unselect ele_unselected;
check_double_click event ele_unselected;
with
Failure _ -> ()
in
ignore (wlist#connect#select_row f_select) ;
ignore (wlist#connect#unselect_row f_unselect) ;
ignore (wlist#connect#click_column self#click_column) ;
ignore (wlist#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
)
)
)
end