(* this is a translation in Caml of the gtk+ example testdnd.c *) open Gaux open Gtk open GObj open GMain (* GtkThread.start() *) let drag_icon_xpm = [| "36 48 9 1"; " c None"; ". c #020204"; "+ c #8F8F90"; "@ c #D3D3D2"; "# c #AEAEAC"; "$ c #ECECEC"; "% c #A2A2A4"; "& c #FEFEFC"; "* c #BEBEBC"; " ....................."; " ..&&&&&&&&&&&&&&&&&&&."; " ...&&&&&&&&&&&&&&&&&&&."; " ..&.&&&&&&&&&&&&&&&&&&&."; " ..&&.&&&&&&&&&&&&&&&&&&&."; " ..&&&.&&&&&&&&&&&&&&&&&&&."; " ..&&&&.&&&&&&&&&&&&&&&&&&&."; " ..&&&&&.&&&@&&&&&&&&&&&&&&&."; " ..&&&&&&.*$%$+$&&&&&&&&&&&&&."; " ..&&&&&&&.%$%$+&&&&&&&&&&&&&&."; " ..&&&&&&&&.#&#@$&&&&&&&&&&&&&&."; " ..&&&&&&&&&.#$**#$&&&&&&&&&&&&&."; " ..&&&&&&&&&&.&@%&%$&&&&&&&&&&&&&."; " ..&&&&&&&&&&&.&&&&&&&&&&&&&&&&&&&."; " ..&&&&&&&&&&&&.&&&&&&&&&&&&&&&&&&&."; "................&$@&&&@&&&&&&&&&&&&."; ".&&&&&&&+&&#@%#+@#@*$%$+$&&&&&&&&&&."; ".&&&&&&&+&&#@#@&&@*%$%$+&&&&&&&&&&&."; ".&&&&&&&+&$%&#@&#@@#&#@$&&&&&&&&&&&."; ".&&&&&&@#@@$&*@&@#@#$**#$&&&&&&&&&&."; ".&&&&&&&&&&&&&&&&&&&@%&%$&&&&&&&&&&."; ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."; ".&&&&&&&&$#@@$&&&&&&&&&&&&&&&&&&&&&."; ".&&&&&&&&&+&$+&$&@&$@&&$@&&&&&&&&&&."; ".&&&&&&&&&+&&#@%#+@#@*$%&+$&&&&&&&&."; ".&&&&&&&&&+&&#@#@&&@*%$%$+&&&&&&&&&."; ".&&&&&&&&&+&$%&#@&#@@#&#@$&&&&&&&&&."; ".&&&&&&&&@#@@$&*@&@#@#$#*#$&&&&&&&&."; ".&&&&&&&&&&&&&&&&&&&&&$%&%$&&&&&&&&."; ".&&&&&&&&&&$#@@$&&&&&&&&&&&&&&&&&&&."; ".&&&&&&&&&&&+&$%&$$@&$@&&$@&&&&&&&&."; ".&&&&&&&&&&&+&&#@%#+@#@*$%$+$&&&&&&."; ".&&&&&&&&&&&+&&#@#@&&@*#$%$+&&&&&&&."; ".&&&&&&&&&&&+&$+&*@&#@@#&#@$&&&&&&&."; ".&&&&&&&&&&$%@@&&*@&@#@#$#*#&&&&&&&."; ".&&&&&&&&&&&&&&&&&&&&&&&$%&%$&&&&&&."; ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."; ".&&&&&&&&&&&&&&$#@@$&&&&&&&&&&&&&&&."; ".&&&&&&&&&&&&&&&+&$%&$$@&$@&&$@&&&&."; ".&&&&&&&&&&&&&&&+&&#@%#+@#@*$%$+$&&."; ".&&&&&&&&&&&&&&&+&&#@#@&&@*#$%$+&&&."; ".&&&&&&&&&&&&&&&+&$+&*@&#@@#&#@$&&&."; ".&&&&&&&&&&&&&&$%@@&&*@&@#@#$#*#&&&."; ".&&&&&&&&&&&&&&&&&&&&&&&&&&&$%&%$&&."; ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."; ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."; ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&."; "...................................." |] let trashcan_closed_xpm = [| "64 80 17 1"; " c None"; ". c #030304"; "+ c #5A5A5C"; "@ c #323231"; "# c #888888"; "$ c #1E1E1F"; "% c #767677"; "& c #494949"; "* c #9E9E9C"; "= c #111111"; "- c #3C3C3D"; "; c #6B6B6B"; "> c #949494"; ", c #282828"; "' c #808080"; ") c #545454"; "! c #AEAEAC"; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " "; " ==......=$$...=== "; " ..$------)+++++++++++++@$$... "; " ..=@@-------&+++++++++++++++++++-.... "; " =.$$@@@-&&)++++)-,$$$$=@@&+++++++++++++,..$ "; " .$$$$@@&+++++++&$$$@@@@-&,$,-++++++++++;;;&.. "; " $$$$,@--&++++++&$$)++++++++-,$&++++++;%%'%%;;$@ "; " .-@@-@-&++++++++-@++++++++++++,-++++++;''%;;;%*-$ "; " +------++++++++++++++++++++++++++++++;;%%%;;##*!. "; " =+----+++++++++++++++++++++++;;;;;;;;;;;;%'>>). "; " .=)&+++++++++++++++++;;;;;;;;;;;;;;%''>>#>#@. "; " =..=&++++++++++++;;;;;;;;;;;;;%###>>###+%== "; " .&....=-+++++%;;####''''''''''##'%%%)..#. "; " .+-++@....=,+%#####'%%%%%%%%%;@$-@-@*++!. "; " .+-++-+++-&-@$$=$=......$,,,@;&)+!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " =+-++-+++-+++++++++!++++!++++!+++!++!+++= "; " $.++-+++-+++++++++!++++!++++!+++!++!+.$ "; " =.++++++++++++++!++++!++++!+++!++.= "; " $..+++++++++++++++!++++++...$ "; " $$=.............=$$ "; " "; " "; " "; " "; " "; " "; " "; " "; " " |] let trashcan_open_xpm = [| "64 80 17 1"; " c None"; ". c #030304"; "+ c #5A5A5C"; "@ c #323231"; "# c #888888"; "$ c #1E1E1F"; "% c #767677"; "& c #494949"; "* c #9E9E9C"; "= c #111111"; "- c #3C3C3D"; "; c #6B6B6B"; "> c #949494"; ", c #282828"; "' c #808080"; ") c #545454"; "! c #AEAEAC"; " "; " "; " "; " "; " "; " "; " .=.==.,@ "; " ==.,@-&&&)-= "; " .$@,&++;;;%>*- "; " $,-+)+++%%;;'#+. "; " =---+++++;%%%;%##@. "; " @)++++++++;%%%%'#%$ "; " $&++++++++++;%%;%##@= "; " ,-++++)+++++++;;;'#%) "; " @+++&&--&)++++;;%'#'-. "; " ,&++-@@,,,,-)++;;;'>'+, "; " =-++&@$@&&&&-&+;;;%##%+@ "; " =,)+)-,@@&+++++;;;;%##%&@ "; " @--&&,,@&)++++++;;;;'#)@ "; " ---&)-,@)+++++++;;;%''+, "; " $--&)+&$-+++++++;;;%%'';- "; " .,-&+++-$&++++++;;;%''%&= "; " $,-&)++)-@++++++;;%''%), "; " =,@&)++++&&+++++;%'''+$@&++++++ "; " .$@-++++++++++++;'#';,........=$@&++++ "; " =$@@&)+++++++++++'##-.................=&++ "; " .$$@-&)+++++++++;%#+$.....................=)+ "; " $$,@-)+++++++++;%;@=........................,+ "; " .$$@@-++++++++)-)@=............................ "; " $,@---)++++&)@===............................,. "; " $-@---&)))-$$=..............................=)!. "; " --&-&&,,$=,==...........................=&+++!. "; " =,=$..=$+)+++++&@$=.............=$@&+++++!++!. "; " .)-++-+++++++++++++++++++++++++++!++!++!. "; " .+-++-+++++++++++++++++++++++!+++!++!++!. "; " .+-++-+++-+++++++++!+++!!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " .+-++-+++-+++++++++!++++!++++!+++!++!++!. "; " =+-++-+++-+++++++++!++++!++++!+++!++!+++= "; " $.++-+++-+++++++++!++++!++++!+++!++!+.$ "; " =.++++++++++++++!++++!++++!+++!++.= "; " $..+++++++++++++++!++++++...$ "; " $$==...........==$$ "; " "; " "; " "; " "; " "; " "; " "; " "; " " |] let window = GWindow.window ~title:"DnD Test" () let _ = window#misc#realize () let drag_icon = GDraw.pixmap_from_xpm_d ~data:drag_icon_xpm ~window () let trashcan_open = GDraw.pixmap_from_xpm_d ~data:trashcan_open_xpm ~window () let trashcan_closed = GDraw.pixmap_from_xpm_d ~data:trashcan_closed_xpm ~window () let targets = [ { target = "STRING"; flags = []; info = 0}; { target = "text/plain"; flags = []; info = 0}; { target = "text/uri-list"; flags = []; info = 2}; { target = "application/x-rootwin-drop"; flags = []; info = 1} ] class drag_handler = object method private beginning (_ : drag_context) = () method private data_delete (_ : drag_context) = () method private data_get (_ : drag_context) (_ : selection_data) ~info:(_ : int) ~time:(_ : int) = () method private data_received (_ : drag_context) ~x:(_ : int) ~y:(_ : int) (_ : selection_data) ~info:(_ : int) ~time:(_ : int) = () method private drop (_ : drag_context) ~x:(_ : int) ~y:(_ : int) ~time:(_ : int) = false method private ending (_ : drag_context) = () method private leave (_ : drag_context) ~time:(_ : int) = () method private motion (_ : drag_context) ~x:(_ : int) ~y:(_ : int) ~time:(_ : int) = false end class target_drag ?packing ?show () = let pixmap = GMisc.pixmap trashcan_closed ?packing ?show () in object (self) inherit widget pixmap#as_widget inherit drag_handler val mutable have_drag = false method leave _ ~time = print_endline "leave"; flush stdout; have_drag <- false; pixmap#set_pixmap trashcan_closed method motion context ~x ~y ~time = if not have_drag then begin have_drag <- true; pixmap#set_pixmap trashcan_open end; let source_typename = try context#source_widget#misc#get_type with Gpointer.Null -> "unknown" in Printf.printf "motion, source %s\n" source_typename; flush stdout; context#status [context#suggested_action] ~time; true method drop context ~x ~y ~time = prerr_endline "drop"; flush stdout; have_drag <- false; pixmap#set_pixmap trashcan_closed; match context#targets with | [] -> false | d :: _ -> pixmap#drag#get_data d ~context ~time; true method data_received context ~x ~y data ~info ~time = if data#format = 8 then begin Printf.printf "Received \"%s\" in trashcan\n" data#data; flush stdout; context#finish ~success:true ~del:false ~time end else context#finish ~success:false ~del:false ~time initializer pixmap#drag#dest_set targets ~actions:[`COPY;`MOVE]; pixmap#drag#connect#leave ~callback:self#leave; pixmap#drag#connect#motion ~callback:self#motion; pixmap#drag#connect#drop ~callback:self#drop; pixmap#drag#connect#data_received ~callback:self#data_received; () end class label_drag ?packing ?show () = let label = GMisc.label ~text:"Drop Here\n" ?packing ?show () in object (self) inherit widget label#as_widget inherit drag_handler method data_received context ~x ~y data ~info ~time = if data#format = 8 then begin Printf.printf "Received \"%s\" in label\n" data#data; flush stdout; context#finish ~success:true ~del:false ~time end else context#finish ~success:false ~del:false ~time initializer label#drag#dest_set targets ~actions:[`COPY; `MOVE ]; label#drag#connect#data_received ~callback:self#data_received; () end class source_drag ?packing ?show () = let button = GButton.button ~label:"Drag Here\n" ?packing ?show () in object (self) inherit widget button#as_widget inherit drag_handler method data_get _ data ~info ~time = if info = 1 then begin print_endline "I was dropped on the rootwin"; flush stdout end else if info = 2 then data#set ~typ:data#target ~format:8 ~data:"file:///home/otaylor/images/weave.png" else data#set ~typ:data#target ~format:8 ~data:"I'm Data!" method data_delete _ = print_endline "Delete the data!"; flush stdout initializer button#drag#source_set targets ~modi:[`BUTTON1; `BUTTON3 ] ~actions:[`COPY; `MOVE ]; button#drag#source_set_icon drag_icon; button#drag#connect#data_get ~callback:self#data_get; button#drag#connect#data_delete ~callback:self#data_delete; () end class popup () = object (self) inherit drag_handler val mutable popup_window = (None : GWindow.window option) val mutable popped_up = false val mutable in_popup = false val mutable popdown_timer = None val mutable popup_timer = None method timer = popup_timer method remove_timer () = may popup_timer ~f:(fun pdt -> Timeout.remove pdt; popup_timer <- None) method add_timer time ~callback = popup_timer <- Some (Timeout.add ~ms:time ~callback) method popdown () = popdown_timer <- None; may popup_window ~f:(fun w -> w#misc#hide ()); popped_up <- false; false method motion (_ : drag_context) ~x ~y ~time = if not in_popup then begin in_popup <- true; may popdown_timer ~f: begin fun pdt -> print_endline "removed popdown"; flush stdout; Timeout.remove pdt; popdown_timer <- None end end; true method leave (_ : drag_context) ~time = if in_popup then begin in_popup <- false; if popdown_timer = None then begin print_endline "added popdown"; flush stdout; popdown_timer <- Some (Timeout.add ~ms:500 ~callback:self#popdown) end end method popup () = if not popped_up then begin if popup_window = None then begin let w = GWindow.window ~kind:`POPUP ~position:`MOUSE () in popup_window <- Some w; let table = GPack.table ~rows:3 ~columns:3 ~packing:w#add () in for i = 0 to 2 do for j = 0 to 2 do let button = GButton.button ~label:(string_of_int i ^ "," ^ string_of_int j) ~packing:(table#attach ~left:i ~top:j ~expand:`BOTH) () in button#drag#dest_set targets ~actions:[`COPY; `MOVE ]; button#drag#connect#motion ~callback:self#motion; button#drag#connect#leave ~callback:self#leave; done done end; may popup_window ~f:(fun w -> w#show ()); popped_up <- true end; popdown_timer <- Some (Timeout.add ~ms:500 ~callback:self#popdown); print_endline "added popdown"; flush stdout; self#remove_timer (); false end class popsite ?packing ?show () = let label = GMisc.label ~text:"Popup\n" ?packing ?show () and popup = new popup () in object (self) inherit widget label#as_widget inherit drag_handler method motion _ ~x ~y ~time = if popup#timer = None then begin print_endline "added popdown"; flush stdout; popup#add_timer 500 ~callback:popup#popup end; true method leave _ ~time = popup#remove_timer () initializer label#drag#dest_set targets ~actions:[`COPY; `MOVE ]; label#drag#connect#motion ~callback:self#motion; label#drag#connect#leave ~callback:self#leave; () end let main () = window#connect#destroy ~callback: Main.quit; let table = GPack.table ~rows:2 ~columns:2 ~packing:window#add () in let attach = table#attach ~expand:`BOTH in new label_drag ~packing:(attach ~left:0 ~top:0) (); new target_drag ~packing:(attach ~left:1 ~top:0) (); new source_drag ~packing:(attach ~left:0 ~top:1) (); new popsite ~packing:(attach ~left:1 ~top:1) (); window#show (); Main.main () let _ = main ()