Delete tkinterdnd2 directory

This commit is contained in:
Anjok07 2022-12-18 21:23:37 -06:00 committed by GitHub
parent 7470042271
commit 4ac5aff199
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
30 changed files with 0 additions and 7911 deletions

View File

@ -1,293 +0,0 @@
'''Python wrapper for the tkdnd tk extension.
The tkdnd extension provides an interface to native, platform specific
drag and drop mechanisms. Under Unix the drag & drop protocol in use is
the XDND protocol version 5 (also used by the Qt toolkit, and the KDE and
GNOME desktops). Under Windows, the OLE2 drag & drop interfaces are used.
Under Macintosh, the Cocoa drag and drop interfaces are used.
Once the TkinterDnD2 package is installed, it is safe to do:
from TkinterDnD2 import *
This will add the classes TkinterDnD.Tk and TkinterDnD.TixTk to the global
namespace, plus the following constants:
PRIVATE, NONE, ASK, COPY, MOVE, LINK, REFUSE_DROP,
DND_TEXT, DND_FILES, DND_ALL, CF_UNICODETEXT, CF_TEXT, CF_HDROP,
FileGroupDescriptor, FileGroupDescriptorW
Drag and drop for the application can then be enabled by using one of the
classes TkinterDnD.Tk() or (in case the tix extension shall be used)
TkinterDnD.TixTk() as application main window instead of a regular
tkinter.Tk() window. This will add the drag-and-drop specific methods to the
Tk window and all its descendants.
'''
import tkinter
from tkinter import tix
TkdndVersion = None
def _require(tkroot):
'''Internal function.'''
global TkdndVersion
try:
import os.path
import platform
if platform.system()=="Darwin":
tkdnd_platform_rep = "osx64"
elif platform.system()=="Linux":
tkdnd_platform_rep = "linux64"
elif platform.system()=="Windows":
tkdnd_platform_rep = "win64"
else:
raise RuntimeError('Plaform not supported.')
module_path = os.path.join(os.path.dirname(__file__), 'tkdnd', tkdnd_platform_rep)
tkroot.tk.call('lappend', 'auto_path', module_path)
TkdndVersion = tkroot.tk.call('package', 'require', 'tkdnd')
except tkinter.TclError:
raise RuntimeError('Unable to load tkdnd library.')
return TkdndVersion
class DnDEvent:
"""Internal class.
Container for the properties of a drag-and-drop event, similar to a
normal tkinter.Event.
An instance of the DnDEvent class has the following attributes:
action (string)
actions (tuple)
button (int)
code (string)
codes (tuple)
commonsourcetypes (tuple)
commontargettypes (tuple)
data (string)
name (string)
types (tuple)
modifiers (tuple)
supportedsourcetypes (tuple)
sourcetypes (tuple)
type (string)
supportedtargettypes (tuple)
widget (widget instance)
x_root (int)
y_root (int)
Depending on the type of DnD event however, not all attributes may be set.
"""
pass
class DnDWrapper:
'''Internal class.'''
# some of the percent substitutions need to be enclosed in braces
# so we can use splitlist() to convert them into tuples
_subst_format_dnd = ('%A', '%a', '%b', '%C', '%c', '%CST',
'%CTT', '%D', '%e', '%L', '%m', '%ST',
'%T', '%t', '%TT', '%W', '%X', '%Y')
_subst_format_str_dnd = " ".join(_subst_format_dnd)
#print('_subst_format_dnd: ', _subst_format_dnd)
tkinter.BaseWidget._subst_format_dnd = _subst_format_dnd
tkinter.BaseWidget._subst_format_str_dnd = _subst_format_str_dnd
def _substitute_dnd(self, *args):
"""Internal function."""
if len(args) != len(self._subst_format_dnd):
return args
def getint_event(s):
try:
return int(s)
except ValueError:
return s
def splitlist_event(s):
try:
return self.tk.splitlist(s)
except ValueError:
return s
# valid percent substitutions for DnD event types
# (tested with tkdnd-2.8 on debian jessie):
# <<DragInitCmd>> : %W, %X, %Y %e, %t
# <<DragEndCmd>> : %A, %W, %e
# <<DropEnter>> : all except : %D (always empty)
# <<DropLeave>> : all except %D (always empty)
# <<DropPosition>> :all except %D (always empty)
# <<Drop>> : all
A, a, b, C, c, CST, CTT, D, e, L, m, ST, T, t, TT, W, X, Y = args
ev = DnDEvent()
ev.action = A
ev.actions = splitlist_event(a)
ev.button = getint_event(b)
ev.code = C
ev.codes = splitlist_event(c)
ev.commonsourcetypes = splitlist_event(CST)
ev.commontargettypes = splitlist_event(CTT)
ev.data = D
ev.name = e
ev.types = splitlist_event(L)
ev.modifiers = splitlist_event(m)
ev.supportedsourcetypes = splitlist_event(ST)
ev.sourcetypes = splitlist_event(t)
ev.type = T
ev.supportedtargettypes = splitlist_event(TT)
try:
ev.widget = self.nametowidget(W)
except KeyError:
ev.widget = W
ev.x_root = getint_event(X)
ev.y_root = getint_event(Y)
return (ev,)
tkinter.BaseWidget._substitute_dnd = _substitute_dnd
def _dnd_bind(self, what, sequence, func, add, needcleanup=True):
"""Internal function."""
if isinstance(func, str):
self.tk.call(what + (sequence, func))
elif func:
funcid = self._register(func, self._substitute_dnd, needcleanup)
# FIXME: why doesn't the "return 'break'" mechanism work here??
#cmd = ('%sif {"[%s %s]" == "break"} break\n' % (add and '+' or '',
# funcid, self._subst_format_str_dnd))
cmd = '%s%s %s' %(add and '+' or '', funcid,
self._subst_format_str_dnd)
self.tk.call(what + (sequence, cmd))
return funcid
elif sequence:
return self.tk.call(what + (sequence,))
else:
return self.tk.splitlist(self.tk.call(what))
tkinter.BaseWidget._dnd_bind = _dnd_bind
def dnd_bind(self, sequence=None, func=None, add=None):
'''Bind to this widget at drag and drop event SEQUENCE a call
to function FUNC.
SEQUENCE may be one of the following:
<<DropEnter>>, <<DropPosition>>, <<DropLeave>>, <<Drop>>,
<<Drop:type>>, <<DragInitCmd>>, <<DragEndCmd>> .
The callbacks for the <Drop*>> events, with the exception of
<<DropLeave>>, should always return an action (i.e. one of COPY,
MOVE, LINK, ASK or PRIVATE).
The callback for the <<DragInitCmd>> event must return a tuple
containing three elements: the drop action(s) supported by the
drag source, the format type(s) that the data can be dropped as and
finally the data that shall be dropped. Each of these three elements
may be a tuple of strings or a single string.'''
return self._dnd_bind(('bind', self._w), sequence, func, add)
tkinter.BaseWidget.dnd_bind = dnd_bind
def drag_source_register(self, button=None, *dndtypes):
'''This command will register SELF as a drag source.
A drag source is a widget than can start a drag action. This command
can be executed multiple times on a widget.
When SELF is registered as a drag source, optional DNDTYPES can be
provided. These DNDTYPES will be provided during a drag action, and
it can contain platform independent or platform specific types.
Platform independent are DND_Text for dropping text portions and
DND_Files for dropping a list of files (which can contain one or
multiple files) on SELF. However, these types are
indicative/informative. SELF can initiate a drag action with even a
different type list. Finally, button is the mouse button that will be
used for starting the drag action. It can have any of the values 1
(left mouse button), 2 (middle mouse button - wheel) and 3
(right mouse button). If button is not specified, it defaults to 1.'''
# hack to fix a design bug from the first version
if button is None:
button = 1
else:
try:
button = int(button)
except ValueError:
# no button defined, button is actually
# something like DND_TEXT
dndtypes = (button,) + dndtypes
button = 1
self.tk.call(
'tkdnd::drag_source', 'register', self._w, dndtypes, button)
tkinter.BaseWidget.drag_source_register = drag_source_register
def drag_source_unregister(self):
'''This command will stop SELF from being a drag source. Thus, window
will stop receiving events related to drag operations. It is an error
to use this command for a window that has not been registered as a
drag source with drag_source_register().'''
self.tk.call('tkdnd::drag_source', 'unregister', self._w)
tkinter.BaseWidget.drag_source_unregister = drag_source_unregister
def drop_target_register(self, *dndtypes):
'''This command will register SELF as a drop target. A drop target is
a widget than can accept a drop action. This command can be executed
multiple times on a widget. When SELF is registered as a drop target,
optional DNDTYPES can be provided. These types list can contain one or
more types that SELF will accept during a drop action, and it can
contain platform independent or platform specific types. Platform
independent are DND_Text for dropping text portions and DND_Files for
dropping a list of files (which can contain one or multiple files) on
SELF.'''
self.tk.call('tkdnd::drop_target', 'register', self._w, dndtypes)
tkinter.BaseWidget.drop_target_register = drop_target_register
def drop_target_unregister(self):
'''This command will stop SELF from being a drop target. Thus, SELF
will stop receiving events related to drop operations. It is an error
to use this command for a window that has not been registered as a
drop target with drop_target_register().'''
self.tk.call('tkdnd::drop_target', 'unregister', self._w)
tkinter.BaseWidget.drop_target_unregister = drop_target_unregister
def platform_independent_types(self, *dndtypes):
'''This command will accept a list of types that can contain platform
independnent or platform specific types. A new list will be returned,
where each platform specific type in DNDTYPES will be substituted by
one or more platform independent types. Thus, the returned list may
have more elements than DNDTYPES.'''
return self.tk.split(self.tk.call(
'tkdnd::platform_independent_types', dndtypes))
tkinter.BaseWidget.platform_independent_types = platform_independent_types
def platform_specific_types(self, *dndtypes):
'''This command will accept a list of types that can contain platform
independnent or platform specific types. A new list will be returned,
where each platform independent type in DNDTYPES will be substituted
by one or more platform specific types. Thus, the returned list may
have more elements than DNDTYPES.'''
return self.tk.split(self.tk.call(
'tkdnd::platform_specific_types', dndtypes))
tkinter.BaseWidget.platform_specific_types = platform_specific_types
def get_dropfile_tempdir(self):
'''This command will return the temporary directory used by TkDND for
storing temporary files. When the package is loaded, this temporary
directory will be initialised to a proper directory according to the
operating system. This default initial value can be changed to be the
value of the following environmental variables:
TKDND_TEMP_DIR, TEMP, TMP.'''
return self.tk.call('tkdnd::GetDropFileTempDirectory')
tkinter.BaseWidget.get_dropfile_tempdir = get_dropfile_tempdir
def set_dropfile_tempdir(self, tempdir):
'''This command will change the temporary directory used by TkDND for
storing temporary files to TEMPDIR.'''
self.tk.call('tkdnd::SetDropFileTempDirectory', tempdir)
tkinter.BaseWidget.set_dropfile_tempdir = set_dropfile_tempdir
#######################################################################
#### The main window classes that enable Drag & Drop for ####
#### themselves and all their descendant widgets: ####
#######################################################################
class Tk(tkinter.Tk, DnDWrapper):
'''Creates a new instance of a tkinter.Tk() window; all methods of the
DnDWrapper class apply to this window and all its descendants.'''
def __init__(self, *args, **kw):
tkinter.Tk.__init__(self, *args, **kw)
self.TkdndVersion = _require(self)
class TixTk(tix.Tk, DnDWrapper):
'''Creates a new instance of a tix.Tk() window; all methods of the
DnDWrapper class apply to this window and all its descendants.'''
def __init__(self, *args, **kw):
tix.Tk.__init__(self, *args, **kw)
self.TkdndVersion = _require(self)

View File

@ -1,25 +0,0 @@
# dnd actions
PRIVATE = 'private'
NONE = 'none'
ASK = 'ask'
COPY = 'copy'
MOVE = 'move'
LINK = 'link'
REFUSE_DROP = 'refuse_drop'
# dnd types
DND_TEXT = 'DND_Text'
DND_FILES = 'DND_Files'
DND_ALL = '*'
CF_UNICODETEXT = 'CF_UNICODETEXT'
CF_TEXT = 'CF_TEXT'
CF_HDROP = 'CF_HDROP'
FileGroupDescriptor = 'FileGroupDescriptor - FileContents'# ??
FileGroupDescriptorW = 'FileGroupDescriptorW - FileContents'# ??
from . import TkinterDnD
from .TkinterDnD import Tk
from .TkinterDnD import TixTk

Binary file not shown.

View File

@ -1,10 +0,0 @@
#
# Tcl package index file
#
package ifneeded tkdnd 2.9.2 \
"source \{$dir/tkdnd.tcl\} ; \
tkdnd::initialise \{$dir\} libtkdnd2.9.2.so tkdnd"
package ifneeded tkdnd::utils 2.9.2 \
"source \{$dir/tkdnd_utils.tcl\} ; \
package provide tkdnd::utils 2.9.2"

View File

@ -1,469 +0,0 @@
#
# tkdnd.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
package require Tk
namespace eval ::tkdnd {
variable _topw ".drag"
variable _tabops
variable _state
variable _x0
variable _y0
variable _platform_namespace
variable _drop_file_temp_dir
variable _auto_update 1
variable _dx 3 ;# The difference in pixels before a drag is initiated.
variable _dy 3 ;# The difference in pixels before a drag is initiated.
variable _windowingsystem
bind TkDND_Drag1 <ButtonPress-1> {tkdnd::_begin_drag press 1 %W %s %X %Y %x %y}
bind TkDND_Drag1 <B1-Motion> {tkdnd::_begin_drag motion 1 %W %s %X %Y %x %y}
bind TkDND_Drag2 <ButtonPress-2> {tkdnd::_begin_drag press 2 %W %s %X %Y %x %y}
bind TkDND_Drag2 <B2-Motion> {tkdnd::_begin_drag motion 2 %W %s %X %Y %x %y}
bind TkDND_Drag3 <ButtonPress-3> {tkdnd::_begin_drag press 3 %W %s %X %Y %x %y}
bind TkDND_Drag3 <B3-Motion> {tkdnd::_begin_drag motion 3 %W %s %X %Y %x %y}
# ----------------------------------------------------------------------------
# Command tkdnd::initialise: Initialise the TkDND package.
# ----------------------------------------------------------------------------
proc initialise { dir PKG_LIB_FILE PACKAGE_NAME} {
variable _platform_namespace
variable _drop_file_temp_dir
variable _windowingsystem
global env
switch [tk windowingsystem] {
x11 {
set _windowingsystem x11
}
win32 -
windows {
set _windowingsystem windows
}
aqua {
set _windowingsystem aqua
}
default {
error "unknown Tk windowing system"
}
}
## Get User's home directory: We try to locate the proper path from a set of
## environmental variables...
foreach var {HOME HOMEPATH USERPROFILE ALLUSERSPROFILE APPDATA} {
if {[info exists env($var)]} {
if {[file isdirectory $env($var)]} {
set UserHomeDir $env($var)
break
}
}
}
## Should use [tk windowingsystem] instead of tcl platform array:
## OS X returns "unix," but that's not useful because it has its own
## windowing system, aqua
## Under windows we have to also combine HOMEDRIVE & HOMEPATH...
if {![info exists UserHomeDir] &&
[string equal $_windowingsystem windows] &&
[info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)]} {
if {[file isdirectory $env(HOMEDRIVE)$env(HOMEPATH)]} {
set UserHomeDir $env(HOMEDRIVE)$env(HOMEPATH)
}
}
## Have we located the needed path?
if {![info exists UserHomeDir]} {
set UserHomeDir [pwd]
}
set UserHomeDir [file normalize $UserHomeDir]
## Try to locate a temporary directory...
foreach var {TKDND_TEMP_DIR TEMP TMP} {
if {[info exists env($var)]} {
if {[file isdirectory $env($var)] && [file writable $env($var)]} {
set _drop_file_temp_dir $env($var)
break
}
}
}
if {![info exists _drop_file_temp_dir]} {
foreach _dir [list "$UserHomeDir/Local Settings/Temp" \
"$UserHomeDir/AppData/Local/Temp" \
/tmp \
C:/WINDOWS/Temp C:/Temp C:/tmp \
D:/WINDOWS/Temp D:/Temp D:/tmp] {
if {[file isdirectory $_dir] && [file writable $_dir]} {
set _drop_file_temp_dir $_dir
break
}
}
}
if {![info exists _drop_file_temp_dir]} {
set _drop_file_temp_dir $UserHomeDir
}
set _drop_file_temp_dir [file native $_drop_file_temp_dir]
source $dir/tkdnd_generic.tcl
switch $_windowingsystem {
x11 {
source $dir/tkdnd_unix.tcl
set _platform_namespace xdnd
}
win32 -
windows {
source $dir/tkdnd_windows.tcl
set _platform_namespace olednd
}
aqua {
source $dir/tkdnd_macosx.tcl
set _platform_namespace macdnd
}
default {
error "unknown Tk windowing system"
}
}
load $dir/$PKG_LIB_FILE $PACKAGE_NAME
source $dir/tkdnd_compat.tcl
${_platform_namespace}::initialise
};# initialise
proc GetDropFileTempDirectory { } {
variable _drop_file_temp_dir
return $_drop_file_temp_dir
}
proc SetDropFileTempDirectory { dir } {
variable _drop_file_temp_dir
set _drop_file_temp_dir $dir
}
};# namespace ::tkdnd
# ----------------------------------------------------------------------------
# Command tkdnd::drag_source
# ----------------------------------------------------------------------------
proc ::tkdnd::drag_source { mode path { types {} } { event 1 }
{ tagprefix TkDND_Drag } } {
set tags [bindtags $path]
set idx [lsearch $tags ${tagprefix}$event]
switch -- $mode {
register {
if { $idx != -1 } {
## No need to do anything!
# bindtags $path [lreplace $tags $idx $idx ${tagprefix}$event]
} else {
bindtags $path [linsert $tags 1 ${tagprefix}$event]
}
_drag_source_update_types $path $types
}
unregister {
if { $idx != -1 } {
bindtags $path [lreplace $tags $idx $idx]
}
}
}
};# tkdnd::drag_source
proc ::tkdnd::_drag_source_update_types { path types } {
set types [platform_specific_types $types]
set old_types [bind $path <<DragSourceTypes>>]
foreach type $types {
if {[lsearch $old_types $type] < 0} {lappend old_types $type}
}
bind $path <<DragSourceTypes>> $old_types
};# ::tkdnd::_drag_source_update_types
# ----------------------------------------------------------------------------
# Command tkdnd::drop_target
# ----------------------------------------------------------------------------
proc ::tkdnd::drop_target { mode path { types {} } } {
variable _windowingsystem
set types [platform_specific_types $types]
switch -- $mode {
register {
switch $_windowingsystem {
x11 {
_register_types $path [winfo toplevel $path] $types
}
win32 -
windows {
_RegisterDragDrop $path
bind <Destroy> $path {+ tkdnd::_RevokeDragDrop %W}
}
aqua {
macdnd::registerdragwidget [winfo toplevel $path] $types
}
default {
error "unknown Tk windowing system"
}
}
set old_types [bind $path <<DropTargetTypes>>]
set new_types {}
foreach type $types {
if {[lsearch -exact $old_types $type] < 0} {lappend new_types $type}
}
if {[llength $new_types]} {
bind $path <<DropTargetTypes>> [concat $old_types $new_types]
}
}
unregister {
switch $_windowingsystem {
x11 {
}
win32 -
windows {
_RevokeDragDrop $path
}
aqua {
error todo
}
default {
error "unknown Tk windowing system"
}
}
bind $path <<DropTargetTypes>> {}
}
}
};# tkdnd::drop_target
# ----------------------------------------------------------------------------
# Command tkdnd::_begin_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_begin_drag { event button source state X Y x y } {
variable _x0
variable _y0
variable _state
switch -- $event {
press {
set _x0 $X
set _y0 $Y
set _state "press"
}
motion {
if { ![info exists _state] } {
# This is just extra protection. There seem to be
# rare cases where the motion comes before the press.
return
}
if { [string equal $_state "press"] } {
variable _dx
variable _dy
if { abs($_x0-$X) > ${_dx} || abs($_y0-$Y) > ${_dy} } {
set _state "done"
_init_drag $button $source $state $X $Y $x $y
}
}
}
}
};# tkdnd::_begin_drag
# ----------------------------------------------------------------------------
# Command tkdnd::_init_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_init_drag { button source state rootX rootY X Y } {
# Call the <<DragInitCmd>> binding.
set cmd [bind $source <<DragInitCmd>>]
# puts "CMD: $cmd"
if {[string length $cmd]} {
set cmd [string map [list %W $source %X $rootX %Y $rootY %x $X %y $Y \
%S $state %e <<DragInitCmd>> %A \{\} %% % \
%t [bind $source <<DragSourceTypes>>]] $cmd]
set code [catch {uplevel \#0 $cmd} info options]
# puts "CODE: $code ---- $info"
switch -exact -- $code {
0 {}
3 - 4 {
# FRINK: nocheck
return
}
default {
return -options $options $info
}
}
set len [llength $info]
if {$len == 3} {
foreach { actions types _data } $info { break }
set types [platform_specific_types $types]
set data [list]
foreach type $types {
lappend data $_data
}
unset _data
} elseif {$len == 2} {
foreach { actions _data } $info { break }
set data [list]; set types [list]
foreach {t d} $_data {
foreach t [platform_specific_types $t] {
lappend types $t; lappend data $d
}
}
unset _data t d
} else {
if {$len == 1 && [string equal [lindex $actions 0] "refuse_drop"]} {
return
}
error "not enough items in the result of the <<DragInitCmd>>\
event binding. Either 2 or 3 items are expected. The command
executed was: \"$cmd\"\nResult was: \"$info\""
}
set action refuse_drop
variable _windowingsystem
# puts "Source: \"$source\""
# puts "Types: \"[join $types {", "}]\""
# puts "Actions: \"[join $actions {", "}]\""
# puts "Button: \"$button\""
# puts "Data: \"[string range $data 0 100]\""
switch $_windowingsystem {
x11 {
set action [xdnd::_dodragdrop $source $actions $types $data $button]
}
win32 -
windows {
set action [_DoDragDrop $source $actions $types $data $button]
}
aqua {
set action [macdnd::dodragdrop $source $actions $types $data $button]
}
default {
error "unknown Tk windowing system"
}
}
## Call _end_drag to notify the widget of the result of the drag
## operation...
_end_drag $button $source {} $action {} $data {} $state $rootX $rootY $X $Y
}
};# tkdnd::_init_drag
# ----------------------------------------------------------------------------
# Command tkdnd::_end_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_end_drag { button source target action type data result
state rootX rootY X Y } {
set rootX 0
set rootY 0
# Call the <<DragEndCmd>> binding.
set cmd [bind $source <<DragEndCmd>>]
if {[string length $cmd]} {
set cmd [string map [list %W $source %X $rootX %Y $rootY %x $X %y $Y %% % \
%S $state %e <<DragEndCmd>> %A \{$action\}] $cmd]
set info [uplevel \#0 $cmd]
# if { $info != "" } {
# variable _windowingsystem
# foreach { actions types data } $info { break }
# set types [platform_specific_types $types]
# switch $_windowingsystem {
# x11 {
# error "dragging from Tk widgets not yet supported"
# }
# win32 -
# windows {
# set action [_DoDragDrop $source $actions $types $data $button]
# }
# aqua {
# macdnd::dodragdrop $source $actions $types $data
# }
# default {
# error "unknown Tk windowing system"
# }
# }
# ## Call _end_drag to notify the widget of the result of the drag
# ## operation...
# _end_drag $button $source {} $action {} $data {} $state $rootX $rootY
# }
}
};# tkdnd::_end_drag
# ----------------------------------------------------------------------------
# Command tkdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_specific_types { types } {
variable _platform_namespace
${_platform_namespace}::platform_specific_types $types
}; # tkdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
variable _platform_namespace
${_platform_namespace}::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command tkdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_specific_type { type } {
variable _platform_namespace
${_platform_namespace}::platform_specific_type $type
}; # tkdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_type { type } {
variable _platform_namespace
${_platform_namespace}::platform_independent_type $type
}; # tkdnd::platform_independent_type
# ----------------------------------------------------------------------------
# Command tkdnd::bytes_to_string
# ----------------------------------------------------------------------------
proc ::tkdnd::bytes_to_string { bytes } {
set string {}
foreach byte $bytes {
append string [binary format c $byte]
}
return $string
};# tkdnd::bytes_to_string
# ----------------------------------------------------------------------------
# Command tkdnd::urn_unquote
# ----------------------------------------------------------------------------
proc ::tkdnd::urn_unquote {url} {
set result ""
set start 0
while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
foreach {first last} $match break
append result [string range $url $start [expr {$first - 1}]]
append result [format %c 0x[string range $url [incr first] $last]]
set start [incr last]
}
append result [string range $url $start end]
return [encoding convertfrom utf-8 $result]
};# tkdnd::urn_unquote

