open Ocvs_types
let roots = ref []
let usage ="Usage : "^Sys.argv.(0)^" [dir1 dir2 ...]"
let options_list = []
let _ = Arg.parse options_list
(fun s ->
let len = String.length s in
match len with
0 -> ()
| _ ->
let dir =
if s.[len - 1] = '/' then
String.sub s 0 (len -1)
else
s
in
try
let st = Unix.stat dir in
if st.Unix.st_kind = Unix.S_DIR then
roots := !roots @ [dir]
else
prerr_endline (dir^" is not a directory")
with
Unix.Unix_error (e, s1, s2) ->
prerr_endline ((Unix.error_message e)^": "^s2)
)
usage
let _ = if !roots = [] then roots := [Filename.current_dir_name]
let _ = GMain.Main.init ()
let window = GWindow.window
~width: 600
~height: 600
~title: "ocamlcvs" ()
let _ = window#connect#destroy GMain.Main.quit
let vbox = GPack.vbox ~packing: window#add ()
let menubar = GMenu.menu_bar
~packing: (vbox#pack ~expand: false)
()
let menuFile = GMenu.menu ()
let itemFile = GMenu.menu_item
~label: Ocvs_messages.m_file
~packing: menubar#add
()
let _ = itemFile#set_submenu menuFile
let itemQuit = GMenu.menu_item
~label: Ocvs_messages.m_quit
~packing: menuFile#add
()
let menuCvs = GMenu.menu ()
let itemCvs = GMenu.menu_item
~label: Ocvs_messages.m_cvs
~packing: menubar#add
()
let _ = itemCvs#set_submenu menuCvs
let itemAdd_dir = GMenu.menu_item
~label: Ocvs_messages.m_add_dir
~packing: menuCvs#add
()
let itemUpdate_dir = GMenu.menu_item
~label: Ocvs_messages.m_update_dir
~packing: menuCvs#add
()
let itemCommit_dir = GMenu.menu_item
~label: Ocvs_messages.m_commit_dir
~packing: menuCvs#add
()
let itemTag_dir = GMenu.menu_item
~label: Ocvs_messages.m_tag_dir
~packing: menuCvs#add
()
let _ = GMenu.menu_item ~packing: menuCvs#add ()
let itemAdd_files = GMenu.menu_item
~label: Ocvs_messages.m_add_files
~packing: menuCvs#add
()
let itemAdd_binary_files = GMenu.menu_item
~label: Ocvs_messages.m_add_binary_files
~packing: menuCvs#add
()
let itemCommit_files = GMenu.menu_item
~label: Ocvs_messages.m_commit_files
~packing: menuCvs#add
()
let itemTag_files = GMenu.menu_item
~label: Ocvs_messages.m_tag_files
~packing: menuCvs#add
()
let itemTags_of_file = GMenu.menu_item
~label: Ocvs_messages.m_tags_of_file
~packing: menuCvs#add
()
let itemRemove_files = GMenu.menu_item
~label: Ocvs_messages.m_remove_files
~packing: menuCvs#add
()
let _ = GMenu.menu_item ~packing: menuCvs#add ()
let itemLast_diff = GMenu.menu_item
~label: Ocvs_messages.m_last_diff
~packing: menuCvs#add
()
let itemDiff_with = GMenu.menu_item
~label: Ocvs_messages.m_diff_with
~packing: menuCvs#add
()
let itemDiff_between = GMenu.menu_item
~label: Ocvs_messages.m_diff_between
~packing: menuCvs#add
()
let itemResolve_conflicts = GMenu.menu_item
~label: Ocvs_messages.m_resolve_conflicts
~packing: menuCvs#add
()
let itemLog_file = GMenu.menu_item
~label: Ocvs_messages.m_log
~packing: menuCvs#add
()
class data () =
object
val mutable elements = ([] : cvs_info list)
method elements dir =
List.filter
(fun ci ->
(Filename.dirname ci.cvs_file) = dir)
elements
method update_element ci =
let rec iter = function
[] ->
[ci]
| t :: q when t.cvs_file = ci.cvs_file ->
ci :: q
| t :: q ->
t :: (iter q)
in
elements <- iter elements
method remove_element file =
elements <- List.filter
(fun t -> t.cvs_file <> file)
elements
method cvs_info_of_t (ci : cvs_info) = ci
method t_of_cvs_info (ci : cvs_info) = ci
end
let data = new data ()
let color_string_of_status s =
match s with
| Up_to_date -> "DarkGreen"
| Locally_modified
| Locally_added
| Locally_removed -> "SlateBlue"
| Needs_checkout -> "Orange"
| Needs_Patch -> "Orange"
| Needs_Merge -> "Orange"
| Conflicts_on_merge -> "Red"
| Unknown -> "Black"
class list_behaviour data : [cvs_info] Ocvs_behav.list_behaviour =
object
inherit [cvs_info] Ocvs_behav.cvs data
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 (string_of_status ci1.cvs_status) (string_of_status ci2.cvs_status)
| 2 -> fun ci1 -> fun ci2 ->
compare ci1.cvs_work_rev ci2.cvs_work_rev
| 3 -> fun ci1 -> fun ci2 ->
compare ci1.cvs_rep_rev ci2.cvs_rep_rev
| 4 -> fun ci1 -> fun ci2 ->
compare ci1.cvs_date_string ci2.cvs_date_string
| _ -> fun ci1 -> fun ci2 ->
compare ci1.cvs_file ci2.cvs_file
method display_strings ci =
(Some (color_string_of_status ci.cvs_status),
[ Filename.basename ci.cvs_file ;
string_of_status ci.cvs_status ;
ci.cvs_work_rev ;
ci.cvs_rep_rev ;
ci.cvs_date_string ]
)
method titles = [ "file" ; "status"; "working rev." ; "rep. rev." ; "date"]
method autorize_file (_ : cvs_info) = Ocvs_behav.Continue
method after_action (_ : cvs_info) = ()
method menu_ctx (selection : cvs_info list) =
match selection with
[] ->
[ `I (Ocvs_messages.m_add_files, itemAdd_files#activate) ;
`I (Ocvs_messages.m_add_binary_files, itemAdd_binary_files#activate) ;
]
| _ ->
[ `I (Ocvs_messages.m_add_files, itemAdd_files#activate) ;
`I (Ocvs_messages.m_add_binary_files, itemAdd_binary_files#activate) ;
`I (Ocvs_messages.m_commit_files, itemCommit_files#activate) ;
`I (Ocvs_messages.m_tag_files, itemTag_files#activate) ;
`I (Ocvs_messages.m_tags_of_file, itemTags_of_file#activate) ;
`I (Ocvs_messages.m_remove_files, itemRemove_files#activate) ;
`I (Ocvs_messages.m_last_diff, itemLast_diff#activate) ;
`I (Ocvs_messages.m_diff_with, itemDiff_with#activate) ;
`I (Ocvs_messages.m_diff_between, itemDiff_between#activate) ;
`I (Ocvs_messages.m_resolve_conflicts, itemResolve_conflicts#activate);
`I (Ocvs_messages.m_log, itemLog_file#activate);
]
method select (_ : cvs_info) = ()
method unselect (_ : cvs_info) = ()
method double_click (_ : cvs_info) = ()
method needs_cvs_status = true
end
class tree_behaviour (roots : string list)
(box : cvs_info Ocvs_list.box)
data : [cvs_info] Ocvs_behav.tree_behaviour =
object
inherit [cvs_info] Ocvs_behav.cvs data
method expand_dir (_:string) = true
method add_expanded_dir (_:string) = ()
method remove_expanded_dir (_:string) = ()
method update_element = data#update_element
method t_of_cvs_info = data#t_of_cvs_info
method roots = roots
method menu_ctx (selection : string option) =
match selection with
None ->
[ `I (Ocvs_messages.m_add_dir, itemAdd_dir#activate) ]
| Some s ->
[ `I (Ocvs_messages.m_add_dir, itemAdd_dir#activate) ;
`I (Ocvs_messages.m_update_dir, itemUpdate_dir#activate) ;
`I (Ocvs_messages.m_commit_dir, itemCommit_dir#activate) ;
`I (Ocvs_messages.m_tag_dir, itemTag_dir#activate) ;
]
method select (dir : string) = (box#display_dir (Some dir) : unit)
method unselect (dir : string) = (box#display_dir None : unit)
end
let lb = new list_behaviour data
let wpane = GPack.paned `HORIZONTAL
~packing: (vbox#pack ~expand: true) ()
let vbox_list = GPack.vbox ~packing: wpane#add2 ()
let listbox = new Ocvs_list.box (lb :> Ocvs_types.cvs_info Ocvs_behav.list_behaviour)
let _ = vbox_list#pack ~expand: true listbox#box#coerce
let vbox_tree = GPack.vbox ~width: 200 ~packing: wpane#add1 ()
let tb = new tree_behaviour !roots listbox data
let treebox = new Ocvs_tree.box (tb :> Ocvs_types.cvs_info Ocvs_behav.tree_behaviour)
let _ = vbox_tree#pack ~expand: true treebox#box#coerce
let _ = itemQuit#connect#activate window#destroy
let _ = itemAdd_files#connect#activate (fun () -> treebox#cvs_add_files)
let _ = itemAdd_binary_files#connect#activate (fun () -> treebox#cvs_add_binary_files)
let _ = itemCommit_files#connect#activate (fun () -> listbox#cvs_commit_selected_files)
let _ = itemTag_files#connect#activate (fun () -> listbox#cvs_tag_selected_files)
let _ = itemTags_of_file#connect#activate (fun () -> listbox#cvs_tags_of_file)
let _ = itemRemove_files#connect#activate (fun () -> listbox#cvs_remove_selected_files)
let _ = itemLast_diff#connect#activate (fun () -> listbox#cvs_lastdiff_file)
let _ = itemDiff_with#connect#activate (fun () -> listbox#cvs_differences_with)
let _ = itemDiff_between#connect#activate (fun () -> listbox#cvs_differences_between)
let _ = itemResolve_conflicts#connect#activate (fun () -> listbox#cvs_resolve_conflicts)
let _ = itemLog_file#connect#activate (fun () -> listbox#cvs_log_file)
let _ = itemCommit_dir#connect#activate (fun () -> treebox#cvs_commit_dir)
let _ = itemTag_dir#connect#activate (fun () -> treebox#cvs_tag_dir)
let _ = itemUpdate_dir#connect#activate (fun () -> treebox#cvs_update_dir)
let _ = itemAdd_dir#connect#activate (fun () -> treebox#cvs_add_dir)
let _ = window#show ()
let _ = GMain.Main.main ()