Below is the file 'query.ml' from this revision. You can also download the file.

open Viz_types

module Selector = struct

  let escape_selector s =
    let len = String.length s in
    let nb_escp = ref 0 in
    for i = 0 to len - 1 do
      let c = s.[i] in
      if c = '\\' || c = '/'
      then incr nb_escp
    done ;
    if !nb_escp = 0
    then s
    else begin
      let o = String.create (len + !nb_escp) in
      let j = ref 0 in
      for i = 0 to len - 1 do
	let c = s.[i] in
	if c = '\\' || c = '/'
	then (o.[!j] <- '\\' ; incr j) ;
	o.[!j] <- c ;
	incr j
      done ;
      assert (!j = len + !nb_escp) ;
      o
    end

  let make_selectors g sel =
    match (Agraph.get_query g).dom with
    | QUERY_ALL ->
	[ escape_selector sel ]
    | QUERY_BRANCHES br ->
	List.map
	  (fun b -> Printf.sprintf "b:%s/%s" (escape_selector b) (escape_selector sel))
	  br

  let running_select = ref None

  let abort () =
    match !running_select with
    | Some id ->
	Subprocess.abort id ;
	running_select := None
    | _ ->
	()

  let has_date_limit g =
    (Agraph.get_query g).lim <> QUERY_NO_LIMIT

  let filter_present g = function
    | `IDS ids when has_date_limit g ->
	`IDS (List.filter (Agraph.mem g) ids)
    | x -> x

  let select ctrl db g sel cont =
    let id =
      Database.run_monotone_select
	db
	ctrl#get_prefs.Viz_style.monotone_path
	(ctrl#status "search")
	(fun r ->
	  running_select := None ;
	  cont (filter_present g r))
	(make_selectors g sel) in
    running_select := Some id

end

let revision_contains pat = function
  | [ _, changes ] ->
      List.exists
	(function
	  | Revision_types.PATCH (f, _, _)
	  | Revision_types.ADD_FILE (f, _)
	  | Revision_types.ADD_DIR f
	  | Revision_types.DELETE_FILE f
	  | Revision_types.DELETE_DIR f
	  | Revision_types.ATTR_CLEAR (_, f)
	  | Revision_types.ATTR_SET (_, f, _) ->
	      Gpattern.match_string pat f
	  | Revision_types.RENAME_FILE (f1, f2)
	  | Revision_types.RENAME_DIR (f1, f2) ->
	      Gpattern.match_string pat f1 ||
	      Gpattern.match_string pat f2)
	changes
  | _ ->
      (* return false for merges *)
      false

let filter_by_revision_content
    (ctrl : <status : string -> <with_status : 'a. string -> (unit -> 'a) -> 'a; ..>; ..>)
    db revision_content ids =
  (ctrl#status "search")#with_status
    "Searching the monotone database ..."
    (fun () ->
      let pat = Gpattern.make revision_content in
      Ui.fold_in_loop
	(fun acc id ->
	  let r = Database.fetch_revision db id in
	  if revision_contains pat r.revision_set
	  then id :: acc
	  else acc)
	[] ids)

let select_by_revision_content ctrl db revision_content g =
  filter_by_revision_content
    ctrl db revision_content
    (Agraph.get_ids g)


let expand_results db ids =
  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 do_query ~selector ~revision_content ctrl results_cb =
  let no_results () =
    results_cb (`IDS []) in
  let results_ids db ids =
    results_cb (`IDS (expand_results db ids)) in

  match ctrl#get_db, ctrl#get_agraph with
  | Some db, Some g when selector <> "" ->
      Selector.select
	ctrl db g selector
	(function
	  | `IDS ids when revision_content <> "" ->
	      results_ids db
		(filter_by_revision_content
		   ctrl db revision_content ids)
	  | `IDS ids ->
	      results_ids db ids
	  | `SUB_PROC_ERROR _ as err ->
	      results_cb err)
  | Some db, Some g when revision_content <> "" ->
      results_ids db
	(select_by_revision_content
	   ctrl db revision_content g)
  | _ ->
      no_results ()





let category title ?expand (vbox : #GPack.box) =
  let base_label =
    Printf.sprintf "<b>%s</b>" (Glib.Markup.escape_text title) in
  let lab =
    GMisc.label
      ~markup:base_label
      ~xalign:0.
      ~packing:vbox#pack () in
  let set_label nb =
    if nb = 0
    then lab#set_label base_label
    else lab#set_label (Printf.sprintf "%s (%d matches)" base_label nb) in
  let al = GBin.alignment ~border_width:8 ~packing:(vbox#pack ?expand) () in
  al#misc#set_property "left-padding" (`INT 16) ;
  (al#add, set_label)

let setup_query_builder vbox =
  let (packing, _) = category "Query" vbox in
  let packing = (GPack.vbox ~packing ())#pack in
  let hbox = GPack.hbox ~packing () in
  let _ = GMisc.label ~text:"Monotone selector: " ~packing:hbox#pack () in
  let e_selector =
    GEdit.entry ~packing:(hbox#pack ~expand:true) () in

  let hbox = GPack.hbox ~packing () in
  let _ = GMisc.label ~text:"Revision concerns file: " ~packing:hbox#pack () in
  let e_revision =
    GEdit.entry ~packing:(hbox#pack ~expand:true) () in
  (e_selector, e_revision)


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 `DESCENDING ;
  { 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 vbox =
  let (packing, set_label) = category "Results" ~expand:true vbox in
  let { model = model } as m = make_model () in
  let packing = Ui.wrap_in_scroll_window packing in
  let v = GTree.view ~model ~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, set_label

let update_results m r =
  clear_model m ;
  m.model#set_sort_column_id (-2) `DESCENDING ;
  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 ;
  m.model#set_sort_column_id m.col_date.GTree.index `DESCENDING


type t = {
    window    : [`CLOSE|`CLEAR|`DELETE_EVENT|`QUERY] GWindow.dialog ;
    id_store  : model ;
    entries   : GEdit.entry list ;
    set_label : int -> unit ;
  }

let make ctrl =
  let w = GWindow.dialog
      ~title:"Monotone-viz Query"
      ~screen:ctrl#get_toplevel#screen
      ~icon:(Lazy.force Icon.monotone)
      ~type_hint:`NORMAL
      ~border_width:8  () in

  let (e1, e2) = setup_query_builder w#vbox in
  let (m, rv, set_label)  = setup_results_view  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#after#close w#misc#hide) ;
  ignore (w#event#connect#delete (fun _ -> w#misc#hide () ; true)) ;

  ignore (e1#connect#activate (fun () ->
    w#response `QUERY)) ;
  ignore (e2#connect#activate (fun () ->
    w#response `QUERY)) ;

  ignore (w#connect#response (function
    | `CLOSE | `DELETE_EVENT ->
	w#misc#hide ()
    | `CLEAR ->
	clear_model m ;
	set_label 0
    | `QUERY ->
	w#set_response_sensitive `QUERY false ;
	let busy = Ui.Busy.make w in
	Ui.Busy.start busy ;
	do_query
	  ~selector:e1#text
	  ~revision_content:e2#text
	  ctrl
	  (fun r ->
	    begin
	      match r with
	      | `IDS results ->
		  update_results m results ;
		  set_label (List.length results)
	      | `SUB_PROC_ERROR msg ->
		  Ui.error_notice ~parent:w msg
	    end ;
	    Ui.Busy.stop busy ;
	    w#set_response_sensitive `QUERY true))) ;

  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
    ctrl#center_on_by_id id)) ;

  { window = w ;
    id_store = m ;
    entries = [ e1 ; e2 ] ;
    set_label = set_label }

let clear q =
  Selector.abort () ;
  clear_model q.id_store ;
  q.set_label 0 ;
  List.iter (fun e -> e#set_text "") q.entries ;
  q.window#set_response_sensitive `QUERY false

let activate q =
  q.window#set_response_sensitive `QUERY true

let show q =
  q.window#present ()