View File

@ -1,160 +0,0 @@
#
# tkdnd_compat.tcl --
#
# This file implements some utility procedures, to support older versions
# of the TkDND package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval compat {
};# namespace compat
# ----------------------------------------------------------------------------
# Command ::dnd
# ----------------------------------------------------------------------------
proc ::dnd {method window args} {
switch $method {
bindtarget {
switch [llength $args] {
0 {return [tkdnd::compat::bindtarget0 $window]}
1 {return [tkdnd::compat::bindtarget1 $window [lindex $args 0]]}
2 {return [tkdnd::compat::bindtarget2 $window [lindex $args 0] \
[lindex $args 1]]}
3 {return [tkdnd::compat::bindtarget3 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2]]}
4 {return [tkdnd::compat::bindtarget4 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2] [lindex $args 3]]}
}
}
cleartarget {
return [tkdnd::compat::cleartarget $window]
}
bindsource {
switch [llength $args] {
0 {return [tkdnd::compat::bindsource0 $window]}
1 {return [tkdnd::compat::bindsource1 $window [lindex $args 0]]}
2 {return [tkdnd::compat::bindsource2 $window [lindex $args 0] \
[lindex $args 1]]}
3 {return [tkdnd::compat::bindsource3 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2]]}
}
}
clearsource {
return [tkdnd::compat::clearsource $window]
}
drag {
return [tkdnd::_init_drag 1 $window "press" 0 0 0 0]
}
}
error "invalid number of arguments!"
};# ::dnd
# ----------------------------------------------------------------------------
# Command compat::bindtarget
# ----------------------------------------------------------------------------
proc compat::bindtarget0 {window} {
return [bind $window <<DropTargetTypes>>]
};# compat::bindtarget0
proc compat::bindtarget1 {window type} {
return [bindtarget2 $window $type <Drop>]
};# compat::bindtarget1
proc compat::bindtarget2 {window type event} {
switch $event {
<DragEnter> {return [bind $window <<DropEnter>>]}
<Drag> {return [bind $window <<DropPosition>>]}
<DragLeave> {return [bind $window <<DropLeave>>]}
<Drop> {return [bind $window <<Drop>>]}
}
};# compat::bindtarget2
proc compat::bindtarget3 {window type event script} {
set type [normalise_type $type]
::tkdnd::drop_target register $window [list $type]
switch $event {
<DragEnter> {return [bind $window <<DropEnter>> $script]}
<Drag> {return [bind $window <<DropPosition>> $script]}
<DragLeave> {return [bind $window <<DropLeave>> $script]}
<Drop> {return [bind $window <<Drop>> $script]}
}
};# compat::bindtarget3
proc compat::bindtarget4 {window type event script priority} {
return [bindtarget3 $window $type $event $script]
};# compat::bindtarget4
proc compat::normalise_type { type } {
switch $type {
text/plain -
{text/plain;charset=UTF-8} -
Text {return DND_Text}
text/uri-list -
Files {return DND_Files}
default {return $type}
}
};# compat::normalise_type
# ----------------------------------------------------------------------------
# Command compat::bindsource
# ----------------------------------------------------------------------------
proc compat::bindsource0 {window} {
return [bind $window <<DropTargetTypes>>]
};# compat::bindsource0
proc compat::bindsource1 {window type} {
return [bindsource2 $window $type <Drop>]
};# compat::bindsource1
proc compat::bindsource2 {window type script} {
set type [normalise_type $type]
::tkdnd::drag_source register $window $type
bind $window <<DragInitCmd>> "list {copy} {%t} \[$script\]"
};# compat::bindsource2
proc compat::bindsource3 {window type script priority} {
return [bindsource2 $window $type $script]
};# compat::bindsource3
# ----------------------------------------------------------------------------
# Command compat::cleartarget
# ----------------------------------------------------------------------------
proc compat::cleartarget {window} {
};# compat::cleartarget
# ----------------------------------------------------------------------------
# Command compat::clearsource
# ----------------------------------------------------------------------------
proc compat::clearsource {window} {
};# compat::clearsource

View File

@ -1,520 +0,0 @@
#
# tkdnd_generic.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval generic {
variable _types {}
variable _typelist {}
variable _codelist {}
variable _actionlist {}
variable _pressedkeys {}
variable _action {}
variable _common_drag_source_types {}
variable _common_drop_target_types {}
variable _drag_source {}
variable _drop_target {}
variable _last_mouse_root_x 0
variable _last_mouse_root_y 0
variable _tkdnd2platform
variable _platform2tkdnd
proc debug {msg} {
puts $msg
};# debug
proc initialise { } {
};# initialise
proc initialise_platform_to_tkdnd_types { types } {
variable _platform2tkdnd
variable _tkdnd2platform
set _platform2tkdnd [dict create {*}$types]
set _tkdnd2platform [dict create]
foreach type [dict keys $_platform2tkdnd] {
dict lappend _tkdnd2platform [dict get $_platform2tkdnd $type] $type
}
};# initialise_platform_to_tkdnd_types
proc initialise_tkdnd_to_platform_types { types } {
variable _tkdnd2platform
set _tkdnd2platform [dict create {*}$types]
};# initialise_tkdnd_to_platform_types
};# namespace generic
# ----------------------------------------------------------------------------
# Command generic::HandleEnter
# ----------------------------------------------------------------------------
proc generic::HandleEnter { drop_target drag_source typelist codelist
actionlist pressedkeys } {
variable _typelist; set _typelist $typelist
variable _pressedkeys; set _pressedkeys $pressedkeys
variable _action; set _action refuse_drop
variable _common_drag_source_types; set _common_drag_source_types {}
variable _common_drop_target_types; set _common_drop_target_types {}
variable _actionlist
variable _drag_source; set _drag_source $drag_source
variable _drop_target; set _drop_target {}
variable _actionlist; set _actionlist $actionlist
variable _codelist set _codelist $codelist
variable _last_mouse_root_x; set _last_mouse_root_x 0
variable _last_mouse_root_y; set _last_mouse_root_y 0
# debug "\n==============================================================="
# debug "generic::HandleEnter: drop_target=$drop_target,\
# drag_source=$drag_source,\
# typelist=$typelist"
# debug "generic::HandleEnter: ACTION: default"
return default
};# generic::HandleEnter
# ----------------------------------------------------------------------------
# Command generic::HandlePosition
# ----------------------------------------------------------------------------
proc generic::HandlePosition { drop_target drag_source pressedkeys
rootX rootY { time 0 } } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
# debug "generic::HandlePosition: drop_target=$drop_target,\
# _drop_target=$_drop_target, rootX=$rootX, rootY=$rootY"
if {![info exists _drag_source] && ![string length $_drag_source]} {
# debug "generic::HandlePosition: no or empty _drag_source:\
# return refuse_drop"
return refuse_drop
}
if {$drag_source ne "" && $drag_source ne $_drag_source} {
debug "generic position event from unexpected source: $_drag_source\
!= $drag_source"
return refuse_drop
}
set _pressedkeys $pressedkeys
## Does the new drop target support any of our new types?
# foreach {common_drag_source_types common_drop_target_types} \
# [GetWindowCommonTypes $drop_target $_typelist] {break}
foreach {drop_target common_drag_source_types common_drop_target_types} \
[FindWindowWithCommonTypes $drop_target $_typelist] {break}
set data [GetDroppedData $time]
# debug "\t($_drop_target) -> ($drop_target)"
if {$drop_target != $_drop_target} {
if {[string length $_drop_target]} {
## Call the <<DropLeave>> event.
# debug "\t<<DropLeave>> on $_drop_target"
set cmd [bind $_drop_target <<DropLeave>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A \{$_action\} %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D \{\} %e <<DropLeave>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
uplevel \#0 $cmd
}
}
set _drop_target $drop_target
set _action refuse_drop
if {[llength $common_drag_source_types]} {
set _action [lindex $_actionlist 0]
set _common_drag_source_types $common_drag_source_types
set _common_drop_target_types $common_drop_target_types
## Drop target supports at least one type. Send a <<DropEnter>>.
# puts "<<DropEnter>> -> $drop_target"
set cmd [bind $drop_target <<DropEnter>>]
if {[string length $cmd]} {
focus $drop_target
set cmd [string map [list %W $drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<DropEnter>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
}
}
}
set _drop_target {}
if {[llength $common_drag_source_types]} {
set _common_drag_source_types $common_drag_source_types
set _common_drop_target_types $common_drop_target_types
set _drop_target $drop_target
## Drop target supports at least one type. Send a <<DropPosition>>.
set cmd [bind $drop_target <<DropPosition>>]
if {[string length $cmd]} {
set cmd [string map [list %W $drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<DropPosition>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
}
# Return values: copy, move, link, ask, private, refuse_drop, default
# debug "generic::HandlePosition: ACTION: $_action"
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
};# generic::HandlePosition
# ----------------------------------------------------------------------------
# Command generic::HandleLeave
# ----------------------------------------------------------------------------
proc generic::HandleLeave { } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x
variable _last_mouse_root_y
if {![info exists _drop_target]} {set _drop_target {}}
# debug "generic::HandleLeave: _drop_target=$_drop_target"
if {[info exists _drop_target] && [string length $_drop_target]} {
set cmd [bind $_drop_target <<DropLeave>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target \
%X $_last_mouse_root_x %Y $_last_mouse_root_y \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A \{$_action\} %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D \{\} %e <<DropLeave>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
}
foreach var {_types _typelist _actionlist _pressedkeys _action
_common_drag_source_types _common_drop_target_types
_drag_source _drop_target} {
set $var {}
}
};# generic::HandleLeave
# ----------------------------------------------------------------------------
# Command generic::HandleDrop
# ----------------------------------------------------------------------------
proc generic::HandleDrop {drop_target drag_source pressedkeys rootX rootY time } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x
variable _last_mouse_root_y
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
set _pressedkeys $pressedkeys
# puts "generic::HandleDrop: $time"
if {![info exists _drag_source] && ![string length $_drag_source]} {
return refuse_drop
}
if {![info exists _drop_target] && ![string length $_drop_target]} {
return refuse_drop
}
if {![llength $_common_drag_source_types]} {return refuse_drop}
## Get the dropped data.
set data [GetDroppedData $time]
## Try to select the most specific <<Drop>> event.
foreach type [concat $_common_drag_source_types $_common_drop_target_types] {
set type [platform_independent_type $type]
set cmd [bind $_drop_target <<Drop:$type>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<Drop:$type>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
# Return values: copy, move, link, ask, private, refuse_drop
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
}
}
set cmd [bind $_drop_target <<Drop>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<Drop>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
# Return values: copy, move, link, ask, private, refuse_drop
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
};# generic::HandleDrop
# ----------------------------------------------------------------------------
# Command generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetWindowCommonTypes { win typelist } {
set types [bind $win <<DropTargetTypes>>]
# debug ">> Accepted types: $win $_types"
set common_drag_source_types {}
set common_drop_target_types {}
if {[llength $types]} {
## Examine the drop target types, to find at least one match with the drag
## source types...
set supported_types [supported_types $typelist]
foreach type $types {
foreach matched [lsearch -glob -all -inline $supported_types $type] {
## Drop target supports this type.
lappend common_drag_source_types $matched
lappend common_drop_target_types $type
}
}
}
list $common_drag_source_types $common_drop_target_types
};# generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
# Command generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
proc generic::FindWindowWithCommonTypes { win typelist } {
set toplevel [winfo toplevel $win]
while {![string equal $win $toplevel]} {
foreach {common_drag_source_types common_drop_target_types} \
[GetWindowCommonTypes $win $typelist] {break}
if {[llength $common_drag_source_types]} {
return [list $win $common_drag_source_types $common_drop_target_types]
}
set win [winfo parent $win]
}
## We have reached the toplevel, which may be also a target (SF Bug #30)
foreach {common_drag_source_types common_drop_target_types} \
[GetWindowCommonTypes $win $typelist] {break}
if {[llength $common_drag_source_types]} {
return [list $win $common_drag_source_types $common_drop_target_types]
}
return { {} {} {} }
};# generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
# Command generic::GetDroppedData
# ----------------------------------------------------------------------------
proc generic::GetDroppedData { time } {
variable _dropped_data
return $_dropped_data
};# generic::GetDroppedData
# ----------------------------------------------------------------------------
# Command generic::SetDroppedData
# ----------------------------------------------------------------------------
proc generic::SetDroppedData { data } {
variable _dropped_data
set _dropped_data $data
};# generic::SetDroppedData
# ----------------------------------------------------------------------------
# Command generic::GetDragSource
# ----------------------------------------------------------------------------
proc generic::GetDragSource { } {
variable _drag_source
return $_drag_source
};# generic::GetDragSource
# ----------------------------------------------------------------------------
# Command generic::GetDropTarget
# ----------------------------------------------------------------------------
proc generic::GetDropTarget { } {
variable _drop_target
return $_drop_target
};# generic::GetDropTarget
# ----------------------------------------------------------------------------
# Command generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDragSourceCommonTypes { } {
variable _common_drag_source_types
return $_common_drag_source_types
};# generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDropTargetCommonTypes { } {
variable _common_drag_source_types
return $_common_drag_source_types
};# generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
# Command generic::platform_specific_types
# ----------------------------------------------------------------------------
proc generic::platform_specific_types { types } {
set new_types {}
foreach type $types {
set new_types [concat $new_types [platform_specific_type $type]]
}
return $new_types
}; # generic::platform_specific_types
# ----------------------------------------------------------------------------
# Command generic::platform_specific_type
# ----------------------------------------------------------------------------
proc generic::platform_specific_type { type } {
variable _tkdnd2platform
if {[dict exists $_tkdnd2platform $type]} {
return [dict get $_tkdnd2platform $type]
}
list $type
}; # generic::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
set new_types {}
foreach type $types {
set new_types [concat $new_types [platform_independent_type $type]]
}
return $new_types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command generic::platform_independent_type
# ----------------------------------------------------------------------------
proc generic::platform_independent_type { type } {
variable _platform2tkdnd
if {[dict exists $_platform2tkdnd $type]} {
return [dict get $_platform2tkdnd $type]
}
return $type
}; # generic::platform_independent_type
# ----------------------------------------------------------------------------
# Command generic::supported_types
# ----------------------------------------------------------------------------
proc generic::supported_types { types } {
set new_types {}
foreach type $types {
if {[supported_type $type]} {lappend new_types $type}
}
return $new_types
}; # generic::supported_types
# ----------------------------------------------------------------------------
# Command generic::supported_type
# ----------------------------------------------------------------------------
proc generic::supported_type { type } {
variable _platform2tkdnd
if {[dict exists $_platform2tkdnd $type]} {
return 1
}
return 0
}; # generic::supported_type

View File

@ -1,144 +0,0 @@
#
# tkdnd_macosx.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
# This software is copyrighted by:
# Georgios Petasis, Athens, Greece.
# e-mail: petasisg@yahoo.gr, petasis@iit.demokritos.gr
#
# Mac portions (c) 2009 Kevin Walzer/WordTech Communications LLC,
# kw@codebykevin.com
#
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
#basic API for Mac Drag and Drop
#two data types supported: strings and file paths
#two commands at C level: ::tkdnd::macdnd::registerdragwidget, ::tkdnd::macdnd::unregisterdragwidget
#data retrieval mechanism: text or file paths are copied from drag clipboard to system clipboard and retrieved via [clipboard get]; array of file paths is converted to single tab-separated string, can be split into Tcl list
if {[tk windowingsystem] eq "aqua" && "AppKit" ni [winfo server .]} {
error {TkAqua Cocoa required}
}
namespace eval macdnd {
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
NSPasteboardTypeString DND_Text \
NSFilenamesPboardType DND_Files \
NSPasteboardTypeHTML DND_HTML \
]
};# initialise
};# namespace macdnd
# ----------------------------------------------------------------------------
# Command macdnd::HandleEnter
# ----------------------------------------------------------------------------
proc macdnd::HandleEnter { path drag_source typelist { data {} } } {
variable _pressedkeys
variable _actionlist
set _pressedkeys 1
set _actionlist { copy move link ask private }
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleEnter $path $drag_source $typelist $typelist \
$_actionlist $_pressedkeys
};# macdnd::HandleEnter
# ----------------------------------------------------------------------------
# Command macdnd::HandlePosition
# ----------------------------------------------------------------------------
proc macdnd::HandlePosition { drop_target rootX rootY {drag_source {}} } {
variable _pressedkeys
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
::tkdnd::generic::HandlePosition $drop_target $drag_source \
$_pressedkeys $rootX $rootY
};# macdnd::HandlePosition
# ----------------------------------------------------------------------------
# Command macdnd::HandleLeave
# ----------------------------------------------------------------------------
proc macdnd::HandleLeave { args } {
::tkdnd::generic::HandleLeave
};# macdnd::HandleLeave
# ----------------------------------------------------------------------------
# Command macdnd::HandleDrop
# ----------------------------------------------------------------------------
proc macdnd::HandleDrop { drop_target data args } {
variable _pressedkeys
variable _last_mouse_root_x
variable _last_mouse_root_y
## Get the dropped data...
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleDrop {} {} $_pressedkeys \
$_last_mouse_root_x $_last_mouse_root_y 0
};# macdnd::HandleDrop
# ----------------------------------------------------------------------------
# Command macdnd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc macdnd::GetDragSourceCommonTypes { } {
::tkdnd::generic::GetDragSourceCommonTypes
};# macdnd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command macdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc macdnd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # macdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command macdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc macdnd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # macdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command macdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc macdnd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # macdnd::platform_independent_type

View File

