summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--deleted_files/xlib/ximage.c115
-rw-r--r--tests/send.test656
-rw-r--r--unix/tkUnixDialog.c207
-rw-r--r--win/makefile.vc9
-rw-r--r--win/rc/tk.rc3
-rw-r--r--win/tkWinMenu.c6
-rw-r--r--win/tkWinX.c6
7 files changed, 990 insertions, 12 deletions
diff --git a/deleted_files/xlib/ximage.c b/deleted_files/xlib/ximage.c
new file mode 100644
index 0000000..057e973
--- /dev/null
+++ b/deleted_files/xlib/ximage.c
@@ -0,0 +1,115 @@
+/*
+ * ximage.c --
+ *
+ * X bitmap and image routines.
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) ximage.c 1.6 96/07/23 16:59:10
+ */
+
+#include "tkInt.h"
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * XCreateBitmapFromData --
+ *
+ * Construct a single plane pixmap from bitmap data.
+ *
+ * Results:
+ * Returns a new Pixmap.
+ *
+ * Side effects:
+ * Allocates a new bitmap and drawable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Pixmap
+XCreateBitmapFromData(display, d, data, width, height)
+ Display* display;
+ Drawable d;
+ _Xconst char* data;
+ unsigned int width;
+ unsigned int height;
+{
+ XImage ximage;
+ GC gc;
+ Pixmap pix;
+
+ pix = Tk_GetPixmap(display, d, width, height, 1);
+ gc = XCreateGC(display, pix, 0, NULL);
+ if (gc == NULL) {
+ return None;
+ }
+ ximage.height = height;
+ ximage.width = width;
+ ximage.depth = 1;
+ ximage.bits_per_pixel = 1;
+ ximage.xoffset = 0;
+ ximage.format = XYBitmap;
+ ximage.data = (char *)data;
+ ximage.byte_order = LSBFirst;
+ ximage.bitmap_unit = 8;
+ ximage.bitmap_bit_order = LSBFirst;
+ ximage.bitmap_pad = 8;
+ ximage.bytes_per_line = (width+7)/8;
+
+ TkPutImage(NULL, 0, display, pix, gc, &ximage, 0, 0, 0, 0, width, height);
+ XFreeGC(display, gc);
+ return pix;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * XReadBitmapFile --
+ *
+ * Loads a bitmap image in X bitmap format into the specified
+ * drawable.
+ *
+ * Results:
+ * Sets the size, hotspot, and bitmap on success.
+ *
+ * Side effects:
+ * Creates a new bitmap from the file data.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+XReadBitmapFile(display, d, filename, width_return, height_return,
+ bitmap_return, x_hot_return, y_hot_return)
+ Display* display;
+ Drawable d;
+ _Xconst char* filename;
+ unsigned int* width_return;
+ unsigned int* height_return;
+ Pixmap* bitmap_return;
+ int* x_hot_return;
+ int* y_hot_return;
+{
+ Tcl_Interp *dummy;
+ char *data;
+
+ dummy = Tcl_CreateInterp();
+
+ data = TkGetBitmapData(dummy, NULL, (char *) filename,
+ (int *) width_return, (int *) height_return, x_hot_return,
+ y_hot_return);
+ if (data == NULL) {
+ return BitmapFileInvalid;
+ }
+
+ *bitmap_return = XCreateBitmapFromData(display, d, data, *width_return,
+ *height_return);
+
+ Tcl_DeleteInterp(dummy);
+ ckfree(data);
+ return BitmapSuccess;
+}
diff --git a/tests/send.test b/tests/send.test
new file mode 100644
index 0000000..fd164b2
--- /dev/null
+++ b/tests/send.test
@@ -0,0 +1,656 @@
+# This file is a Tcl script to test out the "send" command and the
+# other procedures in the file tkSend.c. It is organized in the
+# standard fashion for Tcl tests.
+#
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: send.test,v 1.1.4.2 1998/10/06 03:27:36 stanton Exp $
+
+if {$tcl_platform(platform) == "macintosh"} {
+ puts "send is not available on the Mac - skipping tests"
+ return
+}
+if {$tcl_platform(platform) == "window"} {
+ puts "send is not available under Windows - skipping tests"
+ return
+}
+if {[auto_execok xhost] == ""} {
+ puts "xhost application isn't available - skipping tests"
+ return
+}
+
+if {[info procs test] != "test"} {
+ source defs
+}
+if {[info commands testsend] == "testsend"} {
+ set gotTestCmds 1
+} else {
+ set gotTestCmds 0
+}
+
+foreach i [winfo children .] {
+ destroy $i
+}
+wm geometry . {}
+raise .
+
+# If send is disabled because of inadequate security, don't run any
+# of these tests at all.
+
+setupbg
+set app [dobg {tk appname}]
+if {[catch {send $app set a 0} msg] == 1} {
+ if [string match "X server insecure *" $msg] {
+ puts -nonewline "Your X server is insecure, so \"send\" can't be used;"
+ puts " skipping \"send\" tests."
+ cleanupbg
+ return
+ }
+}
+cleanupbg
+
+# Compute a script that will load Tk into a child interpreter.
+
+foreach pkg [info loaded] {
+ if {[lindex $pkg 1] == "Tk"} {
+ set loadTk "load $pkg"
+ break
+ }
+}
+
+# Procedure to create a new application with a given name and class.
+
+proc newApp {screen name class} {
+ global loadTk
+ interp create $name
+ $name eval [list set argv [list -display $screen -name $name -class $class]]
+ eval $loadTk $name
+}
+
+set name [tk appname]
+if $gotTestCmds {
+ set registry [testsend prop root InterpRegistry]
+ set commId [lindex [testsend prop root InterpRegistry] 0]
+}
+tk appname tktest
+catch {send t_s_1 destroy .}
+catch {send t_s_2 destroy .}
+
+if $gotTestCmds {
+ test send-1.1 {RegOpen procedure, bogus property} {
+ testsend bogus
+ set result [winfo interps]
+ tk appname tktest
+ list $result [winfo interps]
+ } {{} tktest}
+ test send-1.2 {RegOpen procedure, bogus property} {
+ testsend prop root InterpRegistry {}
+ set result [winfo interps]
+ tk appname tktest
+ list $result [winfo interps]
+ } {{} tktest}
+ test send-1.3 {RegOpen procedure, bogus property} {
+ testsend prop root InterpRegistry abcdefg
+ tk appname tktest
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+ } " tktest\nabcdefg\n"
+
+ frame .f -width 1 -height 1
+ set id [string range [winfo id .f] 2 end]
+ test send-2.1 {RegFindName procedure} {
+ testsend prop root InterpRegistry {}
+ list [catch {send foo bar} msg] $msg
+ } {1 {no application named "foo"}}
+ test send-2.2 {RegFindName procedure} {
+ testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"
+ tk appname foo
+ } {foo #2}
+ test send-2.3 {RegFindName procedure} {
+ testsend prop root InterpRegistry "gyz foo\n"
+ tk appname foo
+ } {foo}
+ test send-2.4 {RegFindName procedure} {
+ testsend prop root InterpRegistry "${id}z foo\n"
+ tk appname foo
+ } {foo}
+
+ test send-3.1 {RegDeleteName procedure} {
+ tk appname tktest
+ testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+ } " x\n012345 gorp\n12345 foo\n"
+ test send-3.2 {RegDeleteName procedure} {
+ tk appname tktest
+ testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+ } " x\n012345 gorp\n23456 tktest\n"
+ test send-3.3 {RegDeleteName procedure} {
+ tk appname tktest
+ testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+ } " x\n12345 bar\n23456 tktest\n"
+ test send-3.4 {RegDeleteName procedure} {
+ tk appname tktest
+ testsend prop root InterpRegistry "foo"
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+ } " x\nfoo\n"
+ test send-3.5 {RegDeleteName procedure} {
+ tk appname tktest
+ testsend prop root InterpRegistry ""
+ tk appname x
+ set x [testsend prop root InterpRegistry]
+ string range $x [string first " " $x] end
+ } " x\n"
+
+ test send-4.1 {RegAddName procedure} {
+ testsend prop root InterpRegistry ""
+ tk appname bar
+ testsend prop root InterpRegistry
+ } "$commId bar\n"
+ test send-4.2 {RegAddName procedure} {
+ testsend prop root InterpRegistry "abc def"
+ tk appname bar
+ tk appname foo
+ testsend prop root InterpRegistry
+ } "$commId foo\nabc def\n"
+
+ # Previous checks should already cover the Regclose procedure.
+
+ test send-5.1 {ValidateName procedure} {
+ testsend prop root InterpRegistry "123 abc\n"
+ winfo interps
+ } {}
+ test send-5.2 {ValidateName procedure} {
+ testsend prop root InterpRegistry "$id Hi there"
+ winfo interps
+ } {{Hi there}}
+ test send-5.3 {ValidateName procedure} {
+ testsend prop root InterpRegistry "$id Bogus"
+ list [catch {send Bogus set a 44} msg] $msg
+ } {1 {target application died or uses a Tk version before 4.0}}
+ test send-5.4 {ValidateName procedure} {
+ tk appname test
+ testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"
+ winfo interps
+ } {test}
+}
+
+winfo interps
+tk appname tktest
+update
+setupbg
+set x [split [exec xhost] \n]
+foreach i [lrange $x 1 end] {
+ exec xhost - $i
+}
+test send-6.1 {ServerSecure procedure} {nonPortable} {
+ set a 44
+ list [dobg [list send [tk appname] set a 55]] $a
+} {55 55}
+test send-6.2 {ServerSecure procedure} {nonPortable} {
+ set a 22
+ exec xhost [exec hostname]
+ list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg
+} {0 22 {X server insecure (must use xauth-style authorization); command ignored}}
+test send-6.3 {ServerSecure procedure} {nonPortable} {
+ set a abc
+ exec xhost - [exec hostname]
+ list [dobg [list send [tk appname] set a new]] $a
+} {new new}
+cleanupbg
+
+if $gotTestCmds {
+ test send-7.1 {Tk_SetAppName procedure} {
+ testsend prop root InterpRegistry ""
+ tk appname newName
+ list [tk appname oldName] [testsend prop root InterpRegistry]
+ } "oldName {$commId oldName\n}"
+ test send-7.2 {Tk_SetAppName procedure, name not in use} {
+ testsend prop root InterpRegistry ""
+ list [tk appname gorp] [testsend prop root InterpRegistry]
+ } "gorp {$commId gorp\n}"
+ test send-7.3 {Tk_SetAppName procedure, name in use by us} {
+ tk appname name1
+ testsend prop root InterpRegistry "$commId name2\n"
+ list [tk appname name2] [testsend prop root InterpRegistry]
+ } "name2 {$commId name2\n}"
+ test send-7.4 {Tk_SetAppName procedure, name in use} {
+ tk appname name1
+ testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n"
+ list [tk appname foo] [testsend prop root InterpRegistry]
+ } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}"
+}
+
+test send-8.1 {Tk_SendCmd procedure, options} {
+ setupbg
+ set app [dobg {tk appname}]
+ set a 66
+ send -async $app [list send [tk appname] set a 77]
+ set result $a
+ after 200 set x 40
+ tkwait variable x
+ cleanupbg
+ lappend result $a
+} {66 77}
+if [info exists env(TK_ALT_DISPLAY)] {
+ test send-8.2 {Tk_SendCmd procedure, options} {
+ setupbg -display $env(TK_ALT_DISPLAY)
+ tk appname xyzgorp
+ set a homeDisplay
+ set result [dobg "
+ toplevel .t -screen [winfo screen .]
+ wm geometry .t +0+0
+ set a altDisplay
+ tk appname xyzgorp
+ list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\]
+ "]
+ cleanupbg
+ set result
+ } {altDisplay homeDisplay}
+}
+test send-8.3 {Tk_SendCmd procedure, options} {
+ list [catch {send -- -async foo bar baz} msg] $msg
+} {1 {no application named "-async"}}
+test send-8.4 {Tk_SendCmd procedure, options} {
+ list [catch {send -gorp foo bar baz} msg] $msg
+} {1 {bad option "-gorp": must be -async, -displayof, or --}}
+test send-8.5 {Tk_SendCmd procedure, options} {
+ list [catch {send -async foo} msg] $msg
+} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
+test send-8.6 {Tk_SendCmd procedure, options} {
+ list [catch {send foo} msg] $msg
+} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}}
+test send-8.7 {Tk_SendCmd procedure, local execution} {
+ set a initial
+ send [tk appname] {set a new}
+ set a
+} {new}
+test send-8.8 {Tk_SendCmd procedure, local execution} {
+ set a initial
+ send [tk appname] set a new
+ set a
+} {new}
+test send-8.9 {Tk_SendCmd procedure, local execution} {
+ set a initial
+ string tolower [list [catch {send [tk appname] open bad_file} msg] \
+ $msg $errorInfo $errorCode]
+} {1 {couldn't open "bad_file": no such file or directory} {couldn't open "bad_file": no such file or directory
+ while executing
+"open bad_file"
+ invoked from within
+"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}
+test send-8.10 {Tk_SendCmd procedure, no such interpreter} {
+ list [catch {send bogus_name bogus_command} msg] $msg
+} {1 {no application named "bogus_name"}}
+if $gotTestCmds {
+ newApp "" t_s_1 Test
+ t_s_1 eval wm withdraw .
+ test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {
+ set a us
+ send t_s_1 set a them
+ list $a [send t_s_1 set a]
+ } {us them}
+ test send-8.12 {Tk_SendCmd procedure, local execution, different interp} {
+ set a us
+ send t_s_1 {set a them}
+ list $a [send t_s_1 {set a}]
+ } {us them}
+ test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {
+ set a us
+ send t_s_1 {set a them}
+ list $a [send t_s_1 {set a}]
+ } {us them}
+ test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {
+ newApp "" t_s_2 Test
+ list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
+ } {0 result}
+ interp delete t_s_2
+ test send-8.15 {Tk_SendCmd procedure, local interp, error info} {
+ catch {error foo}
+ list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode
+ } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory
+ while executing
+"open bogus_file_name"
+ invoked from within
+"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}}
+ test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {
+ testsend prop root InterpRegistry "10234 bogus\n"
+ set result [list [catch {send bogus bogus command} msg] $msg]
+ winfo interps
+ tk appname tktest
+ set result
+ } {1 {no application named "bogus"}}
+ interp delete t_s_1
+}
+test send-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} {
+ # Non-portable because some window managers ignore "raise"
+ # requests so can't guarantee that new app's window won't
+ # obscure .f, thereby masking the Expose event.
+
+ setupbg
+ set app [dobg {tk appname}]
+ raise . ; # Don't want new app obscuring .f
+ catch {destroy .f}
+ frame .f
+ place .f -x 0 -y 0
+ bind .f <Expose> {set a exposed}
+ set a {no event yet}
+ set result ""
+ lappend result [send $app send [list [tk appname]] set a]
+ lappend result $a
+ update
+ cleanupbg
+ lappend result $a
+} {{no event yet} {no event yet} exposed}
+test send-8.18 {Tk_SendCmd procedure, error in remote app} {
+ setupbg
+ set app [dobg {tk appname}]
+ set result [string tolower [list [catch {send $app open bad_name} msg] \
+ $msg $errorInfo $errorCode]]
+ cleanupbg
+ set result
+} {1 {couldn't open "bad_name": no such file or directory} {couldn't open "bad_name": no such file or directory
+ while executing
+"open bad_name"
+ invoked from within
+"send $app open bad_name"} {posix enoent {no such file or directory}}}
+test send-8.19 {Tk_SendCmd, using modal timeouts} {
+ setupbg
+ set app [dobg {tk appname}]
+ set x no
+ set result ""
+ after 0 {set x yes}
+ lappend result [send $app {concat x y z}]
+ lappend result $x
+ update
+ cleanupbg
+ lappend result $x
+} {{x y z} no yes}
+
+tk appname tktest
+catch {destroy .f}
+frame .f
+set id [string range [winfo id .f] 2 end]
+if $gotTestCmds {
+ test send-9.1 {Tk_GetInterpNames procedure} {
+ testsend prop root InterpRegistry \
+ "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n"
+ list [winfo interps] [testsend prop root InterpRegistry]
+ } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f
+}"
+ test send-9.2 {Tk_GetInterpNames procedure} {
+ testsend prop root InterpRegistry \
+ "$commId tktest\nfoobar\n$commId gorp\n"
+ list [winfo interps] [testsend prop root InterpRegistry]
+ } "tktest {$commId tktest\n}"
+ test send-9.3 {Tk_GetInterpNames procedure} {
+ testsend prop root InterpRegistry {}
+ list [winfo interps] [testsend prop root InterpRegistry]
+ } {{} {}}
+
+ testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"
+ test send-10.1 {SendEventProc procedure, bogus comm property} {
+ testsend prop comm Comm {abc def}
+ testsend prop comm Comm {}
+ update
+ } {}
+ test send-10.2 {SendEventProc procedure, simultaneous messages} {
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n"
+ set a null
+ set b xyzzy
+ update
+ list $a $b
+ } {44 45}
+ test send-10.3 {SendEventProc procedure, simultaneous messages} {
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n"
+ set a null
+ set b xyzzy
+ set x [send dummy bogus]
+ list $x $a $b
+ } {12345 newA newB}
+ test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} {
+ testsend prop comm Comm \
+ "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n"
+ set a null
+ update
+ set a
+ } {44}
+ test send-10.5 {SendEventProc procedure, extraneous command options} {
+ testsend prop comm Comm \
+ "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n"
+ set a null
+ update
+ set a
+ } {new}
+ test send-10.6 {SendEventProc procedure, unknown interpreter} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n unknown\n-r $id 44\n-s set a new\n"
+ set a null
+ update
+ list [testsend prop [winfo id .f] Comm] $a
+ } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null"
+ test send-10.7 {SendEventProc procedure, error in script} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
+ update
+ testsend prop [winfo id .f] Comm
+ } {
+r
+-s 62
+-r test error
+-i Initial errorInfo
+ ("foreach" body line 1)
+ invoked from within
+"foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}"
+-e test code
+-c 1
+}
+ test send-10.8 {SendEventProc procedure, exceptional return} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-r $id 62\n-s break\n"
+ update
+ testsend prop [winfo id .f] Comm
+ } {
+r
+-s 62
+-r
+-c 3
+}
+ test send-10.9 {SendEventProc procedure, empty return} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-r $id 62\n-s concat\n"
+ update
+ testsend prop [winfo id .f] Comm
+ } {
+r
+-s 62
+-r
+}
+ test send-10.10 {SendEventProc procedure, asynchronous calls} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n"
+ update
+ testsend prop [winfo id .f] Comm
+ } {}
+ test send-10.11 {SendEventProc procedure, exceptional return} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s break\n"
+ update
+ testsend prop [winfo id .f] Comm
+ } {}
+ test send-10.12 {SendEventProc procedure, empty return} {
+ testsend prop [winfo id .f] Comm {}
+ testsend prop comm Comm \
+ "c\n-n tktest\n-s concat\n"
+ update
+ testsend prop [winfo id .f] Comm
+ } {}
+ test send-10.13 {SendEventProc procedure, return processing} {
+ testsend prop comm Comm \
+ "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n"
+ list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
+ } {1 test3 {test2
+ invoked from within
+"send dummy foo"} test1}
+ test send-10.14 {SendEventProc procedure, extraneous return options} {
+ testsend prop comm Comm \
+ "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n"
+ list [catch {send dummy foo} msg] $msg
+ } {0 result}
+ test send-10.15 {SendEventProc procedure, serial number} {
+ testsend prop comm Comm \
+ "r\n-r response\n"
+ list [catch {send dummy foo} msg] $msg
+ } {1 {target application died or uses a Tk version before 4.0}}
+ test send-10.16 {SendEventProc procedure, serial number} {
+ testsend prop comm Comm \
+ "r\n-r response\n\n-s 0"
+ list [catch {send dummy foo} msg] $msg
+ } {1 {target application died or uses a Tk version before 4.0}}
+ test send-10.17 {SendEventProc procedure, errorCode and errorInfo} {
+ testsend prop comm Comm \
+ "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n"
+ set errorCode oldErrorCode
+ set errorInfo oldErrorInfo
+ list [catch {send dummy foo} msg] $msg $errorInfo $errorCode
+ } {4 {} oldErrorInfo oldErrorCode}
+ test send-10.18 {SendEventProc procedure, send kills application} {
+ setupbg
+ dobg {tk appname t_s_3}
+ set x [list [catch {send t_s_3 destroy .} msg] $msg]
+ cleanupbg
+ set x
+ } {0 {}}
+ test send-10.19 {SendEventProc procedure, send exits} {
+ setupbg
+ dobg {tk appname t_s_3}
+ set x [list [catch {send t_s_3 exit} msg] $msg]
+ close $fd
+ set x
+ } {1 {target application died}}
+
+ test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} {
+ testsend prop root InterpRegistry "0x21447 dummy\n"
+ list [catch {send dummy foo} msg] $msg
+ } {1 {no application named "dummy"}}
+ test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {
+ testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n"
+ update
+ } {}
+}
+
+winfo interps
+tk appname tktest
+catch {destroy .f}
+frame .f
+set id [string range [winfo id .f] 2 end]
+if $gotTestCmds {
+ test send-12.1 {TimeoutProc procedure} {
+ testsend prop root InterpRegistry "$id dummy\n"
+ list [catch {send dummy foo} msg] $msg
+ } {1 {target application died or uses a Tk version before 4.0}}
+ testsend prop root InterpRegistry ""
+}
+test send-12.2 {TimeoutProc procedure} {
+ winfo interps
+ tk appname tktest
+ update
+ setupbg
+ puts $fd {after 10 {after 5000; exit}; puts [tk appname]; puts **DONE**; flush stdout}
+ set bgDone 0
+ set bgData {}
+ flush $fd
+ tkwait variable bgDone
+ set app $bgData
+ after 200
+ set result [list [catch {send $app foo} msg] $msg]
+ close $fd
+ set result
+} {1 {target application died}}
+
+winfo interps
+tk appname tktest
+test send-13.1 {DeleteProc procedure} {
+ setupbg
+ set app [dobg {rename send {}; tk appname}]
+ set result [list [catch {send $app foo} msg] $msg [winfo interps]]
+ cleanupbg
+ set result
+} {1 {no application named "tktest #2"} tktest}
+test send-13.2 {DeleteProc procedure} {
+ winfo interps
+ tk appname tktest
+ rename send {}
+ set result {}
+ lappend result [winfo interps] [info commands send]
+ tk appname foo
+ lappend result [winfo interps] [info commands send]
+} {{} {} foo send}
+
+if [info exists env(TK_ALT_DISPLAY)] {
+ test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} {
+ setupbg -display $env(TK_ALT_DISPLAY)
+ set result [dobg "
+ toplevel .t -screen [winfo screen .]
+ wm geometry .t +0+0
+ tk appname xyzgorp1
+ set x child
+ "]
+ toplevel .t -screen $env(TK_ALT_DISPLAY)
+ wm geometry .t +0+0
+ tk appname xyzgorp2
+ update
+ set y parent
+ set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}]
+ destroy .t
+ cleanupbg
+ set result
+ } {child parent}
+}
+
+if $gotTestCmds {
+ testsend prop root InterpRegister $registry
+ tk appname tktest
+ test send-15.1 {UpdateCommWindow procedure} {
+ set x [list [testsend prop comm TK_APPLICATION]]
+ newApp "" t_s_1 Test
+ send t_s_1 wm withdraw .
+ newApp "" t_s_2 Test
+ send t_s_2 wm withdraw .
+ lappend x [testsend prop comm TK_APPLICATION]
+ interp delete t_s_1
+ lappend x [testsend prop comm TK_APPLICATION]
+ interp delete t_s_2
+ lappend x [testsend prop comm TK_APPLICATION]
+ } {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest}
+}
+
+tk appname $name
+if $gotTestCmds {
+ testsend prop root InterpRegistry $registry
+}
+if $gotTestCmds {
+ testdeleteapps
+}
+rename newApp {}
diff --git a/unix/tkUnixDialog.c b/unix/tkUnixDialog.c
new file mode 100644
index 0000000..199fa20
--- /dev/null
+++ b/unix/tkUnixDialog.c
@@ -0,0 +1,207 @@
+/*
+ * tkUnixDialog.c --
+ *
+ * Contains the Unix implementation of the common dialog boxes:
+ *
+ * Copyright (c) 1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tkUnixDialog.c,v 1.1.4.2 1998/10/06 03:27:36 stanton Exp $
+ *
+ */
+
+#include "tkPort.h"
+#include "tkInt.h"
+#include "tkUnixInt.h"
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EvalArgv --
+ *
+ * Invokes the Tcl procedure with the arguments. argv[0] is set by
+ * the caller of this function. It may be different than cmdName.
+ * The TCL command will see argv[0], not cmdName, as its name if it
+ * invokes [lindex [info level 0] 0]
+ *
+ * Results:
+ * TCL_ERROR if the command does not exist and cannot be autoloaded.
+ * Otherwise, return the result of the evaluation of the command.
+ *
+ * Side effects:
+ * The command may be autoloaded.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int EvalArgv(interp, cmdName, argc, argv)
+ Tcl_Interp *interp; /* Current interpreter. */
+ char * cmdName; /* Name of the TCL command to call */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tcl_CmdInfo cmdInfo;
+
+ if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) {
+ char * cmdArgv[2];
+
+ /*
+ * This comand is not in the interpreter yet -- looks like we
+ * have to auto-load it
+ */
+ if (!Tcl_GetCommandInfo(interp, "auto_load", &cmdInfo)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "cannot execute command \"auto_load\"",
+ NULL);
+ return TCL_ERROR;
+ }
+
+ cmdArgv[0] = "auto_load";
+ cmdArgv[1] = cmdName;
+
+ if ((*cmdInfo.proc)(cmdInfo.clientData, interp, 2, cmdArgv)!= TCL_OK){
+ return TCL_ERROR;
+ }
+
+ if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "cannot auto-load command \"",
+ cmdName, "\"",NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ return (*cmdInfo.proc)(cmdInfo.clientData, interp, argc, argv);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_ChooseColorCmd --
+ *
+ * This procedure implements the color dialog box for the Unix
+ * platform. See the user documentation for details on what it
+ * does.
+ *
+ * Results:
+ * See user documentation.
+ *
+ * Side effects:
+ * A dialog window is created the first time this procedure is called.
+ * This window is not destroyed and will be reused the next time the
+ * application invokes the "tk_chooseColor" command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_ChooseColorCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Main window associated with interpreter. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ return EvalArgv(interp, "tkColorDialog", argc, argv);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetOpenFileCmd --
+ *
+ * This procedure implements the "open file" dialog box for the
+ * Unix platform. See the user documentation for details on what
+ * it does.
+ *
+ * Results:
+ * See user documentation.
+ *
+ * Side effects:
+ * A dialog window is created the first this procedure is called.
+ * This window is not destroyed and will be reused the next time
+ * the application invokes the "tk_getOpenFile" or
+ * "tk_getSaveFile" command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetOpenFileCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Main window associated with interpreter. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tk_Window tkwin = (Tk_Window)clientData;
+
+ if (Tk_StrictMotif(tkwin)) {
+ return EvalArgv(interp, "tkMotifFDialog", argc, argv);
+ } else {
+ return EvalArgv(interp, "tkFDialog", argc, argv);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetSaveFileCmd --
+ *
+ * Same as Tk_GetOpenFileCmd but opens a "save file" dialog box
+ * instead
+ *
+ * Results:
+ * Same as Tk_GetOpenFileCmd.
+ *
+ * Side effects:
+ * Same as Tk_GetOpenFileCmd.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_GetSaveFileCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Main window associated with interpreter. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tk_Window tkwin = (Tk_Window)clientData;
+
+ if (Tk_StrictMotif(tkwin)) {
+ return EvalArgv(interp, "tkMotifFDialog", argc, argv);
+ } else {
+ return EvalArgv(interp, "tkFDialog", argc, argv);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_MessageBoxCmd --
+ *
+ * This procedure implements the MessageBox window for the
+ * Unix platform. See the user documentation for details on what
+ * it does.
+ *
+ * Results:
+ * See user documentation.
+ *
+ * Side effects:
+ * None. The MessageBox window will be destroy before this procedure
+ * returns.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_MessageBoxCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Main window associated with interpreter. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ return EvalArgv(interp, "tkMessageBox", argc, argv);
+}
+
diff --git a/win/makefile.vc b/win/makefile.vc
index 4dc4594..5dc1fae 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -4,7 +4,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
-# RCS: @(#) $Id: makefile.vc,v 1.1.4.2 1998/09/30 02:19:26 stanton Exp $
+# RCS: @(#) $Id: makefile.vc,v 1.1.4.3 1998/10/06 03:27:36 stanton Exp $
# Does not depend on the presence of any environment variables in
# order to compile tcl; all needed information is derived from
@@ -28,7 +28,7 @@
ROOT = ..
TOOLS32 = c:\progra~1\devstudio\vc
TOOLS32_rc = c:\progra~1\devstudio\sharedide
-TCLDIR = ..\..\tcl8.1a2
+TCLDIR = ..\..\tcl8.1
# Set this to the appropriate value of /MACHINE: for your platform
MACHINE = IX86
@@ -297,9 +297,10 @@ CON_CFLAGS = $(cdebug) $(cflags) $(cvars) $(include32) -DCONSOLE
######################################################################
all: setup $(WISH)
-test: setup $(TKTEST)
plugin: setup $(TKPLUGINDLL) $(WISHP)
+test: setup $(TKTEST)
+
setup:
@mkd $(TMPDIR)
@mkd $(OUTDIR)
@@ -389,7 +390,7 @@ $(TMPDIR)\winMain.obj: $(ROOT)\win\winMain.c
$(cc32) -DDLL_BUILD -DBUILD_tk $(TK_CFLAGS) -Fo$(TMPDIR)\ $<
{$(RCDIR)}.rc{$(TMPDIR)}.res:
- $(rc32) -fo $@ -r -i $(GENERICDIR) $<
+ $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(TOOLS32)\include $<
clean:
-@del $(OUTDIR)\*.exp
diff --git a/win/rc/tk.rc b/win/rc/tk.rc
index db90945..d3da276 100644
--- a/win/rc/tk.rc
+++ b/win/rc/tk.rc
@@ -1,10 +1,9 @@
-// RCS: @(#) $Id: tk.rc,v 1.1.4.2 1998/09/30 02:19:42 stanton Exp $
+// RCS: @(#) $Id: tk.rc,v 1.1.4.3 1998/10/06 03:27:38 stanton Exp $
//
// Version
//
#include <windows.h>
-
#define RESOURCE_INCLUDED
#include <tk.h>
diff --git a/win/tkWinMenu.c b/win/tkWinMenu.c
index 47915ae..d92c8b7 100644
--- a/win/tkWinMenu.c
+++ b/win/tkWinMenu.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tkWinMenu.c,v 1.1.4.2 1998/09/30 02:19:35 stanton Exp $
+ * RCS: @(#) $Id: tkWinMenu.c,v 1.1.4.3 1998/10/06 03:27:36 stanton Exp $
*/
#define OEMRESOURCE
@@ -1820,8 +1820,8 @@ MenuKeyBindProc(clientData, interp, eventPtr, tkwin, keySym)
CallWindowProc(DefWindowProc, Tk_GetHWND(Tk_WindowId(tkwin)),
WM_SYSKEYDOWN, virtualKey, ((scanCode << 16)
| (1 << 29)));
- if (eventPtr->xkey.nchars > 0) {
- for (i = 0; i < eventPtr->xkey.nchars; i++) {
+ if (eventPtr->xkey.nbytes > 0) {
+ for (i = 0; i < eventPtr->xkey.nbytes; i++) {
CallWindowProc(DefWindowProc,
Tk_GetHWND(Tk_WindowId(tkwin)),
WM_SYSCHAR,
diff --git a/win/tkWinX.c b/win/tkWinX.c
index 3ef489b..9ec1865 100644
--- a/win/tkWinX.c
+++ b/win/tkWinX.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tkWinX.c,v 1.1.4.2 1998/09/30 02:19:40 stanton Exp $
+ * RCS: @(#) $Id: tkWinX.c,v 1.1.4.3 1998/10/06 03:27:37 stanton Exp $
*/
#include "tkWinInt.h"
@@ -941,8 +941,8 @@ GetTranslatedKey(xkey)
while ((xkey->nbytes < XMaxTransChars)
&& PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
if ((msg.message == WM_CHAR) || (msg.message == WM_SYSCHAR)) {
- xkey->trans_chars[xkey->nchars] = (char) msg.wParam;
- xkey->nchars++;
+ xkey->trans_chars[xkey->nbytes] = (char) msg.wParam;
+ xkey->nbytes++;
GetMessage(&msg, NULL, 0, 0);
/*
generated by cgit v0.12 at 2024-11-30 12:46:24 (GMT)