summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Changelog7
-rw-r--r--demos/basic.tcl41
-rw-r--r--library/tkdnd_unix.tcl254
-rw-r--r--unix/TkDND_XDND.c120
-rw-r--r--unix/tkUnixSelect.c51
5 files changed, 415 insertions, 58 deletions
diff --git a/Changelog b/Changelog
index 9c9d6c7..fe13114 100644
--- a/Changelog
+++ b/Changelog
@@ -1,3 +1,10 @@
+2012-06-07 Petasis George <petasis@iit.demokritos.gr>
+ * demos/basic.tcl: Updated demo with support for colours, which only
+ works for XDND right now.
+
+ * unix/TkDND_XDND.c:
+ * unix/tkUnixSelect.c: Implementation of unix (XDND) drags completed.
+
2012-06-06 Petasis George <petasis@iit.demokritos.gr>
* unix/Cursors.c: Ported cursors from TkDND 1.x to TkDND 2.x
diff --git a/demos/basic.tcl b/demos/basic.tcl
index af74d72..6b852c4 100644
--- a/demos/basic.tcl
+++ b/demos/basic.tcl
@@ -39,7 +39,8 @@ foreach colour {red green blue navy} {
pack [label .colours.$colour -text $colour -fg white -bg $colour] \
-side left -padx 2
tkdnd::drag_source register .colours.$colour
- bind .colours.$colour <<DragInitCmd>> "list copy TK_COLOUR $colour"
+ bind .colours.$colour <<DragInitCmd>> \
+ "list copy DND_Color $colour"
}
grid .colours -sticky snew -columnspan 2
@@ -50,8 +51,15 @@ grid [label .drop_target -text {Drop Target:} -bg yellow] \
# Register .drop_target as a drop target of every type!
tkdnd::drop_target register .drop_target *
-# Add the various events...
+# During drag and drop, the drop target receives information through 3
+# virtual events: <<DropEnter>> <<DropPosition>> <<DropLeave>>
+# The fields that can be used in the event callbacks, are given in "cmd",
+# while their "label" is given in "itemList"...
set cmd {handle_event %e %W %X %Y %ST %TT %a %A %CST %CTT %t %T %b %D}
+set itemList {Event Widget X Y Source_Types Target_Types Source_Actions Action
+ Common_Source_Types Common_Target_Types Types Drop_Type
+ Pressed_Keys Data}
+# Add the various events...
bind .drop_target <<DropEnter>> $cmd
bind .drop_target <<DropPosition>> $cmd
bind .drop_target <<DropLeave>> $cmd
@@ -63,10 +71,10 @@ bind .drop_target <<Drop>> $cmd
# Add a specialised <<Drop>> event, when will be called if a file is dropped.
bind .drop_target <<Drop:DND_Files>> $cmd
+# Add a special drop command for DND_Color...
+bind .drop_target <<Drop:DND_Color>> $cmd
+
# Create some widgets for showing event info.
-set itemList {Event Widget X Y Source_Types Target_Types Source_Actions Action
- Common_Source_Types Common_Target_Types Types Drop_Type
- Pressed_Keys Data}
foreach item $itemList {
grid [label .[string tolower $item] -text [string map {_ \ } $item]:\
-anchor w] [label .[string tolower $item]_val -width 30 -anchor w \
@@ -81,11 +89,26 @@ proc handle_event $itemList {
.[string tolower $item]_val configure -text [set $item]
}
switch -glob $Event {
- <<DropEnter>> {$Widget configure -bg green}
- <<DropLeave>> {$Widget configure -bg yellow}
+ <<DropEnter>> {$Widget configure -bg green}
+ <<DropLeave>> {$Widget configure -bg yellow}
+ <<Drop:DND_Color>> {
+ $Widget configure -bg yellow
+ .drop_target_value configure -text $Data
+ ## Convert data into a Tk color: the colour data is a list of 4 elements
+ ## (red green blue opacity), expressed as Hex numbers...
+ set color "#"
+ for {set i 0} {$i < 3} {incr i} {
+ ## Just remove the 0x prefix...
+ append color [string range [lindex $Data $i] 2 end]
+ }
+ .drop_target_value configure -background $color -foreground white
+ }
<<Drop>> -
- <<Drop:*>> {$Widget configure -bg yellow
- .drop_target_value configure -text $Data}
+ <<Drop:*>> {
+ $Widget configure -bg yellow
+ .drop_target_value configure -text $Data \
+ -background [. cget -background] -foreground black
+ }
}
return copy
};# handle_event
diff --git a/library/tkdnd_unix.tcl b/library/tkdnd_unix.tcl
index 58ce39a..fbaef3d 100644
--- a/library/tkdnd_unix.tcl
+++ b/library/tkdnd_unix.tcl
@@ -327,6 +327,7 @@ proc xdnd::_GetDroppedData { time } {
} else {
set _use_tk_selection 1
}
+ #set _use_tk_selection 1
foreach type $_common_drag_source_types {
# puts "TYPE: $type ($_drop_target)"
# _get_selection $_drop_target $time $type
@@ -400,25 +401,28 @@ proc xdnd::_normalise_data { type data } {
# STRING, TEXT, COMPOUND_TEXT
# UTF8_STRING
# Else, it returns a list of 8 or 32 bit numbers...
- switch $type {
+ switch -glob $type {
STRING - UTF8_STRING - TEXT - COMPOUND_TEXT {return $data}
text/html -
text/plain {
- if {[catch {tkdnd::bytes_to_string $data} string]} {
+ if {[catch {
+ encoding convertfrom utf-8 [tkdnd::bytes_to_string $data]
+ } string]} {
set string $data
}
- return [string map {\r\n \n} \
- [encoding convertfrom utf-8 $string]]
+ return [string map {\r\n \n} $string
}
- text/uri-list {
- if {[catch {tkdnd::bytes_to_string $data} string]} {
+ text/uri-list* {
+ if {[catch {
+ encoding convertfrom utf-8 [tkdnd::bytes_to_string $data
+ } string]} {
set string $data
}
## Get rid of \r\n
set string [string trim [string map {\r\n \n} $string]]
set files {}
foreach quoted_file [split $string] {
- set file [encoding convertfrom utf-8 [tkdnd::urn_unquote $quoted_file]]
+ set file [tkdnd::urn_unquote $quoted_file]
switch -glob $file {
file://* {lappend files [string range $file 7 end]}
ftp://* -
@@ -429,6 +433,9 @@ proc xdnd::_normalise_data { type data } {
}
return $files
}
+ application/x-color {
+ return $data
+ }
text/x-moz-url -
application/q-iconlist -
default {return $data}
@@ -441,8 +448,9 @@ proc xdnd::_normalise_data { type data } {
proc xdnd::_platform_specific_type { type } {
switch $type {
DND_Text {return [list text/plain\;charset=utf-8 UTF8_STRING \
- text/plain STRING]}
+ text/plain STRING TEXT COMPOUND_TEXT]}
DND_Files {return [list text/uri-list]}
+ DND_Color {return [list application/x-color]}
default {return [list $type]}
}
}; # xdnd::_platform_specific_type
@@ -451,12 +459,15 @@ proc xdnd::_platform_specific_type { type } {
# Command xdnd::_platform_independent_type
# ----------------------------------------------------------------------------
proc xdnd::_platform_independent_type { type } {
- switch $type {
- UTF8_STRING -
- STRING -
- text/plain {return DND_Text}
- text/uri-list {return DND_Files}
- default {return [list $type]}
+ switch -glob $type {
+ UTF8_STRING -
+ STRING -
+ TEXT -
+ COMPOUND_TEXT -
+ text/plain* {return DND_Text}
+ text/uri-list* {return DND_Files}
+ application/x-color {return DND_Color}
+ default {return [list $type]}
}
}; # xdnd::_platform_independent_type
@@ -464,9 +475,11 @@ proc xdnd::_platform_independent_type { type } {
# Command xdnd::_supported_type
# ----------------------------------------------------------------------------
proc xdnd::_supported_type { type } {
- switch $type {
- {text/plain;charset=UTF-8} - text/plain -
- text/uri-list {return 1}
+ switch -glob [string tolower $type] {
+ {text/plain;charset=utf-8} - text/plain -
+ utf8_string - string - text - compound_text -
+ text/uri-list* -
+ application/x-color {return 1}
}
return 0
}; # xdnd::_supported_type
@@ -491,8 +504,8 @@ proc xdnd::_selection_ownership_lost {} {
proc xdnd::_dodragdrop { source actions types data button } {
variable _dragging
- puts "xdnd::_dodragdrop: source: $source, actions: $actions, types: $types,\
- data: \"$data\", button: $button"
+ # puts "xdnd::_dodragdrop: source: $source, actions: $actions, types: $types,\
+ # data: \"$data\", button: $button"
if {$_dragging} {
## We are in the middle of another drag operation...
error "another drag operation in progress"
@@ -507,6 +520,7 @@ proc xdnd::_dodragdrop { source actions types data button } {
variable _dodragdrop_types $types
variable _dodragdrop_types_len [llength $types]
variable _dodragdrop_data $data
+ variable _dodragdrop_transfer_data {}
variable _dodragdrop_button $button
variable _dodragdrop_time 0
variable _dodragdrop_default_action refuse_drop
@@ -515,6 +529,7 @@ proc xdnd::_dodragdrop { source actions types data button } {
variable _dodragdrop_drop_target_accepts_action refuse_drop
variable _dodragdrop_current_cursor $_dodragdrop_default_action
variable _dodragdrop_drop_occured 0
+ variable _dodragdrop_selection_requestor 0
##
## If we have more than 3 types, the property XdndTypeList must be set on
@@ -534,10 +549,7 @@ proc xdnd::_dodragdrop { source actions types data button } {
##
## Arrange selection handlers for our drag source, and all the supported types
##
- foreach t $types {
- selection handle -selection XdndSelection -type $t -format UTF8_STRING \
- $source [list ::tkdnd::xdnd::_SendData $t]
- }
+ registerSelectionHandler $source $types
##
## Step 1: When a drag begins, the source takes ownership of XdndSelection.
@@ -565,32 +577,33 @@ proc xdnd::_dodragdrop { source actions types data button } {
_ungrab_pointer $source
_unregister_generic_event_handler
catch {selection clear -selection XdndSelection}
- foreach t $types {
- catch {
- selection handle -selection XdndSelection -type $t -format UTF8_STRING \
- $source {}
- }
- }
+ unregisterSelectionHandler $source $types
};# xdnd::_dodragdrop
# ----------------------------------------------------------------------------
# Command xdnd::_process_drag_events
# ----------------------------------------------------------------------------
proc xdnd::_process_drag_events {event} {
+ # The return value from proc is normally 0. A non-zero return value indicates
+ # that the event is not to be handled further; that is, proc has done all
+ # processing that is to be allowed for the event
variable _dragging
if {!$_dragging} {return 0}
# puts $event
variable _dodragdrop_time
set time [dict get $event time]
- if {$time < $_dodragdrop_time} {return 0}
+ set type [dict get $event type]
+ if {$time < $_dodragdrop_time && ![string equal $type SelectionRequest]} {
+ return 0
+ }
set _dodragdrop_time $time
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_default_action
- switch [dict get $event type] {
+ switch $type {
MotionNotify {
set rootx [dict get $event x_root]
set rooty [dict get $event y_root]
@@ -643,6 +656,19 @@ proc xdnd::_process_drag_events {event} {
}
}
}
+ SelectionRequest {
+ variable _dodragdrop_selection_requestor
+ variable _dodragdrop_selection_property
+ variable _dodragdrop_selection_selection
+ variable _dodragdrop_selection_target
+ variable _dodragdrop_selection_time
+ set _dodragdrop_selection_requestor [dict get $event requestor]
+ set _dodragdrop_selection_property [dict get $event property]
+ set _dodragdrop_selection_selection [dict get $event selection]
+ set _dodragdrop_selection_target [dict get $event target]
+ set _dodragdrop_selection_time $time
+ return 0
+ }
default {
return 0
}
@@ -785,15 +811,6 @@ proc xdnd::_SendXdndDrop {} {
};# xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
-# Command xdnd::_SendData
-# ----------------------------------------------------------------------------
-proc xdnd::_SendData {type s e args} {
- variable _dodragdrop_data
- puts "SendData: $type $s $e $args ($_dodragdrop_data)"
- return [string range $_dodragdrop_data $s $e]
-};# xdnd::_SendData
-
-# ----------------------------------------------------------------------------
# Command xdnd::_update_cursor
# ----------------------------------------------------------------------------
proc xdnd::_update_cursor { {cursor {}}} {
@@ -814,6 +831,7 @@ proc xdnd::_update_cursor { {cursor {}}} {
set _dodragdrop_current_cursor $cursor
}
};# xdnd::_update_cursor
+
# ----------------------------------------------------------------------------
# Command xdnd::_default_action
# ----------------------------------------------------------------------------
@@ -837,3 +855,159 @@ proc xdnd::_default_action {event} {
}
return default
};# xdnd::_default_action
+
+# ----------------------------------------------------------------------------
+# Command xdnd::getFormatForType
+# ----------------------------------------------------------------------------
+proc xdnd::getFormatForType {type} {
+ switch -glob [string tolower $type] {
+ text/plain\;charset=utf-8 -
+ utf8_string {set format UTF8_STRING}
+ text/plain -
+ string -
+ text -
+ compound_text {set format STRING}
+ text/uri-list* {set format UTF8_STRING}
+ application/x-color {set format $type}
+ default {set format $type}
+ }
+ return $format
+};# xdnd::getFormatForType
+
+# ----------------------------------------------------------------------------
+# Command xdnd::registerSelectionHandler
+# ----------------------------------------------------------------------------
+proc xdnd::registerSelectionHandler {source types} {
+ foreach type $types {
+ selection handle -selection XdndSelection \
+ -type $type \
+ -format [getFormatForType $type] \
+ $source [list ::tkdnd::xdnd::_SendData $type]
+ }
+};# xdnd::registerSelectionHandler
+
+# ----------------------------------------------------------------------------
+# Command xdnd::unregisterSelectionHandler
+# ----------------------------------------------------------------------------
+proc xdnd::unregisterSelectionHandler {source types} {
+ foreach type $types {
+ catch {
+ selection handle -selection XdndSelection \
+ -type $type \
+ -format [getFormatForType $type] \
+ $source {}
+ }
+ }
+};# xdnd::unregisterSelectionHandler
+
+# ----------------------------------------------------------------------------
+# Command xdnd::_convert_to_unsigned
+# ----------------------------------------------------------------------------
+proc xdnd::_convert_to_unsigned {data format} {
+ switch $format {
+ 8 { set mask 0xff }
+ 16 { set mask 0xffff }
+ 32 { set mask 0xffffff }
+ default {error "unsupported format $format"}
+ }
+ ## Convert signed integer into unsigned...
+ set d [list]
+ foreach num $data {
+ lappend d [expr { $num & $mask }]
+ }
+ return $d
+};# xdnd::_convert_to_unsigned
+
+# ----------------------------------------------------------------------------
+# Command xdnd::_SendData
+# ----------------------------------------------------------------------------
+proc xdnd::_SendData {type offset bytes args} {
+ variable _dodragdrop_drag_source
+ variable _dodragdrop_data
+ variable _dodragdrop_transfer_data
+ set format 8
+ if {$offset == 0} {
+ ## Prepare the data to be transfered...
+ switch -glob $type {
+ text/plain* - UTF8_STRING - STRING - TEXT - COMPOUND_TEXT {
+ binary scan [encoding convertto utf-8 $_dodragdrop_data] \
+ c* _dodragdrop_transfer_data
+ set _dodragdrop_transfer_data \
+ [_convert_to_unsigned $_dodragdrop_transfer_data $format]
+ }
+ text/uri-list* {
+ set files [list]
+ foreach file $_dodragdrop_data {
+ switch -glob $file {
+ *://* {lappend files $file}
+ default {lappend files file://$file}
+ }
+ }
+ binary scan [encoding convertto utf-8 "[join $files \r\n]\r\n"] \
+ c* _dodragdrop_transfer_data
+ set _dodragdrop_transfer_data \
+ [_convert_to_unsigned $_dodragdrop_transfer_data $format]
+ }
+ application/x-color {
+ set format 16
+ ## Try to understand the provided data: we accept a standard Tk colour,
+ ## or a list of 3 values (red green blue) or a list of 4 values
+ ## (red green blue opacity).
+ switch [llength $_dodragdrop_data] {
+ 1 { set color [winfo rgb $_dodragdrop_drag_source $_dodragdrop_data]
+ lappend color 65535 }
+ 3 { set color $_dodragdrop_data; lappend color 65535 }
+ 4 { set color $_dodragdrop_data }
+ default {error "unknown color data: \"$_dodragdrop_data\""}
+ }
+ ## Convert the 4 elements into 16 bit values...
+ set _dodragdrop_transfer_data [list]
+ foreach c $color {
+ lappend _dodragdrop_transfer_data [format 0x%04X $c]
+ }
+ }
+ default {
+ set format 32
+ binary scan $_dodragdrop_data c* _dodragdrop_transfer_data
+ }
+ }
+ }
+
+ ##
+ ## Data has been split into bytes. Count the bytes requested, and return them
+ ##
+ set data [lrange $_dodragdrop_transfer_data $offset [expr {$offset+$bytes-1}]]
+ switch $format {
+ 8 {
+ set data [encoding convertfrom utf-8 [binary format c* $data]]
+ }
+ 16 {
+ variable _dodragdrop_selection_requestor
+ if {$_dodragdrop_selection_requestor} {
+ ## Tk selection cannot process this format (only 8 & 32 supported).
+ ## Call our XChangeProperty...
+ set numItems [llength $data]
+ variable _dodragdrop_selection_property
+ variable _dodragdrop_selection_selection
+ variable _dodragdrop_selection_target
+ variable _dodragdrop_selection_time
+ XChangeProperty $_dodragdrop_drag_source \
+ $_dodragdrop_selection_requestor \
+ $_dodragdrop_selection_property \
+ $_dodragdrop_selection_target \
+ $format \
+ $_dodragdrop_selection_time \
+ $data $numItems
+ return -code break
+ }
+ }
+ 32 {
+ }
+ default {
+ error "unsupported format $format"
+ }
+ }
+ # puts "SendData: $type $offset $bytes $args ($_dodragdrop_data)"
+ # puts " $data"
+ return $data
+};# xdnd::_SendData
diff --git a/unix/TkDND_XDND.c b/unix/TkDND_XDND.c
index 993a685..d807b66 100644
--- a/unix/TkDND_XDND.c
+++ b/unix/TkDND_XDND.c
@@ -38,6 +38,7 @@
#include "tcl.h"
#include "tk.h"
#include <string.h>
+#include <stdlib.h>
#include <X11/Xlib.h>
#include <X11/X.h>
#include <X11/Xatom.h>
@@ -392,8 +393,8 @@ int TkDND_HandleXdndPosition(Tk_Window tkwin, XEvent *xevent) {
ActionCopy, ActionMove, ActionLink, ActionAsk, ActionPrivate,
refuse_drop, ActionDefault
};
- Time time;
- Atom action;
+/*Time time;
+ Atom action;*/
if (interp == NULL || tkwin == NULL) return False;
@@ -402,9 +403,9 @@ int TkDND_HandleXdndPosition(Tk_Window tkwin, XEvent *xevent) {
rootX = XDND_POSITION_ROOT_X(xevent);
rootY = XDND_POSITION_ROOT_Y(xevent);
/* Get the time from the event... */
- time = XDND_POSITION_TIME(xevent);
+ /* time = XDND_POSITION_TIME(xevent); */
/* Get the user action from the event... */
- action = XDND_POSITION_ACTION(xevent);
+ /* action = XDND_POSITION_ACTION(xevent); */
/* The event may have been delivered to the toplevel wrapper.
* Try to find the toplevel window... */
@@ -1032,7 +1033,21 @@ int TkDND_HandleGenericEvent(ClientData clientData, XEvent *eventPtr) {
TkDND_Dict_Put(dict, "type", "LeaveNotify");
TkDND_Dict_PutLong(dict, "time", eventPtr->xcrossing.time);
break;
- default:
+ case SelectionRequest:
+ main_window = Tk_MainWindow(interp);
+ TkDND_Dict_Put(dict, "type", "SelectionRequest");
+ TkDND_Dict_PutLong(dict, "time", eventPtr->xselectionrequest.time);
+ TkDND_Dict_PutLong(dict, "owner", eventPtr->xselectionrequest.owner);
+ TkDND_Dict_PutLong(dict, "requestor",
+ eventPtr->xselectionrequest.requestor);
+ TkDND_Dict_Put(dict, "selection",
+ Tk_GetAtomName(main_window, eventPtr->xselectionrequest.selection));
+ TkDND_Dict_Put(dict, "target",
+ Tk_GetAtomName(main_window, eventPtr->xselectionrequest.target));
+ TkDND_Dict_Put(dict, "property",
+ Tk_GetAtomName(main_window, eventPtr->xselectionrequest.property));
+ break;
+ default:
Tcl_DecrRefCount(dict);
return 0;
}
@@ -1360,6 +1375,95 @@ int TkDND_SendXdndDropObjCmd(ClientData clientData,
return TCL_OK;
}; /* TkDND_SendXdndDropObjCmd */
+int TkDND_XChangePropertyObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
+ XEvent event;
+ Window target;
+ Atom property = None, type = None;
+ int format, numItems, numFields, i;
+ Display *display;
+ Tk_Window source;
+ Time time;
+ unsigned char *data = NULL;
+ Tcl_Obj **field;
+
+ if (objc != 9) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "source requestor property type format time data data_items");
+ return TCL_ERROR;
+ }
+
+ source = TkDND_TkWin(objv[1]);
+ if (!source) return TCL_ERROR;
+ if (Tcl_GetLongFromObj(interp, objv[2], (long *) &target) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ display = Tk_Display(source);
+ property = Tk_InternAtom(source, Tcl_GetString(objv[3]));
+ type = Tk_InternAtom(source, Tcl_GetString(objv[4]));
+ if (Tcl_GetIntFromObj(interp, objv[5], &format) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (format != 8 && format != 16 && format != 32) {
+ Tcl_SetResult(interp, "unsupported format: not 8, 16 or 32", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[5], &format) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetLongFromObj(interp, objv[6], (long *) &time) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[8], &numItems) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!time) time = CurrentTime;
+ switch (format) {
+ case 8:
+ data = (unsigned char *) Tcl_GetString(objv[7]);
+ break;
+ case 16: {
+ short *propPtr = (short *) Tcl_Alloc(sizeof(short)*numItems);
+ data = (unsigned char *) propPtr;
+ if (Tcl_ListObjGetElements(interp, objv[7], &numFields, &field)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i = 0; i < numItems; i++) {
+ char *dummy;
+ propPtr[i] = (short) strtol(Tcl_GetString(field[i]), &dummy, 0);
+ }
+ break;
+ }
+ case 32: {
+ long *propPtr = (long *) Tcl_Alloc(sizeof(long)*numItems);
+ data = (unsigned char *) propPtr;
+ if (Tcl_ListObjGetElements(interp, objv[7], &numFields, &field)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i = 0; i < numItems; i++) {
+ char *dummy;
+ propPtr[i] = (short) strtol(Tcl_GetString(field[i]), &dummy, 0);
+ }
+ break;
+ }
+ }
+ XChangeProperty(display, target, property, type, format, PropModeReplace,
+ (unsigned char *) data, numItems);
+ if (format > 8 && data) Tcl_Free((char *) data);
+ /* Send selection notify to requestor... */
+ event.xselection.type = SelectionNotify;
+ event.xselection.display = display;
+ event.xselection.requestor = target;
+ event.xselection.selection = Tk_InternAtom(source, "XdndSelection");
+ event.xselection.target = type;
+ event.xselection.property = property;
+ event.xselection.time = time;
+ XSendEvent(display, target, False, NoEventMask, &event);
+ return TCL_OK;
+}; /* TkDND_XChangePropertyObjCmd */
+
/*
* For C++ compilers, use extern "C"
*/
@@ -1500,6 +1604,12 @@ int DLLEXPORT Tkdnd_Init(Tcl_Interp *interp) {
return TCL_ERROR;
}
+ if (Tcl_CreateObjCommand(interp, "XChangeProperty",
+ (Tcl_ObjCmdProc*) TkDND_XChangePropertyObjCmd,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL) == NULL) {
+ return TCL_ERROR;
+ }
+
/* Create the cursors... */
TkDND_InitialiseCursors(interp);
diff --git a/unix/tkUnixSelect.c b/unix/tkUnixSelect.c
index 2baa0fb..99f208b 100644
--- a/unix/tkUnixSelect.c
+++ b/unix/tkUnixSelect.c
@@ -65,7 +65,7 @@ int TkDND_ClipboardReadProperty(Tk_Window tkwin,
}
XFree((char*)data);
- int offset = 0, format_inc = 1;
+ int offset = 0, format_inc = 1, proplen = bytes_left;
switch (*format) {
case 8:
@@ -75,10 +75,12 @@ int TkDND_ClipboardReadProperty(Tk_Window tkwin,
case 16:
format_inc = sizeof(short) / 2;
+ proplen *= sizeof(short) / 2;
break;
case 32:
format_inc = sizeof(long) / 4;
+ proplen *= sizeof(long) / 4;
break;
}
@@ -88,13 +90,46 @@ int TkDND_ClipboardReadProperty(Tk_Window tkwin,
&length, &bytes_left, &data);
if (r != Success || (type && *type == None))
break;
+ switch (*format) {
+ case 8:
+ default:
+ offset += length / (32 / *format);
+ length *= format_inc * (*format) / 8;
+ Tcl_DStringAppend(buffer, (char *) data, length);
+ break;
+ case 16: {
+ register unsigned short *propPtr = (unsigned short *) data;
+ for (; length > 0; propPtr++, length--) {
+ char buf[12];
+
+ sprintf(buf, "0x%04x", (unsigned short) *propPtr);
+ Tcl_DStringAppendElement(buffer, buf);
+ }
+ Tcl_DStringAppend(buffer, " ", 1);
+ break;
+ }
+ case 32: {
+ register unsigned long *propPtr = (unsigned long *) data;
+ for (; length > 0; propPtr++, length--) {
+ char buf[12];
- offset += length / (32 / *format);
- length *= format_inc * (*format) / 8;
- Tcl_DStringAppend(buffer, (char *) data, length);
+ sprintf(buf, "0x%x", (unsigned int) *propPtr);
+ Tcl_DStringAppendElement(buffer, buf);
+ }
+ Tcl_DStringAppend(buffer, " ", 1);
+ break;
+ }
+ }
XFree((char*)data);
}
+#if 0
+ printf("Selection details:\n");
+ printf(" type: %s\n", XGetAtomName(display, *type));
+ printf(" format: %d %s\n", *format, XGetAtomName(display, *format));
+ printf(" length: %d\n", Tcl_DStringLength(buffer));
+ printf(" data: \"%s\"\n", Tcl_DStringValue(buffer));
+#endif
if (*format == 8 && *type == Tk_InternAtom(tkwin, "COMPOUND_TEXT")) {
// convert COMPOUND_TEXT to a multibyte string
@@ -166,6 +201,14 @@ void TkDND_SelectionNotifyEventProc(ClientData clientData, XEvent *eventPtr) {
status = TkDND_ClipboardReadProperty(detail->tkwin, detail->property, 1,
detail, &size, &type, &format);
if (status) {
+#ifdef TKDND_DebugSelectionRequests
+ printf("SelectionNotify: selection: %s, target: %s, property: %s,\
+ type: %s, format: %d\n",
+ Tk_GetAtomName(detail->tkwin, eventPtr->xselection.selection),
+ Tk_GetAtomName(detail->tkwin, eventPtr->xselection.target),
+ Tk_GetAtomName(detail->tkwin, eventPtr->xselection.property),
+ Tk_GetAtomName(detail->tkwin, type), format);
+#endif /* TKDND_DebugSelectionRequests */
if (type == Tk_InternAtom(detail->tkwin, "INCR")) {
status = TkDND_ClipboardReadIncrementalProperty(detail->tkwin,
detail->property, detail);
generated by cgit v0.12 at 2024-11-01 02:00:30 (GMT)