@ -1,810 +0,0 @@
#
# tkdnd_unix.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval xdnd {
variable _dragging 0
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
text/plain\;charset=utf-8 DND_Text \
UTF8_STRING DND_Text \
text/plain DND_Text \
STRING DND_Text \
TEXT DND_Text \
COMPOUND_TEXT DND_Text \
text/uri-list DND_Files \
text/html\;charset=utf-8 DND_HTML \
text/html DND_HTML \
application/x-color DND_Color \
]
};# initialise
};# namespace xdnd
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndEnter
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndEnter { path drag_source typelist time { data {} } } {
variable _pressedkeys
variable _actionlist
variable _typelist
set _pressedkeys 1
set _actionlist { copy move link ask private }
set _typelist $typelist
# puts "xdnd::HandleXdndEnter: $time"
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleEnter $path $drag_source $typelist $typelist \
$_actionlist $_pressedkeys
};# xdnd::HandleXdndEnter
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndPosition
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndPosition { drop_target rootX rootY time {drag_source {}} } {
variable _pressedkeys
variable _typelist
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
# puts "xdnd::HandleXdndPosition: $time"
## Get the dropped data...
catch {
::tkdnd::generic::SetDroppedData [GetPositionData $drop_target $_typelist $time]
}
::tkdnd::generic::HandlePosition $drop_target $drag_source \
$_pressedkeys $rootX $rootY
};# xdnd::HandleXdndPosition
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndLeave
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndLeave { } {
::tkdnd::generic::HandleLeave
};# xdnd::HandleXdndLeave
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndDrop
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndDrop { time } {
variable _pressedkeys
variable _last_mouse_root_x
variable _last_mouse_root_y
## Get the dropped data...
::tkdnd::generic::SetDroppedData [GetDroppedData \
[::tkdnd::generic::GetDragSource] [::tkdnd::generic::GetDropTarget] \
[::tkdnd::generic::GetDragSourceCommonTypes] $time]
::tkdnd::generic::HandleDrop {} {} $_pressedkeys \
$_last_mouse_root_x $_last_mouse_root_y $time
};# xdnd::HandleXdndDrop
# ----------------------------------------------------------------------------
# Command xdnd::GetPositionData
# ----------------------------------------------------------------------------
proc xdnd::GetPositionData { drop_target typelist time } {
foreach {drop_target common_drag_source_types common_drop_target_types} \
[::tkdnd::generic::FindWindowWithCommonTypes $drop_target $typelist] {break}
GetDroppedData [::tkdnd::generic::GetDragSource] $drop_target \
$common_drag_source_types $time
};# xdnd::GetPositionData
# ----------------------------------------------------------------------------
# Command xdnd::GetDroppedData
# ----------------------------------------------------------------------------
proc xdnd::GetDroppedData { _drag_source _drop_target _common_drag_source_types time } {
if {![llength $_common_drag_source_types]} {
error "no common data types between the drag source and drop target widgets"
}
## Is drag source in this application?
if {[catch {winfo pathname -displayof $_drop_target $_drag_source} p]} {
set _use_tk_selection 0
} else {
set _use_tk_selection 1
}
foreach type $_common_drag_source_types {
# puts "TYPE: $type ($_drop_target)"
# _get_selection $_drop_target $time $type
if {$_use_tk_selection} {
if {![catch {
selection get -displayof $_drop_target -selection XdndSelection \
-type $type
} result options]} {
return [normalise_data $type $result]
}
} else {
# puts "_selection_get -displayof $_drop_target -selection XdndSelection \
# -type $type -time $time"
#after 100 [list focus -force $_drop_target]
#after 50 [list raise [winfo toplevel $_drop_target]]
if {![catch {
_selection_get -displayof $_drop_target -selection XdndSelection \
-type $type -time $time
} result options]} {
return [normalise_data $type $result]
}
}
}
return -options $options $result
};# xdnd::GetDroppedData
# ----------------------------------------------------------------------------
# Command xdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc xdnd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # xdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command xdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc xdnd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # xdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command xdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc xdnd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # xdnd::platform_independent_type
# ----------------------------------------------------------------------------
# Command xdnd::_normalise_data
# ----------------------------------------------------------------------------
proc xdnd::normalise_data { type data } {
# Tk knows how to interpret the following types:
# STRING, TEXT, COMPOUND_TEXT
# UTF8_STRING
# Else, it returns a list of 8 or 32 bit numbers...
switch -glob $type {
STRING - UTF8_STRING - TEXT - COMPOUND_TEXT {return $data}
text/html {
if {[catch {
encoding convertfrom unicode $data
} string]} {
set string $data
}
return [string map {\r\n \n} $string]
}
text/html\;charset=utf-8 -
text/plain\;charset=utf-8 -
text/plain {
if {[catch {
encoding convertfrom utf-8 [tkdnd::bytes_to_string $data]
} string]} {
set string $data
}
return [string map {\r\n \n} $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 [tkdnd::urn_unquote $quoted_file]
switch -glob $file {
\#* {}
file://* {lappend files [string range $file 7 end]}
ftp://* -
https://* -
http://* {lappend files $quoted_file}
default {lappend files $file}
}
}
return $files
}
application/x-color {
return $data
}
text/x-moz-url -
application/q-iconlist -
default {return $data}
}
}; # xdnd::normalise_data
#############################################################################
##
## XDND drag implementation
##
#############################################################################
# ----------------------------------------------------------------------------
# Command xdnd::_selection_ownership_lost
# ----------------------------------------------------------------------------
proc xdnd::_selection_ownership_lost {} {
variable _dragging
set _dragging 0
};# _selection_ownership_lost
# ----------------------------------------------------------------------------
# Command xdnd::_dodragdrop
# ----------------------------------------------------------------------------
proc xdnd::_dodragdrop { source actions types data button } {
variable _dragging
# 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"
}
variable _dodragdrop_drag_source $source
variable _dodragdrop_drop_target 0
variable _dodragdrop_drop_target_proxy 0
variable _dodragdrop_actions $actions
variable _dodragdrop_action_descriptions $actions
variable _dodragdrop_actions_len [llength $actions]
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
variable _dodragdrop_waiting_status 0
variable _dodragdrop_drop_target_accepts_drop 0
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
## the drag source widget...
##
if {$_dodragdrop_types_len > 3} {
_announce_type_list $_dodragdrop_drag_source $_dodragdrop_types
}
##
## Announce the actions & their descriptions on the XdndActionList &
## XdndActionDescription properties...
##
_announce_action_list $_dodragdrop_drag_source $_dodragdrop_actions \
$_dodragdrop_action_descriptions
##
## Arrange selection handlers for our drag source, and all the supported types
##
registerSelectionHandler $source $types
##
## Step 1: When a drag begins, the source takes ownership of XdndSelection.
##
selection own -command ::tkdnd::xdnd::_selection_ownership_lost \
-selection XdndSelection $source
set _dragging 1
## Grab the mouse pointer...
_grab_pointer $source $_dodragdrop_default_action
## Register our generic event handler...
# The generic event callback will report events by modifying variable
# ::xdnd::_dodragdrop_event: a dict with event information will be set as
# the value of the variable...
_register_generic_event_handler
## Set a timeout for debugging purposes...
# after 60000 {set ::tkdnd::xdnd::_dragging 0}
tkwait variable ::tkdnd::xdnd::_dragging
_SendXdndLeave
set _dragging 0
_ungrab_pointer $source
_unregister_generic_event_handler
catch {selection clear -selection XdndSelection}
unregisterSelectionHandler $source $types
return $_dodragdrop_drop_target_accepts_action
};# 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]
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 $type {
MotionNotify {
set rootx [dict get $event x_root]
set rooty [dict get $event y_root]
set window [_find_drop_target_window $_dodragdrop_drag_source \
$rootx $rooty]
if {[string length $window]} {
## Examine the modifiers to suggest an action...
set _dodragdrop_default_action [_default_action $event]
## Is it a Tk widget?
# set path [winfo containing $rootx $rooty]
# puts "Window under mouse: $window ($path)"
if {$_dodragdrop_drop_target != $window} {
## Send XdndLeave to $_dodragdrop_drop_target
_SendXdndLeave
## Is there a proxy? If not, _find_drop_target_proxy returns the
## target window, so we always get a valid "proxy".
set proxy [_find_drop_target_proxy $_dodragdrop_drag_source $window]
## Send XdndEnter to $window
_SendXdndEnter $window $proxy
## Send XdndPosition to $_dodragdrop_drop_target
_SendXdndPosition $rootx $rooty $_dodragdrop_default_action
} else {
## Send XdndPosition to $_dodragdrop_drop_target
_SendXdndPosition $rootx $rooty $_dodragdrop_default_action
}
} else {
## No window under the mouse. Send XdndLeave to $_dodragdrop_drop_target
_SendXdndLeave
}
}
ButtonPress {
}
ButtonRelease {
variable _dodragdrop_button
set button [dict get $event button]
if {$button == $_dodragdrop_button} {
## The button that initiated the drag was released. Trigger drop...
_SendXdndDrop
}
return 1
}
KeyPress {
}
KeyRelease {
set keysym [dict get $event keysym]
switch $keysym {
Escape {
## The user has pressed escape. Abort...
if {$_dragging} {set _dragging 0}
}
}
}
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
}
}
return 0
};# _process_drag_events
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndEnter
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndEnter {window proxy} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_types
variable _dodragdrop_waiting_status
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_target > 0} _SendXdndLeave
if {$_dodragdrop_drop_occured} return
set _dodragdrop_drop_target $window
set _dodragdrop_drop_target_proxy $proxy
set _dodragdrop_waiting_status 0
if {$_dodragdrop_drop_target < 1} return
# puts "XdndEnter: $_dodragdrop_drop_target $_dodragdrop_drop_target_proxy"
_send_XdndEnter $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy $_dodragdrop_types
};# xdnd::_SendXdndEnter
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndPosition
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndPosition {rootx rooty action} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_waiting_status
## Arrange a new XdndPosition, to be send periodically...
variable _dodragdrop_xdnd_position_heartbeat
catch {after cancel $_dodragdrop_xdnd_position_heartbeat}
set _dodragdrop_xdnd_position_heartbeat [after 200 \
[list ::tkdnd::xdnd::_SendXdndPosition $rootx $rooty $action]]
if {$_dodragdrop_waiting_status} {return}
# puts "XdndPosition: $_dodragdrop_drop_target $rootx $rooty $action"
_send_XdndPosition $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy $rootx $rooty $action
set _dodragdrop_waiting_status 1
};# xdnd::_SendXdndPosition
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndStatus
# ----------------------------------------------------------------------------
proc xdnd::_HandleXdndStatus {event} {
variable _dodragdrop_drop_target
variable _dodragdrop_waiting_status
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_waiting_status 0
foreach key {target accept want_position action x y w h} {
set $key [dict get $event $key]
}
set _dodragdrop_drop_target_accepts_drop $accept
set _dodragdrop_drop_target_accepts_action $action
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
_update_cursor
# puts "XdndStatus: $event"
};# xdnd::_HandleXdndStatus
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndFinished
# ----------------------------------------------------------------------------
proc xdnd::_HandleXdndFinished {event} {
variable _dodragdrop_xdnd_finished_event_after_id
catch {after cancel $_dodragdrop_xdnd_finished_event_after_id}
set _dodragdrop_xdnd_finished_event_after_id {}
variable _dodragdrop_drop_target
set _dodragdrop_drop_target 0
variable _dragging
if {$_dragging} {set _dragging 0}
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
if {[dict size $event]} {
foreach key {target accept action} {
set $key [dict get $event $key]
}
set _dodragdrop_drop_target_accepts_drop $accept
set _dodragdrop_drop_target_accepts_action $action
} else {
set _dodragdrop_drop_target_accepts_drop 0
}
if {!$_dodragdrop_drop_target_accepts_drop} {
set _dodragdrop_drop_target_accepts_action refuse_drop
}
# puts "XdndFinished: $event"
};# xdnd::_HandleXdndFinished
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndLeave
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndLeave {} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_target_proxy
# puts "XdndLeave: $_dodragdrop_drop_target"
_send_XdndLeave $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy
set _dodragdrop_drop_target 0
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_drop_target_accepts_drop 0
set _dodragdrop_drop_target_accepts_action refuse_drop
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
_update_cursor
};# xdnd::_SendXdndLeave
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndDrop {} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} {
## The mouse has been released over a widget that does not accept drops.
_HandleXdndFinished {}
return
}
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} {return}
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_drop_occured 1
_update_cursor clock
if {!$_dodragdrop_drop_target_accepts_drop} {
_SendXdndLeave
_HandleXdndFinished {}
return
}
# puts "XdndDrop: $_dodragdrop_drop_target"
variable _dodragdrop_drop_timestamp
set _dodragdrop_drop_timestamp [_send_XdndDrop \
$_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy]
set _dodragdrop_drop_target 0
# puts "XdndDrop: $_dodragdrop_drop_target"
## Arrange a timeout for receiving XdndFinished...
variable _dodragdrop_xdnd_finished_event_after_id
set _dodragdrop_xdnd_finished_event_after_id \
[after 10000 [list ::tkdnd::xdnd::_HandleXdndFinished {}]]
};# xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
# Command xdnd::_update_cursor
# ----------------------------------------------------------------------------
proc xdnd::_update_cursor { {cursor {}}} {
# puts "_update_cursor $cursor"
variable _dodragdrop_current_cursor
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
if {![string length $cursor]} {
set cursor refuse_drop
if {$_dodragdrop_drop_target_accepts_drop} {
set cursor $_dodragdrop_drop_target_accepts_action
}
}
if {![string equal $cursor $_dodragdrop_current_cursor]} {
_set_pointer_cursor $_dodragdrop_drag_source $cursor
set _dodragdrop_current_cursor $cursor
}
};# xdnd::_update_cursor
# ----------------------------------------------------------------------------
# Command xdnd::_default_action
# ----------------------------------------------------------------------------
proc xdnd::_default_action {event} {
variable _dodragdrop_actions
variable _dodragdrop_actions_len
if {$_dodragdrop_actions_len == 1} {return [lindex $_dodragdrop_actions 0]}
set alt [dict get $event Alt]
set shift [dict get $event Shift]
set control [dict get $event Control]
if {$shift && $control && [lsearch $_dodragdrop_actions link] != -1} {
return link
} elseif {$control && [lsearch $_dodragdrop_actions copy] != -1} {
return copy
} elseif {$shift && [lsearch $_dodragdrop_actions move] != -1} {
return move
} elseif {$alt && [lsearch $_dodragdrop_actions link] != -1} {
return link
}
return default
};# xdnd::_default_action
# ----------------------------------------------------------------------------
# Command xdnd::getFormatForType
# ----------------------------------------------------------------------------
proc xdnd::getFormatForType {type} {
switch -glob [string tolower $type] {
text/plain\;charset=utf-8 -
text/html\;charset=utf-8 -
utf8_string {set format UTF8_STRING}
text/html -
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_types
variable _dodragdrop_data
variable _dodragdrop_transfer_data
## The variable _dodragdrop_data contains a list of data, one for each
## type in the _dodragdrop_types variable. We have to search types, and find
## the corresponding entry in the _dodragdrop_data list.
set index [lsearch $_dodragdrop_types $type]
if {$index < 0} {
error "unable to locate data suitable for type \"$type\""
}
set typed_data [lindex $_dodragdrop_data $index]
set format 8
if {$offset == 0} {
## Prepare the data to be transferred...
switch -glob $type {
text/plain* - UTF8_STRING - STRING - TEXT - COMPOUND_TEXT {
binary scan [encoding convertto utf-8 $typed_data] \
c* _dodragdrop_transfer_data
set _dodragdrop_transfer_data \
[_convert_to_unsigned $_dodragdrop_transfer_data $format]
}
text/uri-list* {
set files [list]
foreach file $typed_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 $typed_data] {
1 { set color [winfo rgb $_dodragdrop_drag_source $typed_data]
lappend color 65535 }
3 { set color $typed_data; lappend color 65535 }
4 { set color $typed_data }
default {error "unknown color data: \"$typed_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 $typed_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 ($typed_data)"
# puts " $data"
return $data
};# xdnd::_SendData

View File

@ -1,252 +0,0 @@
#
# tkdnd_utils.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
package require tkdnd
namespace eval ::tkdnd {
namespace eval utils {
};# namespace ::tkdnd::utils
namespace eval text {
variable _drag_tag tkdnd::drag::selection::tag
variable _state {}
variable _drag_source_widget {}
variable _drop_target_widget {}
variable _now_dragging 0
};# namespace ::tkdnd::text
};# namespace ::tkdnd
bind TkDND_Drag_Text1 <ButtonPress-1> {tkdnd::text::_begin_drag clear 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text1 <B1-Motion> {tkdnd::text::_begin_drag motion 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text1 <B1-Leave> {tkdnd::text::_TextAutoScan %W %x %y}
bind TkDND_Drag_Text1 <ButtonRelease-1> {tkdnd::text::_begin_drag reset 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <ButtonPress-2> {tkdnd::text::_begin_drag clear 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <B2-Motion> {tkdnd::text::_begin_drag motion 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <ButtonRelease-2> {tkdnd::text::_begin_drag reset 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <ButtonPress-3> {tkdnd::text::_begin_drag clear 3 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <B3-Motion> {tkdnd::text::_begin_drag motion 3 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <ButtonRelease-3> {tkdnd::text::_begin_drag reset 3 %W %s %X %Y %x %y}
# ----------------------------------------------------------------------------
# Command tkdnd::text::drag_source
# ----------------------------------------------------------------------------
proc ::tkdnd::text::drag_source { mode path { types DND_Text } { event 1 } { tagprefix TkDND_Drag_Text } { tag sel } } {
switch -exact -- $mode {
register {
$path tag bind $tag <ButtonPress-${event}> \
"tkdnd::text::_begin_drag press ${event} %W %s %X %Y %x %y"
## Set a binding to the widget, to put selection as data...
bind $path <<DragInitCmd>> "::tkdnd::text::DragInitCmd $path {%t} $tag"
## Set a binding to the widget, to remove selection if action is move...
bind $path <<DragEndCmd>> "::tkdnd::text::DragEndCmd $path %A $tag"
}
unregister {
$path tag bind $tag <ButtonPress-${event}> {}
bind $path <<DragInitCmd>> {}
bind $path <<DragEndCmd>> {}
}
}
::tkdnd::drag_source $mode $path $types $event $tagprefix
};# ::tkdnd::text::drag_source
# ----------------------------------------------------------------------------
# Command tkdnd::text::drop_target
# ----------------------------------------------------------------------------
proc ::tkdnd::text::drop_target { mode path { types DND_Text } } {
switch -exact -- $mode {
register {
bind $path <<DropPosition>> "::tkdnd::text::DropPosition $path %X %Y %A %a %m"
bind $path <<Drop>> "::tkdnd::text::Drop $path %D %X %Y %A %a %m"
}
unregister {
bind $path <<DropEnter>> {}
bind $path <<DropPosition>> {}
bind $path <<DropLeave>> {}
bind $path <<Drop>> {}
}
}
::tkdnd::drop_target $mode $path $types
};# ::tkdnd::text::drop_target
# ----------------------------------------------------------------------------
# Command tkdnd::text::DragInitCmd
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DragInitCmd { path { types DND_Text } { tag sel } { actions { copy move } } } {
## Save the selection indices...
variable _drag_source_widget
variable _drop_target_widget
set _drag_source_widget $path
set _drop_target_widget {}
_save_selection $path $tag
list $actions $types [$path get $tag.first $tag.last]
};# ::tkdnd::text::DragInitCmd
# ----------------------------------------------------------------------------
# Command tkdnd::text::DragEndCmd
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DragEndCmd { path action { tag sel } } {
variable _drag_source_widget
variable _drop_target_widget
set _drag_source_widget {}
set _drop_target_widget {}
_restore_selection $path $tag
switch -exact -- $action {
move {
## Delete the original selected text...
variable _selection_first
variable _selection_last
$path delete $_selection_first $_selection_last
}
}
};# ::tkdnd::text::DragEndCmd
# ----------------------------------------------------------------------------
# Command tkdnd::text::DropPosition
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DropPosition { path X Y action actions keys} {
variable _drag_source_widget
variable _drop_target_widget
set _drop_target_widget $path
## This check is primitive, a more accurate one is needed!
if {$path eq $_drag_source_widget} {
## This is a drag within the same widget! Set action to move...
if {"move" in $actions} {set action move}
}
incr X -[winfo rootx $path]
incr Y -[winfo rooty $path]
$path mark set insert @$X,$Y; update
return $action
};# ::tkdnd::text::DropPosition
# ----------------------------------------------------------------------------
# Command tkdnd::text::Drop
# ----------------------------------------------------------------------------
proc ::tkdnd::text::Drop { path data X Y action actions keys } {
incr X -[winfo rootx $path]
incr Y -[winfo rooty $path]
$path mark set insert @$X,$Y
$path insert [$path index insert] $data
return $action
};# ::tkdnd::text::Drop
# ----------------------------------------------------------------------------
# Command tkdnd::text::_save_selection
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_save_selection { path tag} {
variable _drag_tag
variable _selection_first
variable _selection_last
variable _selection_tag $tag
set _selection_first [$path index $tag.first]
set _selection_last [$path index $tag.last]
$path tag add $_drag_tag $_selection_first $_selection_last
$path tag configure $_drag_tag \
-background [$path tag cget $tag -background] \
-foreground [$path tag cget $tag -foreground]
};# tkdnd::text::_save_selection
# ----------------------------------------------------------------------------
# Command tkdnd::text::_restore_selection
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_restore_selection { path tag} {
variable _drag_tag
variable _selection_first
variable _selection_last
$path tag delete $_drag_tag
$path tag remove $tag 0.0 end
#$path tag add $tag $_selection_first $_selection_last
};# tkdnd::text::_restore_selection
# ----------------------------------------------------------------------------
# Command tkdnd::text::_begin_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_begin_drag { event button source state X Y x y } {
variable _drop_target_widget
variable _state
# puts "::tkdnd::text::_begin_drag $event $button $source $state $X $Y $x $y"
switch -exact -- $event {
clear {
switch -exact -- $_state {
press {
## Do not execute other bindings, as they will erase selection...
return -code break
}
}
set _state clear
}
motion {
variable _now_dragging
if {$_now_dragging} {return -code break}
if { [string equal $_state "press"] } {
variable _x0; variable _y0
if { abs($_x0-$X) > ${::tkdnd::_dx} || abs($_y0-$Y) > ${::tkdnd::_dy} } {
set _state "done"
set _drop_target_widget {}
set _now_dragging 1
set code [catch {
::tkdnd::_init_drag $button $source $state $X $Y $x $y
} info options]
set _drop_target_widget {}
set _now_dragging 0
if {$code != 0} {
## Something strange occurred...
return -options $options $info
}
}
return -code break
}
set _state clear
}
press {
variable _x0; variable _y0
set _x0 $X
set _y0 $Y
set _state "press"
}
reset {
set _state {}
}
}
if {$source eq $_drop_target_widget} {return -code break}
return -code continue
};# tkdnd::text::_begin_drag
proc tkdnd::text::_TextAutoScan {w x y} {
variable _now_dragging
if {$_now_dragging} {return -code break}
return -code continue
};# tkdnd::text::_TextAutoScan

View File

@ -1,167 +0,0 @@
#
# tkdnd_windows.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval olednd {
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
CF_UNICODETEXT DND_Text \
CF_TEXT DND_Text \
CF_HDROP DND_Files \
UniformResourceLocator DND_URL \
CF_HTML DND_HTML \
{HTML Format} DND_HTML \
CF_RTF DND_RTF \
CF_RTFTEXT DND_RTF \
{Rich Text Format} DND_RTF \
]
# FileGroupDescriptorW DND_Files \
# FileGroupDescriptor DND_Files \
## Mapping from TkDND types to platform types...
::tkdnd::generic::initialise_tkdnd_to_platform_types [list \
DND_Text {CF_UNICODETEXT CF_TEXT} \
DND_Files {CF_HDROP} \
DND_URL {UniformResourceLocator UniformResourceLocatorW} \
DND_HTML {CF_HTML {HTML Format}} \
DND_RTF {CF_RTF CF_RTFTEXT {Rich Text Format}} \
]
};# initialise
};# namespace olednd
# ----------------------------------------------------------------------------
# Command olednd::HandleDragEnter
# ----------------------------------------------------------------------------
proc olednd::HandleDragEnter { drop_target typelist actionlist pressedkeys
rootX rootY codelist { data {} } } {
::tkdnd::generic::SetDroppedData $data
focus $drop_target
::tkdnd::generic::HandleEnter $drop_target 0 $typelist \
$codelist $actionlist $pressedkeys
set action [::tkdnd::generic::HandlePosition $drop_target {} \
$pressedkeys $rootX $rootY]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDragEnter
# ----------------------------------------------------------------------------
# Command olednd::HandleDragOver
# ----------------------------------------------------------------------------
proc olednd::HandleDragOver { drop_target pressedkeys rootX rootY } {
set action [::tkdnd::generic::HandlePosition $drop_target {} \
$pressedkeys $rootX $rootY]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDragOver
# ----------------------------------------------------------------------------
# Command olednd::HandleDragLeave
# ----------------------------------------------------------------------------
proc olednd::HandleDragLeave { drop_target } {
::tkdnd::generic::HandleLeave
if {$::tkdnd::_auto_update} {update idletasks}
};# olednd::HandleDragLeave
# ----------------------------------------------------------------------------
# Command olednd::HandleDrop
# ----------------------------------------------------------------------------
proc olednd::HandleDrop { drop_target pressedkeys rootX rootY type data } {
::tkdnd::generic::SetDroppedData [normalise_data $type $data]
set action [::tkdnd::generic::HandleDrop $drop_target {} \
$pressedkeys $rootX $rootY 0]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDrop
# ----------------------------------------------------------------------------
# Command olednd::GetDataType
# ----------------------------------------------------------------------------
proc olednd::GetDataType { drop_target typelist } {
foreach {drop_target common_drag_source_types common_drop_target_types} \
[::tkdnd::generic::FindWindowWithCommonTypes $drop_target $typelist] {break}
lindex $common_drag_source_types 0
};# olednd::GetDataType
# ----------------------------------------------------------------------------
# Command olednd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc olednd::GetDragSourceCommonTypes { drop_target } {
::tkdnd::generic::GetDragSourceCommonTypes
};# olednd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command olednd::platform_specific_types
# ----------------------------------------------------------------------------
proc olednd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # olednd::platform_specific_types
# ----------------------------------------------------------------------------
# Command olednd::platform_specific_type
# ----------------------------------------------------------------------------
proc olednd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # olednd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command olednd::platform_independent_type
# ----------------------------------------------------------------------------
proc olednd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # olednd::platform_independent_type
# ----------------------------------------------------------------------------
# Command olednd::normalise_data
# ----------------------------------------------------------------------------
proc olednd::normalise_data { type data } {
switch [lindex [::tkdnd::generic::platform_independent_type $type] 0] {
DND_Text {return $data}
DND_Files {return $data}
DND_HTML {return [encoding convertfrom utf-8 $data]}
default {return $data}
}
}; # olednd::normalise_data

Binary file not shown.

View File

@ -1,10 +0,0 @@
#
# Tcl package index file
#
package ifneeded tkdnd 2.9.2 \
"source \{$dir/tkdnd.tcl\} ; \
tkdnd::initialise \{$dir\} libtkdnd2.9.2.dylib tkdnd"
package ifneeded tkdnd::utils 2.9.2 \
"source \{$dir/tkdnd_utils.tcl\} ; \
package provide tkdnd::utils 2.9.2"

View File

@ -1,469 +0,0 @@
#
# tkdnd.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
package require Tk
namespace eval ::tkdnd {
variable _topw ".drag"
variable _tabops
variable _state
variable _x0
variable _y0
variable _platform_namespace
variable _drop_file_temp_dir
variable _auto_update 1
variable _dx 3 ;# The difference in pixels before a drag is initiated.
variable _dy 3 ;# The difference in pixels before a drag is initiated.
variable _windowingsystem
bind TkDND_Drag1 <ButtonPress-1> {tkdnd::_begin_drag press 1 %W %s %X %Y %x %y}
bind TkDND_Drag1 <B1-Motion> {tkdnd::_begin_drag motion 1 %W %s %X %Y %x %y}
bind TkDND_Drag2 <ButtonPress-2> {tkdnd::_begin_drag press 2 %W %s %X %Y %x %y}
bind TkDND_Drag2 <B2-Motion> {tkdnd::_begin_drag motion 2 %W %s %X %Y %x %y}
bind TkDND_Drag3 <ButtonPress-3> {tkdnd::_begin_drag press 3 %W %s %X %Y %x %y}
bind TkDND_Drag3 <B3-Motion> {tkdnd::_begin_drag motion 3 %W %s %X %Y %x %y}
# ----------------------------------------------------------------------------
# Command tkdnd::initialise: Initialise the TkDND package.
# ----------------------------------------------------------------------------
proc initialise { dir PKG_LIB_FILE PACKAGE_NAME} {
variable _platform_namespace
variable _drop_file_temp_dir
variable _windowingsystem
global env
switch [tk windowingsystem] {
x11 {
set _windowingsystem x11
}
win32 -
windows {
set _windowingsystem windows
}
aqua {
set _windowingsystem aqua
}
default {
error "unknown Tk windowing system"
}
}
## Get User's home directory: We try to locate the proper path from a set of
## environmental variables...
foreach var {HOME HOMEPATH USERPROFILE ALLUSERSPROFILE APPDATA} {
if {[info exists env($var)]} {
if {[file isdirectory $env($var)]} {
set UserHomeDir $env($var)
break
}
}
}
## Should use [tk windowingsystem] instead of tcl platform array:
## OS X returns "unix," but that's not useful because it has its own
## windowing system, aqua
## Under windows we have to also combine HOMEDRIVE & HOMEPATH...
if {![info exists UserHomeDir] &&
[string equal $_windowingsystem windows] &&
[info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)]} {
if {[file isdirectory $env(HOMEDRIVE)$env(HOMEPATH)]} {
set UserHomeDir $env(HOMEDRIVE)$env(HOMEPATH)
}
}
## Have we located the needed path?
if {![info exists UserHomeDir]} {
set UserHomeDir [pwd]
}
set UserHomeDir [file normalize $UserHomeDir]
## Try to locate a temporary directory...
foreach var {TKDND_TEMP_DIR TEMP TMP} {
if {[info exists env($var)]} {
if {[file isdirectory $env($var)] && [file writable $env($var)]} {
set _drop_file_temp_dir $env($var)
break
}
}
}
if {![info exists _drop_file_temp_dir]} {
foreach _dir [list "$UserHomeDir/Local Settings/Temp" \
"$UserHomeDir/AppData/Local/Temp" \
/tmp \
C:/WINDOWS/Temp C:/Temp C:/tmp \
D:/WINDOWS/Temp D:/Temp D:/tmp] {
if {[file isdirectory $_dir] && [file writable $_dir]} {
set _drop_file_temp_dir $_dir
break
}
}
}
if {![info exists _drop_file_temp_dir]} {
set _drop_file_temp_dir $UserHomeDir
}
set _drop_file_temp_dir [file native $_drop_file_temp_dir]
source $dir/tkdnd_generic.tcl
switch $_windowingsystem {
x11 {
source $dir/tkdnd_unix.tcl
set _platform_namespace xdnd
}
win32 -
windows {
source $dir/tkdnd_windows.tcl
set _platform_namespace olednd
}
aqua {
source $dir/tkdnd_macosx.tcl
set _platform_namespace macdnd
}
default {
error "unknown Tk windowing system"
}
}
load $dir/$PKG_LIB_FILE $PACKAGE_NAME
source $dir/tkdnd_compat.tcl
${_platform_namespace}::initialise
};# initialise
proc GetDropFileTempDirectory { } {
variable _drop_file_temp_dir
return $_drop_file_temp_dir
}
proc SetDropFileTempDirectory { dir } {
variable _drop_file_temp_dir
set _drop_file_temp_dir $dir
}
};# namespace ::tkdnd
# ----------------------------------------------------------------------------
# Command tkdnd::drag_source
# ----------------------------------------------------------------------------
proc ::tkdnd::drag_source { mode path { types {} } { event 1 }
{ tagprefix TkDND_Drag } } {
set tags [bindtags $path]
set idx [lsearch $tags ${tagprefix}$event]
switch -- $mode {
register {
if { $idx != -1 } {
## No need to do anything!
# bindtags $path [lreplace $tags $idx $idx ${tagprefix}$event]
} else {
bindtags $path [linsert $tags 1 ${tagprefix}$event]
}
_drag_source_update_types $path $types
}
unregister {
if { $idx != -1 } {
bindtags $path [lreplace $tags $idx $idx]
}
}
}
};# tkdnd::drag_source
proc ::tkdnd::_drag_source_update_types { path types } {
set types [platform_specific_types $types]
set old_types [bind $path <<DragSourceTypes>>]
foreach type $types {
if {[lsearch $old_types $type] < 0} {lappend old_types $type}
}
bind $path <<DragSourceTypes>> $old_types
};# ::tkdnd::_drag_source_update_types
# ----------------------------------------------------------------------------
# Command tkdnd::drop_target
# ----------------------------------------------------------------------------
proc ::tkdnd::drop_target { mode path { types {} } } {
variable _windowingsystem
set types [platform_specific_types $types]
switch -- $mode {
register {
switch $_windowingsystem {
x11 {
_register_types $path [winfo toplevel $path] $types
}
win32 -
windows {
_RegisterDragDrop $path
bind <Destroy> $path {+ tkdnd::_RevokeDragDrop %W}
}
aqua {
macdnd::registerdragwidget [winfo toplevel $path] $types
}
default {
error "unknown Tk windowing system"
}
}
set old_types [bind $path <<DropTargetTypes>>]
set new_types {}
foreach type $types {
if {[lsearch -exact $old_types $type] < 0} {lappend new_types $type}
}
if {[llength $new_types]} {
bind $path <<DropTargetTypes>> [concat $old_types $new_types]
}
}
unregister {
switch $_windowingsystem {
x11 {
}
win32 -
windows {
_RevokeDragDrop $path
}
aqua {
error todo
}
default {
error "unknown Tk windowing system"
}
}
bind $path <<DropTargetTypes>> {}
}
}
};# tkdnd::drop_target
# ----------------------------------------------------------------------------
# Command tkdnd::_begin_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_begin_drag { event button source state X Y x y } {
variable _x0
variable _y0
variable _state
switch -- $event {
press {
set _x0 $X
set _y0 $Y
set _state "press"
}
motion {
if { ![info exists _state] } {
# This is just extra protection. There seem to be
# rare cases where the motion comes before the press.
return
}
if { [string equal $_state "press"] } {
variable _dx
variable _dy
if { abs($_x0-$X) > ${_dx} || abs($_y0-$Y) > ${_dy} } {
set _state "done"
_init_drag $button $source $state $X $Y $x $y
}
}
}
}
};# tkdnd::_begin_drag
# ----------------------------------------------------------------------------
# Command tkdnd::_init_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_init_drag { button source state rootX rootY X Y } {
# Call the <<DragInitCmd>> binding.
set cmd [bind $source <<DragInitCmd>>]
# puts "CMD: $cmd"
if {[string length $cmd]} {
set cmd [string map [list %W $source %X $rootX %Y $rootY %x $X %y $Y \
%S $state %e <<DragInitCmd>> %A \{\} %% % \
%t [bind $source <<DragSourceTypes>>]] $cmd]
set code [catch {uplevel \#0 $cmd} info options]
# puts "CODE: $code ---- $info"
switch -exact -- $code {
0 {}
3 - 4 {
# FRINK: nocheck
return
}
default {
return -options $options $info
}
}
set len [llength $info]
if {$len == 3} {
foreach { actions types _data } $info { break }
set types [platform_specific_types $types]
set data [list]
foreach type $types {
lappend data $_data
}
unset _data
} elseif {$len == 2} {
foreach { actions _data } $info { break }
set data [list]; set types [list]
foreach {t d} $_data {
foreach t [platform_specific_types $t] {
lappend types $t; lappend data $d
}
}
unset _data t d
} else {
if {$len == 1 && [string equal [lindex $actions 0] "refuse_drop"]} {
return
}
error "not enough items in the result of the <<DragInitCmd>>\
event binding. Either 2 or 3 items are expected. The command
executed was: \"$cmd\"\nResult was: \"$info\""
}
set action refuse_drop
variable _windowingsystem
# puts "Source: \"$source\""
# puts "Types: \"[join $types {", "}]\""
# puts "Actions: \"[join $actions {", "}]\""
# puts "Button: \"$button\""
# puts "Data: \"[string range $data 0 100]\""
switch $_windowingsystem {
x11 {
set action [xdnd::_dodragdrop $source $actions $types $data $button]
}
win32 -
windows {
set action [_DoDragDrop $source $actions $types $data $button]
}
aqua {
set action [macdnd::dodragdrop $source $actions $types $data $button]
}
default {
error "unknown Tk windowing system"
}
}
## Call _end_drag to notify the widget of the result of the drag
## operation...
_end_drag $button $source {} $action {} $data {} $state $rootX $rootY $X $Y
}
};# tkdnd::_init_drag
# ----------------------------------------------------------------------------
# Command tkdnd::_end_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_end_drag { button source target action type data result
state rootX rootY X Y } {
set rootX 0
set rootY 0
# Call the <<DragEndCmd>> binding.
set cmd [bind $source <<DragEndCmd>>]
if {[string length $cmd]} {
set cmd [string map [list %W $source %X $rootX %Y $rootY %x $X %y $Y %% % \
%S $state %e <<DragEndCmd>> %A \{$action\}] $cmd]
set info [uplevel \#0 $cmd]
# if { $info != "" } {
# variable _windowingsystem
# foreach { actions types data } $info { break }
# set types [platform_specific_types $types]
# switch $_windowingsystem {
# x11 {
# error "dragging from Tk widgets not yet supported"
# }
# win32 -
# windows {
# set action [_DoDragDrop $source $actions $types $data $button]
# }
# aqua {
# macdnd::dodragdrop $source $actions $types $data
# }
# default {
# error "unknown Tk windowing system"
# }
# }
# ## Call _end_drag to notify the widget of the result of the drag
# ## operation...
# _end_drag $button $source {} $action {} $data {} $state $rootX $rootY
# }
}
};# tkdnd::_end_drag
# ----------------------------------------------------------------------------
# Command tkdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_specific_types { types } {
variable _platform_namespace
${_platform_namespace}::platform_specific_types $types
}; # tkdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
variable _platform_namespace
${_platform_namespace}::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command tkdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_specific_type { type } {
variable _platform_namespace
${_platform_namespace}::platform_specific_type $type
}; # tkdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_type { type } {
variable _platform_namespace
${_platform_namespace}::platform_independent_type $type
}; # tkdnd::platform_independent_type
# ----------------------------------------------------------------------------
# Command tkdnd::bytes_to_string
# ----------------------------------------------------------------------------
proc ::tkdnd::bytes_to_string { bytes } {
set string {}
foreach byte $bytes {
append string [binary format c $byte]
}
return $string
};# tkdnd::bytes_to_string
# ----------------------------------------------------------------------------
# Command tkdnd::urn_unquote
# ----------------------------------------------------------------------------
proc ::tkdnd::urn_unquote {url} {
set result ""
set start 0
while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
foreach {first last} $match break
append result [string range $url $start [expr {$first - 1}]]
append result [format %c 0x[string range $url [incr first] $last]]
set start [incr last]
}
append result [string range $url $start end]
return [encoding convertfrom utf-8 $result]
};# tkdnd::urn_unquote

View File

@ -1,160 +0,0 @@
#
# tkdnd_compat.tcl --
#
# This file implements some utility procedures, to support older versions
# of the TkDND package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval compat {
};# namespace compat
# ----------------------------------------------------------------------------
# Command ::dnd
# ----------------------------------------------------------------------------
proc ::dnd {method window args} {
switch $method {
bindtarget {
switch [llength $args] {
0 {return [tkdnd::compat::bindtarget0 $window]}
1 {return [tkdnd::compat::bindtarget1 $window [lindex $args 0]]}
2 {return [tkdnd::compat::bindtarget2 $window [lindex $args 0] \
[lindex $args 1]]}
3 {return [tkdnd::compat::bindtarget3 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2]]}
4 {return [tkdnd::compat::bindtarget4 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2] [lindex $args 3]]}
}
}
cleartarget {
return [tkdnd::compat::cleartarget $window]
}
bindsource {
switch [llength $args] {
0 {return [tkdnd::compat::bindsource0 $window]}
1 {return [tkdnd::compat::bindsource1 $window [lindex $args 0]]}
2 {return [tkdnd::compat::bindsource2 $window [lindex $args 0] \
[lindex $args 1]]}
3 {return [tkdnd::compat::bindsource3 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2]]}
}
}
clearsource {
return [tkdnd::compat::clearsource $window]
}
drag {
return [tkdnd::_init_drag 1 $window "press" 0 0 0 0]
}
}
error "invalid number of arguments!"
};# ::dnd
# ----------------------------------------------------------------------------
# Command compat::bindtarget
# ----------------------------------------------------------------------------
proc compat::bindtarget0 {window} {
return [bind $window <<DropTargetTypes>>]
};# compat::bindtarget0
proc compat::bindtarget1 {window type} {
return [bindtarget2 $window $type <Drop>]
};# compat::bindtarget1
proc compat::bindtarget2 {window type event} {
switch $event {
<DragEnter> {return [bind $window <<DropEnter>>]}
<Drag> {return [bind $window <<DropPosition>>]}
<DragLeave> {return [bind $window <<DropLeave>>]}
<Drop> {return [bind $window <<Drop>>]}
}
};# compat::bindtarget2
proc compat::bindtarget3 {window type event script} {
set type [normalise_type $type]
::tkdnd::drop_target register $window [list $type]
switch $event {
<DragEnter> {return [bind $window <<DropEnter>> $script]}
<Drag> {return [bind $window <<DropPosition>> $script]}
<DragLeave> {return [bind $window <<DropLeave>> $script]}
<Drop> {return [bind $window <<Drop>> $script]}
}
};# compat::bindtarget3
proc compat::bindtarget4 {window type event script priority} {
return [bindtarget3 $window $type $event $script]
};# compat::bindtarget4
proc compat::normalise_type { type } {
switch $type {
text/plain -
{text/plain;charset=UTF-8} -
Text {return DND_Text}
text/uri-list -
Files {return DND_Files}
default {return $type}
}
};# compat::normalise_type
# ----------------------------------------------------------------------------
# Command compat::bindsource
# ----------------------------------------------------------------------------
proc compat::bindsource0 {window} {
return [bind $window <<DropTargetTypes>>]
};# compat::bindsource0
proc compat::bindsource1 {window type} {
return [bindsource2 $window $type <Drop>]
};# compat::bindsource1
proc compat::bindsource2 {window type script} {
set type [normalise_type $type]
::tkdnd::drag_source register $window $type
bind $window <<DragInitCmd>> "list {copy} {%t} \[$script\]"
};# compat::bindsource2
proc compat::bindsource3 {window type script priority} {
return [bindsource2 $window $type $script]
};# compat::bindsource3
# ----------------------------------------------------------------------------
# Command compat::cleartarget
# ----------------------------------------------------------------------------
proc compat::cleartarget {window} {
};# compat::cleartarget
# ----------------------------------------------------------------------------
# Command compat::clearsource
# ----------------------------------------------------------------------------
proc compat::clearsource {window} {
};# compat::clearsource

View File

@ -1,520 +0,0 @@
#
# tkdnd_generic.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval generic {
variable _types {}
variable _typelist {}
variable _codelist {}
variable _actionlist {}
variable _pressedkeys {}
variable _action {}
variable _common_drag_source_types {}
variable _common_drop_target_types {}
variable _drag_source {}
variable _drop_target {}
variable _last_mouse_root_x 0
variable _last_mouse_root_y 0
variable _tkdnd2platform
variable _platform2tkdnd
proc debug {msg} {
puts $msg
};# debug
proc initialise { } {
};# initialise
proc initialise_platform_to_tkdnd_types { types } {
variable _platform2tkdnd
variable _tkdnd2platform
set _platform2tkdnd [dict create {*}$types]
set _tkdnd2platform [dict create]
foreach type [dict keys $_platform2tkdnd] {
dict lappend _tkdnd2platform [dict get $_platform2tkdnd $type] $type
}
};# initialise_platform_to_tkdnd_types
proc initialise_tkdnd_to_platform_types { types } {
variable _tkdnd2platform
set _tkdnd2platform [dict create {*}$types]
};# initialise_tkdnd_to_platform_types
};# namespace generic
# ----------------------------------------------------------------------------
# Command generic::HandleEnter
# ----------------------------------------------------------------------------
proc generic::HandleEnter { drop_target drag_source typelist codelist
actionlist pressedkeys } {
variable _typelist; set _typelist $typelist
variable _pressedkeys; set _pressedkeys $pressedkeys
variable _action; set _action refuse_drop
variable _common_drag_source_types; set _common_drag_source_types {}
variable _common_drop_target_types; set _common_drop_target_types {}
variable _actionlist
variable _drag_source; set _drag_source $drag_source
variable _drop_target; set _drop_target {}
variable _actionlist; set _actionlist $actionlist
variable _codelist set _codelist $codelist
variable _last_mouse_root_x; set _last_mouse_root_x 0
variable _last_mouse_root_y; set _last_mouse_root_y 0
# debug "\n==============================================================="
# debug "generic::HandleEnter: drop_target=$drop_target,\
# drag_source=$drag_source,\
# typelist=$typelist"
# debug "generic::HandleEnter: ACTION: default"
return default
};# generic::HandleEnter
# ----------------------------------------------------------------------------
# Command generic::HandlePosition
# ----------------------------------------------------------------------------
proc generic::HandlePosition { drop_target drag_source pressedkeys
rootX rootY { time 0 } } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
# debug "generic::HandlePosition: drop_target=$drop_target,\
# _drop_target=$_drop_target, rootX=$rootX, rootY=$rootY"
if {![info exists _drag_source] && ![string length $_drag_source]} {
# debug "generic::HandlePosition: no or empty _drag_source:\
# return refuse_drop"
return refuse_drop
}
if {$drag_source ne "" && $drag_source ne $_drag_source} {
debug "generic position event from unexpected source: $_drag_source\
!= $drag_source"
return refuse_drop
}
set _pressedkeys $pressedkeys
## Does the new drop target support any of our new types?
# foreach {common_drag_source_types common_drop_target_types} \
# [GetWindowCommonTypes $drop_target $_typelist] {break}
foreach {drop_target common_drag_source_types common_drop_target_types} \
[FindWindowWithCommonTypes $drop_target $_typelist] {break}
set data [GetDroppedData $time]
# debug "\t($_drop_target) -> ($drop_target)"
if {$drop_target != $_drop_target} {
if {[string length $_drop_target]} {
## Call the <<DropLeave>> event.
# debug "\t<<DropLeave>> on $_drop_target"
set cmd [bind $_drop_target <<DropLeave>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A \{$_action\} %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D \{\} %e <<DropLeave>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
uplevel \#0 $cmd
}
}
set _drop_target $drop_target
set _action refuse_drop
if {[llength $common_drag_source_types]} {
set _action [lindex $_actionlist 0]
set _common_drag_source_types $common_drag_source_types
set _common_drop_target_types $common_drop_target_types
## Drop target supports at least one type. Send a <<DropEnter>>.
# puts "<<DropEnter>> -> $drop_target"
set cmd [bind $drop_target <<DropEnter>>]
if {[string length $cmd]} {
focus $drop_target
set cmd [string map [list %W $drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<DropEnter>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
}
}
}
set _drop_target {}
if {[llength $common_drag_source_types]} {
set _common_drag_source_types $common_drag_source_types
set _common_drop_target_types $common_drop_target_types
set _drop_target $drop_target
## Drop target supports at least one type. Send a <<DropPosition>>.
set cmd [bind $drop_target <<DropPosition>>]
if {[string length $cmd]} {
set cmd [string map [list %W $drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<DropPosition>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
}
# Return values: copy, move, link, ask, private, refuse_drop, default
# debug "generic::HandlePosition: ACTION: $_action"
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
};# generic::HandlePosition
# ----------------------------------------------------------------------------
# Command generic::HandleLeave
# ----------------------------------------------------------------------------
proc generic::HandleLeave { } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x
variable _last_mouse_root_y
if {![info exists _drop_target]} {set _drop_target {}}
# debug "generic::HandleLeave: _drop_target=$_drop_target"
if {[info exists _drop_target] && [string length $_drop_target]} {
set cmd [bind $_drop_target <<DropLeave>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target \
%X $_last_mouse_root_x %Y $_last_mouse_root_y \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A \{$_action\} %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D \{\} %e <<DropLeave>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
}
foreach var {_types _typelist _actionlist _pressedkeys _action
_common_drag_source_types _common_drop_target_types
_drag_source _drop_target} {
set $var {}
}
};# generic::HandleLeave
# ----------------------------------------------------------------------------
# Command generic::HandleDrop
# ----------------------------------------------------------------------------
proc generic::HandleDrop {drop_target drag_source pressedkeys rootX rootY time } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x
variable _last_mouse_root_y
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
set _pressedkeys $pressedkeys
# puts "generic::HandleDrop: $time"
if {![info exists _drag_source] && ![string length $_drag_source]} {
return refuse_drop
}
if {![info exists _drop_target] && ![string length $_drop_target]} {
return refuse_drop
}
if {![llength $_common_drag_source_types]} {return refuse_drop}
## Get the dropped data.
set data [GetDroppedData $time]
## Try to select the most specific <<Drop>> event.
foreach type [concat $_common_drag_source_types $_common_drop_target_types] {
set type [platform_independent_type $type]
set cmd [bind $_drop_target <<Drop:$type>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<Drop:$type>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
# Return values: copy, move, link, ask, private, refuse_drop
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
}
}
set cmd [bind $_drop_target <<Drop>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<Drop>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
# Return values: copy, move, link, ask, private, refuse_drop
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
};# generic::HandleDrop
# ----------------------------------------------------------------------------
# Command generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetWindowCommonTypes { win typelist } {
set types [bind $win <<DropTargetTypes>>]
# debug ">> Accepted types: $win $_types"
set common_drag_source_types {}
set common_drop_target_types {}
if {[llength $types]} {
## Examine the drop target types, to find at least one match with the drag
## source types...
set supported_types [supported_types $typelist]
foreach type $types {
foreach matched [lsearch -glob -all -inline $supported_types $type] {
## Drop target supports this type.
lappend common_drag_source_types $matched
lappend common_drop_target_types $type
}
}
}
list $common_drag_source_types $common_drop_target_types
};# generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
# Command generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
proc generic::FindWindowWithCommonTypes { win typelist } {
set toplevel [winfo toplevel $win]
while {![string equal $win $toplevel]} {
foreach {common_drag_source_types common_drop_target_types} \
[GetWindowCommonTypes $win $typelist] {break}
if {[llength $common_drag_source_types]} {
return [list $win $common_drag_source_types $common_drop_target_types]
}
set win [winfo parent $win]
}
## We have reached the toplevel, which may be also a target (SF Bug #30)
foreach {common_drag_source_types common_drop_target_types} \
[GetWindowCommonTypes $win $typelist] {break}
if {[llength $common_drag_source_types]} {
return [list $win $common_drag_source_types $common_drop_target_types]
}
return { {} {} {} }
};# generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
# Command generic::GetDroppedData
# ----------------------------------------------------------------------------
proc generic::GetDroppedData { time } {
variable _dropped_data
return $_dropped_data
};# generic::GetDroppedData
# ----------------------------------------------------------------------------
# Command generic::SetDroppedData
# ----------------------------------------------------------------------------
proc generic::SetDroppedData { data } {
variable _dropped_data
set _dropped_data $data
};# generic::SetDroppedData
# ----------------------------------------------------------------------------
# Command generic::GetDragSource
# ----------------------------------------------------------------------------
proc generic::GetDragSource { } {
variable _drag_source
return $_drag_source
};# generic::GetDragSource
# ----------------------------------------------------------------------------
# Command generic::GetDropTarget
# ----------------------------------------------------------------------------
proc generic::GetDropTarget { } {
variable _drop_target
return $_drop_target
};# generic::GetDropTarget
# ----------------------------------------------------------------------------
# Command generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDragSourceCommonTypes { } {
variable _common_drag_source_types
return $_common_drag_source_types
};# generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDropTargetCommonTypes { } {
variable _common_drag_source_types
return $_common_drag_source_types
};# generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
# Command generic::platform_specific_types
# ----------------------------------------------------------------------------
proc generic::platform_specific_types { types } {
set new_types {}
foreach type $types {
set new_types [concat $new_types [platform_specific_type $type]]
}
return $new_types
}; # generic::platform_specific_types
# ----------------------------------------------------------------------------
# Command generic::platform_specific_type
# ----------------------------------------------------------------------------
proc generic::platform_specific_type { type } {
variable _tkdnd2platform
if {[dict exists $_tkdnd2platform $type]} {
return [dict get $_tkdnd2platform $type]
}
list $type
}; # generic::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
set new_types {}
foreach type $types {
set new_types [concat $new_types [platform_independent_type $type]]
}
return $new_types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command generic::platform_independent_type
# ----------------------------------------------------------------------------
proc generic::platform_independent_type { type } {
variable _platform2tkdnd
if {[dict exists $_platform2tkdnd $type]} {
return [dict get $_platform2tkdnd $type]
}
return $type
}; # generic::platform_independent_type
# ----------------------------------------------------------------------------
# Command generic::supported_types
# ----------------------------------------------------------------------------
proc generic::supported_types { types } {
set new_types {}
foreach type $types {
if {[supported_type $type]} {lappend new_types $type}
}
return $new_types
}; # generic::supported_types
# ----------------------------------------------------------------------------
# Command generic::supported_type
# ----------------------------------------------------------------------------
proc generic::supported_type { type } {
variable _platform2tkdnd
if {[dict exists $_platform2tkdnd $type]} {
return 1
}
return 0
}; # generic::supported_type

View File

@ -1,144 +0,0 @@
#
# tkdnd_macosx.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
# This software is copyrighted by:
# Georgios Petasis, Athens, Greece.
# e-mail: petasisg@yahoo.gr, petasis@iit.demokritos.gr
#
# Mac portions (c) 2009 Kevin Walzer/WordTech Communications LLC,
# kw@codebykevin.com
#
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
#basic API for Mac Drag and Drop
#two data types supported: strings and file paths
#two commands at C level: ::tkdnd::macdnd::registerdragwidget, ::tkdnd::macdnd::unregisterdragwidget
#data retrieval mechanism: text or file paths are copied from drag clipboard to system clipboard and retrieved via [clipboard get]; array of file paths is converted to single tab-separated string, can be split into Tcl list
if {[tk windowingsystem] eq "aqua" && "AppKit" ni [winfo server .]} {
error {TkAqua Cocoa required}
}
namespace eval macdnd {
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
NSPasteboardTypeString DND_Text \
NSFilenamesPboardType DND_Files \
NSPasteboardTypeHTML DND_HTML \
]
};# initialise
};# namespace macdnd
# ----------------------------------------------------------------------------
# Command macdnd::HandleEnter
# ----------------------------------------------------------------------------
proc macdnd::HandleEnter { path drag_source typelist { data {} } } {
variable _pressedkeys
variable _actionlist
set _pressedkeys 1
set _actionlist { copy move link ask private }
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleEnter $path $drag_source $typelist $typelist \
$_actionlist $_pressedkeys
};# macdnd::HandleEnter
# ----------------------------------------------------------------------------
# Command macdnd::HandlePosition
# ----------------------------------------------------------------------------
proc macdnd::HandlePosition { drop_target rootX rootY {drag_source {}} } {
variable _pressedkeys
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
::tkdnd::generic::HandlePosition $drop_target $drag_source \
$_pressedkeys $rootX $rootY
};# macdnd::HandlePosition
# ----------------------------------------------------------------------------
# Command macdnd::HandleLeave
# ----------------------------------------------------------------------------
proc macdnd::HandleLeave { args } {
::tkdnd::generic::HandleLeave
};# macdnd::HandleLeave
# ----------------------------------------------------------------------------
# Command macdnd::HandleDrop
# ----------------------------------------------------------------------------
proc macdnd::HandleDrop { drop_target data args } {
variable _pressedkeys
variable _last_mouse_root_x
variable _last_mouse_root_y
## Get the dropped data...
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleDrop {} {} $_pressedkeys \
$_last_mouse_root_x $_last_mouse_root_y 0
};# macdnd::HandleDrop
# ----------------------------------------------------------------------------
# Command macdnd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc macdnd::GetDragSourceCommonTypes { } {
::tkdnd::generic::GetDragSourceCommonTypes
};# macdnd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command macdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc macdnd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # macdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command macdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc macdnd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # macdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command macdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc macdnd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # macdnd::platform_independent_type

