#
# add_file "query.ml"
#
# patch "Makefile"
# from [4508b318048d0ab8116433ad4959364486e9265c]
# to [955871eb9f150270818844a8e968cca2025f2a29]
#
# patch "agraph.ml"
# from [8dc92d0353dff544c9d4bd5b7f8e63013e480f1f]
# to [43224748d96e15241ae74b68ddd5e538158c78fc]
#
# patch "agraph.mli"
# from [0ebe4d2e32b297856f7940c0e932bcc0891c984a]
# to [1d7a0b49f88ba46b8eb32138705e04da348bef7f]
#
# patch "database.ml"
# from [417f553c4ad5b0bda0aa848e7b4d952929f28171]
# to [99e4716a7708554fb354c9d365237844831a9e12]
#
# patch "database.mli"
# from [587a34962c95fe2a1837b5df23e38a1c8acc3cbd]
# to [cf83c69520e679903cc25bd22aaf4093e4535ebb]
#
# patch "query.ml"
# from []
# to [6275ad90471c3193c0b477af9ce2f30b1fc413c0]
#
# patch "ui.ml"
# from [a76162c49e1b57c4df6465d1f868ab3d9ba729b5]
# to [0d4d672f6ed2a70f09ca2f22d54947d27e59c400]
#
# patch "view.ml"
# from [6b15dbfdf086880a588dd52f42bfbf76bd3f3975]
# to [ef71335aa33860ed09179219898da53d7256f4d4]
#
# patch "view.mli"
# from [8cf21ebc1a553dbec23d160331a7eced392f7210]
# to [2e44176961f054a130b1abd7cb28dface0b26ac4]
#
# patch "viz_misc.ml"
# from [3480861e960d4f97092d197316e8032766a24b9e]
# to [3239ead06c767d585cb8579ffa802b6267d3f0eb]
#
# patch "viz_misc.mli"
# from [143f89f5d846cb9ed5603040321df691a98e33b1]
# to [05b0d6067400240a80ed825580a60e65346b8b5e]
#
========================================================================
--- Makefile 4508b318048d0ab8116433ad4959364486e9265c
+++ Makefile 955871eb9f150270818844a8e968cca2025f2a29
@@ -23,7 +23,7 @@
database.ml database.mli agraph.ml agraph.mli \
autocolor.ml autocolor.mli viz_style.ml viz_style.mli \
icon.ml unidiff.ml unidiff.mli \
- view.ml view.mli ui.ml main.ml
+ view.ml view.mli query.ml ui.ml main.ml
C_OBJ = mlsqlite/ocaml-sqlite3.o \
glib/ocaml-gspawn.o glib/ocaml-giochannel.o \
========================================================================
--- agraph.ml 8dc92d0353dff544c9d4bd5b7f8e63013e480f1f
+++ agraph.ml 43224748d96e15241ae74b68ddd5e538158c78fc
@@ -328,6 +328,10 @@
(get_related_ids g PARENT id))
end
+let get_node g id =
+ let n = NodeMap.find id (get_layout g).c_nodes in
+ id, n
+
(* keyboard nav *)
let get_parents g id =
get_related g `PARENT id
========================================================================
--- agraph.mli 0ebe4d2e32b297856f7940c0e932bcc0891c984a
+++ agraph.mli 1d7a0b49f88ba46b8eb32138705e04da348bef7f
@@ -23,6 +23,7 @@
val mem : t -> string -> bool
val get_ancestors : t -> string -> string list
+val get_node : t -> string -> string * c_node (* query window *)
val get_parents : t -> string -> (string * c_node) list (* keyboard nav *)
val get_children : t -> string -> (string * c_node) list (* keyboard nav *)
val get_siblings : t -> string -> (string * c_node) list (* keyboard nav *)
========================================================================
--- database.ml 417f553c4ad5b0bda0aa848e7b4d952929f28171
+++ database.ml 99e4716a7708554fb354c9d365237844831a9e12
@@ -385,6 +385,19 @@
get_matching_cert db "date"
(string_is_prefix d_pref)
+let query_certs db query name pattern =
+ let p = string_contains pattern in
+ List.rev
+ (fetch_with_view query db.db
+ (fun db query ->
+ Sqlite3.fetch_f db
+ (fun acc -> function
+ | [| id ; v |] when p v -> id :: acc
+ | _ -> acc)
+ []
+ "SELECT id, unbase64(value) FROM revision_certs WHERE id IN %s AND name = '%s'"
+ view_name name))
+
let run_monotone_diff db monotone_exe edge status cb =
ignore
(spawn_monotone_diff db.filename monotone_exe edge status cb)
========================================================================
--- database.mli 587a34962c95fe2a1837b5df23e38a1c8acc3cbd
+++ database.mli cf83c69520e679903cc25bd22aaf4093e4535ebb
@@ -18,6 +18,7 @@
val get_matching_tags : t -> (string -> bool) -> (string * string) list
val get_matching_dates : t -> string -> (string * string) list
+val query_certs : t -> query -> string -> string -> string list
val get_key_rowid : t -> string -> int
========================================================================
--- query.ml
+++ query.ml 6275ad90471c3193c0b477af9ce2f30b1fc413c0
@@ -0,0 +1,161 @@
+let make_factory () =
+ let id = "mviz-query" in
+ let set = GtkStock.Icon_factory.lookup_default "gtk-execute" in
+ GtkStock.Item.add
+ { GtkStock.stock_id = id ; label = "_Query" ;
+ modifier = [] ; keyval = 0 } ;
+ ignore (GtkStock.make_icon_factory ~icons:[ `STOCK id, set ] ())
+
+let init_stock = Lazy.lazy_from_fun make_factory
+
+
+
+let do_query ~cert_name ~cert_value v =
+ match v.View.db, v.View.agraph with
+ | Some db, Some g when cert_name <> "" && cert_value <> "" ->
+ let ids =
+ Database.query_certs
+ db (Agraph.get_query g)
+ cert_name cert_value in
+
+ let fetch_first_cert id c =
+ match Database.fetch_cert_value db id c with
+ | h :: _ -> h
+ | [] -> "" in
+
+ List.map
+ (fun id ->
+ let date = fetch_first_cert id "date" in
+ let author = fetch_first_cert id "author" in
+ id, date, author)
+ ids
+
+ | _ ->
+ []
+
+
+let category title ?expand (vbox : #GPack.box) =
+ let _ =
+ GMisc.label
+ ~markup:(Printf.sprintf "%s" (Glib.Markup.escape_text title))
+ ~xalign:0.
+ ~packing:vbox#pack () in
+ let al = GBin.alignment ~border_width:8 ~packing:(vbox#pack ?expand) () in
+ al#misc#set_property "left-padding" (`INT 16) ;
+ al#add
+
+let setup_query_builder packing =
+ Lazy.force init_stock ;
+ let packing = (GPack.hbox ~packing ())#pack in
+ let _ = GMisc.label ~text:"Cert name: " ~packing () in
+ let (e_cert_name, _) =
+ GEdit.combo_box_entry_text
+ ~strings:["author" ; "changelog" ; "comment" ; "date" ; "tag" ]
+ ~packing () in
+ let _ = GMisc.label ~text:" contains " ~packing () in
+ let e_cert_value =
+ GEdit.entry ~packing () in
+ (e_cert_name#entry, e_cert_value)
+
+
+type model = {
+ model : GTree.list_store ;
+ col_id : string GTree.column ;
+ col_date : string GTree.column ;
+ col_author : string GTree.column ;
+ }
+
+
+let make_model () =
+ let cols = new GTree.column_list in
+ let col_id = cols#add Gobject.Data.string in
+ let col_date = cols#add Gobject.Data.string in
+ let col_author = cols#add Gobject.Data.string in
+ let store = GTree.list_store cols in
+ store#set_sort_column_id col_date.GTree.index `ASCENDING ;
+ { model = store ;
+ col_id = col_id ; col_date = col_date ; col_author = col_author }
+
+let clear_model m =
+ m.model#clear ()
+
+let setup_results_view packing =
+ let { model = model } as m = make_model () in
+ let packing = View.wrap_in_scroll_window packing in
+ let v = GTree.view ~model ~headers_clickable:true ~packing ~height:100 () in
+ let add_string_renderer ?(props=[]) title col =
+ let vc = GTree.view_column ~title () in
+ let r = GTree.cell_renderer_text props in
+ vc#pack r ;
+ vc#add_attribute r "text" col ;
+ vc#set_sort_column_id col.GTree.index ;
+ ignore (v#append_column vc) in
+ add_string_renderer "Id" ~props:[`FAMILY "Monospace"] m.col_id ;
+ add_string_renderer "Date" m.col_date ;
+ add_string_renderer "Author" m.col_author ;
+ m, v
+
+let update_results m r =
+ if r <> [] then clear_model m ;
+ List.iter
+ (fun (id, date, author) ->
+ let row = m.model#append () in
+ m.model#set ~row ~column:m.col_id id ;
+ m.model#set ~row ~column:m.col_date date ;
+ m.model#set ~row ~column:m.col_author author)
+ r
+
+
+
+let make v =
+ let w = GWindow.dialog
+ ~title:"Monotone-viz Query"
+ ~icon:(Lazy.force Icon.monotone)
+ ?parent:(View.get_toplevel v)
+ ~destroy_with_parent:true
+ ~border_width:8 () in
+
+ let (e1, e2) = setup_query_builder (category "Query" w#vbox) in
+ let (m, rv) = setup_results_view (category "Results" ~expand:true w#vbox) in
+
+ w#add_button_stock `CLOSE `CLOSE ;
+ w#add_button_stock `CLEAR `CLEAR ;
+ w#add_button_stock (`STOCK "mviz-query") `QUERY ;
+ w#set_default_response `QUERY ;
+ ignore (w#connect#close w#misc#hide) ;
+ ignore (w#event#connect#delete (fun _ -> w#misc#hide () ; true)) ;
+
+ ignore (e2#connect#activate (fun () ->
+ w#response `QUERY)) ;
+
+ ignore (w#connect#response (function
+ | `CLOSE | `DELETE_EVENT ->
+ w#misc#hide ()
+ | `CLEAR ->
+ clear_model m
+ | `QUERY ->
+ update_results m
+ (do_query
+ ~cert_name:e1#text ~cert_value:e2#text
+ v))) ;
+
+ ignore (rv#connect#row_activated (fun path view_col ->
+ let id =
+ let row = m.model#get_iter path in
+ m.model#get ~row ~column:m.col_id in
+ View.Canvas.center_on_by_id v id)) ;
+
+ View.connect_event v
+ (function
+ | `CLEAR ->
+ clear_model m ;
+ w#set_response_sensitive `QUERY false
+ | `UPDATE_BEGIN ->
+ w#set_response_sensitive `QUERY true
+ | _ -> ()) ;
+
+ w
+
+let show v =
+ let p = lazy (make v) in
+ fun () -> (Lazy.force p)#present ()
========================================================================
--- ui.ml a76162c49e1b57c4df6465d1f868ab3d9ba729b5
+++ ui.ml 0d4d672f6ed2a70f09ca2f22d54947d27e59c400
@@ -13,6 +13,7 @@
\
\
\
+ \
\
\
\
@@ -33,6 +34,7 @@
\
\
\
+ \
\
\
\
@@ -78,7 +80,8 @@
add "ViewMenu" ~label:"_View" ;
add "Refresh" ~stock:`REFRESH ~tooltip:"Reload" ~accel:"R" ;
add "Zoom_in" ~stock:`ZOOM_IN ~tooltip:"Zoom in" ~accel:"KP_Add" ;
- add "Zoom_out" ~stock:`ZOOM_OUT ~tooltip:"Zoom out" ~accel:"KP_Subtract" ] ;
+ add "Zoom_out" ~stock:`ZOOM_OUT ~tooltip:"Zoom out" ~accel:"KP_Subtract" ;
+ add "Query" ~stock:`FIND ~tooltip:"Search the database" ] ;
g_view#set_sensitive false ;
(g_main, g_popup, g_view)
@@ -385,6 +388,9 @@
action_connect "/toolbar/Prefs"
(Prefs.show v) ;
+ action_connect "/toolbar/Query"
+ (Query.show v) ;
+
action_connect "/popup/Certs"
(fun () ->
View.display_certs v
========================================================================
--- view.ml 6b15dbfdf086880a588dd52f42bfbf76bd3f3975
+++ view.ml ef71335aa33860ed09179219898da53d7256f4d4
@@ -642,6 +642,12 @@
c.w#scroll_to ~x ~y ;
Signal.emit v.event_signal (`NODE_SELECT id)
+ let center_on_by_id v id =
+ match v.agraph with
+ | Some g ->
+ center_on v (Agraph.get_node g id)
+ | None -> ()
+
module PQueue = Heap.Imperative (struct
type t = float * (unit -> unit)
let compare ((x, _) : t) (y, _) = compare x y
========================================================================
--- view.mli 8cf21ebc1a553dbec23d160331a7eced392f7210
+++ view.mli 2e44176961f054a130b1abd7cb28dface0b26ac4
@@ -1,5 +1,7 @@
val error_notice : parent:#GObj.widget -> string -> unit
+val wrap_in_scroll_window : (GObj.widget -> unit) -> GObj.widget -> unit
+
type info_display
type branch_selector
type event =
@@ -59,6 +61,7 @@
val zoom : t -> [< `IN | `OUT ] -> unit -> unit
val clear : t -> unit
val center_on : t -> string * Viz_types.c_node -> unit
+ val center_on_by_id : t -> string -> unit
val update_graph : t -> unit
end
========================================================================
--- viz_misc.ml 3480861e960d4f97092d197316e8032766a24b9e
+++ viz_misc.ml 3239ead06c767d585cb8579ffa802b6267d3f0eb
@@ -30,6 +30,12 @@
| Some e -> e in
String.sub str start (stop - start)
+let string_contains p =
+ let r = Str.regexp_string_case_fold p in
+ fun s ->
+ try ignore (Str.search_forward r s 0) ; true
+ with Not_found -> false
+
let option_of_list = function
| [] -> None
| x :: _ -> Some x
========================================================================
--- viz_misc.mli 143f89f5d846cb9ed5603040321df691a98e33b1
+++ viz_misc.mli 05b0d6067400240a80ed825580a60e65346b8b5e
@@ -1,7 +1,8 @@
val string_is_prefix : string -> ?offset:int -> string -> bool
val string_split :
?collapse:bool -> ?max_elem:int -> char -> string -> string list
val string_slice : ?s:int -> ?e:int -> string -> string (** @raise Invalid_argument if slice isn't valid *)
+val string_contains : string -> string -> bool
val option_of_list : 'a list -> 'a option
val list_uniq : 'a list -> 'a list