module Ocvs_types = Ocamlcvs.Types
module Ocvs_commands = Ocamlcvs.Commands
module Ocvs_behav = Ocamlcvs.Behav
module Ocvs_list = Ocamlcvs.List
module Ocvs_tree = Ocamlcvs.Tree
module M = Cam_messages
class cvs_file_data () =
object
val mutable elements = ([] : Ocvs_types.cvs_info list)
method elements dir =
List.filter
(fun ci ->
(Filename.dirname ci.Ocvs_types.cvs_file) = dir)
elements
method update_element ci =
let rec iter = function
[] ->
[ci]
| t :: q when t.Ocvs_types.cvs_file = ci.Ocvs_types.cvs_file ->
ci :: q
| t :: q ->
t :: (iter q)
in
elements <- iter elements
method remove_element file =
elements <- List.filter
(fun t -> t.Ocvs_types.cvs_file <> file)
elements
method cvs_info_of_t (ci : Ocvs_types.cvs_info) = ci
method t_of_cvs_info (ci : Ocvs_types.cvs_info) = ci
end
let handle_error f p def =
try f p
with Failure s ->
GToolbox.message_box M.error s; def
class cvs_tree root =
let data = ((new cvs_file_data ()) :> Ocvs_types.cvs_info Ocvs_behav.data) in
let cvs = new Ocamlcvs.Behav.cvs data in
object (self)
inherit Cam_dir_view.dir_view root as base
method subdirs s =
List.filter (fun s -> Filename.basename s <> "CVS") (base#subdirs s)
method private update_dir dir () =
let f () =
ignore (cvs#cvs_update_dir dir);
Cam_view.refresh_ressource_views dir
in
handle_error f () ()
method private commit_dir dir () =
let f () =
let com_opt = GToolbox.input_text
M.enter_comment
(M.enter_comment_commit^" : ")
in
match com_opt with
None -> ()
| Some comment ->
cvs#cvs_commit_dir ~comment dir;
Cam_view.refresh_ressource_views dir
in
handle_error f () ()
method private add_dir dir () =
let f () =
match Cam_misc.select_in_list ~value_in_list: false
~choices: (List.map Filename.basename (self#subdirs dir)) ~title: M.add_dir
(Printf.sprintf "%s/" dir)
with
| None -> ()
| Some new_d ->
let new_d = Filename.concat dir new_d in
if Sys.file_exists new_d then
(
cvs#cvs_add_dir new_d;
self#update_selected_dir
)
else
match GToolbox.question_box
~title: M.add_dir
~buttons: [ M.yes ; M.no ]
(M.should_create_dir new_d)
with
1 ->
cvs#cvs_create_and_add_dir new_d;
self#update_selected_dir
| _ ->
()
in
handle_error f () ()
method private tag_dir dir () =
let f () =
let tag_opt = GToolbox.input_string
M.tag_dir
(M.enter_tag_for_dir dir)
in
match tag_opt with
None -> ()
| Some tag ->
let confirm s =
(GToolbox.question_box
~title: M.confirm
~buttons: [ M.yes ; M.no ]
s
) = 1
in
cvs#cvs_tag_dir confirm tag dir
in
handle_error f () ()
method menu_ctx (selection : string option) =
let l =
match selection with
None -> []
| Some dir ->
[
`I (M.add_dir, self#add_dir dir) ;
`I (M.update_dir, self#update_dir dir) ;
`I (M.commit_dir, self#commit_dir dir) ;
`I (M.tag_dir, self#tag_dir dir) ;
]
in
match l with
[] -> base#menu_ctx selection
| _ -> l @ (`S :: base#menu_ctx selection)
method init_col_display ~col_display ~complete ~renderer store =
let f (store:GTree.model) (iter:Gtk.tree_iter) =
let s = store#get ~row: iter ~column: complete in
let props =
if Sys.file_exists (Filename.concat s "CVS") then
[`WEIGHT `BOLD]
else
[`WEIGHT `NORMAL]
in
renderer#set_properties ((`TEXT (Filename.basename s)) :: props)
in
ignore (col_display#set_cell_data_func renderer f)
end
class cvs_tree_view
(name : Cam_view.view_name)
(root : Cam_view.ressource_name)
(gdir : Gdir.gdir)
(close_window_on_close : bool) =
object (self)
method changed = false
method close = close_window_on_close
method name = name
method refresh = gdir#update
method ressource = root
method ressource_kind : Cam_view.ressource_kind = `Dir
end
class cvs_tree_factory : Cam_view.view_factory =
object (self)
method create res_name args =
let gdir = new cvs_tree res_name in
let v = new cvs_tree_view (self#name) res_name gdir true in
let w = Cam_view.create_view_window
~title: (Printf.sprintf "%s [%s]" res_name self#name)
v
in
let _ = w#vbox#pack ~expand: true gdir#box#coerce in
(v, w#window)
method create_no_window window res_name args =
let gdir = new cvs_tree res_name in
let v = new cvs_tree_view (self#name) res_name gdir false in
(v, gdir#box#coerce)
method known_ressource_kinds = [`Dir]
method name = "cvstree"
end
let _ = Cam_view.register_factory (new cvs_tree_factory)
let color_string_of_status s =
match s with
| Ocvs_types.Up_to_date -> "DarkGreen"
| Ocvs_types.Locally_modified
| Ocvs_types.Locally_added
| Ocvs_types.Locally_removed -> "SlateBlue"
| Ocvs_types.Needs_checkout -> "Orange"
| Ocvs_types.Needs_Patch -> "Orange"
| Ocvs_types.Needs_Merge -> "Orange"
| Ocvs_types.Conflicts_on_merge -> "Red"
| Ocvs_types.Unknown -> "Black"
class cvs_files_behaviour f_update dir =
let data = ((new cvs_file_data ()) :> Ocvs_types.cvs_info Ocvs_behav.data) in
object(self)
inherit [Ocvs_types.cvs_info] Ocamlcvs.Behav.cvs data as cvs
val mutable last_clicked_column = 0
method elements = data#elements
method update_element = data#update_element
method remove_element = data#remove_element
method t_of_cvs_info = data#t_of_cvs_info
method cvs_info_of_t = data#cvs_info_of_t
method comparison_function col =
match col with
| 1 -> fun ci1 -> fun ci2 ->
compare
(Ocvs_types.string_of_status ci1.Ocvs_types.cvs_status)
(Ocvs_types.string_of_status ci2.Ocvs_types.cvs_status)
| 2 -> fun ci1 -> fun ci2 ->
compare ci1.Ocvs_types.cvs_work_rev ci2.Ocvs_types.cvs_work_rev
| 3 -> fun ci1 -> fun ci2 ->
compare ci1.Ocvs_types.cvs_rep_rev ci2.Ocvs_types.cvs_rep_rev
| 4 -> fun ci1 -> fun ci2 ->
compare ci1.Ocvs_types.cvs_date_string ci2.Ocvs_types.cvs_date_string
| _ -> fun ci1 -> fun ci2 ->
compare ci1.Ocvs_types.cvs_file ci2.Ocvs_types.cvs_file
method display_strings ci =
(Some (color_string_of_status ci.Ocvs_types.cvs_status),
[ Filename.basename ci.Ocvs_types.cvs_file ;
Ocvs_types.string_of_status ci.Ocvs_types.cvs_status ;
ci.Ocvs_types.cvs_work_rev ;
ci.Ocvs_types.cvs_rep_rev ;
ci.Ocvs_types.cvs_date_string ;
]
)
method autorize_file (f : Ocvs_types.cvs_info) =
Ocvs_behav.Continue
method after_action (_ : Ocvs_types.cvs_info) = ()
method private real_cvs_add_files binary () =
let add f =
let (ok, ko) = cvs#cvs_add_files ~binary: binary [f] in
match ko with
_ :: _ ->
GToolbox.message_box M.error (M.error_add_files ko)
| [] ->
()
in
match GToolbox.select_file ~dir: (ref dir) ~title: M.add_files () with
Some f -> add f; f_update ()
| None -> ()
method private add_files = self#real_cvs_add_files false
method private add_binary_files = self#real_cvs_add_files true
method private commit_selected_files selection () =
let files_ok =
try
let f acc file =
match self#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
[] -> ()
| files ->
let files = List.map (fun t -> t.Ocvs_types.cvs_file) files in
let f () =
let comment_opt = GToolbox.input_text
M.enter_comment
(M.enter_comment_commit^" : ")
in
match comment_opt with
None -> ()
| Some s ->
cvs#cvs_commit_files ~comment: s files
in
handle_error f () () ;
f_update ()
method private tag_selected_files selection () =
let files = List.map (fun t -> t.Ocvs_types.cvs_file) selection in
match GToolbox.input_string
M.tag_files
(M.enter_tag_for_files files)
with
| None -> ()
| Some tag ->
let f () =
let confirm s =
(GToolbox.question_box ~title: M.confirm
~buttons: [ M.yes ; M.no ]
s
) = 1
in
cvs#cvs_tag_files confirm tag files
in
handle_error f () ()
method private tags_of_selected_file selection () =
match selection with
[] -> ()
| file :: _ ->
let f () =
let filename = file.Ocvs_types.cvs_file in
let tags_revs = cvs#cvs_tags_file filename in
Ocvs_list.display_string_list_list
~width: 300 ~height: 400
(M.tags_of filename)
[ M.tag ; M.revision ]
(List.map (fun (t,r) -> [t ; r]) tags_revs)
in
handle_error f () ()
method private remove_selected_files selection () =
let files = List.map (fun t -> t.Ocvs_types.cvs_file) selection in
let f () =
match GToolbox.question_box
~title: M.remove_files
~buttons: [ M.ok ; M.cancel ]
(M.confirm_remove_files files)
with
1 ->
(
let (ok, ko) = cvs#cvs_remove_files files in
match ko with
| [] -> ()
| _ :: _ ->
GToolbox.message_box M.error
(M.error_remove_files ko)
);
f_update ()
| _ ->
()
in
handle_error f () ()
method private lastdiff_selected_file selection () =
let f () =
match selection with
[] -> ()
| cvsi :: _ ->
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, _ ) = cvs#cvs_diff_file filename in
Ocamlcvs.Diffs.display_diffs
~title: (filename^" : "^Ocvs_messages.m_last_diff)
~file: filename
diffs
in
handle_error f () ()
method private revisions_file file =
let f () =
let filename = file.Ocvs_types.cvs_file in
let revs = cvs#cvs_revisions_file filename in
revs
in
handle_error f () []
method private select_revision file =
let f () =
let revs = self#cvs_revisions_file file in
match revs with
[] -> None
| _ ->
match Ocamlcvs.Revisions.first_revision revs with
None -> None
| Some first_rev ->
let rec build_tree rev =
match Ocamlcvs.Revisions.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 = Ocamlcvs.Revisions.string_of_revision_number rev.Ocvs_types.rev_number in
let f_string rev = Glib.Convert.locale_to_utf8
(Ocamlcvs.Revisions.string_of_revision rev)
in
GToolbox.tree_selection_dialog ~title: file
~tree: tree
~label: f_label
~info: f_string
()
in
handle_error f () None
method private log_selected_file selection () =
match selection with
[] -> ()
| f :: _ ->
let f () =
let cvsi = self#cvs_info_of_t f in
let log = cvs#cvs_log_file cvsi.Ocvs_types.cvs_file in
Ocvs_list.display_log ~title: cvsi.Ocvs_types.cvs_file ~log ()
in
handle_error f () ()
method private differences_with selection () =
match selection with
[] -> ()
| file :: _ ->
let filename = (self#cvs_info_of_t file).Ocvs_types.cvs_file in
let f () =
match self#select_revision filename with
None -> ()
| Some rev ->
let (diffs, _) = cvs#cvs_diff_file
~rev: rev filename
in
Ocamlcvs.Diffs.display_diffs
~title: (filename^" : "^
(Ocvs_revision.string_of_revision_number rev.Ocvs_types.rev_number)^
" -> "^Ocvs_messages.working_rev)
~file: filename
diffs
in
handle_error f () ()
method private differences_between selection () =
match selection with
[] -> ()
| file :: _ ->
let filename = file.Ocvs_types.cvs_file in
let f () =
match self#select_revision filename with
None -> ()
| Some rev ->
match self#select_revision filename with
None -> ()
| Some rev2 ->
let (diffs, archive) = cvs#cvs_diff_file
~rev: rev ~rev2: rev2 filename
in
let temp_file = cvs#rcs_revision rev2 archive in
Ocamlcvs.Diffs.display_diffs
~on_close: (fun () -> Ocvs_commands.delete_file temp_file)
~title:
(filename^" : "^
(Ocamlcvs.Revisions.string_of_revision_number rev.Ocvs_types.rev_number)^
" -> "^
(Ocamlcvs.Revisions.string_of_revision_number rev2.Ocvs_types.rev_number)
)
~file: temp_file
diffs
in
handle_error f () ()
method private resolve_conflicts selection () =
match selection with
[] -> ()
| file :: _ ->
let f () =
match file.Ocvs_types.cvs_status with
Ocvs_types.Conflicts_on_merge ->
Ocamlcvs.Diffs.manual_merge M.resolve_conflicts file.Ocvs_types.cvs_file
| _ -> ()
in
handle_error f () ()
method menu_ctx (selection : Ocvs_types.cvs_info list) : GToolbox.menu_entry list =
match selection with
[] ->
[
`I (M.add_files, self#add_files) ;
`I (M.add_binary_files, self#add_binary_files) ;
]
| f :: _ ->
let cvs_choices =
[
`I (M.add_files, self#add_files) ;
`I (M.add_binary_files, self#add_binary_files) ;
`I (M.commit_files, self#commit_selected_files selection);
`I (M.tag_files, self#tag_selected_files selection) ;
`I (M.tags_of_file, self#tags_of_selected_file selection) ;
`I (M.remove_files, self#remove_selected_files selection) ;
`I (M.last_diff, self#lastdiff_selected_file selection) ;
`I (M.diff_with, self#differences_with selection) ;
`I (M.diff_between, self#differences_between selection) ;
`I (M.resolve_conflicts, self#resolve_conflicts selection);
`I (M.log, self#log_selected_file selection);
]
in
let l =
match Cam_files.edition_commands_menu_entries f.Ocvs_types.cvs_file with
[] -> []
| l -> l @ [`S]
in
l @ cvs_choices
method titles = [ "file" ; "status"; "working rev." ; "rep. rev." ; "date"]
method select (_ : Ocvs_types.cvs_info) = ()
method unselect (_ : Ocvs_types.cvs_info) = ()
method double_click (_ : Ocvs_types.cvs_info) = ()
method needs_cvs_status = true
end
class cvs_files_view
(name : Cam_view.view_name)
(root : Cam_view.ressource_name)
(lb : Ocvs_types.cvs_info Ocvs_behav.list_behaviour)
(box : Ocvs_types.cvs_info Ocvs_list.box)
close_window_on_close =
object (self)
method changed = false
method close : bool = close_window_on_close
method name = name
method refresh = box#display_dir ~force: true (Some root)
method ressource = root
method ressource_kind : Cam_view.ressource_kind = `Dir
initializer
lb#cvs_status_dir root;
self#refresh
end
class cvs_files_factory : Cam_view.view_factory =
object (self)
method create res_name args =
let ref_f_update = ref (fun () -> ()) in
let f_update () = !ref_f_update () in
let lb = new cvs_files_behaviour f_update res_name in
let box = new Ocvs_list.box ~display_dir: false lb in
ref_f_update := (fun () -> box#display_dir ~force: true (Some res_name));
let v = new cvs_files_view (self#name) res_name lb box true in
let w = Cam_view.create_view_window
~width: 500
~height: 500
~title: (Printf.sprintf "%s [%s]" res_name self#name)
v
in
let _ = w#vbox#pack ~expand: true box#box#coerce in
(v, w#window)
method create_no_window window res_name args =
let ref_f_update = ref (fun () -> ()) in
let f_update () = !ref_f_update () in
let lb = new cvs_files_behaviour f_update res_name in
let box = new Ocvs_list.box ~display_dir: false lb in
ref_f_update := (fun () -> box#display_dir ~force: true (Some res_name));
let v = new cvs_files_view (self#name) res_name lb box false in
(v, box#box#coerce)
method known_ressource_kinds = [`Dir]
method name = "cvsfiles"
end
let _ = Cam_view.register_factory (new cvs_files_factory)