View File

@ -1,810 +0,0 @@
#
# tkdnd_unix.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval xdnd {
variable _dragging 0
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
text/plain\;charset=utf-8 DND_Text \
UTF8_STRING DND_Text \
text/plain DND_Text \
STRING DND_Text \
TEXT DND_Text \
COMPOUND_TEXT DND_Text \
text/uri-list DND_Files \
text/html\;charset=utf-8 DND_HTML \
text/html DND_HTML \
application/x-color DND_Color \
]
};# initialise
};# namespace xdnd
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndEnter
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndEnter { path drag_source typelist time { data {} } } {
variable _pressedkeys
variable _actionlist
variable _typelist
set _pressedkeys 1
set _actionlist { copy move link ask private }
set _typelist $typelist
# puts "xdnd::HandleXdndEnter: $time"
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleEnter $path $drag_source $typelist $typelist \
$_actionlist $_pressedkeys
};# xdnd::HandleXdndEnter
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndPosition
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndPosition { drop_target rootX rootY time {drag_source {}} } {
variable _pressedkeys
variable _typelist
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
# puts "xdnd::HandleXdndPosition: $time"
## Get the dropped data...
catch {
::tkdnd::generic::SetDroppedData [GetPositionData $drop_target $_typelist $time]
}
::tkdnd::generic::HandlePosition $drop_target $drag_source \
$_pressedkeys $rootX $rootY
};# xdnd::HandleXdndPosition
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndLeave
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndLeave { } {
::tkdnd::generic::HandleLeave
};# xdnd::HandleXdndLeave
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndDrop
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndDrop { time } {
variable _pressedkeys
variable _last_mouse_root_x
variable _last_mouse_root_y
## Get the dropped data...
::tkdnd::generic::SetDroppedData [GetDroppedData \
[::tkdnd::generic::GetDragSource] [::tkdnd::generic::GetDropTarget] \
[::tkdnd::generic::GetDragSourceCommonTypes] $time]
::tkdnd::generic::HandleDrop {} {} $_pressedkeys \
$_last_mouse_root_x $_last_mouse_root_y $time
};# xdnd::HandleXdndDrop
# ----------------------------------------------------------------------------
# Command xdnd::GetPositionData
# ----------------------------------------------------------------------------
proc xdnd::GetPositionData { drop_target typelist time } {
foreach {drop_target common_drag_source_types common_drop_target_types} \
[::tkdnd::generic::FindWindowWithCommonTypes $drop_target $typelist] {break}
GetDroppedData [::tkdnd::generic::GetDragSource] $drop_target \
$common_drag_source_types $time
};# xdnd::GetPositionData
# ----------------------------------------------------------------------------
# Command xdnd::GetDroppedData
# ----------------------------------------------------------------------------
proc xdnd::GetDroppedData { _drag_source _drop_target _common_drag_source_types time } {
if {![llength $_common_drag_source_types]} {
error "no common data types between the drag source and drop target widgets"
}
## Is drag source in this application?
if {[catch {winfo pathname -displayof $_drop_target $_drag_source} p]} {
set _use_tk_selection 0
} else {
set _use_tk_selection 1
}
foreach type $_common_drag_source_types {
# puts "TYPE: $type ($_drop_target)"
# _get_selection $_drop_target $time $type
if {$_use_tk_selection} {
if {![catch {
selection get -displayof $_drop_target -selection XdndSelection \
-type $type
} result options]} {
return [normalise_data $type $result]
}
} else {
# puts "_selection_get -displayof $_drop_target -selection XdndSelection \
# -type $type -time $time"
#after 100 [list focus -force $_drop_target]
#after 50 [list raise [winfo toplevel $_drop_target]]
if {![catch {
_selection_get -displayof $_drop_target -selection XdndSelection \
-type $type -time $time
} result options]} {
return [normalise_data $type $result]
}
}
}
return -options $options $result
};# xdnd::GetDroppedData
# ----------------------------------------------------------------------------
# Command xdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc xdnd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # xdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command xdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc xdnd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # xdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command xdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc xdnd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # xdnd::platform_independent_type
# ----------------------------------------------------------------------------
# Command xdnd::_normalise_data
# ----------------------------------------------------------------------------
proc xdnd::normalise_data { type data } {
# Tk knows how to interpret the following types:
# STRING, TEXT, COMPOUND_TEXT
# UTF8_STRING
# Else, it returns a list of 8 or 32 bit numbers...
switch -glob $type {
STRING - UTF8_STRING - TEXT - COMPOUND_TEXT {return $data}
text/html {
if {[catch {
encoding convertfrom unicode $data
} string]} {
set string $data
}
return [string map {\r\n \n} $string]
}
text/html\;charset=utf-8 -
text/plain\;charset=utf-8 -
text/plain {
if {[catch {
encoding convertfrom utf-8 [tkdnd::bytes_to_string $data]
} string]} {
set string $data
}
return [string map {\r\n \n} $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 [tkdnd::urn_unquote $quoted_file]
switch -glob $file {
\#* {}
file://* {lappend files [string range $file 7 end]}
ftp://* -
https://* -
http://* {lappend files $quoted_file}
default {lappend files $file}
}
}
return $files
}
application/x-color {
return $data
}
text/x-moz-url -
application/q-iconlist -
default {return $data}
}
}; # xdnd::normalise_data
#############################################################################
##
## XDND drag implementation
##
#############################################################################
# ----------------------------------------------------------------------------
# Command xdnd::_selection_ownership_lost
# ----------------------------------------------------------------------------
proc xdnd::_selection_ownership_lost {} {
variable _dragging
set _dragging 0
};# _selection_ownership_lost
# ----------------------------------------------------------------------------
# Command xdnd::_dodragdrop
# ----------------------------------------------------------------------------
proc xdnd::_dodragdrop { source actions types data button } {
variable _dragging
# 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"
}
variable _dodragdrop_drag_source $source
variable _dodragdrop_drop_target 0
variable _dodragdrop_drop_target_proxy 0
variable _dodragdrop_actions $actions
variable _dodragdrop_action_descriptions $actions
variable _dodragdrop_actions_len [llength $actions]
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
variable _dodragdrop_waiting_status 0
variable _dodragdrop_drop_target_accepts_drop 0
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
## the drag source widget...
##
if {$_dodragdrop_types_len > 3} {
_announce_type_list $_dodragdrop_drag_source $_dodragdrop_types
}
##
## Announce the actions & their descriptions on the XdndActionList &
## XdndActionDescription properties...
##
_announce_action_list $_dodragdrop_drag_source $_dodragdrop_actions \
$_dodragdrop_action_descriptions
##
## Arrange selection handlers for our drag source, and all the supported types
##
registerSelectionHandler $source $types
##
## Step 1: When a drag begins, the source takes ownership of XdndSelection.
##
selection own -command ::tkdnd::xdnd::_selection_ownership_lost \
-selection XdndSelection $source
set _dragging 1
## Grab the mouse pointer...
_grab_pointer $source $_dodragdrop_default_action
## Register our generic event handler...
# The generic event callback will report events by modifying variable
# ::xdnd::_dodragdrop_event: a dict with event information will be set as
# the value of the variable...
_register_generic_event_handler
## Set a timeout for debugging purposes...
# after 60000 {set ::tkdnd::xdnd::_dragging 0}
tkwait variable ::tkdnd::xdnd::_dragging
_SendXdndLeave
set _dragging 0
_ungrab_pointer $source
_unregister_generic_event_handler
catch {selection clear -selection XdndSelection}
unregisterSelectionHandler $source $types
return $_dodragdrop_drop_target_accepts_action
};# 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]
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 $type {
MotionNotify {
set rootx [dict get $event x_root]
set rooty [dict get $event y_root]
set window [_find_drop_target_window $_dodragdrop_drag_source \
$rootx $rooty]
if {[string length $window]} {
## Examine the modifiers to suggest an action...
set _dodragdrop_default_action [_default_action $event]
## Is it a Tk widget?
# set path [winfo containing $rootx $rooty]
# puts "Window under mouse: $window ($path)"
if {$_dodragdrop_drop_target != $window} {
## Send XdndLeave to $_dodragdrop_drop_target
_SendXdndLeave
## Is there a proxy? If not, _find_drop_target_proxy returns the
## target window, so we always get a valid "proxy".
set proxy [_find_drop_target_proxy $_dodragdrop_drag_source $window]
## Send XdndEnter to $window
_SendXdndEnter $window $proxy
## Send XdndPosition to $_dodragdrop_drop_target
_SendXdndPosition $rootx $rooty $_dodragdrop_default_action
} else {
## Send XdndPosition to $_dodragdrop_drop_target
_SendXdndPosition $rootx $rooty $_dodragdrop_default_action
}
} else {
## No window under the mouse. Send XdndLeave to $_dodragdrop_drop_target
_SendXdndLeave
}
}
ButtonPress {
}
ButtonRelease {
variable _dodragdrop_button
set button [dict get $event button]
if {$button == $_dodragdrop_button} {
## The button that initiated the drag was released. Trigger drop...
_SendXdndDrop
}
return 1
}
KeyPress {
}
KeyRelease {
set keysym [dict get $event keysym]
switch $keysym {
Escape {
## The user has pressed escape. Abort...
if {$_dragging} {set _dragging 0}
}
}
}
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
}
}
return 0
};# _process_drag_events
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndEnter
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndEnter {window proxy} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_types
variable _dodragdrop_waiting_status
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_target > 0} _SendXdndLeave
if {$_dodragdrop_drop_occured} return
set _dodragdrop_drop_target $window
set _dodragdrop_drop_target_proxy $proxy
set _dodragdrop_waiting_status 0
if {$_dodragdrop_drop_target < 1} return
# puts "XdndEnter: $_dodragdrop_drop_target $_dodragdrop_drop_target_proxy"
_send_XdndEnter $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy $_dodragdrop_types
};# xdnd::_SendXdndEnter
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndPosition
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndPosition {rootx rooty action} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_waiting_status
## Arrange a new XdndPosition, to be send periodically...
variable _dodragdrop_xdnd_position_heartbeat
catch {after cancel $_dodragdrop_xdnd_position_heartbeat}
set _dodragdrop_xdnd_position_heartbeat [after 200 \
[list ::tkdnd::xdnd::_SendXdndPosition $rootx $rooty $action]]
if {$_dodragdrop_waiting_status} {return}
# puts "XdndPosition: $_dodragdrop_drop_target $rootx $rooty $action"
_send_XdndPosition $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy $rootx $rooty $action
set _dodragdrop_waiting_status 1
};# xdnd::_SendXdndPosition
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndStatus
# ----------------------------------------------------------------------------
proc xdnd::_HandleXdndStatus {event} {
variable _dodragdrop_drop_target
variable _dodragdrop_waiting_status
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_waiting_status 0
foreach key {target accept want_position action x y w h} {
set $key [dict get $event $key]
}
set _dodragdrop_drop_target_accepts_drop $accept
set _dodragdrop_drop_target_accepts_action $action
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
_update_cursor
# puts "XdndStatus: $event"
};# xdnd::_HandleXdndStatus
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndFinished
# ----------------------------------------------------------------------------
proc xdnd::_HandleXdndFinished {event} {
variable _dodragdrop_xdnd_finished_event_after_id
catch {after cancel $_dodragdrop_xdnd_finished_event_after_id}
set _dodragdrop_xdnd_finished_event_after_id {}
variable _dodragdrop_drop_target
set _dodragdrop_drop_target 0
variable _dragging
if {$_dragging} {set _dragging 0}
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
if {[dict size $event]} {
foreach key {target accept action} {
set $key [dict get $event $key]
}
set _dodragdrop_drop_target_accepts_drop $accept
set _dodragdrop_drop_target_accepts_action $action
} else {
set _dodragdrop_drop_target_accepts_drop 0
}
if {!$_dodragdrop_drop_target_accepts_drop} {
set _dodragdrop_drop_target_accepts_action refuse_drop
}
# puts "XdndFinished: $event"
};# xdnd::_HandleXdndFinished
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndLeave
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndLeave {} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_target_proxy
# puts "XdndLeave: $_dodragdrop_drop_target"
_send_XdndLeave $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy
set _dodragdrop_drop_target 0
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_drop_target_accepts_drop 0
set _dodragdrop_drop_target_accepts_action refuse_drop
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
_update_cursor
};# xdnd::_SendXdndLeave
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndDrop {} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} {
## The mouse has been released over a widget that does not accept drops.
_HandleXdndFinished {}
return
}
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} {return}
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_drop_occured 1
_update_cursor clock
if {!$_dodragdrop_drop_target_accepts_drop} {
_SendXdndLeave
_HandleXdndFinished {}
return
}
# puts "XdndDrop: $_dodragdrop_drop_target"
variable _dodragdrop_drop_timestamp
set _dodragdrop_drop_timestamp [_send_XdndDrop \
$_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy]
set _dodragdrop_drop_target 0
# puts "XdndDrop: $_dodragdrop_drop_target"
## Arrange a timeout for receiving XdndFinished...
variable _dodragdrop_xdnd_finished_event_after_id
set _dodragdrop_xdnd_finished_event_after_id \
[after 10000 [list ::tkdnd::xdnd::_HandleXdndFinished {}]]
};# xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
# Command xdnd::_update_cursor
# ----------------------------------------------------------------------------
proc xdnd::_update_cursor { {cursor {}}} {
# puts "_update_cursor $cursor"
variable _dodragdrop_current_cursor
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
if {![string length $cursor]} {
set cursor refuse_drop
if {$_dodragdrop_drop_target_accepts_drop} {
set cursor $_dodragdrop_drop_target_accepts_action
}
}
if {![string equal $cursor $_dodragdrop_current_cursor]} {
_set_pointer_cursor $_dodragdrop_drag_source $cursor
set _dodragdrop_current_cursor $cursor
}
};# xdnd::_update_cursor
# ----------------------------------------------------------------------------
# Command xdnd::_default_action
# ----------------------------------------------------------------------------
proc xdnd::_default_action {event} {
variable _dodragdrop_actions
variable _dodragdrop_actions_len
if {$_dodragdrop_actions_len == 1} {return [lindex $_dodragdrop_actions 0]}
set alt [dict get $event Alt]
set shift [dict get $event Shift]
set control [dict get $event Control]
if {$shift && $control && [lsearch $_dodragdrop_actions link] != -1} {
return link
} elseif {$control && [lsearch $_dodragdrop_actions copy] != -1} {
return copy
} elseif {$shift && [lsearch $_dodragdrop_actions move] != -1} {
return move
} elseif {$alt && [lsearch $_dodragdrop_actions link] != -1} {
return link
}
return default
};# xdnd::_default_action
# ----------------------------------------------------------------------------
# Command xdnd::getFormatForType
# ----------------------------------------------------------------------------
proc xdnd::getFormatForType {type} {
switch -glob [string tolower $type] {
text/plain\;charset=utf-8 -
text/html\;charset=utf-8 -
utf8_string {set format UTF8_STRING}
text/html -
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_types
variable _dodragdrop_data
variable _dodragdrop_transfer_data
## The variable _dodragdrop_data contains a list of data, one for each
## type in the _dodragdrop_types variable. We have to search types, and find
## the corresponding entry in the _dodragdrop_data list.
set index [lsearch $_dodragdrop_types $type]
if {$index < 0} {
error "unable to locate data suitable for type \"$type\""
}
set typed_data [lindex $_dodragdrop_data $index]
set format 8
if {$offset == 0} {
## Prepare the data to be transferred...
switch -glob $type {
text/plain* - UTF8_STRING - STRING - TEXT - COMPOUND_TEXT {
binary scan [encoding convertto utf-8 $typed_data] \
c* _dodragdrop_transfer_data
set _dodragdrop_transfer_data \
[_convert_to_unsigned $_dodragdrop_transfer_data $format]
}
text/uri-list* {
set files [list]
foreach file $typed_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 $typed_data] {
1 { set color [winfo rgb $_dodragdrop_drag_source $typed_data]
lappend color 65535 }
3 { set color $typed_data; lappend color 65535 }
4 { set color $typed_data }
default {error "unknown color data: \"$typed_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 $typed_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 ($typed_data)"
# puts " $data"
return $data
};# xdnd::_SendData

View File

@ -1,252 +0,0 @@
#
# tkdnd_utils.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
package require tkdnd
namespace eval ::tkdnd {
namespace eval utils {
};# namespace ::tkdnd::utils
namespace eval text {
variable _drag_tag tkdnd::drag::selection::tag
variable _state {}
variable _drag_source_widget {}
variable _drop_target_widget {}
variable _now_dragging 0
};# namespace ::tkdnd::text
};# namespace ::tkdnd
bind TkDND_Drag_Text1 <ButtonPress-1> {tkdnd::text::_begin_drag clear 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text1 <B1-Motion> {tkdnd::text::_begin_drag motion 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text1 <B1-Leave> {tkdnd::text::_TextAutoScan %W %x %y}
bind TkDND_Drag_Text1 <ButtonRelease-1> {tkdnd::text::_begin_drag reset 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <ButtonPress-2> {tkdnd::text::_begin_drag clear 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <B2-Motion> {tkdnd::text::_begin_drag motion 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <ButtonRelease-2> {tkdnd::text::_begin_drag reset 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <ButtonPress-3> {tkdnd::text::_begin_drag clear 3 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <B3-Motion> {tkdnd::text::_begin_drag motion 3 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <ButtonRelease-3> {tkdnd::text::_begin_drag reset 3 %W %s %X %Y %x %y}
# ----------------------------------------------------------------------------
# Command tkdnd::text::drag_source
# ----------------------------------------------------------------------------
proc ::tkdnd::text::drag_source { mode path { types DND_Text } { event 1 } { tagprefix TkDND_Drag_Text } { tag sel } } {
switch -exact -- $mode {
register {
$path tag bind $tag <ButtonPress-${event}> \
"tkdnd::text::_begin_drag press ${event} %W %s %X %Y %x %y"
## Set a binding to the widget, to put selection as data...
bind $path <<DragInitCmd>> "::tkdnd::text::DragInitCmd $path {%t} $tag"
## Set a binding to the widget, to remove selection if action is move...
bind $path <<DragEndCmd>> "::tkdnd::text::DragEndCmd $path %A $tag"
}
unregister {
$path tag bind $tag <ButtonPress-${event}> {}
bind $path <<DragInitCmd>> {}
bind $path <<DragEndCmd>> {}
}
}
::tkdnd::drag_source $mode $path $types $event $tagprefix
};# ::tkdnd::text::drag_source
# ----------------------------------------------------------------------------
# Command tkdnd::text::drop_target
# ----------------------------------------------------------------------------
proc ::tkdnd::text::drop_target { mode path { types DND_Text } } {
switch -exact -- $mode {
register {
bind $path <<DropPosition>> "::tkdnd::text::DropPosition $path %X %Y %A %a %m"
bind $path <<Drop>> "::tkdnd::text::Drop $path %D %X %Y %A %a %m"
}
unregister {
bind $path <<DropEnter>> {}
bind $path <<DropPosition>> {}
bind $path <<DropLeave>> {}
bind $path <<Drop>> {}
}
}
::tkdnd::drop_target $mode $path $types
};# ::tkdnd::text::drop_target
# ----------------------------------------------------------------------------
# Command tkdnd::text::DragInitCmd
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DragInitCmd { path { types DND_Text } { tag sel } { actions { copy move } } } {
## Save the selection indices...
variable _drag_source_widget
variable _drop_target_widget
set _drag_source_widget $path
set _drop_target_widget {}
_save_selection $path $tag
list $actions $types [$path get $tag.first $tag.last]
};# ::tkdnd::text::DragInitCmd
# ----------------------------------------------------------------------------
# Command tkdnd::text::DragEndCmd
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DragEndCmd { path action { tag sel } } {
variable _drag_source_widget
variable _drop_target_widget
set _drag_source_widget {}
set _drop_target_widget {}
_restore_selection $path $tag
switch -exact -- $action {
move {
## Delete the original selected text...
variable _selection_first
variable _selection_last
$path delete $_selection_first $_selection_last
}
}
};# ::tkdnd::text::DragEndCmd
# ----------------------------------------------------------------------------
# Command tkdnd::text::DropPosition
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DropPosition { path X Y action actions keys} {
variable _drag_source_widget
variable _drop_target_widget
set _drop_target_widget $path
## This check is primitive, a more accurate one is needed!
if {$path eq $_drag_source_widget} {
## This is a drag within the same widget! Set action to move...
if {"move" in $actions} {set action move}
}
incr X -[winfo rootx $path]
incr Y -[winfo rooty $path]
$path mark set insert @$X,$Y; update
return $action
};# ::tkdnd::text::DropPosition
# ----------------------------------------------------------------------------
# Command tkdnd::text::Drop
# ----------------------------------------------------------------------------
proc ::tkdnd::text::Drop { path data X Y action actions keys } {
incr X -[winfo rootx $path]
incr Y -[winfo rooty $path]
$path mark set insert @$X,$Y
$path insert [$path index insert] $data
return $action
};# ::tkdnd::text::Drop
# ----------------------------------------------------------------------------
# Command tkdnd::text::_save_selection
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_save_selection { path tag} {
variable _drag_tag
variable _selection_first
variable _selection_last
variable _selection_tag $tag
set _selection_first [$path index $tag.first]
set _selection_last [$path index $tag.last]
$path tag add $_drag_tag $_selection_first $_selection_last
$path tag configure $_drag_tag \
-background [$path tag cget $tag -background] \
-foreground [$path tag cget $tag -foreground]
};# tkdnd::text::_save_selection
# ----------------------------------------------------------------------------
# Command tkdnd::text::_restore_selection
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_restore_selection { path tag} {
variable _drag_tag
variable _selection_first
variable _selection_last
$path tag delete $_drag_tag
$path tag remove $tag 0.0 end
#$path tag add $tag $_selection_first $_selection_last
};# tkdnd::text::_restore_selection
# ----------------------------------------------------------------------------
# Command tkdnd::text::_begin_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_begin_drag { event button source state X Y x y } {
variable _drop_target_widget
variable _state
# puts "::tkdnd::text::_begin_drag $event $button $source $state $X $Y $x $y"
switch -exact -- $event {
clear {
switch -exact -- $_state {
press {
## Do not execute other bindings, as they will erase selection...
return -code break
}
}
set _state clear
}
motion {
variable _now_dragging
if {$_now_dragging} {return -code break}
if { [string equal $_state "press"] } {
variable _x0; variable _y0
if { abs($_x0-$X) > ${::tkdnd::_dx} || abs($_y0-$Y) > ${::tkdnd::_dy} } {
set _state "done"
set _drop_target_widget {}
set _now_dragging 1
set code [catch {
::tkdnd::_init_drag $button $source $state $X $Y $x $y
} info options]
set _drop_target_widget {}
set _now_dragging 0
if {$code != 0} {
## Something strange occurred...
return -options $options $info
}
}
return -code break
}
set _state clear
}
press {
variable _x0; variable _y0
set _x0 $X
set _y0 $Y
set _state "press"
}
reset {
set _state {}
}
}
if {$source eq $_drop_target_widget} {return -code break}
return -code continue
};# tkdnd::text::_begin_drag
proc tkdnd::text::_TextAutoScan {w x y} {
variable _now_dragging
if {$_now_dragging} {return -code break}
return -code continue
};# tkdnd::text::_TextAutoScan

View File

@ -1,167 +0,0 @@
#
# tkdnd_windows.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval olednd {
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
CF_UNICODETEXT DND_Text \
CF_TEXT DND_Text \
CF_HDROP DND_Files \
UniformResourceLocator DND_URL \
CF_HTML DND_HTML \
{HTML Format} DND_HTML \
CF_RTF DND_RTF \
CF_RTFTEXT DND_RTF \
{Rich Text Format} DND_RTF \
]
# FileGroupDescriptorW DND_Files \
# FileGroupDescriptor DND_Files \
## Mapping from TkDND types to platform types...
::tkdnd::generic::initialise_tkdnd_to_platform_types [list \
DND_Text {CF_UNICODETEXT CF_TEXT} \
DND_Files {CF_HDROP} \
DND_URL {UniformResourceLocator UniformResourceLocatorW} \
DND_HTML {CF_HTML {HTML Format}} \
DND_RTF {CF_RTF CF_RTFTEXT {Rich Text Format}} \
]
};# initialise
};# namespace olednd
# ----------------------------------------------------------------------------
# Command olednd::HandleDragEnter
# ----------------------------------------------------------------------------
proc olednd::HandleDragEnter { drop_target typelist actionlist pressedkeys
rootX rootY codelist { data {} } } {
::tkdnd::generic::SetDroppedData $data
focus $drop_target
::tkdnd::generic::HandleEnter $drop_target 0 $typelist \
$codelist $actionlist $pressedkeys
set action [::tkdnd::generic::HandlePosition $drop_target {} \
$pressedkeys $rootX $rootY]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDragEnter
# ----------------------------------------------------------------------------
# Command olednd::HandleDragOver
# ----------------------------------------------------------------------------
proc olednd::HandleDragOver { drop_target pressedkeys rootX rootY } {
set action [::tkdnd::generic::HandlePosition $drop_target {} \
$pressedkeys $rootX $rootY]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDragOver
# ----------------------------------------------------------------------------
# Command olednd::HandleDragLeave
# ----------------------------------------------------------------------------
proc olednd::HandleDragLeave { drop_target } {
::tkdnd::generic::HandleLeave
if {$::tkdnd::_auto_update} {update idletasks}
};# olednd::HandleDragLeave
# ----------------------------------------------------------------------------
# Command olednd::HandleDrop
# ----------------------------------------------------------------------------
proc olednd::HandleDrop { drop_target pressedkeys rootX rootY type data } {
::tkdnd::generic::SetDroppedData [normalise_data $type $data]
set action [::tkdnd::generic::HandleDrop $drop_target {} \
$pressedkeys $rootX $rootY 0]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDrop
# ----------------------------------------------------------------------------
# Command olednd::GetDataType
# ----------------------------------------------------------------------------
proc olednd::GetDataType { drop_target typelist } {
foreach {drop_target common_drag_source_types common_drop_target_types} \
[::tkdnd::generic::FindWindowWithCommonTypes $drop_target $typelist] {break}
lindex $common_drag_source_types 0
};# olednd::GetDataType
# ----------------------------------------------------------------------------
# Command olednd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc olednd::GetDragSourceCommonTypes { drop_target } {
::tkdnd::generic::GetDragSourceCommonTypes
};# olednd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command olednd::platform_specific_types
# ----------------------------------------------------------------------------
proc olednd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # olednd::platform_specific_types
# ----------------------------------------------------------------------------
# Command olednd::platform_specific_type
# ----------------------------------------------------------------------------
proc olednd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # olednd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command olednd::platform_independent_type
# ----------------------------------------------------------------------------
proc olednd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # olednd::platform_independent_type
# ----------------------------------------------------------------------------
# Command olednd::normalise_data
# ----------------------------------------------------------------------------
proc olednd::normalise_data { type data } {
switch [lindex [::tkdnd::generic::platform_independent_type $type] 0] {
DND_Text {return $data}
DND_Files {return $data}
DND_HTML {return [encoding convertfrom utf-8 $data]}
default {return $data}
}
}; # olednd::normalise_data

Binary file not shown.

View File

@ -1,7 +0,0 @@
package ifneeded tkdnd 2.9.2 \
"source \{$dir/tkdnd.tcl\} ; \
tkdnd::initialise \{$dir\} libtkdnd2.9.2[info sharedlibextension] tkdnd"
package ifneeded tkdnd::utils 2.9.2 \
"source \{$dir/tkdnd_utils.tcl\} ; \
package provide tkdnd::utils 2.9.2"

View File

@ -1,469 +0,0 @@
#
# tkdnd.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
package require Tk
namespace eval ::tkdnd {
variable _topw ".drag"
variable _tabops
variable _state
variable _x0
variable _y0
variable _platform_namespace
variable _drop_file_temp_dir
variable _auto_update 1
variable _dx 3 ;# The difference in pixels before a drag is initiated.
variable _dy 3 ;# The difference in pixels before a drag is initiated.
variable _windowingsystem
bind TkDND_Drag1 <ButtonPress-1> {tkdnd::_begin_drag press 1 %W %s %X %Y %x %y}
bind TkDND_Drag1 <B1-Motion> {tkdnd::_begin_drag motion 1 %W %s %X %Y %x %y}
bind TkDND_Drag2 <ButtonPress-2> {tkdnd::_begin_drag press 2 %W %s %X %Y %x %y}
bind TkDND_Drag2 <B2-Motion> {tkdnd::_begin_drag motion 2 %W %s %X %Y %x %y}
bind TkDND_Drag3 <ButtonPress-3> {tkdnd::_begin_drag press 3 %W %s %X %Y %x %y}
bind TkDND_Drag3 <B3-Motion> {tkdnd::_begin_drag motion 3 %W %s %X %Y %x %y}
# ----------------------------------------------------------------------------
# Command tkdnd::initialise: Initialise the TkDND package.
# ----------------------------------------------------------------------------
proc initialise { dir PKG_LIB_FILE PACKAGE_NAME} {
variable _platform_namespace
variable _drop_file_temp_dir
variable _windowingsystem
global env
switch [tk windowingsystem] {
x11 {
set _windowingsystem x11
}
win32 -
windows {
set _windowingsystem windows
}
aqua {
set _windowingsystem aqua
}
default {
error "unknown Tk windowing system"
}
}
## Get User's home directory: We try to locate the proper path from a set of
## environmental variables...
foreach var {HOME HOMEPATH USERPROFILE ALLUSERSPROFILE APPDATA} {
if {[info exists env($var)]} {
if {[file isdirectory $env($var)]} {
set UserHomeDir $env($var)
break
}
}
}
## Should use [tk windowingsystem] instead of tcl platform array:
## OS X returns "unix," but that's not useful because it has its own
## windowing system, aqua
## Under windows we have to also combine HOMEDRIVE & HOMEPATH...
if {![info exists UserHomeDir] &&
[string equal $_windowingsystem windows] &&
[info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)]} {
if {[file isdirectory $env(HOMEDRIVE)$env(HOMEPATH)]} {
set UserHomeDir $env(HOMEDRIVE)$env(HOMEPATH)
}
}
## Have we located the needed path?
if {![info exists UserHomeDir]} {
set UserHomeDir [pwd]
}
set UserHomeDir [file normalize $UserHomeDir]
## Try to locate a temporary directory...
foreach var {TKDND_TEMP_DIR TEMP TMP} {
if {[info exists env($var)]} {
if {[file isdirectory $env($var)] && [file writable $env($var)]} {
set _drop_file_temp_dir $env($var)
break
}
}
}
if {![info exists _drop_file_temp_dir]} {
foreach _dir [list "$UserHomeDir/Local Settings/Temp" \
"$UserHomeDir/AppData/Local/Temp" \
/tmp \
C:/WINDOWS/Temp C:/Temp C:/tmp \
D:/WINDOWS/Temp D:/Temp D:/tmp] {
if {[file isdirectory $_dir] && [file writable $_dir]} {
set _drop_file_temp_dir $_dir
break
}
}
}
if {![info exists _drop_file_temp_dir]} {
set _drop_file_temp_dir $UserHomeDir
}
set _drop_file_temp_dir [file native $_drop_file_temp_dir]
source $dir/tkdnd_generic.tcl
switch $_windowingsystem {
x11 {
source $dir/tkdnd_unix.tcl
set _platform_namespace xdnd
}
win32 -
windows {
source $dir/tkdnd_windows.tcl
set _platform_namespace olednd
}
aqua {
source $dir/tkdnd_macosx.tcl
set _platform_namespace macdnd
}
default {
error "unknown Tk windowing system"
}
}
load $dir/$PKG_LIB_FILE $PACKAGE_NAME
source $dir/tkdnd_compat.tcl
${_platform_namespace}::initialise
};# initialise
proc GetDropFileTempDirectory { } {
variable _drop_file_temp_dir
return $_drop_file_temp_dir
}
proc SetDropFileTempDirectory { dir } {
variable _drop_file_temp_dir
set _drop_file_temp_dir $dir
}
};# namespace ::tkdnd
# ----------------------------------------------------------------------------
# Command tkdnd::drag_source
# ----------------------------------------------------------------------------
proc ::tkdnd::drag_source { mode path { types {} } { event 1 }
{ tagprefix TkDND_Drag } } {
set tags [bindtags $path]
set idx [lsearch $tags ${tagprefix}$event]
switch -- $mode {
register {
if { $idx != -1 } {
## No need to do anything!
# bindtags $path [lreplace $tags $idx $idx ${tagprefix}$event]
} else {
bindtags $path [linsert $tags 1 ${tagprefix}$event]
}
_drag_source_update_types $path $types
}
unregister {
if { $idx != -1 } {
bindtags $path [lreplace $tags $idx $idx]
}
}
}
};# tkdnd::drag_source
proc ::tkdnd::_drag_source_update_types { path types } {
set types [platform_specific_types $types]
set old_types [bind $path <<DragSourceTypes>>]
foreach type $types {
if {[lsearch $old_types $type] < 0} {lappend old_types $type}
}
bind $path <<DragSourceTypes>> $old_types
};# ::tkdnd::_drag_source_update_types
# ----------------------------------------------------------------------------
# Command tkdnd::drop_target
# ----------------------------------------------------------------------------
proc ::tkdnd::drop_target { mode path { types {} } } {
variable _windowingsystem
set types [platform_specific_types $types]
switch -- $mode {
register {
switch $_windowingsystem {
x11 {
_register_types $path [winfo toplevel $path] $types
}
win32 -
windows {
_RegisterDragDrop $path
bind <Destroy> $path {+ tkdnd::_RevokeDragDrop %W}
}
aqua {
macdnd::registerdragwidget [winfo toplevel $path] $types
}
default {
error "unknown Tk windowing system"
}
}
set old_types [bind $path <<DropTargetTypes>>]
set new_types {}
foreach type $types {
if {[lsearch -exact $old_types $type] < 0} {lappend new_types $type}
}
if {[llength $new_types]} {
bind $path <<DropTargetTypes>> [concat $old_types $new_types]
}
}
unregister {
switch $_windowingsystem {
x11 {
}
win32 -
windows {
_RevokeDragDrop $path
}
aqua {
error todo
}
default {
error "unknown Tk windowing system"
}
}
bind $path <<DropTargetTypes>> {}
}
}
};# tkdnd::drop_target
# ----------------------------------------------------------------------------
# Command tkdnd::_begin_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_begin_drag { event button source state X Y x y } {
variable _x0
variable _y0
variable _state
switch -- $event {
press {
set _x0 $X
set _y0 $Y
set _state "press"
}
motion {
if { ![info exists _state] } {
# This is just extra protection. There seem to be
# rare cases where the motion comes before the press.
return
}
if { [string equal $_state "press"] } {
variable _dx
variable _dy
if { abs($_x0-$X) > ${_dx} || abs($_y0-$Y) > ${_dy} } {
set _state "done"
_init_drag $button $source $state $X $Y $x $y
}
}
}
}
};# tkdnd::_begin_drag
# ----------------------------------------------------------------------------
# Command tkdnd::_init_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_init_drag { button source state rootX rootY X Y } {
# Call the <<DragInitCmd>> binding.
set cmd [bind $source <<DragInitCmd>>]
# puts "CMD: $cmd"
if {[string length $cmd]} {
set cmd [string map [list %W $source %X $rootX %Y $rootY %x $X %y $Y \
%S $state %e <<DragInitCmd>> %A \{\} %% % \
%t [bind $source <<DragSourceTypes>>]] $cmd]
set code [catch {uplevel \#0 $cmd} info options]
# puts "CODE: $code ---- $info"
switch -exact -- $code {
0 {}
3 - 4 {
# FRINK: nocheck
return
}
default {
return -options $options $info
}
}
set len [llength $info]
if {$len == 3} {
foreach { actions types _data } $info { break }
set types [platform_specific_types $types]
set data [list]
foreach type $types {
lappend data $_data
}
unset _data
} elseif {$len == 2} {
foreach { actions _data } $info { break }
set data [list]; set types [list]
foreach {t d} $_data {
foreach t [platform_specific_types $t] {
lappend types $t; lappend data $d
}
}
unset _data t d
} else {
if {$len == 1 && [string equal [lindex $actions 0] "refuse_drop"]} {
return
}
error "not enough items in the result of the <<DragInitCmd>>\
event binding. Either 2 or 3 items are expected. The command
executed was: \"$cmd\"\nResult was: \"$info\""
}
set action refuse_drop
variable _windowingsystem
# puts "Source: \"$source\""
# puts "Types: \"[join $types {", "}]\""
# puts "Actions: \"[join $actions {", "}]\""
# puts "Button: \"$button\""
# puts "Data: \"[string range $data 0 100]\""
switch $_windowingsystem {
x11 {
set action [xdnd::_dodragdrop $source $actions $types $data $button]
}
win32 -
windows {
set action [_DoDragDrop $source $actions $types $data $button]
}
aqua {
set action [macdnd::dodragdrop $source $actions $types $data $button]
}
default {
error "unknown Tk windowing system"
}
}
## Call _end_drag to notify the widget of the result of the drag
## operation...
_end_drag $button $source {} $action {} $data {} $state $rootX $rootY $X $Y
}
};# tkdnd::_init_drag
# ----------------------------------------------------------------------------
# Command tkdnd::_end_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::_end_drag { button source target action type data result
state rootX rootY X Y } {
set rootX 0
set rootY 0
# Call the <<DragEndCmd>> binding.
set cmd [bind $source <<DragEndCmd>>]
if {[string length $cmd]} {
set cmd [string map [list %W $source %X $rootX %Y $rootY %x $X %y $Y %% % \
%S $state %e <<DragEndCmd>> %A \{$action\}] $cmd]
set info [uplevel \#0 $cmd]
# if { $info != "" } {
# variable _windowingsystem
# foreach { actions types data } $info { break }
# set types [platform_specific_types $types]
# switch $_windowingsystem {
# x11 {
# error "dragging from Tk widgets not yet supported"
# }
# win32 -
# windows {
# set action [_DoDragDrop $source $actions $types $data $button]
# }
# aqua {
# macdnd::dodragdrop $source $actions $types $data
# }
# default {
# error "unknown Tk windowing system"
# }
# }
# ## Call _end_drag to notify the widget of the result of the drag
# ## operation...
# _end_drag $button $source {} $action {} $data {} $state $rootX $rootY
# }
}
};# tkdnd::_end_drag
# ----------------------------------------------------------------------------
# Command tkdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_specific_types { types } {
variable _platform_namespace
${_platform_namespace}::platform_specific_types $types
}; # tkdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
variable _platform_namespace
${_platform_namespace}::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command tkdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_specific_type { type } {
variable _platform_namespace
${_platform_namespace}::platform_specific_type $type
}; # tkdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_type { type } {
variable _platform_namespace
${_platform_namespace}::platform_independent_type $type
}; # tkdnd::platform_independent_type
# ----------------------------------------------------------------------------
# Command tkdnd::bytes_to_string
# ----------------------------------------------------------------------------
proc ::tkdnd::bytes_to_string { bytes } {
set string {}
foreach byte $bytes {
append string [binary format c $byte]
}
return $string
};# tkdnd::bytes_to_string
# ----------------------------------------------------------------------------
# Command tkdnd::urn_unquote
# ----------------------------------------------------------------------------
proc ::tkdnd::urn_unquote {url} {
set result ""
set start 0
while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
foreach {first last} $match break
append result [string range $url $start [expr {$first - 1}]]
append result [format %c 0x[string range $url [incr first] $last]]
set start [incr last]
}
append result [string range $url $start end]
return [encoding convertfrom utf-8 $result]
};# tkdnd::urn_unquote

Binary file not shown.

View File

@ -1,160 +0,0 @@
#
# tkdnd_compat.tcl --
#
# This file implements some utility procedures, to support older versions
# of the TkDND package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval compat {
};# namespace compat
# ----------------------------------------------------------------------------
# Command ::dnd
# ----------------------------------------------------------------------------
proc ::dnd {method window args} {
switch $method {
bindtarget {
switch [llength $args] {
0 {return [tkdnd::compat::bindtarget0 $window]}
1 {return [tkdnd::compat::bindtarget1 $window [lindex $args 0]]}
2 {return [tkdnd::compat::bindtarget2 $window [lindex $args 0] \
[lindex $args 1]]}
3 {return [tkdnd::compat::bindtarget3 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2]]}
4 {return [tkdnd::compat::bindtarget4 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2] [lindex $args 3]]}
}
}
cleartarget {
return [tkdnd::compat::cleartarget $window]
}
bindsource {
switch [llength $args] {
0 {return [tkdnd::compat::bindsource0 $window]}
1 {return [tkdnd::compat::bindsource1 $window [lindex $args 0]]}
2 {return [tkdnd::compat::bindsource2 $window [lindex $args 0] \
[lindex $args 1]]}
3 {return [tkdnd::compat::bindsource3 $window [lindex $args 0] \
[lindex $args 1] [lindex $args 2]]}
}
}
clearsource {
return [tkdnd::compat::clearsource $window]
}
drag {
return [tkdnd::_init_drag 1 $window "press" 0 0 0 0]
}
}
error "invalid number of arguments!"
};# ::dnd
# ----------------------------------------------------------------------------
# Command compat::bindtarget
# ----------------------------------------------------------------------------
proc compat::bindtarget0 {window} {
return [bind $window <<DropTargetTypes>>]
};# compat::bindtarget0
proc compat::bindtarget1 {window type} {
return [bindtarget2 $window $type <Drop>]
};# compat::bindtarget1
proc compat::bindtarget2 {window type event} {
switch $event {
<DragEnter> {return [bind $window <<DropEnter>>]}
<Drag> {return [bind $window <<DropPosition>>]}
<DragLeave> {return [bind $window <<DropLeave>>]}
<Drop> {return [bind $window <<Drop>>]}
}
};# compat::bindtarget2
proc compat::bindtarget3 {window type event script} {
set type [normalise_type $type]
::tkdnd::drop_target register $window [list $type]
switch $event {
<DragEnter> {return [bind $window <<DropEnter>> $script]}
<Drag> {return [bind $window <<DropPosition>> $script]}
<DragLeave> {return [bind $window <<DropLeave>> $script]}
<Drop> {return [bind $window <<Drop>> $script]}
}
};# compat::bindtarget3
proc compat::bindtarget4 {window type event script priority} {
return [bindtarget3 $window $type $event $script]
};# compat::bindtarget4
proc compat::normalise_type { type } {
switch $type {
text/plain -
{text/plain;charset=UTF-8} -
Text {return DND_Text}
text/uri-list -
Files {return DND_Files}
default {return $type}
}
};# compat::normalise_type
# ----------------------------------------------------------------------------
# Command compat::bindsource
# ----------------------------------------------------------------------------
proc compat::bindsource0 {window} {
return [bind $window <<DropTargetTypes>>]
};# compat::bindsource0
proc compat::bindsource1 {window type} {
return [bindsource2 $window $type <Drop>]
};# compat::bindsource1
proc compat::bindsource2 {window type script} {
set type [normalise_type $type]
::tkdnd::drag_source register $window $type
bind $window <<DragInitCmd>> "list {copy} {%t} \[$script\]"
};# compat::bindsource2
proc compat::bindsource3 {window type script priority} {
return [bindsource2 $window $type $script]
};# compat::bindsource3
# ----------------------------------------------------------------------------
# Command compat::cleartarget
# ----------------------------------------------------------------------------
proc compat::cleartarget {window} {
};# compat::cleartarget
# ----------------------------------------------------------------------------
# Command compat::clearsource
# ----------------------------------------------------------------------------
proc compat::clearsource {window} {
};# compat::clearsource

View File

@ -1,520 +0,0 @@
#
# tkdnd_generic.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval generic {
variable _types {}
variable _typelist {}
variable _codelist {}
variable _actionlist {}
variable _pressedkeys {}
variable _action {}
variable _common_drag_source_types {}
variable _common_drop_target_types {}
variable _drag_source {}
variable _drop_target {}
variable _last_mouse_root_x 0
variable _last_mouse_root_y 0
variable _tkdnd2platform
variable _platform2tkdnd
proc debug {msg} {
puts $msg
};# debug
proc initialise { } {
};# initialise
proc initialise_platform_to_tkdnd_types { types } {
variable _platform2tkdnd
variable _tkdnd2platform
set _platform2tkdnd [dict create {*}$types]
set _tkdnd2platform [dict create]
foreach type [dict keys $_platform2tkdnd] {
dict lappend _tkdnd2platform [dict get $_platform2tkdnd $type] $type
}
};# initialise_platform_to_tkdnd_types
proc initialise_tkdnd_to_platform_types { types } {
variable _tkdnd2platform
set _tkdnd2platform [dict create {*}$types]
};# initialise_tkdnd_to_platform_types
};# namespace generic
# ----------------------------------------------------------------------------
# Command generic::HandleEnter
# ----------------------------------------------------------------------------
proc generic::HandleEnter { drop_target drag_source typelist codelist
actionlist pressedkeys } {
variable _typelist; set _typelist $typelist
variable _pressedkeys; set _pressedkeys $pressedkeys
variable _action; set _action refuse_drop
variable _common_drag_source_types; set _common_drag_source_types {}
variable _common_drop_target_types; set _common_drop_target_types {}
variable _actionlist
variable _drag_source; set _drag_source $drag_source
variable _drop_target; set _drop_target {}
variable _actionlist; set _actionlist $actionlist
variable _codelist set _codelist $codelist
variable _last_mouse_root_x; set _last_mouse_root_x 0
variable _last_mouse_root_y; set _last_mouse_root_y 0
# debug "\n==============================================================="
# debug "generic::HandleEnter: drop_target=$drop_target,\
# drag_source=$drag_source,\
# typelist=$typelist"
# debug "generic::HandleEnter: ACTION: default"
return default
};# generic::HandleEnter
# ----------------------------------------------------------------------------
# Command generic::HandlePosition
# ----------------------------------------------------------------------------
proc generic::HandlePosition { drop_target drag_source pressedkeys
rootX rootY { time 0 } } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
# debug "generic::HandlePosition: drop_target=$drop_target,\
# _drop_target=$_drop_target, rootX=$rootX, rootY=$rootY"
if {![info exists _drag_source] && ![string length $_drag_source]} {
# debug "generic::HandlePosition: no or empty _drag_source:\
# return refuse_drop"
return refuse_drop
}
if {$drag_source ne "" && $drag_source ne $_drag_source} {
debug "generic position event from unexpected source: $_drag_source\
!= $drag_source"
return refuse_drop
}
set _pressedkeys $pressedkeys
## Does the new drop target support any of our new types?
# foreach {common_drag_source_types common_drop_target_types} \
# [GetWindowCommonTypes $drop_target $_typelist] {break}
foreach {drop_target common_drag_source_types common_drop_target_types} \
[FindWindowWithCommonTypes $drop_target $_typelist] {break}
set data [GetDroppedData $time]
# debug "\t($_drop_target) -> ($drop_target)"
if {$drop_target != $_drop_target} {
if {[string length $_drop_target]} {
## Call the <<DropLeave>> event.
# debug "\t<<DropLeave>> on $_drop_target"
set cmd [bind $_drop_target <<DropLeave>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A \{$_action\} %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D \{\} %e <<DropLeave>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
uplevel \#0 $cmd
}
}
set _drop_target $drop_target
set _action refuse_drop
if {[llength $common_drag_source_types]} {
set _action [lindex $_actionlist 0]
set _common_drag_source_types $common_drag_source_types
set _common_drop_target_types $common_drop_target_types
## Drop target supports at least one type. Send a <<DropEnter>>.
# puts "<<DropEnter>> -> $drop_target"
set cmd [bind $drop_target <<DropEnter>>]
if {[string length $cmd]} {
focus $drop_target
set cmd [string map [list %W $drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<DropEnter>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
}
}
}
set _drop_target {}
if {[llength $common_drag_source_types]} {
set _common_drag_source_types $common_drag_source_types
set _common_drop_target_types $common_drop_target_types
set _drop_target $drop_target
## Drop target supports at least one type. Send a <<DropPosition>>.
set cmd [bind $drop_target <<DropPosition>>]
if {[string length $cmd]} {
set cmd [string map [list %W $drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<DropPosition>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
}
# Return values: copy, move, link, ask, private, refuse_drop, default
# debug "generic::HandlePosition: ACTION: $_action"
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
};# generic::HandlePosition
# ----------------------------------------------------------------------------
# Command generic::HandleLeave
# ----------------------------------------------------------------------------
proc generic::HandleLeave { } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x
variable _last_mouse_root_y
if {![info exists _drop_target]} {set _drop_target {}}
# debug "generic::HandleLeave: _drop_target=$_drop_target"
if {[info exists _drop_target] && [string length $_drop_target]} {
set cmd [bind $_drop_target <<DropLeave>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target \
%X $_last_mouse_root_x %Y $_last_mouse_root_y \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A \{$_action\} %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D \{\} %e <<DropLeave>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
}
foreach var {_types _typelist _actionlist _pressedkeys _action
_common_drag_source_types _common_drop_target_types
_drag_source _drop_target} {
set $var {}
}
};# generic::HandleLeave
# ----------------------------------------------------------------------------
# Command generic::HandleDrop
# ----------------------------------------------------------------------------
proc generic::HandleDrop {drop_target drag_source pressedkeys rootX rootY time } {
variable _types
variable _typelist
variable _codelist
variable _actionlist
variable _pressedkeys
variable _action
variable _common_drag_source_types
variable _common_drop_target_types
variable _drag_source
variable _drop_target
variable _last_mouse_root_x
variable _last_mouse_root_y
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
set _pressedkeys $pressedkeys
# puts "generic::HandleDrop: $time"
if {![info exists _drag_source] && ![string length $_drag_source]} {
return refuse_drop
}
if {![info exists _drop_target] && ![string length $_drop_target]} {
return refuse_drop
}
if {![llength $_common_drag_source_types]} {return refuse_drop}
## Get the dropped data.
set data [GetDroppedData $time]
## Try to select the most specific <<Drop>> event.
foreach type [concat $_common_drag_source_types $_common_drop_target_types] {
set type [platform_independent_type $type]
set cmd [bind $_drop_target <<Drop:$type>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<Drop:$type>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
# Return values: copy, move, link, ask, private, refuse_drop
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
}
}
set cmd [bind $_drop_target <<Drop>>]
if {[string length $cmd]} {
set cmd [string map [list %W $_drop_target %X $rootX %Y $rootY \
%CST \{$_common_drag_source_types\} \
%CTT \{$_common_drop_target_types\} \
%CPT \{[lindex [platform_independent_type [lindex $_common_drag_source_types 0]] 0]\} \
%ST \{$_typelist\} %TT \{$_types\} \
%A $_action %a \{$_actionlist\} \
%b \{$_pressedkeys\} %m \{$_pressedkeys\} \
%D [list $data] %e <<Drop>> \
%L \{$_typelist\} %% % \
%t \{$_typelist\} %T \{[lindex $_common_drag_source_types 0]\} \
%c \{$_codelist\} %C \{[lindex $_codelist 0]\} \
] $cmd]
set _action [uplevel \#0 $cmd]
}
# Return values: copy, move, link, ask, private, refuse_drop
switch -exact -- $_action {
copy - move - link - ask - private - refuse_drop - default {}
default {set _action copy}
}
return $_action
};# generic::HandleDrop
# ----------------------------------------------------------------------------
# Command generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetWindowCommonTypes { win typelist } {
set types [bind $win <<DropTargetTypes>>]
# debug ">> Accepted types: $win $_types"
set common_drag_source_types {}
set common_drop_target_types {}
if {[llength $types]} {
## Examine the drop target types, to find at least one match with the drag
## source types...
set supported_types [supported_types $typelist]
foreach type $types {
foreach matched [lsearch -glob -all -inline $supported_types $type] {
## Drop target supports this type.
lappend common_drag_source_types $matched
lappend common_drop_target_types $type
}
}
}
list $common_drag_source_types $common_drop_target_types
};# generic::GetWindowCommonTypes
# ----------------------------------------------------------------------------
# Command generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
proc generic::FindWindowWithCommonTypes { win typelist } {
set toplevel [winfo toplevel $win]
while {![string equal $win $toplevel]} {
foreach {common_drag_source_types common_drop_target_types} \
[GetWindowCommonTypes $win $typelist] {break}
if {[llength $common_drag_source_types]} {
return [list $win $common_drag_source_types $common_drop_target_types]
}
set win [winfo parent $win]
}
## We have reached the toplevel, which may be also a target (SF Bug #30)
foreach {common_drag_source_types common_drop_target_types} \
[GetWindowCommonTypes $win $typelist] {break}
if {[llength $common_drag_source_types]} {
return [list $win $common_drag_source_types $common_drop_target_types]
}
return { {} {} {} }
};# generic::FindWindowWithCommonTypes
# ----------------------------------------------------------------------------
# Command generic::GetDroppedData
# ----------------------------------------------------------------------------
proc generic::GetDroppedData { time } {
variable _dropped_data
return $_dropped_data
};# generic::GetDroppedData
# ----------------------------------------------------------------------------
# Command generic::SetDroppedData
# ----------------------------------------------------------------------------
proc generic::SetDroppedData { data } {
variable _dropped_data
set _dropped_data $data
};# generic::SetDroppedData
# ----------------------------------------------------------------------------
# Command generic::GetDragSource
# ----------------------------------------------------------------------------
proc generic::GetDragSource { } {
variable _drag_source
return $_drag_source
};# generic::GetDragSource
# ----------------------------------------------------------------------------
# Command generic::GetDropTarget
# ----------------------------------------------------------------------------
proc generic::GetDropTarget { } {
variable _drop_target
return $_drop_target
};# generic::GetDropTarget
# ----------------------------------------------------------------------------
# Command generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDragSourceCommonTypes { } {
variable _common_drag_source_types
return $_common_drag_source_types
};# generic::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
proc generic::GetDropTargetCommonTypes { } {
variable _common_drag_source_types
return $_common_drag_source_types
};# generic::GetDropTargetCommonTypes
# ----------------------------------------------------------------------------
# Command generic::platform_specific_types
# ----------------------------------------------------------------------------
proc generic::platform_specific_types { types } {
set new_types {}
foreach type $types {
set new_types [concat $new_types [platform_specific_type $type]]
}
return $new_types
}; # generic::platform_specific_types
# ----------------------------------------------------------------------------
# Command generic::platform_specific_type
# ----------------------------------------------------------------------------
proc generic::platform_specific_type { type } {
variable _tkdnd2platform
if {[dict exists $_tkdnd2platform $type]} {
return [dict get $_tkdnd2platform $type]
}
list $type
}; # generic::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
set new_types {}
foreach type $types {
set new_types [concat $new_types [platform_independent_type $type]]
}
return $new_types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command generic::platform_independent_type
# ----------------------------------------------------------------------------
proc generic::platform_independent_type { type } {
variable _platform2tkdnd
if {[dict exists $_platform2tkdnd $type]} {
return [dict get $_platform2tkdnd $type]
}
return $type
}; # generic::platform_independent_type
# ----------------------------------------------------------------------------
# Command generic::supported_types
# ----------------------------------------------------------------------------
proc generic::supported_types { types } {
set new_types {}
foreach type $types {
if {[supported_type $type]} {lappend new_types $type}
}
return $new_types
}; # generic::supported_types
# ----------------------------------------------------------------------------
# Command generic::supported_type
# ----------------------------------------------------------------------------
proc generic::supported_type { type } {
variable _platform2tkdnd
if {[dict exists $_platform2tkdnd $type]} {
return 1
}
return 0
}; # generic::supported_type

View File

@ -1,144 +0,0 @@
#
# tkdnd_macosx.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
# This software is copyrighted by:
# Georgios Petasis, Athens, Greece.
# e-mail: petasisg@yahoo.gr, petasis@iit.demokritos.gr
#
# Mac portions (c) 2009 Kevin Walzer/WordTech Communications LLC,
# kw@codebykevin.com
#
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
#basic API for Mac Drag and Drop
#two data types supported: strings and file paths
#two commands at C level: ::tkdnd::macdnd::registerdragwidget, ::tkdnd::macdnd::unregisterdragwidget
#data retrieval mechanism: text or file paths are copied from drag clipboard to system clipboard and retrieved via [clipboard get]; array of file paths is converted to single tab-separated string, can be split into Tcl list
if {[tk windowingsystem] eq "aqua" && "AppKit" ni [winfo server .]} {
error {TkAqua Cocoa required}
}
namespace eval macdnd {
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
NSPasteboardTypeString DND_Text \
NSFilenamesPboardType DND_Files \
NSPasteboardTypeHTML DND_HTML \
]
};# initialise
};# namespace macdnd
# ----------------------------------------------------------------------------
# Command macdnd::HandleEnter
# ----------------------------------------------------------------------------
proc macdnd::HandleEnter { path drag_source typelist { data {} } } {
variable _pressedkeys
variable _actionlist
set _pressedkeys 1
set _actionlist { copy move link ask private }
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleEnter $path $drag_source $typelist $typelist \
$_actionlist $_pressedkeys
};# macdnd::HandleEnter
# ----------------------------------------------------------------------------
# Command macdnd::HandlePosition
# ----------------------------------------------------------------------------
proc macdnd::HandlePosition { drop_target rootX rootY {drag_source {}} } {
variable _pressedkeys
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
::tkdnd::generic::HandlePosition $drop_target $drag_source \
$_pressedkeys $rootX $rootY
};# macdnd::HandlePosition
# ----------------------------------------------------------------------------
# Command macdnd::HandleLeave
# ----------------------------------------------------------------------------
proc macdnd::HandleLeave { args } {
::tkdnd::generic::HandleLeave
};# macdnd::HandleLeave
# ----------------------------------------------------------------------------
# Command macdnd::HandleDrop
# ----------------------------------------------------------------------------
proc macdnd::HandleDrop { drop_target data args } {
variable _pressedkeys
variable _last_mouse_root_x
variable _last_mouse_root_y
## Get the dropped data...
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleDrop {} {} $_pressedkeys \
$_last_mouse_root_x $_last_mouse_root_y 0
};# macdnd::HandleDrop
# ----------------------------------------------------------------------------
# Command macdnd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc macdnd::GetDragSourceCommonTypes { } {
::tkdnd::generic::GetDragSourceCommonTypes
};# macdnd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command macdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc macdnd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # macdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command macdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc macdnd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # macdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command macdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc macdnd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # macdnd::platform_independent_type

View File

@ -1,810 +0,0 @@
#
# tkdnd_unix.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval xdnd {
variable _dragging 0
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
text/plain\;charset=utf-8 DND_Text \
UTF8_STRING DND_Text \
text/plain DND_Text \
STRING DND_Text \
TEXT DND_Text \
COMPOUND_TEXT DND_Text \
text/uri-list DND_Files \
text/html\;charset=utf-8 DND_HTML \
text/html DND_HTML \
application/x-color DND_Color \
]
};# initialise
};# namespace xdnd
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndEnter
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndEnter { path drag_source typelist time { data {} } } {
variable _pressedkeys
variable _actionlist
variable _typelist
set _pressedkeys 1
set _actionlist { copy move link ask private }
set _typelist $typelist
# puts "xdnd::HandleXdndEnter: $time"
::tkdnd::generic::SetDroppedData $data
::tkdnd::generic::HandleEnter $path $drag_source $typelist $typelist \
$_actionlist $_pressedkeys
};# xdnd::HandleXdndEnter
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndPosition
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndPosition { drop_target rootX rootY time {drag_source {}} } {
variable _pressedkeys
variable _typelist
variable _last_mouse_root_x; set _last_mouse_root_x $rootX
variable _last_mouse_root_y; set _last_mouse_root_y $rootY
# puts "xdnd::HandleXdndPosition: $time"
## Get the dropped data...
catch {
::tkdnd::generic::SetDroppedData [GetPositionData $drop_target $_typelist $time]
}
::tkdnd::generic::HandlePosition $drop_target $drag_source \
$_pressedkeys $rootX $rootY
};# xdnd::HandleXdndPosition
# ----------------------------------------------------------------------------
# Command xdnd::HandleXdndLeave
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndLeave { } {
::tkdnd::generic::HandleLeave
};# xdnd::HandleXdndLeave
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndDrop
# ----------------------------------------------------------------------------
proc xdnd::HandleXdndDrop { time } {
variable _pressedkeys
variable _last_mouse_root_x
variable _last_mouse_root_y
## Get the dropped data...
::tkdnd::generic::SetDroppedData [GetDroppedData \
[::tkdnd::generic::GetDragSource] [::tkdnd::generic::GetDropTarget] \
[::tkdnd::generic::GetDragSourceCommonTypes] $time]
::tkdnd::generic::HandleDrop {} {} $_pressedkeys \
$_last_mouse_root_x $_last_mouse_root_y $time
};# xdnd::HandleXdndDrop
# ----------------------------------------------------------------------------
# Command xdnd::GetPositionData
# ----------------------------------------------------------------------------
proc xdnd::GetPositionData { drop_target typelist time } {
foreach {drop_target common_drag_source_types common_drop_target_types} \
[::tkdnd::generic::FindWindowWithCommonTypes $drop_target $typelist] {break}
GetDroppedData [::tkdnd::generic::GetDragSource] $drop_target \
$common_drag_source_types $time
};# xdnd::GetPositionData
# ----------------------------------------------------------------------------
# Command xdnd::GetDroppedData
# ----------------------------------------------------------------------------
proc xdnd::GetDroppedData { _drag_source _drop_target _common_drag_source_types time } {
if {![llength $_common_drag_source_types]} {
error "no common data types between the drag source and drop target widgets"
}
## Is drag source in this application?
if {[catch {winfo pathname -displayof $_drop_target $_drag_source} p]} {
set _use_tk_selection 0
} else {
set _use_tk_selection 1
}
foreach type $_common_drag_source_types {
# puts "TYPE: $type ($_drop_target)"
# _get_selection $_drop_target $time $type
if {$_use_tk_selection} {
if {![catch {
selection get -displayof $_drop_target -selection XdndSelection \
-type $type
} result options]} {
return [normalise_data $type $result]
}
} else {
# puts "_selection_get -displayof $_drop_target -selection XdndSelection \
# -type $type -time $time"
#after 100 [list focus -force $_drop_target]
#after 50 [list raise [winfo toplevel $_drop_target]]
if {![catch {
_selection_get -displayof $_drop_target -selection XdndSelection \
-type $type -time $time
} result options]} {
return [normalise_data $type $result]
}
}
}
return -options $options $result
};# xdnd::GetDroppedData
# ----------------------------------------------------------------------------
# Command xdnd::platform_specific_types
# ----------------------------------------------------------------------------
proc xdnd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # xdnd::platform_specific_types
# ----------------------------------------------------------------------------
# Command xdnd::platform_specific_type
# ----------------------------------------------------------------------------
proc xdnd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # xdnd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command xdnd::platform_independent_type
# ----------------------------------------------------------------------------
proc xdnd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # xdnd::platform_independent_type
# ----------------------------------------------------------------------------
# Command xdnd::_normalise_data
# ----------------------------------------------------------------------------
proc xdnd::normalise_data { type data } {
# Tk knows how to interpret the following types:
# STRING, TEXT, COMPOUND_TEXT
# UTF8_STRING
# Else, it returns a list of 8 or 32 bit numbers...
switch -glob $type {
STRING - UTF8_STRING - TEXT - COMPOUND_TEXT {return $data}
text/html {
if {[catch {
encoding convertfrom unicode $data
} string]} {
set string $data
}
return [string map {\r\n \n} $string]
}
text/html\;charset=utf-8 -
text/plain\;charset=utf-8 -
text/plain {
if {[catch {
encoding convertfrom utf-8 [tkdnd::bytes_to_string $data]
} string]} {
set string $data
}
return [string map {\r\n \n} $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 [tkdnd::urn_unquote $quoted_file]
switch -glob $file {
\#* {}
file://* {lappend files [string range $file 7 end]}
ftp://* -
https://* -
http://* {lappend files $quoted_file}
default {lappend files $file}
}
}
return $files
}
application/x-color {
return $data
}
text/x-moz-url -
application/q-iconlist -
default {return $data}
}
}; # xdnd::normalise_data
#############################################################################
##
## XDND drag implementation
##
#############################################################################
# ----------------------------------------------------------------------------
# Command xdnd::_selection_ownership_lost
# ----------------------------------------------------------------------------
proc xdnd::_selection_ownership_lost {} {
variable _dragging
set _dragging 0
};# _selection_ownership_lost
# ----------------------------------------------------------------------------
# Command xdnd::_dodragdrop
# ----------------------------------------------------------------------------
proc xdnd::_dodragdrop { source actions types data button } {
variable _dragging
# 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"
}
variable _dodragdrop_drag_source $source
variable _dodragdrop_drop_target 0
variable _dodragdrop_drop_target_proxy 0
variable _dodragdrop_actions $actions
variable _dodragdrop_action_descriptions $actions
variable _dodragdrop_actions_len [llength $actions]
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
variable _dodragdrop_waiting_status 0
variable _dodragdrop_drop_target_accepts_drop 0
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
## the drag source widget...
##
if {$_dodragdrop_types_len > 3} {
_announce_type_list $_dodragdrop_drag_source $_dodragdrop_types
}
##
## Announce the actions & their descriptions on the XdndActionList &
## XdndActionDescription properties...
##
_announce_action_list $_dodragdrop_drag_source $_dodragdrop_actions \
$_dodragdrop_action_descriptions
##
## Arrange selection handlers for our drag source, and all the supported types
##
registerSelectionHandler $source $types
##
## Step 1: When a drag begins, the source takes ownership of XdndSelection.
##
selection own -command ::tkdnd::xdnd::_selection_ownership_lost \
-selection XdndSelection $source
set _dragging 1
## Grab the mouse pointer...
_grab_pointer $source $_dodragdrop_default_action
## Register our generic event handler...
# The generic event callback will report events by modifying variable
# ::xdnd::_dodragdrop_event: a dict with event information will be set as
# the value of the variable...
_register_generic_event_handler
## Set a timeout for debugging purposes...
# after 60000 {set ::tkdnd::xdnd::_dragging 0}
tkwait variable ::tkdnd::xdnd::_dragging
_SendXdndLeave
set _dragging 0
_ungrab_pointer $source
_unregister_generic_event_handler
catch {selection clear -selection XdndSelection}
unregisterSelectionHandler $source $types
return $_dodragdrop_drop_target_accepts_action
};# 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]
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 $type {
MotionNotify {
set rootx [dict get $event x_root]
set rooty [dict get $event y_root]
set window [_find_drop_target_window $_dodragdrop_drag_source \
$rootx $rooty]
if {[string length $window]} {
## Examine the modifiers to suggest an action...
set _dodragdrop_default_action [_default_action $event]
## Is it a Tk widget?
# set path [winfo containing $rootx $rooty]
# puts "Window under mouse: $window ($path)"
if {$_dodragdrop_drop_target != $window} {
## Send XdndLeave to $_dodragdrop_drop_target
_SendXdndLeave
## Is there a proxy? If not, _find_drop_target_proxy returns the
## target window, so we always get a valid "proxy".
set proxy [_find_drop_target_proxy $_dodragdrop_drag_source $window]
## Send XdndEnter to $window
_SendXdndEnter $window $proxy
## Send XdndPosition to $_dodragdrop_drop_target
_SendXdndPosition $rootx $rooty $_dodragdrop_default_action
} else {
## Send XdndPosition to $_dodragdrop_drop_target
_SendXdndPosition $rootx $rooty $_dodragdrop_default_action
}
} else {
## No window under the mouse. Send XdndLeave to $_dodragdrop_drop_target
_SendXdndLeave
}
}
ButtonPress {
}
ButtonRelease {
variable _dodragdrop_button
set button [dict get $event button]
if {$button == $_dodragdrop_button} {
## The button that initiated the drag was released. Trigger drop...
_SendXdndDrop
}
return 1
}
KeyPress {
}
KeyRelease {
set keysym [dict get $event keysym]
switch $keysym {
Escape {
## The user has pressed escape. Abort...
if {$_dragging} {set _dragging 0}
}
}
}
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
}
}
return 0
};# _process_drag_events
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndEnter
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndEnter {window proxy} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_types
variable _dodragdrop_waiting_status
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_target > 0} _SendXdndLeave
if {$_dodragdrop_drop_occured} return
set _dodragdrop_drop_target $window
set _dodragdrop_drop_target_proxy $proxy
set _dodragdrop_waiting_status 0
if {$_dodragdrop_drop_target < 1} return
# puts "XdndEnter: $_dodragdrop_drop_target $_dodragdrop_drop_target_proxy"
_send_XdndEnter $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy $_dodragdrop_types
};# xdnd::_SendXdndEnter
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndPosition
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndPosition {rootx rooty action} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_waiting_status
## Arrange a new XdndPosition, to be send periodically...
variable _dodragdrop_xdnd_position_heartbeat
catch {after cancel $_dodragdrop_xdnd_position_heartbeat}
set _dodragdrop_xdnd_position_heartbeat [after 200 \
[list ::tkdnd::xdnd::_SendXdndPosition $rootx $rooty $action]]
if {$_dodragdrop_waiting_status} {return}
# puts "XdndPosition: $_dodragdrop_drop_target $rootx $rooty $action"
_send_XdndPosition $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy $rootx $rooty $action
set _dodragdrop_waiting_status 1
};# xdnd::_SendXdndPosition
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndStatus
# ----------------------------------------------------------------------------
proc xdnd::_HandleXdndStatus {event} {
variable _dodragdrop_drop_target
variable _dodragdrop_waiting_status
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_waiting_status 0
foreach key {target accept want_position action x y w h} {
set $key [dict get $event $key]
}
set _dodragdrop_drop_target_accepts_drop $accept
set _dodragdrop_drop_target_accepts_action $action
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
_update_cursor
# puts "XdndStatus: $event"
};# xdnd::_HandleXdndStatus
# ----------------------------------------------------------------------------
# Command xdnd::_HandleXdndFinished
# ----------------------------------------------------------------------------
proc xdnd::_HandleXdndFinished {event} {
variable _dodragdrop_xdnd_finished_event_after_id
catch {after cancel $_dodragdrop_xdnd_finished_event_after_id}
set _dodragdrop_xdnd_finished_event_after_id {}
variable _dodragdrop_drop_target
set _dodragdrop_drop_target 0
variable _dragging
if {$_dragging} {set _dragging 0}
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
if {[dict size $event]} {
foreach key {target accept action} {
set $key [dict get $event $key]
}
set _dodragdrop_drop_target_accepts_drop $accept
set _dodragdrop_drop_target_accepts_action $action
} else {
set _dodragdrop_drop_target_accepts_drop 0
}
if {!$_dodragdrop_drop_target_accepts_drop} {
set _dodragdrop_drop_target_accepts_action refuse_drop
}
# puts "XdndFinished: $event"
};# xdnd::_HandleXdndFinished
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndLeave
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndLeave {} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} return
variable _dodragdrop_drop_target_proxy
# puts "XdndLeave: $_dodragdrop_drop_target"
_send_XdndLeave $_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy
set _dodragdrop_drop_target 0
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_drop_target_accepts_drop 0
set _dodragdrop_drop_target_accepts_action refuse_drop
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} return
_update_cursor
};# xdnd::_SendXdndLeave
# ----------------------------------------------------------------------------
# Command xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
proc xdnd::_SendXdndDrop {} {
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target
if {$_dodragdrop_drop_target < 1} {
## The mouse has been released over a widget that does not accept drops.
_HandleXdndFinished {}
return
}
variable _dodragdrop_drop_occured
if {$_dodragdrop_drop_occured} {return}
variable _dodragdrop_drop_target_proxy
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
set _dodragdrop_drop_occured 1
_update_cursor clock
if {!$_dodragdrop_drop_target_accepts_drop} {
_SendXdndLeave
_HandleXdndFinished {}
return
}
# puts "XdndDrop: $_dodragdrop_drop_target"
variable _dodragdrop_drop_timestamp
set _dodragdrop_drop_timestamp [_send_XdndDrop \
$_dodragdrop_drag_source $_dodragdrop_drop_target \
$_dodragdrop_drop_target_proxy]
set _dodragdrop_drop_target 0
# puts "XdndDrop: $_dodragdrop_drop_target"
## Arrange a timeout for receiving XdndFinished...
variable _dodragdrop_xdnd_finished_event_after_id
set _dodragdrop_xdnd_finished_event_after_id \
[after 10000 [list ::tkdnd::xdnd::_HandleXdndFinished {}]]
};# xdnd::_SendXdndDrop
# ----------------------------------------------------------------------------
# Command xdnd::_update_cursor
# ----------------------------------------------------------------------------
proc xdnd::_update_cursor { {cursor {}}} {
# puts "_update_cursor $cursor"
variable _dodragdrop_current_cursor
variable _dodragdrop_drag_source
variable _dodragdrop_drop_target_accepts_drop
variable _dodragdrop_drop_target_accepts_action
if {![string length $cursor]} {
set cursor refuse_drop
if {$_dodragdrop_drop_target_accepts_drop} {
set cursor $_dodragdrop_drop_target_accepts_action
}
}
if {![string equal $cursor $_dodragdrop_current_cursor]} {
_set_pointer_cursor $_dodragdrop_drag_source $cursor
set _dodragdrop_current_cursor $cursor
}
};# xdnd::_update_cursor
# ----------------------------------------------------------------------------
# Command xdnd::_default_action
# ----------------------------------------------------------------------------
proc xdnd::_default_action {event} {
variable _dodragdrop_actions
variable _dodragdrop_actions_len
if {$_dodragdrop_actions_len == 1} {return [lindex $_dodragdrop_actions 0]}
set alt [dict get $event Alt]
set shift [dict get $event Shift]
set control [dict get $event Control]
if {$shift && $control && [lsearch $_dodragdrop_actions link] != -1} {
return link
} elseif {$control && [lsearch $_dodragdrop_actions copy] != -1} {
return copy
} elseif {$shift && [lsearch $_dodragdrop_actions move] != -1} {
return move
} elseif {$alt && [lsearch $_dodragdrop_actions link] != -1} {
return link
}
return default
};# xdnd::_default_action
# ----------------------------------------------------------------------------
# Command xdnd::getFormatForType
# ----------------------------------------------------------------------------
proc xdnd::getFormatForType {type} {
switch -glob [string tolower $type] {
text/plain\;charset=utf-8 -
text/html\;charset=utf-8 -
utf8_string {set format UTF8_STRING}
text/html -
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_types
variable _dodragdrop_data
variable _dodragdrop_transfer_data
## The variable _dodragdrop_data contains a list of data, one for each
## type in the _dodragdrop_types variable. We have to search types, and find
## the corresponding entry in the _dodragdrop_data list.
set index [lsearch $_dodragdrop_types $type]
if {$index < 0} {
error "unable to locate data suitable for type \"$type\""
}
set typed_data [lindex $_dodragdrop_data $index]
set format 8
if {$offset == 0} {
## Prepare the data to be transferred...
switch -glob $type {
text/plain* - UTF8_STRING - STRING - TEXT - COMPOUND_TEXT {
binary scan [encoding convertto utf-8 $typed_data] \
c* _dodragdrop_transfer_data
set _dodragdrop_transfer_data \
[_convert_to_unsigned $_dodragdrop_transfer_data $format]
}
text/uri-list* {
set files [list]
foreach file $typed_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 $typed_data] {
1 { set color [winfo rgb $_dodragdrop_drag_source $typed_data]
lappend color 65535 }
3 { set color $typed_data; lappend color 65535 }
4 { set color $typed_data }
default {error "unknown color data: \"$typed_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 $typed_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 ($typed_data)"
# puts " $data"
return $data
};# xdnd::_SendData

View File

@ -1,252 +0,0 @@
#
# tkdnd_utils.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
package require tkdnd
namespace eval ::tkdnd {
namespace eval utils {
};# namespace ::tkdnd::utils
namespace eval text {
variable _drag_tag tkdnd::drag::selection::tag
variable _state {}
variable _drag_source_widget {}
variable _drop_target_widget {}
variable _now_dragging 0
};# namespace ::tkdnd::text
};# namespace ::tkdnd
bind TkDND_Drag_Text1 <ButtonPress-1> {tkdnd::text::_begin_drag clear 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text1 <B1-Motion> {tkdnd::text::_begin_drag motion 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text1 <B1-Leave> {tkdnd::text::_TextAutoScan %W %x %y}
bind TkDND_Drag_Text1 <ButtonRelease-1> {tkdnd::text::_begin_drag reset 1 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <ButtonPress-2> {tkdnd::text::_begin_drag clear 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <B2-Motion> {tkdnd::text::_begin_drag motion 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text2 <ButtonRelease-2> {tkdnd::text::_begin_drag reset 2 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <ButtonPress-3> {tkdnd::text::_begin_drag clear 3 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <B3-Motion> {tkdnd::text::_begin_drag motion 3 %W %s %X %Y %x %y}
bind TkDND_Drag_Text3 <ButtonRelease-3> {tkdnd::text::_begin_drag reset 3 %W %s %X %Y %x %y}
# ----------------------------------------------------------------------------
# Command tkdnd::text::drag_source
# ----------------------------------------------------------------------------
proc ::tkdnd::text::drag_source { mode path { types DND_Text } { event 1 } { tagprefix TkDND_Drag_Text } { tag sel } } {
switch -exact -- $mode {
register {
$path tag bind $tag <ButtonPress-${event}> \
"tkdnd::text::_begin_drag press ${event} %W %s %X %Y %x %y"
## Set a binding to the widget, to put selection as data...
bind $path <<DragInitCmd>> "::tkdnd::text::DragInitCmd $path {%t} $tag"
## Set a binding to the widget, to remove selection if action is move...
bind $path <<DragEndCmd>> "::tkdnd::text::DragEndCmd $path %A $tag"
}
unregister {
$path tag bind $tag <ButtonPress-${event}> {}
bind $path <<DragInitCmd>> {}
bind $path <<DragEndCmd>> {}
}
}
::tkdnd::drag_source $mode $path $types $event $tagprefix
};# ::tkdnd::text::drag_source
# ----------------------------------------------------------------------------
# Command tkdnd::text::drop_target
# ----------------------------------------------------------------------------
proc ::tkdnd::text::drop_target { mode path { types DND_Text } } {
switch -exact -- $mode {
register {
bind $path <<DropPosition>> "::tkdnd::text::DropPosition $path %X %Y %A %a %m"
bind $path <<Drop>> "::tkdnd::text::Drop $path %D %X %Y %A %a %m"
}
unregister {
bind $path <<DropEnter>> {}
bind $path <<DropPosition>> {}
bind $path <<DropLeave>> {}
bind $path <<Drop>> {}
}
}
::tkdnd::drop_target $mode $path $types
};# ::tkdnd::text::drop_target
# ----------------------------------------------------------------------------
# Command tkdnd::text::DragInitCmd
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DragInitCmd { path { types DND_Text } { tag sel } { actions { copy move } } } {
## Save the selection indices...
variable _drag_source_widget
variable _drop_target_widget
set _drag_source_widget $path
set _drop_target_widget {}
_save_selection $path $tag
list $actions $types [$path get $tag.first $tag.last]
};# ::tkdnd::text::DragInitCmd
# ----------------------------------------------------------------------------
# Command tkdnd::text::DragEndCmd
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DragEndCmd { path action { tag sel } } {
variable _drag_source_widget
variable _drop_target_widget
set _drag_source_widget {}
set _drop_target_widget {}
_restore_selection $path $tag
switch -exact -- $action {
move {
## Delete the original selected text...
variable _selection_first
variable _selection_last
$path delete $_selection_first $_selection_last
}
}
};# ::tkdnd::text::DragEndCmd
# ----------------------------------------------------------------------------
# Command tkdnd::text::DropPosition
# ----------------------------------------------------------------------------
proc ::tkdnd::text::DropPosition { path X Y action actions keys} {
variable _drag_source_widget
variable _drop_target_widget
set _drop_target_widget $path
## This check is primitive, a more accurate one is needed!
if {$path eq $_drag_source_widget} {
## This is a drag within the same widget! Set action to move...
if {"move" in $actions} {set action move}
}
incr X -[winfo rootx $path]
incr Y -[winfo rooty $path]
$path mark set insert @$X,$Y; update
return $action
};# ::tkdnd::text::DropPosition
# ----------------------------------------------------------------------------
# Command tkdnd::text::Drop
# ----------------------------------------------------------------------------
proc ::tkdnd::text::Drop { path data X Y action actions keys } {
incr X -[winfo rootx $path]
incr Y -[winfo rooty $path]
$path mark set insert @$X,$Y
$path insert [$path index insert] $data
return $action
};# ::tkdnd::text::Drop
# ----------------------------------------------------------------------------
# Command tkdnd::text::_save_selection
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_save_selection { path tag} {
variable _drag_tag
variable _selection_first
variable _selection_last
variable _selection_tag $tag
set _selection_first [$path index $tag.first]
set _selection_last [$path index $tag.last]
$path tag add $_drag_tag $_selection_first $_selection_last
$path tag configure $_drag_tag \
-background [$path tag cget $tag -background] \
-foreground [$path tag cget $tag -foreground]
};# tkdnd::text::_save_selection
# ----------------------------------------------------------------------------
# Command tkdnd::text::_restore_selection
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_restore_selection { path tag} {
variable _drag_tag
variable _selection_first
variable _selection_last
$path tag delete $_drag_tag
$path tag remove $tag 0.0 end
#$path tag add $tag $_selection_first $_selection_last
};# tkdnd::text::_restore_selection
# ----------------------------------------------------------------------------
# Command tkdnd::text::_begin_drag
# ----------------------------------------------------------------------------
proc ::tkdnd::text::_begin_drag { event button source state X Y x y } {
variable _drop_target_widget
variable _state
# puts "::tkdnd::text::_begin_drag $event $button $source $state $X $Y $x $y"
switch -exact -- $event {
clear {
switch -exact -- $_state {
press {
## Do not execute other bindings, as they will erase selection...
return -code break
}
}
set _state clear
}
motion {
variable _now_dragging
if {$_now_dragging} {return -code break}
if { [string equal $_state "press"] } {
variable _x0; variable _y0
if { abs($_x0-$X) > ${::tkdnd::_dx} || abs($_y0-$Y) > ${::tkdnd::_dy} } {
set _state "done"
set _drop_target_widget {}
set _now_dragging 1
set code [catch {
::tkdnd::_init_drag $button $source $state $X $Y $x $y
} info options]
set _drop_target_widget {}
set _now_dragging 0
if {$code != 0} {
## Something strange occurred...
return -options $options $info
}
}
return -code break
}
set _state clear
}
press {
variable _x0; variable _y0
set _x0 $X
set _y0 $Y
set _state "press"
}
reset {
set _state {}
}
}
if {$source eq $_drop_target_widget} {return -code break}
return -code continue
};# tkdnd::text::_begin_drag
proc tkdnd::text::_TextAutoScan {w x y} {
variable _now_dragging
if {$_now_dragging} {return -code break}
return -code continue
};# tkdnd::text::_TextAutoScan

View File

@ -1,167 +0,0 @@
#
# tkdnd_windows.tcl --
#
# This file implements some utility procedures that are used by the TkDND
# package.
#
# This software is copyrighted by:
# George Petasis, National Centre for Scientific Research "Demokritos",
# Aghia Paraskevi, Athens, Greece.
# e-mail: petasis@iit.demokritos.gr
#
# The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
#
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
#
namespace eval olednd {
proc initialise { } {
## Mapping from platform types to TkDND types...
::tkdnd::generic::initialise_platform_to_tkdnd_types [list \
CF_UNICODETEXT DND_Text \
CF_TEXT DND_Text \
CF_HDROP DND_Files \
UniformResourceLocator DND_URL \
CF_HTML DND_HTML \
{HTML Format} DND_HTML \
CF_RTF DND_RTF \
CF_RTFTEXT DND_RTF \
{Rich Text Format} DND_RTF \
]
# FileGroupDescriptorW DND_Files \
# FileGroupDescriptor DND_Files \
## Mapping from TkDND types to platform types...
::tkdnd::generic::initialise_tkdnd_to_platform_types [list \
DND_Text {CF_UNICODETEXT CF_TEXT} \
DND_Files {CF_HDROP} \
DND_URL {UniformResourceLocator UniformResourceLocatorW} \
DND_HTML {CF_HTML {HTML Format}} \
DND_RTF {CF_RTF CF_RTFTEXT {Rich Text Format}} \
]
};# initialise
};# namespace olednd
# ----------------------------------------------------------------------------
# Command olednd::HandleDragEnter
# ----------------------------------------------------------------------------
proc olednd::HandleDragEnter { drop_target typelist actionlist pressedkeys
rootX rootY codelist { data {} } } {
::tkdnd::generic::SetDroppedData $data
focus $drop_target
::tkdnd::generic::HandleEnter $drop_target 0 $typelist \
$codelist $actionlist $pressedkeys
set action [::tkdnd::generic::HandlePosition $drop_target {} \
$pressedkeys $rootX $rootY]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDragEnter
# ----------------------------------------------------------------------------
# Command olednd::HandleDragOver
# ----------------------------------------------------------------------------
proc olednd::HandleDragOver { drop_target pressedkeys rootX rootY } {
set action [::tkdnd::generic::HandlePosition $drop_target {} \
$pressedkeys $rootX $rootY]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDragOver
# ----------------------------------------------------------------------------
# Command olednd::HandleDragLeave
# ----------------------------------------------------------------------------
proc olednd::HandleDragLeave { drop_target } {
::tkdnd::generic::HandleLeave
if {$::tkdnd::_auto_update} {update idletasks}
};# olednd::HandleDragLeave
# ----------------------------------------------------------------------------
# Command olednd::HandleDrop
# ----------------------------------------------------------------------------
proc olednd::HandleDrop { drop_target pressedkeys rootX rootY type data } {
::tkdnd::generic::SetDroppedData [normalise_data $type $data]
set action [::tkdnd::generic::HandleDrop $drop_target {} \
$pressedkeys $rootX $rootY 0]
if {$::tkdnd::_auto_update} {update idletasks}
return $action
};# olednd::HandleDrop
# ----------------------------------------------------------------------------
# Command olednd::GetDataType
# ----------------------------------------------------------------------------
proc olednd::GetDataType { drop_target typelist } {
foreach {drop_target common_drag_source_types common_drop_target_types} \
[::tkdnd::generic::FindWindowWithCommonTypes $drop_target $typelist] {break}
lindex $common_drag_source_types 0
};# olednd::GetDataType
# ----------------------------------------------------------------------------
# Command olednd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
proc olednd::GetDragSourceCommonTypes { drop_target } {
::tkdnd::generic::GetDragSourceCommonTypes
};# olednd::GetDragSourceCommonTypes
# ----------------------------------------------------------------------------
# Command olednd::platform_specific_types
# ----------------------------------------------------------------------------
proc olednd::platform_specific_types { types } {
::tkdnd::generic::platform_specific_types $types
}; # olednd::platform_specific_types
# ----------------------------------------------------------------------------
# Command olednd::platform_specific_type
# ----------------------------------------------------------------------------
proc olednd::platform_specific_type { type } {
::tkdnd::generic::platform_specific_type $type
}; # olednd::platform_specific_type
# ----------------------------------------------------------------------------
# Command tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
proc ::tkdnd::platform_independent_types { types } {
::tkdnd::generic::platform_independent_types $types
}; # tkdnd::platform_independent_types
# ----------------------------------------------------------------------------
# Command olednd::platform_independent_type
# ----------------------------------------------------------------------------
proc olednd::platform_independent_type { type } {
::tkdnd::generic::platform_independent_type $type
}; # olednd::platform_independent_type
# ----------------------------------------------------------------------------
# Command olednd::normalise_data
# ----------------------------------------------------------------------------
proc olednd::normalise_data { type data } {
switch [lindex [::tkdnd::generic::platform_independent_type $type] 0] {
DND_Text {return $data}
DND_Files {return $data}
DND_HTML {return [encoding convertfrom utf-8 $data]}
default {return $data}
}
}; # olednd::normalise_data