tk/tests/macWinMenu.test

   1 # This file is a Tcl script to test menus in Tk.  It is
   2 # organized in the standard fashion for Tcl tests. It tests
   3 # the common implementation of Macintosh and Windows menus.
   4 #
   5 # Copyright (c) 1995-1996 Sun Microsystems, Inc.
   6 #
   7 # See the file "license.terms" for information on usage and redistribution
   8 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   9 #
  10 # RCS: @(#) $Id$
  11
  12 if {$tcl_platform(platform) == "unix"} {
  13     return
  14 }
  15
  16 if {[lsearch [image types] test] < 0} {
  17     puts "This application hasn't been compiled with the \"test\" image"
  18     puts "type, so I can't run this test.  Are you sure you're using"
  19     puts "tktest instead of wish?"
  20     return
  21 }
  22
  23 if {[info procs test] != "test"} {
  24     source defs
  25 }
  26
  27 proc deleteWindows {} {
  28     foreach i [winfo children .] {
  29         catch [destroy $i]
  30     }
  31 }
  32
  33 deleteWindows
  34 wm geometry . {}
  35 raise .
  36
  37 if {$tcl_platform(platform) == "windows" && ![info exists INTERACTIVE]} {
  38     puts " Some tests were skipped because they could not be performed"
  39     puts " automatically on this platform. If you wish to execute them"
  40     puts " interactively, set the TCL variable INTERACTIVE and re-run"
  41     puts " the test."
  42 }
  43
  44 test macWinMenu-1.1 {PreprocessMenu} {
  45     catch {destroy .m1}
  46     menu .m1 -postcommand "destroy .m1"
  47     .m1 add command -label "macWinMenu-1.1: Hit Escape"
  48     list [catch {.m1 post 40 40} msg] $msg
  49 } {0 {}}
  50 if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} {
  51     test macWinMenu-1.2 {PreprocessMenu} {
  52         catch {destroy .m1}
  53         catch {destroy .m2}
  54         set foo1 foo
  55         set foo2 foo
  56         menu .m1 -postcommand "set foo1 .m1"
  57         .m1 add cascade -menu .m2 -label "macWinMenu-1.2: Hit Escape"
  58         menu .m2 -postcommand "set foo2 .m2"
  59         update idletasks
  60         list [catch {.m1 post 40 40} msg] $msg [set foo1] [set foo2] [destroy .m1 .m2] [catch {unset foo1}] [catch {unset foo2}]
  61     } {0 .m2 .m1 .m2 {} 0 0}
  62 }
  63 test macWinMenu-1.3 {PreprocessMenu} {
  64     catch {destroy .l1}
  65     catch {destroy .m1}
  66     catch {destroy .m2}
  67     catch {destroy .m3}
  68     label .l1 -text "Preparing menus..."
  69     pack .l1
  70     update idletasks
  71     menu .m1 -postcommand ".l1 configure -text \"Destroying .m1...\"; update idletasks; destroy .m1"
  72     menu .m2 -postcommand ".l1 configure -text \"Destroying .m2...\"; update idletasks; destroy .m2"
  73     menu .m3 -postcommand ".l1 configure -text \"Destroying .m3...\"; update idletasks; destroy .m3"
  74     .m1 add cascade -menu .m2 -label "macWinMenu-1.3: Hit Escape (.m2)"
  75     .m1 add cascade -menu .m3 -label ".m3"
  76     update idletasks
  77     list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3]
  78 } {0 {} {}}
  79 test macWinMenu-1.4 {PreprocessMenu} {
  80     catch {destroy .l1}
  81     catch {destroy .m1}
  82     catch {destroy .m2}
  83     catch {destroy .m3}
  84     catch {destroy .m4}
  85     label .l1 -text "Preparing menus..."
  86     pack .l1
  87     update idletasks
  88     menu .m1 -postcommand ".l1 configure -text \"Destroying .m1...\"; update idletasks; destroy .m1"
  89     .m1 add cascade -menu .m2 -label "macWinMenu-1.4: Hit Escape (.m2)"
  90     .m1 add cascade -menu .m3 -label ".m3"
  91     menu .m2 -postcommand ".l1 configure -text \"Destroying .m2...\"; update idletasks; destroy .m2"
  92     .m2 add cascade -menu .m4 -label ".m4"
  93     menu .m3 -postcommand ".l1 configure -text \"Destroying .m3...\"; update idletasks; destroy .m3"
  94     menu .m4 -postcommand ".l1 configure -text \"Destroying .m4...\"; update idletasks; destroy .m4"
  95     update idletasks
  96     list [catch {.m1 post 40 40} msg] $msg [destroy .l1 .m2 .m3 .m4]
  97 } {0 {} {}}
  98 test macWinMenu-1.5 {PreprocessMenu} {
  99     catch {destroy .m1}
 100     catch {destroy .m2}
 101     menu .m1
 102     .m1 add cascade -menu .m2 -label "You may need to hit Escape to get this menu to go away."
 103     menu .m2 -postcommand glorp
 104     list [catch {.m1 post 40 40} msg] $msg [destroy .m1 .m2]
 105 } {1 {invalid command name "glorp"} {}}
 106
 107 if {$tcl_platform(platform) != "windows" || [info exists INTERACTIVE]} {
 108     test macWinMenu-2.1 {TkPreprocessMenu} {
 109         catch {destroy .m1}
 110         set foo test
 111         menu .m1 -postcommand "set foo 2.1"
 112         .m1 add command -label "macWinMenu-2.1: Hit Escape"
 113         list [catch {.m1 post 40 40} msg] $msg [set foo] [destroy .m1] [unset foo]
 114     } {0 2.1 2.1 {} {}}
 115 }
 116
 117 deleteWindows