1 (* this is a translation in Caml of the gtk+ example testdnd.c *)
9 (* GtkThread.start() *)
11 let drag_icon_xpm = [|
22 " .....................";
23 " ..&&&&&&&&&&&&&&&&&&&.";
24 " ...&&&&&&&&&&&&&&&&&&&.";
25 " ..&.&&&&&&&&&&&&&&&&&&&.";
26 " ..&&.&&&&&&&&&&&&&&&&&&&.";
27 " ..&&&.&&&&&&&&&&&&&&&&&&&.";
28 " ..&&&&.&&&&&&&&&&&&&&&&&&&.";
29 " ..&&&&&.&&&@&&&&&&&&&&&&&&&.";
30 " ..&&&&&&.*$%$+$&&&&&&&&&&&&&.";
31 " ..&&&&&&&.%$%$+&&&&&&&&&&&&&&.";
32 " ..&&&&&&&&.#&#@$&&&&&&&&&&&&&&.";
33 " ..&&&&&&&&&.#$**#$&&&&&&&&&&&&&.";
34 " ..&&&&&&&&&&.&@%&%$&&&&&&&&&&&&&.";
35 " ..&&&&&&&&&&&.&&&&&&&&&&&&&&&&&&&.";
36 " ..&&&&&&&&&&&&.&&&&&&&&&&&&&&&&&&&.";
37 "................&$@&&&@&&&&&&&&&&&&.";
38 ".&&&&&&&+&&#@%#+@#@*$%$+$&&&&&&&&&&.";
39 ".&&&&&&&+&&#@#@&&@*%$%$+&&&&&&&&&&&.";
40 ".&&&&&&&+&$%&#@&#@@#&#@$&&&&&&&&&&&.";
41 ".&&&&&&@#@@$&*@&@#@#$**#$&&&&&&&&&&.";
42 ".&&&&&&&&&&&&&&&&&&&@%&%$&&&&&&&&&&.";
43 ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&.";
44 ".&&&&&&&&$#@@$&&&&&&&&&&&&&&&&&&&&&.";
45 ".&&&&&&&&&+&$+&$&@&$@&&$@&&&&&&&&&&.";
46 ".&&&&&&&&&+&&#@%#+@#@*$%&+$&&&&&&&&.";
47 ".&&&&&&&&&+&&#@#@&&@*%$%$+&&&&&&&&&.";
48 ".&&&&&&&&&+&$%&#@&#@@#&#@$&&&&&&&&&.";
49 ".&&&&&&&&@#@@$&*@&@#@#$#*#$&&&&&&&&.";
50 ".&&&&&&&&&&&&&&&&&&&&&$%&%$&&&&&&&&.";
51 ".&&&&&&&&&&$#@@$&&&&&&&&&&&&&&&&&&&.";
52 ".&&&&&&&&&&&+&$%&$$@&$@&&$@&&&&&&&&.";
53 ".&&&&&&&&&&&+&&#@%#+@#@*$%$+$&&&&&&.";
54 ".&&&&&&&&&&&+&&#@#@&&@*#$%$+&&&&&&&.";
55 ".&&&&&&&&&&&+&$+&*@&#@@#&#@$&&&&&&&.";
56 ".&&&&&&&&&&$%@@&&*@&@#@#$#*#&&&&&&&.";
57 ".&&&&&&&&&&&&&&&&&&&&&&&$%&%$&&&&&&.";
58 ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&.";
59 ".&&&&&&&&&&&&&&$#@@$&&&&&&&&&&&&&&&.";
60 ".&&&&&&&&&&&&&&&+&$%&$$@&$@&&$@&&&&.";
61 ".&&&&&&&&&&&&&&&+&&#@%#+@#@*$%$+$&&.";
62 ".&&&&&&&&&&&&&&&+&&#@#@&&@*#$%$+&&&.";
63 ".&&&&&&&&&&&&&&&+&$+&*@&#@@#&#@$&&&.";
64 ".&&&&&&&&&&&&&&$%@@&&*@&@#@#$#*#&&&.";
65 ".&&&&&&&&&&&&&&&&&&&&&&&&&&&$%&%$&&.";
66 ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&.";
67 ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&.";
68 ".&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&.";
69 "...................................." |]
73 let trashcan_closed_xpm = [|
114 " ==......=$$...=== ";
115 " ..$------)+++++++++++++@$$... ";
116 " ..=@@-------&+++++++++++++++++++-.... ";
117 " =.$$@@@-&&)++++)-,$$$$=@@&+++++++++++++,..$ ";
118 " .$$$$@@&+++++++&$$$@@@@-&,$,-++++++++++;;;&.. ";
119 " $$$$,@--&++++++&$$)++++++++-,$&++++++;%%'%%;;$@ ";
120 " .-@@-@-&++++++++-@++++++++++++,-++++++;''%;;;%*-$ ";
121 " +------++++++++++++++++++++++++++++++;;%%%;;##*!. ";
122 " =+----+++++++++++++++++++++++;;;;;;;;;;;;%'>>). ";
123 " .=)&+++++++++++++++++;;;;;;;;;;;;;;%''>>#>#@. ";
124 " =..=&++++++++++++;;;;;;;;;;;;;%###>>###+%== ";
125 " .&....=-+++++%;;####''''''''''##'%%%)..#. ";
126 " .+-++@....=,+%#####'%%%%%%%%%;@$-@-@*++!. ";
127 " .+-++-+++-&-@$$=$=......$,,,@;&)+!++!++!. ";
128 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
129 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
130 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
131 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
132 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
133 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
134 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
135 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
136 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
137 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
138 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
139 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
140 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
141 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
142 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
143 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
144 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
145 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
146 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
147 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
148 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
149 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
150 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
151 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
152 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
153 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
154 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
155 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
156 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
157 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
158 " =+-++-+++-+++++++++!++++!++++!+++!++!+++= ";
159 " $.++-+++-+++++++++!++++!++++!+++!++!+.$ ";
160 " =.++++++++++++++!++++!++++!+++!++.= ";
161 " $..+++++++++++++++!++++++...$ ";
162 " $$=.............=$$ ";
173 let trashcan_open_xpm = [|
201 " $,-+)+++%%;;'#+. ";
202 " =---+++++;%%%;%##@. ";
203 " @)++++++++;%%%%'#%$ ";
204 " $&++++++++++;%%;%##@= ";
205 " ,-++++)+++++++;;;'#%) ";
206 " @+++&&--&)++++;;%'#'-. ";
207 " ,&++-@@,,,,-)++;;;'>'+, ";
208 " =-++&@$@&&&&-&+;;;%##%+@ ";
209 " =,)+)-,@@&+++++;;;;%##%&@ ";
210 " @--&&,,@&)++++++;;;;'#)@ ";
211 " ---&)-,@)+++++++;;;%''+, ";
212 " $--&)+&$-+++++++;;;%%'';- ";
213 " .,-&+++-$&++++++;;;%''%&= ";
214 " $,-&)++)-@++++++;;%''%), ";
215 " =,@&)++++&&+++++;%'''+$@&++++++ ";
216 " .$@-++++++++++++;'#';,........=$@&++++ ";
217 " =$@@&)+++++++++++'##-.................=&++ ";
218 " .$$@-&)+++++++++;%#+$.....................=)+ ";
219 " $$,@-)+++++++++;%;@=........................,+ ";
220 " .$$@@-++++++++)-)@=............................ ";
221 " $,@---)++++&)@===............................,. ";
222 " $-@---&)))-$$=..............................=)!. ";
223 " --&-&&,,$=,==...........................=&+++!. ";
224 " =,=$..=$+)+++++&@$=.............=$@&+++++!++!. ";
225 " .)-++-+++++++++++++++++++++++++++!++!++!. ";
226 " .+-++-+++++++++++++++++++++++!+++!++!++!. ";
227 " .+-++-+++-+++++++++!+++!!++++!+++!++!++!. ";
228 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
229 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
230 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
231 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
232 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
233 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
234 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
235 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
236 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
237 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
238 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
239 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
240 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
241 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
242 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
243 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
244 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
245 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
246 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
247 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
248 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
249 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
250 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
251 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
252 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
253 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
254 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
255 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
256 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
257 " .+-++-+++-+++++++++!++++!++++!+++!++!++!. ";
258 " =+-++-+++-+++++++++!++++!++++!+++!++!+++= ";
259 " $.++-+++-+++++++++!++++!++++!+++!++!+.$ ";
260 " =.++++++++++++++!++++!++++!+++!++.= ";
261 " $..+++++++++++++++!++++++...$ ";
262 " $$==...........==$$ ";
273 let window = GWindow.window ~title:"DnD Test" ()
274 let _ = window#misc#realize ()
277 GDraw.pixmap_from_xpm_d ~data:drag_icon_xpm ~window ()
280 GDraw.pixmap_from_xpm_d ~data:trashcan_open_xpm ~window ()
282 let trashcan_closed =
283 GDraw.pixmap_from_xpm_d ~data:trashcan_closed_xpm ~window ()
286 { target = "STRING"; flags = []; info = 0};
287 { target = "text/plain"; flags = []; info = 0};
288 { target = "text/uri-list"; flags = []; info = 2};
289 { target = "application/x-rootwin-drop"; flags = []; info = 1}
292 class drag_handler = object
293 method private beginning (_ : drag_context) = ()
294 method private data_delete (_ : drag_context) = ()
295 method private data_get (_ : drag_context) (_ : selection_data)
296 ~info:(_ : int) ~time:(_ : int) = ()
297 method private data_received (_ : drag_context) ~x:(_ : int) ~y:(_ : int)
298 (_ : selection_data) ~info:(_ : int) ~time:(_ : int) = ()
299 method private drop (_ : drag_context) ~x:(_ : int) ~y:(_ : int)
300 ~time:(_ : int) = false
301 method private ending (_ : drag_context) = ()
302 method private leave (_ : drag_context) ~time:(_ : int) = ()
303 method private motion (_ : drag_context) ~x:(_ : int) ~y:(_ : int)
304 ~time:(_ : int) = false
308 class target_drag ?packing ?show () =
309 let pixmap = GMisc.pixmap trashcan_closed ?packing ?show () in
311 inherit widget pixmap#as_widget
313 val mutable have_drag = false
315 method leave _ ~time =
316 print_endline "leave"; flush stdout;
318 pixmap#set_pixmap trashcan_closed
320 method motion context ~x ~y ~time =
321 if not have_drag then begin
323 pixmap#set_pixmap trashcan_open
325 let source_typename =
327 context#source_widget#misc#get_type
328 with Gpointer.Null -> "unknown"
330 Printf.printf "motion, source %s\n" source_typename; flush stdout;
331 context#status [context#suggested_action] ~time;
334 method drop context ~x ~y ~time =
335 prerr_endline "drop"; flush stdout;
337 pixmap#set_pixmap trashcan_closed;
338 match context#targets with
340 | d :: _ -> pixmap#drag#get_data d ~context ~time; true
342 method data_received context ~x ~y data ~info ~time =
343 if data#format = 8 then begin
344 Printf.printf "Received \"%s\" in trashcan\n" data#data;
346 context#finish ~success:true ~del:false ~time
348 else context#finish ~success:false ~del:false ~time
351 pixmap#drag#dest_set targets ~actions:[`COPY;`MOVE];
352 pixmap#drag#connect#leave ~callback:self#leave;
353 pixmap#drag#connect#motion ~callback:self#motion;
354 pixmap#drag#connect#drop ~callback:self#drop;
355 pixmap#drag#connect#data_received ~callback:self#data_received;
359 class label_drag ?packing ?show () =
360 let label = GMisc.label ~text:"Drop Here\n" ?packing ?show () in
362 inherit widget label#as_widget
364 method data_received context ~x ~y data ~info ~time =
365 if data#format = 8 then begin
366 Printf.printf "Received \"%s\" in label\n" data#data;
368 context#finish ~success:true ~del:false ~time
370 else context#finish ~success:false ~del:false ~time
373 label#drag#dest_set targets ~actions:[`COPY; `MOVE ];
374 label#drag#connect#data_received ~callback:self#data_received;
378 class source_drag ?packing ?show () =
379 let button = GButton.button ~label:"Drag Here\n" ?packing ?show () in
381 inherit widget button#as_widget
383 method data_get _ data ~info ~time =
384 if info = 1 then begin
385 print_endline "I was dropped on the rootwin"; flush stdout
387 else if info = 2 then
388 data#set ~typ:data#target ~format:8
389 ~data:"file:///home/otaylor/images/weave.png"
391 data#set ~typ:data#target ~format:8 ~data:"I'm Data!"
393 method data_delete _ =
394 print_endline "Delete the data!"; flush stdout
397 button#drag#source_set targets
398 ~modi:[`BUTTON1; `BUTTON3 ] ~actions:[`COPY; `MOVE ];
399 button#drag#source_set_icon drag_icon;
400 button#drag#connect#data_get ~callback:self#data_get;
401 button#drag#connect#data_delete ~callback:self#data_delete;
405 class popup () = object (self)
407 val mutable popup_window = (None : GWindow.window option)
408 val mutable popped_up = false
409 val mutable in_popup = false
410 val mutable popdown_timer = None
411 val mutable popup_timer = None
413 method timer = popup_timer
414 method remove_timer () =
416 ~f:(fun pdt -> Timeout.remove pdt; popup_timer <- None)
417 method add_timer time ~callback =
418 popup_timer <- Some (Timeout.add ~ms:time ~callback)
421 popdown_timer <- None;
422 may popup_window ~f:(fun w -> w#misc#hide ());
426 method motion (_ : drag_context) ~x ~y ~time =
427 if not in_popup then begin
429 may popdown_timer ~f:
431 print_endline "removed popdown"; flush stdout;
433 popdown_timer <- None
438 method leave (_ : drag_context) ~time =
439 if in_popup then begin
441 if popdown_timer = None then begin
442 print_endline "added popdown"; flush stdout;
443 popdown_timer <- Some (Timeout.add ~ms:500 ~callback:self#popdown)
448 if not popped_up then begin
449 if popup_window = None then begin
450 let w = GWindow.window ~kind:`POPUP ~position:`MOUSE () in
451 popup_window <- Some w;
452 let table = GPack.table ~rows:3 ~columns:3 ~packing:w#add () in
456 GButton.button ~label:(string_of_int i ^ "," ^ string_of_int j)
457 ~packing:(table#attach ~left:i ~top:j ~expand:`BOTH) ()
459 button#drag#dest_set targets ~actions:[`COPY; `MOVE ];
460 button#drag#connect#motion ~callback:self#motion;
461 button#drag#connect#leave ~callback:self#leave;
465 may popup_window ~f:(fun w -> w#show ());
468 popdown_timer <- Some (Timeout.add ~ms:500 ~callback:self#popdown);
469 print_endline "added popdown"; flush stdout;
470 self#remove_timer ();
474 class popsite ?packing ?show () =
475 let label = GMisc.label ~text:"Popup\n" ?packing ?show ()
476 and popup = new popup () in
478 inherit widget label#as_widget
480 method motion _ ~x ~y ~time =
481 if popup#timer = None then begin
482 print_endline "added popdown"; flush stdout;
483 popup#add_timer 500 ~callback:popup#popup
487 method leave _ ~time =
488 popup#remove_timer ()
491 label#drag#dest_set targets ~actions:[`COPY; `MOVE ];
492 label#drag#connect#motion ~callback:self#motion;
493 label#drag#connect#leave ~callback:self#leave;
498 window#connect#destroy ~callback: Main.quit;
499 let table = GPack.table ~rows:2 ~columns:2 ~packing:window#add () in
500 let attach = table#attach ~expand:`BOTH in
501 new label_drag ~packing:(attach ~left:0 ~top:0) ();
502 new target_drag ~packing:(attach ~left:1 ~top:0) ();
503 new source_drag ~packing:(attach ~left:0 ~top:1) ();
504 new popsite ~packing:(attach ~left:1 ~top:1) ();